URL
https://opencores.org/ocsvn/w11/w11/trunk
Subversion Repositories w11
Compare Revisions
- This comparison shows the changes necessary to convert path
/w11/tags/w11a_V0.74/tools/bin
- from Rev 37 to Rev 38
- ↔ Reverse comparison
Rev 37 → Rev 38
/njobihtm
0,0 → 1,119
#!/usr/bin/perl -w |
# $Id: njobihtm 810 2016-10-02 16:51:12Z mueller $ |
# |
# Copyright 2016- by Walter F.J. Mueller <W.F.J.Mueller@gsi.de> |
# |
# This program is free software; you may redistribute and/or modify it under |
# the terms of the GNU General Public License as published by the Free |
# Software Foundation, either version 2, or at your option any later version. |
# |
# 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 complete details. |
# |
# Revision History: |
# Date Rev Version Comment |
# 2016-10-01 810 1.0 Initial version |
# |
|
use 5.14.0; # require Perl 5.14 or higher |
use strict; # require strict checking |
|
use Getopt::Long; |
|
my %opts = (); |
|
GetOptions(\%opts, "verbose", "mem=s" |
) |
or die "bad options"; |
|
sub get_cpuinfo; |
sub get_meminfo; |
|
my $ncpu; |
my $ntpc; |
my $nkb; |
my $njob = 1; |
|
get_cpuinfo(); |
get_meminfo(); |
|
if (defined $ncpu && defined $ntpc && defined $nkb) { |
} else { |
print STDERR "njobihtm-F: failed to obtain cpu or mem size\n"; |
exit 1; |
} |
|
|
my $ncore = $ncpu / $ntpc; # number of cores |
my $nht = $ncpu - $ncore; |
|
$njob = $ncore + int($nht/4); |
|
if ($opts{verbose}) { |
printf STDERR "#cpus: %d\n", $ncpu; |
printf STDERR "#thread/cpu: %d\n", $ntpc; |
printf STDERR "#cores: %d\n", $ncore; |
printf STDERR "mem(MB): %d\n", int($nkb/1024); |
printf STDERR "#job (cpus): %d\n", $njob; |
} |
|
if (defined $opts{mem}) { |
my $mem; |
if ($opts{mem} =~ m/^(\d+)([MG])$/) { |
$mem = 1024 * $1 if $2 eq 'M'; |
$mem = 1024* 1024 * $1 if $2 eq 'G'; |
my $njobm = int(($nkb - 1024*1024) / $mem); |
$njobm = 1 unless $njobm > 0; |
printf STDERR "#job (mem): %d\n", $njobm if $opts{verbose}; |
if ($njobm < $njob) { |
$njob = $njobm; |
} |
} else { |
print STDERR "njobihtm-F: bad -mem option '$opts{mem}', must be nnn[MG]\n"; |
exit 1; |
} |
} |
|
print "$njob\n"; |
|
exit 0; |
|
#------------------------------------------------------------------------------- |
sub get_cpuinfo { |
open (LSCPU, "lscpu|") |
or die "failed to open 'lscpu|': $!"; |
|
while (<LSCPU>) { |
chomp; |
if (m/^(.*?)\s*:\s*(.*)$/) { |
my $tag = $1; |
my $val = $2; |
# print "+++1 '$tag' : '$val' \n"; |
$ncpu = $val if $tag eq 'CPU(s)'; |
$ntpc = $val if $tag eq 'Thread(s) per core'; |
} |
} |
close LSCPU; |
return; |
} |
|
#------------------------------------------------------------------------------- |
sub get_meminfo { |
open (MEMINFO, "/proc/meminfo") |
or die "failed to open '/proc/meminfo': $!"; |
|
while (<MEMINFO>) { |
chomp; |
if (m/^(.*?)\s*:\s*(\d+)\s*kB/) { |
my $tag = $1; |
my $val = $2; |
# print "+++1 '$tag' : '$val' \n"; |
$nkb = $val if $tag eq 'MemTotal'; |
} |
} |
close MEMINFO; |
return; |
} |
|
njobihtm
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: tbfilt
===================================================================
--- tbfilt (nonexistent)
+++ tbfilt (revision 38)
@@ -0,0 +1,403 @@
+#!/usr/bin/perl -w
+# $Id: tbfilt 807 2016-09-17 07:49:26Z mueller $
+#
+# Copyright 2016- by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-09-10 806 1.0 Initial version
+# 2016-08-05 795 0.1 First draft
+#
+
+use 5.14.0; # require Perl 5.14 or higher
+use strict; # require strict checking
+
+use Getopt::Long;
+use FileHandle;
+use POSIX qw(strftime);
+
+my %opts = ();
+
+GetOptions(\%opts, "tee=s", "pcom",
+ "find=s", "all",
+ "summary", "wide", "compact", "format=s", "nohead"
+ )
+ or die "bad options";
+
+sub do_file;
+sub conv_fd;
+sub conv_ft;
+sub conv_fs;
+sub conv_fa;
+sub conv_tr;
+sub conv_tu;
+sub conv_ts;
+sub conv_tc;
+sub conv_tg;
+sub conv_st;
+sub conv_ss;
+sub conv_sc;
+sub conv_sg;
+sub conv_sp;
+sub conv_sm;
+sub conv_ec;
+sub conv_pf;
+sub conv_nf;
+sub conv_ns;
+
+my %fmttbl = (fd => {conv => \&conv_fd, head=>' file-date'},
+ ft => {conv => \&conv_ft, head=>' time'},
+ fs => {conv => \&conv_fs, head=>' time'},
+ fa => {conv => \&conv_fa, head=>'age'},
+ tr => {conv => \&conv_tr, head=>' time-real'},
+ tu => {conv => \&conv_tu, head=>' time-user'},
+ ts => {conv => \&conv_ts, head=>' time-sys'},
+ tc => {conv => \&conv_tc, head=>' time-cpu'},
+ tg => {conv => \&conv_tg, head=>' time t'},
+ st => {conv => \&conv_st, head=>'stime(ns)'},
+ ss => {conv => \&conv_ss, head=>'stime'},
+ sc => {conv => \&conv_sc, head=>' cycles'},
+ sg => {conv => \&conv_sg, head=>' cyc|tim'},
+ sp => {conv => \&conv_sp, head=>'sperf'},
+ sm => {conv => \&conv_sm, head=>'MHz'},
+ ec => {conv => \&conv_ec, head=>'err'},
+ pf => {conv => \&conv_pf, head=>'stat'},
+ nf => {conv => \&conv_nf, head=>'filename'},
+ ns => {conv => \&conv_ns, head=>'filename'});
+my @fmtlst;
+
+my $format = $ENV{TBFILT_FORMAT};
+$format = '%fd %fs %tr %tc %sc %ec %pf %nf' if $opts{wide};
+$format = '%fa %tg %sg %ec %pf %ns' if $opts{compact};
+$format = $opts{format} if defined $opts{format};
+$format = '%ec %pf %nf' unless defined $format;
+
+while (length($format)) {
+ if ($format =~ m/^([^%]*)%([a-z][a-z])/) {
+ my $pref = $1;
+ my $code = $2;
+ if (exists $fmttbl{$code}) {
+ push @fmtlst, {pref => $pref,
+ conv => $fmttbl{$code}{conv},
+ head => $fmttbl{$code}{head}};
+ } else { last; };
+ $format = $';
+ } else { last; };
+}
+if (length($format)) {
+ print STDERR "tbfilt-f: bad format '$format'\n";
+ exit 2;
+}
+
+autoflush STDOUT 1 if (-p STDOUT);
+
+my $fh_tee;
+if (defined $opts{tee} && $opts{tee} ne '') {
+ $fh_tee = new FileHandle;
+ $fh_tee->open($opts{tee},'>') or die "failed to open for write '$opts{tee}'";
+}
+
+my @flist = @ARGV;
+
+# if find pattern has no '*', expand it
+if (defined $opts{find}) {
+ unless ($opts{find} =~ m/\*/) {
+ $opts{find} = '.*/tb_.*_' . $opts{find} . '.*\.log';
+ }
+}
+
+if (defined $opts{all}) {
+ if (defined $opts{find}) {
+ print STDERR "tbfilt-I: -find ignored because -all given\n";
+ }
+ $opts{find} = '.*/tb_.*_[bfsorept]sim(_.*)?\.log';
+}
+
+if (defined $opts{find}) {
+ if (scalar (@flist)) {
+ print STDERR "tbfilt-I: file names ignored because -all or -find given\n";
+ @flist = ();
+ }
+ open FIND,'-|',"find -regextype egrep -regex '$opts{find}'"
+ or die "failed to open find pipe";
+
+ while () {
+ chomp;
+ s|^\./||; # drop leading ./
+ push @flist, $_;
+ }
+
+ close FIND;
+ @flist = sort @flist;
+ if (scalar (@flist) == 0) {
+ print STDERR "tbfilt-E: no files found by -find or -all\n";
+ exit 2;
+ }
+
+} else {
+ push @flist, '-' if (scalar(@flist) == 0);
+}
+
+my $manyfile = scalar(@flist) > 1;
+my $notsumm = not $opts{summary};
+my %vals;
+my $exitcode = 0;
+
+if ($opts{summary} && (not $opts{nohead})) {
+ foreach my $item (@fmtlst) {
+ print $item->{pref};
+ print $item->{head};
+ }
+ print "\n";
+}
+
+foreach my $fnam (@flist) {
+ my $nfail = do_file($fnam);
+ $exitcode = 1 if $nfail;
+}
+
+exit $exitcode;
+
+#-------------------------------------------------------------------------------
+
+sub do_file {
+ my ($fnam) = @_;
+
+ %vals = ();
+ $vals{fnam} = $fnam;
+ $vals{nfail} = 0;
+
+ my $fh;
+ if ($fnam eq '-') {
+ $fh = *STDIN;
+ } else {
+ $fh = new FileHandle;
+ $fh->open($fnam,'<') or die "failed to open for read '$fnam'";
+ }
+
+ if ($manyfile && $notsumm) {
+ print "-- $fnam";
+ my $npad = 74-length($fnam);
+ print ' '.('-' x $npad) if $npad > 0;
+ print "\n";
+ }
+
+ while (<$fh>) {
+ print $fh_tee $_ if defined $fh_tee;
+ chomp;
+ my $show;
+ my $fail;
+
+ $fail = 1 if m/-[EF]:/;
+ $fail = 1 if m/(ERROR|FAIL)/;
+ $show = 1 if m/-W:/;
+ $show = 1 if m/(PASS)/;
+ $show = 1 if $opts{pcom} && m/^C/; # show lines starting with C
+
+ # ghdl reports or assertions (warning and higher)
+ if (m/:\((report|assertion) (warning|error|failure)\):/) {
+ # ignore ieee lib warnings at t=0
+ next if /:\@0ms:\(assertion warning\): NUMERIC_STD.*metavalue detected/;
+ next if /:\@0ms:\(assertion warning\): CONV_INTEGER: There is an 'U'/;
+ next if /std_logic_arith.*:\@0ms:\(assertion warning\): There is an 'U'/;
+ # ignore ' Simulation Finished' report failure (used to end ghdl sim)
+ next if /:\(report failure\): Simulation Finished/;
+ $fail = 1;
+ }
+
+ # check for DONE line accept
+ # 920 ns: DONE -- tb'swithout clock
+ # 7798080.0 ns 389893: DONE -- single clock tb's
+ # 56075.0 ns 2094: DONE-w -- multiclock tb's (max taken)
+ #
+ if (m/^\s*(\d+\.?\d*)\s+ns\s*(\d*):\s+DONE(-\S+)?\s*$/) {
+ $show = 1;
+ $vals{done_ns} = $1;
+ if ($2 ne '') {
+ if (defined $vals{done_cyc}) {
+ $vals{done_cyc} = $2 if $2 > $vals{done_cyc};
+ } else {
+ $vals{done_cyc} = $2;
+ }
+ }
+ }
+
+ # check for time line
+ # Note: don't root the pattern with /^ --> allow arbitary text before
+ # the 'time' output. In practice 'time' output (to stderr by bash)
+ # and ghdl 'report' (also to stderr) get mixed and one might get
+ # tb_w11a_b3real 0m49.179s user 0m0.993s sys 0m0.293s
+ #
+ if (m/real\s+(\d*)m(\d+\.\d*)s\s+
+ user\s+(\d*)m(\d+\.\d*)s\s+
+ sys\s+(\d*)m(\d+\.\d*)s/x) {
+ $show = 1;
+ $vals{treal} = [$1,$2];
+ $vals{tuser} = [$3,$4];
+ $vals{tsys} = [$5,$6];
+ }
+
+ print "$_\n" if ($show || $fail) && $notsumm;
+ $vals{nfail} += 1 if $fail;
+ }
+
+ if (not defined $vals{done_ns}) {
+ print "tbfilt-I: no DONE seen; FAIL\n" if $notsumm;
+ $vals{nfail} += 1;
+ }
+
+ $vals{mtime} = ($fnam eq '-') ? time : (stat($fh))[9];
+
+ if ($opts{summary}) {
+ foreach my $item (@fmtlst) {
+ print $item->{pref};
+ print &{$item->{conv}};
+ }
+ print "\n";
+ }
+
+ return $vals{nfail};
+}
+
+#-------------------------------------------------------------------------------
+sub time_val {
+ my ($tdsc) = @_;
+ return undef unless defined $tdsc;
+ return 60.*$tdsc->[0] + $tdsc->[1];
+}
+
+sub time_str {
+ my ($tdsc) = @_;
+ return ' -' unless defined $tdsc;
+ return sprintf '%3dm%06.3fs', $tdsc->[0],$tdsc->[1];
+}
+
+sub time_sum {
+ my ($tdsc1,$tdsc2) = @_;
+ return undef unless defined $tdsc1 && defined $tdsc2;
+ return time_val($tdsc1) + time_val($tdsc2);
+}
+
+sub gconv {
+ my ($val) = @_;
+ my $str = sprintf '%4.2f', $val;
+ return substr($str,0,4);
+}
+
+#-------------------------------------------------------------------------------
+sub conv_fd {
+ return strftime "%F", localtime($vals{mtime});
+}
+
+sub conv_ft {
+ return strftime "%T", localtime($vals{mtime});
+}
+
+sub conv_fs {
+ return strftime "%H:%M", localtime($vals{mtime});
+}
+
+sub conv_fa {
+ my $dt = time - $vals{mtime};
+ return sprintf '%2ds', $dt if $dt < 99;
+ $dt /= 60; return sprintf '%2dm', $dt if $dt < 99;
+ $dt /= 60; return sprintf '%2dh', $dt if $dt < 60;
+ $dt /= 24; return sprintf '%2dd', $dt if $dt < 99;
+ return 'old';
+}
+
+sub conv_tr {
+ return time_str($vals{treal});
+}
+
+sub conv_tu {
+ return time_str($vals{tuser});
+ }
+
+sub conv_ts {
+ return time_str($vals{tsys});
+}
+
+sub conv_tc {
+ my $tsum = time_sum($vals{tuser}, $vals{tsys});
+ return ' -' unless defined $tsum;
+ my $min = int($tsum/60.);
+ my $sec = $tsum - 60. * $min;
+ return sprintf '%3dm%06.3fs', $min, $sec;
+}
+
+sub conv_tg {
+ my $treal = time_val($vals{treal});
+ my $tcpu = time_sum($vals{tuser}, $vals{tsys});
+ if (defined $treal && defined $tcpu && $tcpu > 0.4 * $treal) {
+ return conv_tc() . ' c' ;
+ } else {
+ return conv_tr() . ((defined $treal) ? ' r': ' -');
+ }
+}
+
+sub conv_st {
+ return ' -' unless defined $vals{done_ns};
+ return sprintf '%9d', $vals{done_ns};
+}
+
+sub conv_ss {
+ return ' -' unless defined $vals{done_ns};
+ my $stim = 0.001 * $vals{done_ns};
+ return gconv($stim) . 'u' if $stim < 999;
+ $stim *= 0.001; return gconv($stim) . 'm' if $stim < 999;
+ $stim *= 0.001; return gconv($stim) . 's';
+}
+
+sub conv_sc {
+ return ' -' unless defined $vals{done_cyc};
+ return sprintf '%8d', $vals{done_cyc};
+}
+
+sub conv_sg {
+ return conv_sc() if defined $vals{done_cyc};
+ return ' ' . conv_ss();
+}
+
+sub conv_sp {
+ my $nc = $vals{done_cyc};
+ my $tsum = time_sum($vals{tuser}, $vals{tsys});
+ return ' -' unless defined $nc && defined $tsum;
+ my $sperf = 1000000. * $tsum / $nc;
+ return gconv($sperf) . 'u' if $sperf < 999;
+ $sperf *= 0.001; return gconv($sperf) . 'm';
+}
+
+sub conv_sm {
+ return ' -' unless defined $vals{done_ns} && $vals{done_ns} > 200 &&
+ defined $vals{done_cyc};
+ my $mhz = (1000. * $vals{done_cyc}) / ($vals{done_ns} - 200);
+ return sprintf '%3d', int($mhz+0.5);
+}
+
+sub conv_ec {
+ return sprintf '%3d', $vals{nfail};
+}
+
+sub conv_pf {
+ return $vals{nfail} ? 'FAIL' : 'PASS';
+}
+
+sub conv_nf {
+ return $vals{fnam};
+}
+
+sub conv_ns {
+ my $val = $vals{fnam};
+ $val =~ s|^.*/||;
+ return $val;
+}
tbfilt
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: tbrun
===================================================================
--- tbrun (nonexistent)
+++ tbrun (revision 38)
@@ -0,0 +1,830 @@
+#!/usr/bin/perl -w
+# $Id: tbrun 808 2016-09-17 13:02:46Z mueller $
+#
+# Copyright 2016- by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-09-17 808 1.0 Initial version
+# 2016-08-09 796 0.1 First draft
+#
+
+use 5.14.0; # require Perl 5.14 or higher
+use strict; # require strict checking
+
+use Getopt::Long;
+use FileHandle;
+use YAML::XS;
+use Cwd;
+use IO::Select;
+use Time::HiRes qw(gettimeofday);
+
+my %opts = ();
+
+GetOptions(\%opts, "tag=s@", "exclude=s@", "mode=s",
+ "jobs=i", "tee=s", "tmax=i", "dry", "trace",
+ "nomake", "norun",
+ "rlmon", "rbmon", "bwait=i", "swait=i"
+ )
+ or die "bad options";
+
+sub setup_tagfilter;
+sub check_tagfilter;
+sub check_modefilter;
+sub include_file;
+sub read_file;
+sub load_yaml;
+sub check_keys;
+sub expand_vars;
+sub merge_lines;
+sub merge_expand;
+sub key_or_def;
+sub handle_include;
+sub handle_default;
+sub handle_itest;
+sub tpr;
+sub tpre;
+sub print_trace;
+sub run_tests_single;
+sub run_tests_multi;
+
+my @tlist;
+my @olist;
+my @wlist;
+
+
+my %keys_include = ( include => { mode => 'm', ref => ''},
+ tag => { mode => 'o', ref => 'ARRAY'}
+ );
+my %keys_default = ( default => { mode => 'm', ref => 'HASH'}
+ );
+my %keys_defhash = ( tag => { mode => 'o', ref => 'ARRAY'},
+ mode => { mode => 'o', ref => ''}
+ );
+my %keys_itest = ( test => { mode => 'm', ref => ''},
+ tag => { mode => 'o', ref => 'ARRAY'},
+ mode => { mode => 'o', ref => ''}
+ );
+
+my $nseen = 0;
+my $ntest = 0;
+my $ndone = 0;
+my $nfail = 0;
+my $inicwd = getcwd();
+my %gblvars;
+
+$gblvars{ise_modes} = '[bsft]sim,ISim_[bsft]sim';
+$gblvars{ise_modes_noisim} = '[bsft]sim'; # when ISim not possible
+$gblvars{ise_modes_nossim} = 'bsim,ISim_bsim'; # when ssim not available
+#
+$gblvars{viv_modes} = '[bsor]sim,XSim_[bsorept]sim';
+$gblvars{viv_modes_nossim} = 'bsim,XSim_bsim'; # when ssim not available
+
+autoflush STDOUT 1 if -p STDOUT || -t STDOUT;
+my $ticker_on = -t STDOUT;
+
+my $fh_tee;
+if (defined $opts{tee} && $opts{tee} ne '') {
+ $fh_tee = new FileHandle;
+ $fh_tee->open($opts{tee},'>') or die "failed to open for write '$opts{tee}'";
+}
+
+$opts{tag} = ['default'] unless defined $opts{tag};
+$opts{mode} = 'bsim' unless defined $opts{mode};
+
+my %modecache;
+my @modelist;
+foreach (split /,/,$opts{mode}) {
+ $_ .= '_bsim' if m/^[IX]Sim$/;
+ push @modelist, $_;
+}
+
+push @ARGV, 'tbrun.yml' unless scalar( @ARGV);
+
+my @tagincl = setup_tagfilter($opts{tag});
+my @tagexcl = setup_tagfilter($opts{exclude});
+
+foreach my $fnam (@ARGV) {
+ include_file($fnam);
+}
+
+$ntest = scalar(@tlist);
+unless ($ntest) {
+ tpre(sprintf "tbrun-E: %d tests found, none selected\n", $nseen);
+ exit 2;
+}
+
+if (defined $opts{jobs}) {
+ run_tests_multi();
+} else {
+ run_tests_single();
+}
+
+if (defined $opts{dry}) {
+ tpr(sprintf "#tbrun-I: %d tests found, %d selected\n", $nseen,$ntest);
+}
+
+if ($nfail) {
+ tpr(sprintf "tbrun-I: %d tests failed of %d tests executed\n",$nfail,$ndone);
+}
+
+exit $nfail ? 1 : 0;
+
+#-------------------------------------------------------------------------------
+sub setup_tagfilter {
+ my ($targlist) = @_;
+ return () unless defined $targlist;
+ my @tagfiltlist;
+ foreach my $targ (@$targlist) {
+ my @tagfilt = map { "^($_)\$" } split /,/, $targ;
+ push @tagfiltlist, \@tagfilt;
+ }
+ return @tagfiltlist;
+}
+
+#-------------------------------------------------------------------------------
+sub check_tagfilter {
+ my ($tfiltlist,$tlist) = @_;
+ foreach my $tfilt (@$tfiltlist) { # loop over filters
+ my $fok = 1;
+ foreach my $tfele (@$tfilt) { # loop over filter elements
+ my $match = 0;
+ foreach my $tag (@$tlist) { # loop over tags
+ $match = $tag =~ m/$tfele/; # tag matchs filter element
+ last if $match;
+ }
+ $fok = 0 unless $match; # filter missed if one element missed
+ }
+ return 1 if $fok; # return ok of one filter matched
+ }
+ return 0; # here if no filter matched
+}
+
+#-------------------------------------------------------------------------------
+sub check_modefilter {
+ my ($mode,$mlist) = @_;
+ unless (exists $modecache{$mlist}) {
+ my %mh;
+ foreach my $mi (split /,/,$mlist) {
+ if ($mi =~ m/^(.*)\[([a-z]+)\](.*)$/) {
+ foreach (split //,$2) {
+ $mh{$1.$_.$3} = 1;
+ }
+ } else {
+ $mh{$mi} = 1;
+ }
+ }
+ $modecache{$mlist} = \%mh;
+ }
+
+ my $rmh = $modecache{$mlist};
+ return exists $$rmh{$mode};
+}
+
+#-------------------------------------------------------------------------------
+sub include_file {
+ my ($fnam) = @_;
+ my $fdat = read_file($fnam);
+ exit 2 unless defined $fdat;
+ my $ylst = load_yaml($fdat, $fnam);
+ exit 2 unless defined $ylst;
+
+ my $oldcwd = getcwd();
+
+ if ($fnam =~ m|^(.*)/(.*)$|) {
+ chdir $1 or die "chdir to '$1' failed with '$!'";
+ }
+
+ my %defhash;
+ foreach my $yele (@$ylst) {
+ if (exists $yele->{include}) {
+ handle_include($yele);
+ } elsif (exists $yele->{default}) {
+ handle_default($yele, \%defhash);
+ } elsif (exists $yele->{test}) {
+ handle_itest($yele, \%defhash);
+ } else {
+ tpr(sprintf "tbrun-E: unknown list element in '%s'\n found keys: %s\n",
+ $fnam, join(',',sort keys %$yele));
+ exit 2;
+ }
+ }
+
+ chdir $oldcwd or die "chdir to '$oldcwd' failed with '$!'";
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub read_file {
+ my ($fnam) = @_;
+ my $fh = new FileHandle;
+ if (not open $fh, '<', $fnam) {
+ my $err = $!;
+ tpre(sprintf "tbrun-E: failed to open '%s'\n cwd: %s\n error: %s\n",
+ $fnam, getcwd(), $err);
+ return undef;
+ }
+ # nice trick to slurp the whole file into a variable
+ my $fdat = do {
+ local $/ = undef;
+ <$fh>;
+ };
+ close $fh;
+ return $fdat;
+}
+
+#-------------------------------------------------------------------------------
+sub load_yaml {
+ my ($fdat,$fnam) = @_;
+ my $ylst;
+ eval { $ylst = YAML::XS::Load($fdat); };
+ if ($@ ne '') {
+ my $err = $@;
+ tpre(sprintf "tbrun-E: failed to yaml load '%s'\n cwd: %s\n error: %s\n",
+ $fnam, getcwd(), $err);
+ return undef;
+ }
+ if (ref $ylst ne 'ARRAY') {
+ tpre(sprintf "tbrun-E: top level yaml is not a list but '%s'\n", ref $ylst);
+ return undef;
+ }
+ foreach my $yele (@$ylst) {
+ if (ref $yele ne 'HASH') {
+ tpre(sprintf "tbrun-E: second level yaml is not a hash '%s'\n", ref $yele);
+ return undef;
+ }
+ }
+ return $ylst;
+}
+
+#-------------------------------------------------------------------------------
+sub check_keys {
+ my ($yele, $href) = @_;
+ foreach my $keyele ( keys %$yele ) {
+ if (not exists $href->{$keyele}) {
+ tpre(sprintf "tbrun-E: unexpected key '%s'\n", $keyele);
+ return 0;
+ }
+ my $ref = ref $yele->{$keyele};
+ if ($ref ne $href->{$keyele}->{ref}) {
+ tpre(sprintf "tbrun-E: key '%s' is type'%s', expected '%s'\n",
+ $keyele, $ref, $href->{$keyele}->{ref});
+ return 0;
+ }
+ }
+ foreach my $keyref ( keys %$href ) {
+ next if $href->{$keyref}->{mode} eq 'o';
+ if (not exists $yele->{$keyref}) {
+ tpre(sprintf "tbrun-E: key '%s' missing\n", $keyref);
+ return 0;
+ }
+ }
+ return 1;
+}
+
+#-------------------------------------------------------------------------------
+sub lookup_var {
+ my ($vnam,$hrefs) = @_;
+ return $gblvars{$vnam} if exists $gblvars{$vnam};
+ if ($vnam =~ m/[A-Z][A-Z0-9_]*/) {
+ return $ENV{$vnam} if exists $ENV{$vnam};
+ }
+ tpre(sprintf "tbrun-E: can't replace '$vnam'\n");
+ exit 2;
+}
+
+#-------------------------------------------------------------------------------
+sub expand_vars {
+ my ($txt,$hrefs) = @_;
+ my $res = '';
+ while ($txt ne '') {
+ if ($txt =~ m/\$\{([a-zA-Z][a-zA-Z0-9_]*)\}/) {
+ my $vnam = $1;
+ my $vrep = lookup_var($vnam, $hrefs);
+ $res .= $`;
+ $res .= $vrep;
+ $txt = $';
+ } else {
+ $res .= $txt;
+ last;
+ }
+ }
+ return $res;
+}
+
+#-------------------------------------------------------------------------------
+sub merge_lines {
+ my ($txt) = @_;
+ $txt =~ s|\s*\\\n\s*| |mg;
+ chomp $txt;
+ return $txt;
+}
+
+#-------------------------------------------------------------------------------
+sub merge_expand {
+ my ($txt,$hrefs) = @_;
+ return expand_vars(merge_lines($txt), $hrefs);
+}
+
+#-------------------------------------------------------------------------------
+sub key_or_def {
+ my ($tag,$yele,$defhash) = @_;
+ return $yele->{$tag} if exists $yele->{$tag};
+ return $defhash->{$tag} if exists $defhash->{$tag};
+ return undef;
+}
+
+#-------------------------------------------------------------------------------
+sub handle_include {
+ my ($yele) = @_;
+ check_keys($yele, \%keys_include) or exit 2;
+
+ my $fnam = merge_expand($yele->{include}, undef);
+ include_file($fnam);
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub handle_default {
+ my ($yele, $defhash) = @_;
+ check_keys($yele, \%keys_default) or exit 2;
+ check_keys($yele->{default}, \%keys_defhash) or exit 2;
+ foreach my $key (keys %{$yele->{default}}) {
+ $$defhash{$key} = $$yele{default}{$key};
+ }
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub handle_itest {
+ my ($yele, $defhash) = @_;
+ check_keys($yele, \%keys_itest) or exit 2;
+
+ $nseen += 1;
+
+ my $tlist = key_or_def('tag', $yele, $defhash);
+ if (defined $tlist) {
+ return unless check_tagfilter(\@tagincl, $tlist);
+ return if check_tagfilter(\@tagexcl, $tlist);
+ }
+
+ my $mlist = merge_expand(key_or_def('mode', $yele, $defhash), undef);
+
+ foreach my $mode (@modelist) {
+ next unless check_modefilter($mode, $mlist);
+
+ my $ms = '_' . $mode;
+ $ms =~ s/_bsim$//;
+ $gblvars{ms} = $ms;
+
+ my $test = merge_expand($yele->{test}, undef);
+
+ # forward options for tbrun_tbw or tbrun_tbwrri commands
+ if ($test =~ m/^\s*(tbrun_tbw|tbrun_tbwrri)\s+(.*)$/) {
+ my $cmd = $1;
+ my $rest = $2;
+ $test = $cmd;
+ $test .= ' --nomake' if $opts{nomake};
+ $test .= ' --norun' if $opts{norun};
+ if ($cmd eq 'tbrun_tbwrri') {
+ $test .= ' --rlmon' if $opts{rlmon};
+ $test .= ' --rbmon' if $opts{rbmon};
+ $test .= ' --bwait '.$opts{bwait} if $opts{bwait};
+ $test .= ' --swait '.$opts{swait} if $opts{swait};
+ }
+ $test .= ' ' . $rest;
+ }
+
+ my $tid = scalar(@tlist);
+ my $tmsg = sprintf "t%03d - tags: ", $tid;
+ $tmsg .= join ',',@$tlist if defined $tlist;
+
+ my %titem;
+ $titem{id} = $tid;
+ $titem{cd} = getcwd();
+ $titem{test} = $test;
+ $titem{tag} = $tlist;
+ $titem{tmsg} = $tmsg;
+
+ push @{$titem{locks}}, $titem{cd};
+
+ push @tlist, \%titem;
+
+ delete $gblvars{ms};
+ }
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub tpr {
+ my ($txt) = @_;
+ print $txt;
+ print $fh_tee $txt if defined $fh_tee;
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub tpre {
+ my ($txt) = @_;
+ print STDERR $txt;
+ print $fh_tee $txt if defined $fh_tee;
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub max {
+ my ($a,$b) = @_;
+ return ($a > $b) ? $a : $b;
+}
+
+#-------------------------------------------------------------------------------
+sub open_job_fh {
+ my ($cmd) = @_;
+ my $fh = new FileHandle;
+
+ # add STDERR->STDOUT redirect (create sub shell of needed)
+ $cmd = '(' . $cmd . ')' if $cmd =~ m/\n/g;
+ $cmd .= ' 2>&1';
+
+ # open returns pid of created process in case an in or out pipe is created
+ my $pid = open $fh, '-|', $cmd;
+ # print "+++1 $pid\n";
+
+ if (not $pid) {
+ my $err = $!;
+ my $msg = sprintf "tbrun-E: failed to start '%s'\n cwd: %s\n error: %s\n",
+ $cmd, getcwd(), $err;
+ return (undef, undef, $msg);
+ }
+ return ($fh, $pid, undef);
+}
+
+#-------------------------------------------------------------------------------
+sub run_tests_single {
+ my $drycd = '';
+ foreach my $titem (@tlist) {
+ my $cdir = $titem->{cd};
+ my $test = $titem->{test};
+
+ chdir $inicwd or die "chdir to '$inicwd' failed with '$!'";
+
+ if ($opts{dry}) {
+ if ($cdir ne $drycd) {
+ tpr("#------------------------------------------------------------\n");
+ tpr("cd $cdir\n");
+ $drycd = $cdir;
+ }
+ tpr("#----------------------------------------\n");
+ tpr("# $titem->{tmsg}\n");
+ tpr("$test\n");
+
+ } else {
+ tpr("#----------------------------------------\n");
+ tpr("# $titem->{tmsg}\n");
+ $ndone += 1;
+ my $cmd = '';
+ $cmd .= "cd $cdir";
+ $cmd .= "\n";
+ $cmd .= "$test";
+
+ my ($fh,$pid,$msg) = open_job_fh($cmd);
+ if (not defined $fh) {
+ tpre($msg);
+ } else {
+ while (<$fh>) {
+ print $_;
+ }
+ if (not close $fh) {
+ my $err = $?;
+ tpr(sprintf "tbrun-I: test FAILed with exit status %d,%d\n",
+ ($err>>8), ($err&0xff));
+ $nfail += 1;
+ }
+ }
+ }
+ }
+
+ if ($opts{dry}) {
+ tpr("#------------------------------------------------------------\n");
+ tpr(sprintf "cd %s\n", $inicwd);
+ }
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub print_ticker {
+ return unless $ticker_on;
+
+ my ($rwlist) = @_;
+ my $msg = '';
+ state $lastlength = 0;
+
+ if (defined $rwlist) {
+ my $time_now = gettimeofday();
+ $msg = '#-I: ' . join '; ', map {
+ sprintf('t%03d: %dl %3.1fs',
+ $_->{id}, $_->{nlines}, $time_now-$_->{tstart})
+ } @$rwlist;
+ $msg = substr($msg,0,75) . ' ...' if length($msg) >79;
+ unless (defined $opts{trace}) {
+ my $suff = sprintf '(%dt,%dw,%do)',
+ scalar(@tlist), scalar(@wlist), scalar(@olist);
+ if (length($suff) + length($msg) + 1 <= 79) {
+ $msg .= ' ' . $suff;
+ } else {
+ $msg = substr($msg,0,79-6-length($suff)) . ' ... ' . $suff;
+ }
+ }
+ }
+ my $newlength = length($msg);
+ $msg .= ' ' x ($lastlength - $newlength) if $lastlength > $newlength;
+ print $msg . "\r";
+ $lastlength = $newlength;
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub print_jobs {
+ while (defined $olist[0]->{exitcode}) {
+ print_ticker();
+ my $titem = shift @olist;
+ tpr("#----------------------------------------\n");
+ tpr("# $titem->{tmsg}\n");
+ tpr($titem->{out});
+ }
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub print_trace {
+ my ($titem) = @_;
+ my $pref = '';
+ my $suff = sprintf '(%dt,%dw,%do)',
+ scalar(@tlist), scalar(@wlist), scalar(@olist);
+ if (defined $titem->{exitcode}) {
+ $pref = ($titem->{exitcode}==0) ? 'pass ' : 'FAIL ';
+ } else {
+ $pref = 'start';
+ }
+ my $txt = '#-I: ' . $pref . ' ' . $titem->{tmsg};
+ $txt .= ' ' . $suff;
+ $txt .= "\n";
+ print_ticker();
+ tpr($txt);
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub start_jobs {
+
+ # initialize lock hash
+ my %locks;
+ foreach my $titem (@wlist) {
+ foreach my $lock (@{$titem->{locks}}) {
+ $locks{$lock} = 1;
+ }
+ }
+
+ # look for suitable tasks
+ for (my $i=0; $i < scalar(@tlist) && scalar(@wlist) < $opts{jobs}; ) {
+ my $titem = $tlist[$i];
+ my $nlock = 0;
+ foreach my $lock (@{$titem->{locks}}) {
+ if ($locks{$lock}) {
+ $nlock += 1;
+ last;
+ }
+ }
+
+ # suitable task found
+ if ($nlock == 0) {
+ my $cdir = $titem->{cd};
+ my $test = $titem->{test};
+ $ndone += 1;
+
+ my $cmd = '';
+ if ($opts{dry}) {
+ $cmd .= "cd $cdir";
+ $cmd .= "\n";
+ $cmd .= "perl -e 'select(undef, undef, undef, 0.2+1.6*rand( 1.))'";
+ $cmd .= "\n";
+ $cmd .= "echo \"cd $cdir\"";
+ $cmd .= "\n";
+ $cmd .= "echo \"$test\"";
+ } else {
+ $cmd .= "cd $cdir";
+ $cmd .= "\n";
+ $cmd .= "$test";
+ }
+
+ # start job
+ my ($fh,$pid,$msg) = open_job_fh($cmd);
+ if (not defined $fh) {
+ $titem->{out} = $msg;
+ $titem->{exitcode} = 1;
+ print_trace($titem) if $opts{trace};
+ print_jobs();
+ } else {
+ $titem->{fh} = $fh;
+ $titem->{fd} = fileno($fh);
+ $titem->{pid} = $pid;
+ $titem->{out} = '';
+ $titem->{tstart} = gettimeofday();
+ $titem->{nlines} = 0;
+ push @wlist, $titem;
+ foreach my $lock (@{$titem->{locks}}) {
+ $locks{$lock} = 1;
+ }
+ print_trace($titem) if $opts{trace};
+ }
+ splice @tlist, $i, 1; # remove from tlist
+ next; # and re-test i'th list element
+ } # if ($nlock == 0)
+
+ $i += 1; # inspect nexyt list element
+ } # for (my $i=0; ...
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub kill_job {
+ my ($titem, $trun) = @_;
+ my $pid = $titem->{pid};
+ my $pgid = getpgrp(0);
+ my %phash;
+
+ $titem->{killed} = $trun;
+
+ # get process tree data (for whole user, no pgid filtering possible
+ my $rank = 0;
+ open PS,"ps -H -o pid,ppid,pgid,comm --user $ENV{USER}|";
+ while () {
+ chomp;
+ next unless m/^\s*(\d+)\s+(\d+)\s+(\d+)\s(.*)$/;
+ my $cpid = $1;
+ my $cppid = $2;
+ my $cpgid = $3;
+ my $cargs = $4;
+ next unless $cpgid == $pgid; # only current process group
+ next if $cargs =~ m/^\s*ps\s*$/; # skip the 'ps' process itself
+ $phash{$cpid}->{ppid} = $cppid;
+ $phash{$cpid}->{pgid} = $cpgid;
+ $phash{$cpid}->{args} = $cargs;
+ $phash{$cpid}->{rank} = $rank++;
+ push @{$phash{$cppid}->{childs}}, $cpid;
+ }
+ close PS;
+
+ # sanity check 1: own tbrun process should be included
+ unless (exists $phash{$$}) {
+ print_ticker();
+ printf "-E: tmax kill logic error: tbrun master pid not in phash\n";
+ return;
+ }
+ # sanity check 2: job to be killed should be child of master tbrun
+ unless ($phash{$pid}->{ppid} == $$) {
+ print_ticker();
+ printf "-E: tmax kill logic error: job not child of tbrun\n";
+ return;
+ }
+
+ # determine number of leading blanks in master tbrun line
+ my $nstrip = 0;
+ $nstrip = length($1) if ($phash{$$}->{args} =~ m/^(\s*)/);
+
+ # recursively mark all childs of job master
+ my @pids = ($pid);
+ while (scalar(@pids)) {
+ my $cpid = shift @pids;
+ if (not exists $phash{$cpid}) {
+ print_ticker();
+ printf "-E: tmax kill logic error: child pid not in phash\n";
+ return;
+ }
+ $phash{$cpid}->{kill} = 1;
+ if (exists $phash{$cpid}->{childs}) {
+ push @pids, @{$phash{$cpid}->{childs}};
+ }
+ }
+
+ # build list of pid to be killed, and trace message
+ my @kpids;
+ my @ktext;
+ foreach my $cpid (sort {$phash{$a}->{rank} <=> $phash{$b}->{rank} }
+ grep {$phash{$_}->{kill}}
+ keys %phash) {
+ push @kpids, $cpid;
+ push @ktext, sprintf "# %6d %6d %6d %s",
+ $cpid, $phash{$cpid}->{ppid},
+ $phash{$cpid}->{pgid},
+ substr($phash{$cpid}->{args}, $nstrip);
+ }
+
+ # print trace message, if selected
+ if ($opts{trace}) {
+ print_ticker();
+ printf "#-I: kill t%03d after %3.1fs, kill proccesses:\n",
+ $titem->{id}, $trun, join("\n");
+ print "# pid ppid pgid command\n";
+ print join("\n",@ktext) . "\n";
+ }
+
+ # and finally kill all processes of the job
+ kill 'TERM', @kpids;
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+sub run_tests_multi {
+ @olist = @tlist;
+
+ while (scalar(@tlist) || scalar(@wlist)) { # while something to do
+ # start new jobs, if available and job slots free
+ start_jobs();
+
+ my @fhlist = map { $_->{fh} } @wlist;
+ my %fdhash;
+ foreach my $titem (@wlist) {
+ $fdhash{$titem->{fd}} = $titem;
+ }
+
+ my $sel = IO::Select->new(@fhlist);
+ my $neof = 0;
+ my $time_ticker = gettimeofday() + 0.1;
+
+ while ($neof == 0) {
+ my $wait_ticker = max(0.1, $time_ticker - gettimeofday() + 0.1);
+ my @fhlist = $sel->can_read($wait_ticker);
+ my $time_now = gettimeofday();
+ if ($time_now >= $time_ticker) {
+ print_ticker(\@wlist);
+ $time_ticker = $time_now + 0.9;
+ }
+ foreach my $fh (@fhlist) {
+ my $fd = fileno($fh);
+ my $titem = $fdhash{$fd};
+ my $buf = '';
+ my $nb = sysread $fh, $buf, 1024;
+
+ # data read
+ if ($nb) {
+ $titem->{out} .= $buf;
+ $titem->{nlines} += ($buf =~ tr/\n/\n/); # count \n in $buf
+
+ # eof or error
+ } else {
+ if (defined $titem->{killed}) {
+ $titem->{out} .= sprintf
+ "tbrun-I: test killed after %3.1fs\n", $titem->{killed};
+ }
+ if (not close $fh) {
+ my $err = $?;
+ $titem->{out} .= sprintf
+ "tbrun-I: test FAILed with exit status %d,%d\n",
+ ($err>>8), ($err&0xff);
+ $nfail += 1;
+ $titem->{exitcode} = $err;
+ } else {
+ $titem->{exitcode} = 0;
+ }
+
+ $neof += 1;
+ for (my $i=0; $i < scalar(@wlist); $i++) {
+ next unless $wlist[$i]->{fd} == $fd;
+ splice @wlist, $i, 1;
+ last;
+ }
+ print_trace($titem) if $opts{trace};
+ }
+ } # foreach my $fh ...
+
+ # handle tmax
+ if (defined $opts{tmax}) {
+ foreach my $titem (@wlist) {
+ my $trun = $time_now - $titem->{tstart};
+ if ($trun > $opts{tmax}) {
+ kill_job($titem, $trun) unless defined $titem->{killed};
+ }
+ }
+ }
+
+ } # while ($neof == 0)
+ # here if at least one job finished
+ print_jobs();
+ }
+
+ return;
+}
tbrun
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: tbrun_tbw
===================================================================
--- tbrun_tbw (nonexistent)
+++ tbrun_tbw (revision 38)
@@ -0,0 +1,136 @@
+#!/bin/bash
+# $Id: tbrun_tbw 807 2016-09-17 07:49:26Z mueller $
+#
+# Copyright 2014-2016 by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-09-03 805 1.2.2 add TIMEFORMAT and time for make commands
+# 2016-08-21 800 1.2.1 add -norun, -nomake
+# 2016-08-06 795 1.2 use tbfilt; fixup -lsuf logic
+# 2016-07-03 782 1.1.4 drop ghdl_assert_filter (use --ieee=... at ghdl lvl)
+# 2016-06-25 778 1.1.3 drop make ghdl_tmp_clean logic
+# 2016-06-05 773 1.1.2 use _bsim.log for behavioral sim log
+# 2016-04-17 762 1.1.1 don't create '-run' for [IX]Sim anymore (now default)
+# 2016-02-06 727 1.1 add vivado xsim support; Makefile.ise support
+# 2014-12-27 622 1.0.1 add --stack, --ghw, --tbw, --pcom
+# 2014-12-26 621 1.0 Initial version
+#
+
+docmd ()
+{
+ if [[ -z "$optdry" ]] ; then
+ echo "$2"
+ eval "$1"
+ else
+ echo "$1"
+ fi
+}
+
+optdry=""
+optnomake=""
+optnorun=""
+optlsuf=""
+optstack=""
+optghw=""
+opttbw=""
+optpcom=""
+
+# handle options
+while (( $# > 0 )) ; do
+ case $1 in
+ -dry|--dry) optdry=$1 ; shift 1 ;;
+ -nomake|--nomake) optnomake=$1 ; shift 1 ;;
+ -norun|--norun) optnorun=$1 ; shift 1 ;;
+ -lsuf|--lsuf) optlsuf=$2 ; shift 2 ;;
+ -stack|--stack) optstack=$2 ; shift 2 ;;
+ -ghw|--ghw) optghw=$2 ; shift 2 ;;
+ -tbw|--tbw) opttbw=$2 ; shift 2 ;;
+ -pcom|--pcom) optpcom=$1 ; shift 1 ;;
+ -*) echo "tbrun_tbw-E: invalid option '$1'"; exit 1 ;;
+ *) break;;
+ esac
+done
+
+tbench=$1
+stimfile=$2
+
+# complain if no tbench defined
+if (( $# == 0 )) ; then
+ echo "Usage: tbrun_tbw [opts] testbench [stimfile]"
+ echo " Options:"
+ echo " --dry dry run, print commands, don't execute"
+ echo " --nomake don't execute make step"
+ echo " --norun don't execute run step"
+ echo " --lsuf suff use '_.log' as suffix for log file"
+ echo " --stack nnn use as ghdl stack size"
+ echo " --ghw fname write ghw file with name '.ghw"
+ echo " --tbw opts append to tbw command"
+ echo " --pcom print test comments"
+ exit 1
+fi
+
+# defaults
+isghdl=true
+makeopts=""
+
+# check for ISim
+isisim=""
+if [[ $tbench =~ _ISim ]] ; then
+ isisim=true
+ isghdl=""
+ if [[ -f "Makefile.ise" ]] ; then
+ makeopts="-f Makefile.ise"
+ fi
+fi
+
+# check for XSim
+isxsim=""
+if [[ $tbench =~ _XSim ]] ; then
+ isxsim=true
+ isghdl=""
+fi
+
+# issue makes
+if [[ -z "$optnomake" ]] ; then
+ cmd="TIMEFORMAT=$'real %3lR user %3lU sys %3lS'"
+ cmd+=$'\n'
+ cmd+="time make $makeopts $tbench"
+ docmd "$cmd"
+ exitstat=$?
+ if (( $exitstat > 0 )) ; then exit $exitstat; fi
+ echo ""
+fi
+
+# check for test bench
+if [[ ! -x $tbench ]] ; then
+ echo "tbrun_tbw-E: $tbench not existing or not executable"
+ exit 1
+fi
+
+# determine logfile name
+logsuff="_bsim"
+if [[ $tbench =~ _[fsorept]sim$ ]] ; then logsuff=""; fi
+if [[ -n "$optlsuf" ]] ; then logsuff+="_$optlsuf"; fi
+
+logfile="${tbench}${logsuff}.log"
+
+# now build actual test command (a tbw | tbfilt pipe)
+cmdtb="tbw $tbench"
+if [[ -n "$stimfile" ]] ; then cmdtb+=" $stimfile"; fi
+if [[ -n "$opttbw" ]] ; then cmdtb+=" $opttbw"; fi
+if [[ -n "$optstack" ]] ; then cmdtb+=" --stack-max-size=$optstack"; fi
+if [[ -n "$optghw" ]] ; then cmdtb+=" --wave=$optghw.ghw"; fi
+cmdtb+=" 2>&1"
+
+cmdtf="tbfilt -tee $logfile"
+if [[ -n "$optpcom" ]] ; then cmdtf+=" -pcom"; fi
+
+cmd="(export TIMEFORMAT=$'real %3lR user %3lU sys %3lS'; time $cmdtb) 2>&1"
+cmd+=" | $cmdtf"
+txt="$cmdtb | $cmdtf"
+
+if [[ -z "$optnorun" ]] ; then
+ docmd "$cmd" "$txt"
+fi
tbrun_tbw
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: tbrun_tbwrri
===================================================================
--- tbrun_tbwrri (nonexistent)
+++ tbrun_tbwrri (revision 38)
@@ -0,0 +1,239 @@
+#!/bin/bash
+# $Id: tbrun_tbwrri 808 2016-09-17 13:02:46Z mueller $
+#
+# Copyright 2014-2016 by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-09-17 808 1.3.3 add --r(l|b)mon,(b|s)wait; configure now via _conf=
+# 2016-09-03 805 1.3.2 add TIMEFORMAT and time for make commands
+# 2016-08-21 800 1.3.1 add -norun, -nomake
+# 2016-08-06 795 1.3 use tbfilt; fixup -lsuf logic
+# 2016-07-03 783 1.2.5 drop ghdl_assert_filter (use --ieee=... at ghdl lvl)
+# 2016-06-25 778 1.2.4 drop make ghdl_tmp_clean logic
+# 2016-06-18 776 1.2.3 use ti_rri --tout to set connection timeout
+# 2016-06-05 773 1.2.2 use _bsim.log for behavioral sim log
+# 2016-03-20 748 1.2.1 BUGFIX: add portsel oob for -hxon
+# use 120 sec timeout for simulation
+# 2016-03-18 745 1.2 use --sxon and --hxon instead of --xon
+# 2015-04-11 666 1.1 add --fusp,--xon
+# 2014-12-27 622 1.0 Initial version
+#
+
+chkval ()
+{
+ if [[ $1 =~ --.* || $1 =~ -[a-z]* ]]; then
+ echo "tbrun_tbwrri-E: value forgotten prior to '$1'"
+ exit 1
+ fi
+}
+
+docmd ()
+{
+ if [[ -z "$optdry" ]] ; then
+ echo "$2"
+ eval "$1"
+ else
+ echo "$1"
+ fi
+}
+
+optdry=""
+optnomake=""
+optnorun=""
+optlsuf=""
+optstack=""
+optghw=""
+opttbw=""
+optpack=""
+optrri=""
+optpcom=""
+optcuff=""
+optfusp=""
+optsxon=""
+opthxon=""
+optrlmon=""
+optrbmon=""
+optbwait=0
+optswait=0
+
+# handle options
+while (( $# > 0 )) ; do
+ case $1 in
+ -dry|--dry) optdry=$1 ; shift 1 ;;
+ -nomake|--nomake) optnomake=$1 ; shift 1 ;;
+ -norun|--norun) optnorun=$1 ; shift 1 ;;
+ -lsuf|--lsuf) optlsuf=$2 ; chkval $2 ; shift 2 ;;
+ -stack|--stack) optstack=$2 ; chkval $2 ; shift 2 ;;
+ -ghw|--ghw) optghw=$2 ; chkval $2 ; shift 2 ;;
+ -tbw|--tbw) opttbw=$2 ; chkval $2 ; shift 2 ;;
+ -pack|--pack) optpack=$2 ; chkval $2 ; shift 2 ;;
+ -rri|--rri) optrri=$2 ; chkval $2 ; shift 2 ;;
+ -cuff|--cuff) optcuff=$1 ; shift 1 ;;
+ -fusp|--fusp) optfusp=$1 ; shift 1 ;;
+ -sxon|--sxon) optsxon=$1 ; shift 1 ;;
+ -hxon|--hxon) opthxon=$1 ; shift 1 ;;
+ -pcom|--pcom) optpcom=$1 ; shift 1 ;;
+ -rlmon|--rlmon) optrlmon=$1 ; shift 1 ;;
+ -rbmon|--rbmon) optrlmon=$1 ; shift 1 ;;
+ -bwait|--bwait) optbwait=$2 ; chkval $2 ; shift 2 ;;
+ -swait|--swait) optswait=$2 ; chkval $2 ; shift 2 ;;
+ -\?|-h*|--h*) opthelp=$1 ; shift 1 ;;
+ -*) echo "tbrun_tbwrri-E: invalid option '$1'"; exit 1 ;;
+ *) break;;
+ esac
+done
+
+# complain if no tbench defined
+if [[ -n "$opthelp" || $# -eq 0 ]] ; then
+ echo "Usage: tbrun_tbwrri [opts] testbench rricmds..."
+ echo " Options:"
+ echo " --dry dry run, print commands, don't execute"
+ echo " --nomake don't execute make step"
+ echo " --norun don't execute run step"
+ echo " --lsuf suff use '_.log' as suffix for log file"
+ echo " --stack nnn use as ghdl stack size"
+ echo " --ghw fname write ghw file with name '.ghw'"
+ echo " --tbw opts append to tbw command"
+ echo " --pack plist add '--pack=<=plist>' option to ti_rri"
+ echo " --rri opts append to ti_rri command"
+ echo " --cuff use cuff and not serport"
+ echo " --fusp use 2nd serport"
+ echo " --sxon use xon with 1st serport (via SWI(1))"
+ echo " --hxon use xon with 1st serport (hardwired)"
+ echo " --pcom print test comments"
+ echo " --rlmon enable rlmon"
+ echo " --rbmon enable rbmon"
+ echo " --bwait ns start-up wait in ns for behavioral simulations"
+ echo " --swait ns start-up wait in ns for post-syn simulations"
+ exit 1
+fi
+
+# check that only one of --cuff --fusp or --?xon given
+ncfxcount=0
+if [[ -n "$optcuff" ]] ; then ncfxcount=$(($ncfxcount+1)); fi
+if [[ -n "$optfusp" ]] ; then ncfxcount=$(($ncfxcount+1)); fi
+if [[ -n "$opthxon" ]] ; then ncfxcount=$(($ncfxcount+1)); fi
+if [[ -n "$optsxon" ]] ; then ncfxcount=$(($ncfxcount+1)); fi
+
+if (( $ncfxcount > 1 )) ; then
+ echo "tbrun_tbwrri-E: only one of --cuff,-fusp,--sxon,--hxon allowed"
+ exit 1
+fi
+
+tbench=$1
+shift 1
+makeopts=""
+
+tbenchname=$(basename $tbench)
+tbenchpath=$(dirname $tbench)
+
+# issue makes
+# add -C $tbenchpath only if not '.' to avoid 'Entering/Leaving' messages
+makeopts=""
+if [[ "$tbenchpath" != "." ]] ; then
+ makeopts="-C $tbenchpath"
+fi
+if [[ -z "$optnomake" ]] ; then
+ cmd="TIMEFORMAT=$'real %3lR user %3lU sys %3lS'"
+ cmd+=$'\n'
+ cmd+="time make $makeopts $tbench"
+ docmd "$cmd"
+ exitstat=$?
+ if (( $exitstat > 0 )) ; then exit $exitstat; fi
+ echo ""
+fi
+
+# check for test bench
+if [[ ! -x $tbench ]] ; then
+ echo "tbrun_tbwrri-E: $tbench not existing or not executable"
+ exit 1
+fi
+
+# determine logfile name and determine startup wait (bwait or swait)
+logsuff="_bsim"
+waitns=$optbwait
+if [[ $tbenchname =~ _[fsorept]sim$ ]] ; then
+ logsuff=""
+ waitns=$optswait
+fi
+if [[ -n "$optlsuf" ]] ; then logsuff+="_$optlsuf"; fi
+
+logfile="${tbenchname}${logsuff}.log"
+
+# determine simbus configure (done with inline mode _conf={l1;l2;l3})
+# Note: .sdata expects hex in full signal size (addr 8 bit, data 16 bit)
+conf=""
+if [[ -n "$optcuff" ]] ; then
+ conf+=".sdata 08 0004;" # portsel = 0100 -> fx2
+ conf+=".sdata 10 0004;" # swi = 0100 -> fx2
+fi
+
+if [[ -n "$optfusp" ]] ; then
+ conf+=".sdata 08 0001;" # portsel = 0001 -> 2nd ser
+ conf+=".sdata 10 0001;" # swi = 0001 -> 2nd ser
+fi
+
+if [[ -n "$optsxon" ]] ; then
+ conf+=".sdata 08 0002;" # portsel = 0010 -> 1st ser XON
+ conf+=".sdata 10 0002;" # swi = 0010 -> 1st ser XON
+fi
+
+if [[ -n "$opthxon" ]] ; then
+ conf+=".sdata 08 0002;" # portsel = 0010 -> 1st ser XON
+fi
+
+if (( $waitns > 0 )) ; then
+ conf+=".wait $waitns ns;"
+fi
+
+# now build actual test command
+cmdtb+="ti_rri --run=\"tbw $tbench -fifo"
+if [[ -n "$conf" ]] ; then cmdtb+=" '_conf={$conf}'"; fi
+if [[ -n "$opttbw" ]] ; then cmdtb+=" $opttbw"; fi
+if [[ -n "$optstack" ]] ; then cmdtb+=" --stack-max-size=$optstack"; fi
+if [[ -n "$optghw" ]] ; then
+ if [[ "$optghw" != *.ghw ]]; then optghw="$optghw.ghw"; fi
+ cmdtb+=" --wave=$optghw";
+fi
+cmdtb+=" 2>&1 \""
+
+# Note: the following ensurs that we always have 'fifo=,' with an
+# empty first field (the default fifo name)
+fifoopts=""
+if [[ -n "$opthxon" ]] ; then fifoopts+=",xon"; fi
+if [[ -n "$optsxon" ]] ; then fifoopts+=",xon"; fi
+
+if [[ -n "$fifoopts" ]] ; then
+ cmdtb+=" --fifo=$fifoopts"
+else
+ cmdtb+=" --fifo"
+fi
+
+cmdtb+=" --logl=3"
+cmdtb+=" --tout=120." # 120 sec timeout for simulation
+
+if [[ -n "$optpack" ]] ; then cmdtb+=" --pack=$optpack"; fi
+if [[ -n "$optrri" ]] ; then cmdtb+=" $optrri"; fi
+
+cmdtb+=" --"
+
+while (( $# > 0 )) ; do
+ cmdtb+=" "
+ if [[ $1 =~ " " ]] ; then cmdtb+="\""; fi
+ cmdtb+="$1"
+ if [[ $1 =~ " " ]] ; then cmdtb+="\""; fi
+ shift 1
+done
+
+cmdtf="tbfilt -tee $logfile"
+if [[ -n "$optpcom" ]] ; then cmdtf+=" -pcom"; fi
+
+cmd="(export TIMEFORMAT=$'real %3lR user %3lU sys %3lS'; time $cmdtb) 2>&1"
+cmd+=" | $cmdtf"
+txt="$cmdtb | $cmdtf"
+
+if [[ -z "$optnorun" ]] ; then
+ docmd "$cmd" "$txt"
+fi
tbrun_tbwrri
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: tbw
===================================================================
--- tbw (nonexistent)
+++ tbw (revision 38)
@@ -0,0 +1,335 @@
+#!/usr/bin/perl -w
+# $Id: tbw 808 2016-09-17 13:02:46Z mueller $
+#
+# Copyright 2007-2016 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-09-03 805 1.5.4 use {} as delimiter for immediate mode data
+# 2016-08-28 804 1.5.3 BUGFIX: xsim: append -R to ARGV (was prepended...)
+# 2016-07-02 782 1.5.2 add TBW_GHDL_OPTS
+# 2016-06-25 778 1.5.1 support all sim modes
+# 2016-04-17 762 1.5 make '-run' default for [IX]Sim, add '-norun'
+# 2016-03-20 748 1.4 recode OPTIONS handling and -fifo handling
+# 2016-02-06 727 1.3 add XSim support
+# 2015-01-04 629 1.2.6 BUGFIX: setup proper dsc values after -fifo
+# 2014-12-23 619 1.2.5 add -fifo and -verbose options
+# 2014-07-27 575 1.2.4 use xtwi to start ISim models
+# 2011-11-06 420 1.2.3 fix tbw.dat parsing (allow / in file names)
+# 2010-05-23 294 1.2.2 handle tb_code's in non-local directories
+# 2010-04-18 279 1.2.1 add -help and more text to print_usage()
+# 2009-11-22 252 1.2 add ISim support
+# 2007-09-15 82 1.1.1 test for ambigous matches of name arguments; for
+# "suff=[l1;l2;..]" style inlines use linkname_tmp.tmp
+# as filename
+# 2007-09-09 81 1.1 add fifo setup to tbw; allow multiple action lines
+# per target; support immediate mode data
+# "[line1;line2;...]" values
+# 2007-08-03 71 1.0.1 handle redefinition of existing symlink correctly
+# 2007-06-30 62 1.0 Initial version
+#
+# 'test bench wrapper' to setup symlink refering to stimulus file(s)
+#
+# usage: tbw [file] [args]
+#
+# will look for file (default is _stim.dat) and setup a symlink
+# _stim_dat to refer to it. All args are passed along to
+#
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+use POSIX qw(mkfifo);
+use FileHandle;
+use File::Spec;
+use Cwd 'abs_path';
+
+my $tb_code;
+my $is_ghdl; # uses ghdl simulator
+my $is_isim; # uses ISE simulator
+my $is_isim_run;
+my $is_xsim; # uses vivado simulator
+my $opt_run;
+my $opt_norun;
+my $opt_fifo;
+my $opt_verbose;
+
+my @args_pos; # list of positional args
+my @args_nam; # list of named args
+my @file_dsc; # file descriptors from tbw.dat
+
+my $ghdl_opts = $ENV{TBW_GHDL_OPTS}; # ghdl extra options
+
+sub print_usage;
+
+autoflush STDOUT 1; # autoflush, so nothing lost on exec later
+
+if (scalar(@ARGV) && $ARGV[0] =~ m/^-+help$/) { # -help or --help given
+ print_usage;
+ exit 0;
+}
+
+if (scalar(@ARGV) == 0) {
+ print "tbw-E: name of test bench code missing\n";
+ print_usage;
+ exit 1;
+}
+
+# process test-bench-filename
+
+$tb_code = shift @ARGV;
+my $tb_code_path = ".";
+my $tb_code_name = $tb_code;
+if ($tb_code =~ m|^(.*)/(.*)$|) {
+ $tb_code_path = $1;
+ $tb_code_name = $2;
+}
+
+# process -norun, -fifo and -verbose options (can be in any order now)
+
+while (scalar(@ARGV)) {
+ my $opt = $ARGV[0];
+ if ($opt =~ m/^-+norun$/) { $opt_norun = 1; shift @ARGV;}
+ elsif ($opt =~ m/^-+fifo$/) { $opt_fifo = 1; shift @ARGV;}
+ elsif ($opt =~ m/^-+verbose$/) { $opt_verbose = 1; shift @ARGV;}
+ elsif ($opt =~ m/^-+run$/) {
+ print "tbw-I: legacy option '-run' seen and ignored; is now default\n";
+ shift @ARGV;
+ }
+ else { last;}
+}
+
+my $tb_code_stem = $tb_code_name;
+$tb_code_stem =~ s/_[fsorept]sim$//; # drop sim mode suffix
+
+if ($tb_code_stem =~ /_ISim$/) { # is it an ISim executable ?
+ $tb_code_stem =~ s/_ISim$//; # drop _ISim
+ $is_isim = 1;
+ $is_isim_run = not $opt_norun;
+}
+
+if ($tb_code_stem =~ /_XSim$/) { # is it an XSim executable ?
+ $tb_code_stem =~ s/_XSim$//; # drop _XSim
+ $is_xsim = 1;
+ push @ARGV,'-R' unless $opt_norun; # run all unless '-norun' given
+}
+
+$is_ghdl = not ($is_isim or $is_xsim);
+
+if (not -e $tb_code) {
+ print "tbw-E: $tb_code not existing or not executable\n";
+ print_usage;
+ exit 1;
+}
+
+#
+# read tbw.dat file in current directory or directory of executable
+#
+
+my $tbwdat_file = "tbw.dat";
+$tbwdat_file = "$tb_code_path/tbw.dat" unless (-r "tbw.dat");
+
+if (-r $tbwdat_file) {
+ my $ok = 0;
+ my $done = 0;
+
+ open (TBW, $tbwdat_file) or die "failed to open $tbwdat_file: $!";
+ while () {
+ chomp;
+ next if /^#/;
+ if ( m{^\s*\[([\.\/a-zA-Z0-9_]*)\]\s*$} ) {
+ last if $done;
+ $ok = 0;
+ $ok = 1 if ($1 eq $tb_code || $1 eq $tb_code_stem);
+ } elsif ( m{^\s*([a-zA-Z0-9_]*)\s*=\s*([a-zA-Z0-9_./<>]*)\s*$} ) {
+ if ($ok) {
+ push @file_dsc, {tag=>$1, val=>$2};
+ $done = 1;
+ }
+ } else {
+ print "tbw-E: bad line in tbw.dat:\n $_\n";
+ }
+ }
+} else {
+ print "tbw-I: didn't find ${tbwdat_file}, using defaults\n";
+}
+
+#
+# if no tbw.dat or no matching stanza found, setup defaults
+#
+unless (scalar (@file_dsc)) {
+ if ($opt_fifo) {
+ push @file_dsc, {tag=>'rlink_cext_fifo_rx', val=>''};
+ push @file_dsc, {tag=>'rlink_cext_fifo_tx', val=>''};
+ push @file_dsc, {tag=>'rlink_cext_conf', val=>''};
+ } else {
+ push @file_dsc, {tag=>$tb_code_stem . "_stim",
+ val=>$tb_code_stem . "_stim.dat"};
+ }
+}
+
+#
+# now process argument list
+#
+
+{
+ my $ind = 0;
+ while (scalar(@ARGV)>0 && not $ARGV[0] =~ /^-/) {
+ my $arg = shift @ARGV;
+ my $ok;
+ if ($arg =~ /([a-zA-Z0-9_]*)=(.*)/) { # named argument
+ my $tag = $1;
+ my $val = $2;
+ foreach my $dsc (@file_dsc) {
+ if ($dsc->{tag} =~ /$tag$/) {
+ $dsc->{val} = $val;
+ $ok += 1;
+ }
+ }
+ if ($ok == 0) {
+ print STDERR "tbw-F: can't match named argument: $arg\n";
+ exit 1;
+ } elsif ($ok > 1) {
+ print STDERR "tbw-F: ambiguous match for named argument: $arg\n";
+ exit 1;
+ }
+
+ } else { # positional argument
+ if ($ind < scalar(@file_dsc)) {
+ $file_dsc[$ind]->{val} = $arg;
+ } else {
+ print STDERR "tbw-F: too many positional arguments: $arg\n";
+ exit 1;
+ }
+ $ind += 1;
+ }
+ }
+}
+
+if ($opt_verbose) {
+ foreach my $dsc (@file_dsc) {
+ my $tag = $dsc->{tag};
+ my $val = $dsc->{val};
+ printf " %s = %s\n", $tag, $val;
+ }
+}
+
+#
+# now handle all specified file descriptors
+#
+
+foreach my $dsc (@file_dsc) {
+ my $tag = $dsc->{tag};
+ my $val = $dsc->{val};
+ if ($val eq "") { # handle FIFO's
+ next if (-p $tag);
+ print "tbw-I: create FIFO $tag\n";
+ mkfifo($tag, 0666) || die "can't mkfifo $tag: $!";
+
+ } else { # handle link to file cases
+
+ if ($val =~ /^\{(.*)\}$/) { # immediate data case: "{line1;line2;...}"
+ my @lines = split /;/, $1;
+ my $fname = "$tag\_tmp.tmp";
+ open TFILE,">$fname" or die "can't create temporary file $fname: $!";
+ foreach (@lines) {
+ s/^\s*//;
+ s/\s*$//;
+ print TFILE "$_\n";
+ }
+ close TFILE;
+ $val = $fname;
+
+ } else {
+ unlink "$tag\_tmp.tmp" if (-e "$tag\_tmp.tmp"); # remove old .tmp file
+ $val = "/dev/null" if ($val eq ""); # null file case
+ }
+
+ # handle file names
+ # - if absolute path keep then
+ # - if relative path seen note that it is relative to test bench code path
+ # --> prepent test bench path, canonize, and convert to a relative path
+ # name relavive to cwd !
+ unless ($val =~ m|^/|) {
+ $val = $tb_code_path . '/' . $val;
+ $val = File::Spec->abs2rel(abs_path($val));
+ }
+
+ if (not -r $val) {
+ print "tbw-F: file for '$tag' not existing or not readable: $val\n";
+ exit 1;
+ }
+
+ if (-l $tag) {
+ my $cur_link = readlink $tag;
+ if ($cur_link ne $val) {
+ print "tbw-I: redefine $tag -> $val\n";
+ unlink $tag
+ or die "failed to unlink: $!";
+ symlink $val, $tag
+ or die "failed to symlink 1: $!";
+ }
+ } else {
+ if (-e $tag) {
+ print "tbw-F: $tag exists but is not a symlink\n";
+ exit 1;
+ } else {
+ print "tbw-I: define $tag -> $val\n";
+ symlink $val, $tag
+ or die "failed to symlink 2: $!";
+ }
+ }
+ }
+}
+
+#
+# additional ghdl options
+#
+if ($is_ghdl && defined $ghdl_opts) {
+ push @ARGV, split /\s+/,$ghdl_opts;
+}
+
+#
+# here all ok, finally exec test bench
+#
+
+if ($is_isim_run) { # handle for isim 'run all'
+ my $cmd = "xtwi" . " " . $tb_code . " " . join " ",@ARGV;
+ open (ISIM_RUN, "| $cmd")
+ or die "failed to open process pipe to isim: $!";
+ print ISIM_RUN "run all\n";
+ print ISIM_RUN "quit\n";
+ close (ISIM_RUN)
+ or die "failed to close process pipe to isim: $!";
+
+} else { # otherwise just exec
+ # print ($tb_code . " " . join(" ",@ARGV) . "\n");
+ exec $tb_code,@ARGV
+ or die "failed to exec: $!";
+}
+
+# ----------------------------------------------------------------------------
+sub print_usage {
+ print "usage: tbw [opts] [filedefs] [ghdl-opts]\n";
+ print " opts\n";
+ print " -norun for _ISim tb's, runs the tb without 'run all' command\n";
+ print " -fifo use rlink_cext fifo, ignore tbw.dat\n";
+ print " -verbose show the used tag,value settings before execution\n";
+ print " filedefs define tb input, either filename in tbw.dat order or\n";
+ print " tag=name or tag=[] pairs with tag matching one in in\n";
+ print " tbw.dat. The [] form allows to give data inline, e.g.\n";
+ print " like \"_conf={.rpmon 1}\"\n";
+ print " ghdl-opts are all other options starting with a '-', they are\n";
+ print " passed to the testbench. Some useful ghdl options are:\n";
+ print " --wave=x.ghw\n";
+ print " --stack-max-size=16384\n";
+ print " --stop-time=1ns --disp-time --trace-processes\n";
+}
tbw
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: ti_rri
===================================================================
--- ti_rri (nonexistent)
+++ ti_rri (revision 38)
@@ -0,0 +1,344 @@
+#! /usr/bin/env tclshcpp
+# -*- tcl -*-
+# $Id: ti_rri 799 2016-08-21 09:20:19Z mueller $
+#
+# Copyright 2011-2016 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2015-01-09 776 1.2.2 add --tout option to setup rlc timeout before connect
+# 2015-01-09 631 1.2.1 use rlc get/set rather config
+# 2014-11-07 601 1.2 use tclshcpp (C++ based) rather tclsh
+# 2013-05-19 521 1.1.6 setup proper interactive handling; add --run reap
+# 2013-04-26 510 1.1.5 reorganize readline startup
+# 2013-04-12 504 1.1.4 add --pack; trailing '-' argv implies --int
+# 2013-02-05 482 1.1.3 stop server is rls found
+# 2013-01-27 478 1.1.2 use 'exec sh -c $cmd &' for --run implementation
+# 2013-01-02 467 1.1.1 call rlc close only when really open
+# 2012-12-27 465 1.1 add --cuff support
+# 2012-02-09 457 1.0.4 disable autoexec
+# 2011-12-19 440 1.0.3 re-organize option handling for --term and --fifo
+# 2011-12-04 435 1.0.2 add flow attribute to --term
+# 2011-04-22 379 1.0.1 check for RETROBASE; proper exit handling; help text
+# 2011-04-17 376 1.0 Initial version
+# 2011-03-19 371 0.1 First draft
+#
+#
+# --pack=pname,...
+# --fifo[=name,opts,...]
+# --term[=name,baud,opts,...]
+# --cuff[=name,...]
+# --run=command
+# --log=filename ; default "-"
+# --logl=n ; default 2
+# --dmpl=n ; default 0
+# --tiol=n ; default 0
+# --tout=n ; default 1.
+# --int
+# --help
+# --
+# tcl cmds
+# @...tcl
+#
+
+set tirri_interactive 0
+
+array set opts {
+ pack_ ""
+ fifo 0
+ fifo_ ""
+ term 0
+ term_ ""
+ cuff 0
+ cuff_ ""
+ run_ ""
+ log_ "-"
+ logl_ 2
+ dmpl_ 0
+ tiol_ 0
+ tout_ 1.
+ int 0
+ help 0
+}
+
+set clist {}
+set optsendseen 0
+set runpid {}
+
+# disable autoexec
+set auto_noexec 1
+
+#
+# cleanup handler
+# must be in a proc so that it can be called from tclreadline
+# must be defined before ::tclreadline::Loop called (all after ignored...)
+#
+proc tirri_exit {{doexit 1}} {
+ global opts
+ global runpid
+
+ # check for rlink server, stop it
+ if { [info commands rls] eq "rls" } { rls server -stop }
+
+ # now close rlink connection
+ if { $opts(fifo) || $opts(term) || $opts(cuff) } {
+ if { [rlc open] ne "" } { rlc close }
+ }
+
+ # FIXME_code: should sync here with -run process run-down
+ # but no wait available in tcl (grr...)
+ if { "$runpid" ne "" } {
+ after 100; # currently just wait 100ms
+ rutil::waitpid $runpid
+ }
+ if { $doexit } {
+ puts {}; # \n to ensure shell prompt on new line
+ exit
+ }
+ return
+}
+
+foreach arg $argv {
+ if { $optsendseen } {
+ lappend clist $arg
+ continue
+ }
+ switch -regexp -- $arg {
+ ^--?pack=.+$ { regexp -- {=(.*)} $arg dummy opts(pack_) }
+ ^--?fifo=?.*$ { set opts(fifo) 1; regexp -- {=(.*)} $arg dummy opts(fifo_) }
+ ^--?term=?.*$ { set opts(term) 1; regexp -- {=(.*)} $arg dummy opts(term_) }
+ ^--?cuff=?.*$ { set opts(cuff) 1; regexp -- {=(.*)} $arg dummy opts(cuff_) }
+ ^--?run=.+$ { regexp -- {=(.*)} $arg dummy opts(run_) }
+ ^--?log=.+$ { regexp -- {=(.*)} $arg dummy opts(log_) }
+ ^--?logl=.+$ { regexp -- {=(.*)} $arg dummy opts(logl_) }
+ ^--?dmpl=.+$ { regexp -- {=(.*)} $arg dummy opts(dmpl_) }
+ ^--?tiol=.+$ { regexp -- {=(.*)} $arg dummy opts(tiol_) }
+ ^--?tout=.+$ { regexp -- {=(.*)} $arg dummy opts(tout_) }
+ ^--?int$ { set opts(int) 1 }
+ ^--?help$ { set opts(help) 1 }
+ ^--$ { set optsendseen 1 }
+ ^--.+$ { puts "-E: bad option $arg, see --help for proper usage"
+ return 1
+ }
+ default { lappend clist $arg }
+ }
+}
+
+# check whether last element in clist is plain '-'
+if { [llength clist] } {
+ if { [lindex $clist end] eq "-" } {
+ set opts(int) 1
+ set clist [lrange $clist 0 end-1]
+ }
+}
+
+if { $opts(help) } {
+ # use {} as defimiter here to avoid that escaping of all []
+ puts {usage: ti_rri [OPTION]... [COMMAND]...}
+ puts {}
+ puts {Options:}
+ puts { --pack=PLIST load, with package require, additional packages}
+ puts { PLIST is comma separated list of package names}
+ puts { --run=CMD exec's CMD as subprocess before the rlink port opened}
+ puts { useful to start test benches, usually via 'tbw'}
+ puts { --fifo[=ARGS] open fifo type rlink port. Optional arguments are:}
+ puts { --fifo=[NAME[,OPTS]]}
+ puts { --term[=ARGS] open term type rlink port. Optional arguments are:}
+ puts { --term=[NAME[,BAUD[,OPTS]]]}
+ puts { --cuff[=ARGS] open cuff type rlink port. Optional arguments are:}
+ puts { --cuff=[NAME[,OPTS]]}
+ puts { --log=FILE set log file name. Default is to write to stdout}
+ puts { --logl=LVL set log level, default is '2' allowed values 0-3}
+ puts { --dmpl=LVL set dump level, default is '0', values like logl}
+ puts { --tiol=LVL set i/o trace level, default is '0', allowed 0-2}
+ puts { --tout=dt set timeout, default is '1.', must be >0.}
+ puts { --int enter interactive mode even when commands given}
+ puts { --help display this help and exit}
+ puts { -- all following arguments are treated as tcl commands}
+ puts {}
+ puts {Command handling:}
+ puts { For arguments of the form '@.tcl' the respective file is}
+ puts { sourced. All other arguments are treated as Tcl commands and executed}
+ puts { with eval.}
+ puts {}
+ puts {For further details consults the ti_rri man page.}
+ return 0
+}
+
+if {![info exists env(RETROBASE)]} {
+ puts "-E: RETROBASE environment variable not defined"
+ return 1
+}
+
+# check consistency of connection open options
+set nopen 0;
+if { $opts(fifo) } { incr nopen }
+if { $opts(term) } { incr nopen }
+if { $opts(cuff) } { incr nopen }
+
+if { $nopen > 1 } {
+ puts "-E: more than one of --fifo,--term,--cuff given, only one allowed"
+ return 1
+}
+
+# setup auto path
+lappend auto_path [file join $env(RETROBASE) tools tcl]
+lappend auto_path [file join $env(RETROBASE) tools lib]
+
+# setup default packages
+package require rutiltpp
+package require rlinktpp
+package require rlink
+
+# setup signal handling
+rutil::sigaction -init
+
+# setup connect and server objects
+rlinkconnect rlc
+rlinkserver rls rlc
+
+# load additional packages (if -pack given)
+if { $opts(pack_) ne "" } {
+ foreach pack [split $opts(pack_) ","] {
+ package require $pack
+ }
+}
+
+
+# setup logging
+if { $opts(log_) ne "-" } {
+ rlc set logfile $opts(log_)
+}
+rlc set printlevel $opts(logl_)
+rlc set dumplevel $opts(dmpl_)
+rlc set tracelevel $opts(tiol_)
+rlc set timeout $opts(tout_)
+
+# first start, if specified with --run, the test bench
+# exec sh -c $cmd is used to execute a shell command including [], '',""
+# in a direct exec the tcl expansion logic will interfere...
+#
+if { $opts(run_) ne "" } {
+ if { [catch {exec sh -c $opts(run_) &} runpid] } {
+ puts "-E: failed to execute \"$opts(run_)\" with error message\n $runpid"
+ puts "-E: aborting..."
+ return 1
+ }
+}
+
+# than open the rlink connection
+# handle --fifo
+if { $opts(fifo) } {
+ set nlist [split $opts(fifo_) ","]
+ set path [lindex $nlist 0]
+ if {$path eq ""} {set path "rlink_cext_fifo"}
+ set url "fifo:$path"
+ set delim "?"
+ foreach opt [lrange $nlist 1 end] {
+ if {$opt ne ""} {append url "$delim$opt"}
+ set delim ";"
+ }
+ # puts "-I: $url"
+ rlc open $url
+}
+
+# handle --term
+if { $opts(term) } {
+ set nlist [split $opts(term_) ","]
+ set dev [lindex $nlist 0]
+ set baud [lindex $nlist 1]
+ if {$dev eq ""} {set dev "USB0"}
+ if {$baud eq ""} {set baud "115k"}
+ set url "term:$dev?baud=$baud"
+ foreach opt [lrange $nlist 2 end] {
+ if {$opt ne ""} {append url ";$opt"}
+ }
+ # puts "-I: $url"
+ rlc open $url
+}
+
+# handle --cuff
+if { $opts(cuff) } {
+ set nlist [split $opts(cuff_) ","]
+ set path [lindex $nlist 0]
+ set url "cuff:$path"
+ set delim "?"
+ foreach opt [lrange $nlist 1 end] {
+ if {$opt ne ""} {append url "$delim$opt"}
+ set delim ";"
+ }
+ # puts "-I: $url"
+ rlc open $url
+}
+
+# setup simulation mode default
+set rlink::sim_mode [rlink::isfifo]
+
+# if tclsh runs a script given on the command line or is invoked
+# like here via a shebang the tcl_interactive is always set to 0
+# so we have to check whether stdin/stdout is a terminal and set
+# tcl_interactive accordingly
+
+set tcl_interactive [rutil::isatty STDIN]
+
+# determine whether interactive mode, if yes, initialize readline
+if {$tcl_interactive && ($opts(int) || [llength $clist] == 0) } {
+ set tirri_interactive 1
+
+ package require tclreadline
+ namespace eval tclreadline {
+ proc prompt1 {} {
+ set version [info tclversion]
+ return "ti_rri > "
+ }
+ }
+ ::tclreadline::readline eofchar {::tirri_exit; puts {}; exit}
+}
+
+# now execute all commands and scripts given as start-up arguments
+foreach cmd $clist {
+ # puts "executing: $cmd"
+ # handle @filename commands
+ if { [regexp {^@(.+)} $cmd dummy filename] } {
+ # handle @file.tcl --> source tcl file
+ if { [regexp {\.tcl$} $filename] } {
+ if { [catch {source $filename} errmsg] } {
+ puts "-E: failed to source file \"$filename\" with error message:"
+ if {[info exists errorInfo]} {puts $errorInfo} else {puts $errmsg}
+ puts "-E: aborting..."
+ break
+ }
+ # handle @file.dat ect --> not yet supported
+ } else {
+ puts "-E: only tcl supported but $filename found"
+ puts "-E: aborting..."
+ break
+ }
+
+ # handle normal tcl commands --> eval them
+ } else {
+ if { [catch {eval $cmd} errmsg] } {
+ puts "-E: eval of \"$cmd\" failed with error message:"
+ if {[info exists errorInfo]} {puts $errorInfo} else {puts $errmsg}
+ puts "-E: aborting..."
+ break
+ }
+ }
+}
+
+if { $tcl_interactive && $tirri_interactive } {
+ ::tclreadline::Loop
+} else {
+ tirri_exit 0
+}
+
+return 0
ti_rri
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: ticonv_pdpcp
===================================================================
--- ticonv_pdpcp (nonexistent)
+++ ticonv_pdpcp (revision 38)
@@ -0,0 +1,276 @@
+#!/usr/bin/perl -w
+# $Id: ticonv_pdpcp 795 2016-08-09 12:45:58Z mueller $
+#
+# Copyright 2013-2016 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-08-07 795 1.3.2 avoid GetOptions =f (bug in perl v5.22.1)
+# 2015-05-08 675 1.3.1 start/stop/suspend overhaul
+# 2015-04-03 661 1.3 adopt to new stat checking and mask polarity
+# 2014-12-27 622 1.2.1 use wmembe now
+# 2014-12-07 609 1.2 use rlink::anena (for rlink v4)
+# 2014-07-31 576 1.1 add --cmax option (default = 3); support .sdef
+# 2014-07-26 575 1.0.4 add --tout option (sets wtcpu timeout)
+# 2013-05-19 521 1.0.3 use -be subopt of -wibrb
+# 2013-04-12 504 1.0.2 renamed from pi2ti_pdpcp; fix [rm]wi handling
+# use wtcpu command; use wibrbbe command;
+# 2013-02-05 483 1.0.1 make cpucmd parametrizable
+# 2013-02-02 480 1.0 Initial version
+#
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+
+use Getopt::Long;
+
+my %opts = ();
+
+GetOptions(\%opts, "tout=s", "cmax=i"
+ )
+ or die "bad options";
+
+sub cmdlist_do;
+sub add_edata;
+
+my @cmdlist;
+
+if (scalar(@ARGV) != 2) {
+ print STDERR "ticonv_pdpcp-E: usage: ticonv_pdpcp \n";
+ exit 1;
+}
+
+my $cpu = $ARGV[0];
+my $fnam = $ARGV[1];
+my $tout = $opts{tout} || 10.;
+my $cmax = $opts{cmax} || 6;
+
+open IFILE, $fnam or die "failed to open '$fnam'";
+
+print "set old_statvalue [rlc get statvalue]\n";
+print "set old_statmask [rlc get statmask]\n";
+print "\n";
+
+print "rlc set statvalue 0x00\n";
+print "rlc set statmask \$rlink::STAT_DEFMASK\n";
+print "\n";
+
+while () {
+ chomp;
+ s/--.*//; # drop all -- style comments
+ s/\s*$//; # drop traing blanks
+ next if m/^#/;
+
+ # print "$_\n";
+
+ my $cmd = $_;
+
+ $cmd =~ s/^rsp/rr6/; # rsp -> rr6
+ $cmd =~ s/^rpc/rr7/; # rpc -> rr7
+ $cmd =~ s/^wsp/wr6/; # wsp -> wr6
+ $cmd =~ s/^wpc/wr7/; # wpc -> wr7
+
+ # C... comments -> write to rlc log --------------------------------
+ if ($cmd =~ /^C(.*)/) {
+ cmdlist_do();
+ my $msg = $1;
+ $msg =~ s/"/'/g;
+ $msg =~ s/\[/\{/g;
+ $msg =~ s/\]/\}/g;
+ print "rlc log \"C $msg\"\n";
+
+ # .tocmd,.tostp,.togo,.cerr,.merr -> ignore, like pi_rri -----------
+ } elsif ($cmd =~ /^\.(tocmd|tostp|togo|[cm]err)\s+(\d*)$/) {
+ print "# $cmd currently ignored\n";
+
+ # .mode mode -> accept only 'pdpcp', quit otherwise ----------------
+ } elsif ($cmd =~ /^\.mode\s+(.*)$/) {
+ if ($1 ne "pdpcp") {
+ print "# FAIL: $cmd not supported\n";
+ exit 1;
+ }
+
+ # .sdef s=ref[,msk] ------------------------------------------------
+ } elsif ($cmd =~ /^\.sdef\s+s=([01]+),?([01]*)$/) {
+ cmdlist_do();
+ my $ref_sdef = oct("0b$1");
+ my $msk_sdef = oct("0b$2");
+ $msk_sdef = 0 unless defined $msk_sdef; # nothing ignored if not defined
+ printf "rlc log \".sdef 0x%2.2x,0x%2.2x\"\n", $ref_sdef, $msk_sdef;
+ printf "rlc set statvalue 0x%2.2x\n", $ref_sdef;
+ printf "rlc set statmask 0x%2.2x\n", (0xff & ~$msk_sdef);
+
+ # .rlmon,.rbmon ----------------------------------------------------
+ } elsif ($cmd =~ /^\.(r[lb]mon)\s+(\d)$/) {
+ cmdlist_do();
+ print "rlc oob -$1 $2\n";
+
+ # .scntl -----------------------------------------------------------
+ } elsif ($cmd =~ /^\.scntl\s+(\d+)\s+(\d)$/) {
+ cmdlist_do();
+ print "rlc oob -sbcntl $1 $2\n";
+
+ # .anena (0|1) -> rlink::anena n -----------------------------------
+ } elsif ($cmd =~ /^\.anena\s+(\d)$/) {
+ cmdlist_do();
+ print "rlink::anena $1\n";
+ print "rlc exec -attn\n";
+
+ # .reset -----------------------------------------------------------
+ } elsif ($cmd =~ /^\.reset$/) {
+ cmdlist_do();
+ print "rlc exec -init 0 1\n";
+
+ # (write) data type commands: wrx,wps,wal,wah,wm,wmi,stapc ---
+ # Note: 'stapc' must be decoded before 'sta' !!
+ # Note: 'wibrb' must be handled separately
+ # Note: 'wmi' must be matched before 'wm'
+ } elsif ($cmd =~ /^(wr[0-7]|wps|wal|wah|wmi|wm|stapc)\s+([0-7]+)$/) {
+ push @cmdlist, "-$1 0$2";
+
+ # (write) data type commands: wmembe ---
+ } elsif ($cmd =~ /^wmembe\s+([01]+)/) {
+ my $val = oct("0b$1");
+ my $be = $val & 0x3;
+ my $stick = $val & 0x4;
+ if ($stick == 0) {
+ push @cmdlist, "-wmembe $be";
+ } else {
+ push @cmdlist, "-wmembe $be -stick";
+ }
+
+ # (read) [d=data] type commands: rrx,rps,rm,rmi --------------------
+ # Note: 'rmi' must be matched before 'rm'
+ } elsif ($cmd =~ /^(rr[0-7]|rps|rmi|rm)/) {
+ push @cmdlist, "-$1 ";
+ add_edata($');
+
+ # bwm n ------------------------------------------------------------
+ } elsif ($cmd =~ /^bwm\s+(\d+)$/) {
+ my $nw = $1;
+ push @cmdlist, "-bwm {";
+ for (my $i=0; $i<$nw;) {
+ my $dat = ;
+ $dat =~ s/--.*//;
+ $dat =~ s/\s*//g;
+ next if $dat =~ m/^#/;
+ $cmdlist[-1] .= " 0$dat";
+ $i++;
+ }
+ $cmdlist[-1] .= "}";
+ cmdlist_do();
+
+ # brm n ------------------------------------------------------------
+ } elsif ($cmd =~ /^brm\s+(\d+)$/) {
+ my $nw = $1;
+ push @cmdlist, "-brm $1";
+ my @data;
+ my @mask;
+ my $domask;
+ for (my $i=0; $i<$nw;) {
+ my $dat = ;
+ $dat =~ s/--.*//;
+ $dat =~ s/\s*//g;
+ next if $dat =~ m/^#/;
+ if ($dat =~ m/d=([0-7]+)/ ) {
+ push @data, "0$1";
+ push @mask, "0177777";
+ } elsif ($dat =~ m/d=-/) {
+ push @data, "0";
+ push @mask, "0";
+ $domask = 1;
+ } else {
+ exit 1;
+ }
+ $i++;
+ }
+ $cmdlist[-1] .= " -edata {" . join(" ",@data) . "}";
+ $cmdlist[-1] .= " {" . join(" ",@mask) . "}" if $domask;
+ cmdlist_do();
+
+ # wibr off data ---------------------------------------------------
+ } elsif ($cmd =~ /^(wibr)\s+([0-7]+)\s+([0-7]+)$/) {
+ push @cmdlist, "-$1 0$2 0$3";
+
+ # ribr off [d=data] ------------------------------------------------
+ } elsif ($cmd =~ /^(ribr)\s+([0-7]+)/) {
+ push @cmdlist, "-$1 0$2";
+ add_edata($');
+
+ # simple action commands: sta,sto,step,cres,bres -------------------
+ } elsif ($cmd =~ /^(sta|sto|step|cres|bres)$/) {
+ my %cmdmap = (sta => 'start',
+ sto => 'stop',
+ step => 'step',
+ cres => 'creset',
+ bres => 'breset');
+ push @cmdlist, sprintf "-%s", $cmdmap{$1};
+
+ # wtgo -> wtcpu ----------------------------------------------------
+ } elsif ($cmd =~ /^(wtgo)$/) {
+ cmdlist_do();
+ print "$cpu wtcpu $tout";
+ print "\n";
+
+ # wtlam apat -------------------------------------------------------
+ # Note: apat currently ignored !!
+ } elsif ($cmd =~ /^(wtlam)/) {
+ cmdlist_do();
+ print "$cpu wtcpu $tout";
+ print "\n";
+
+ # currently unimplemented commands ... -----------------------------
+ } elsif ($cmd =~ /^(\.wait)/) {
+ print "## TODO... $cmd\n";
+
+ } else {
+ print "# FAIL: no match for '$cmd'\n";
+ exit 1;
+ }
+
+ cmdlist_do() if scalar(@cmdlist) >= $cmax;
+
+}
+
+cmdlist_do();
+
+print "\n";
+print "rlc set statvalue \$old_statvalue\n";
+print "rlc set statmask \$old_statmask\n";
+
+exit 0;
+
+#-------------------------------------------------------------------------------
+sub add_edata {
+ my ($crest) = @_;
+ $crest =~ s/\s+//;
+ if ($crest =~ m/d=([0-7]+)/) {
+ $cmdlist[-1] .= " -edata 0$1";
+ }
+}
+
+#-------------------------------------------------------------------------------
+sub cmdlist_do {
+ return unless scalar(@cmdlist);
+
+# printf "$cpu cp \\\n";
+ print "$cpu cp \\\n";
+ while (scalar(@cmdlist)) {
+ print " ";
+ print shift @cmdlist;
+ print " \\\n" if scalar(@cmdlist);
+ }
+ print "\n";
+ @cmdlist = ();
+ return;
+}
+
ticonv_pdpcp
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: ticonv_rri
===================================================================
--- ticonv_rri (nonexistent)
+++ ticonv_rri (revision 38)
@@ -0,0 +1,546 @@
+#!/usr/bin/perl -w
+# $Id: ticonv_rri 795 2016-08-09 12:45:58Z mueller $
+#
+# Copyright 2014-2016 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-08-07 795 1.2.1 avoid GetOptions =f (bug in perl v5.22.1)
+# 2015-04-03 661 1.2 adopt to new stat checking and mask polarity
+# 2015-01-31 640 1.1.2 use 'rlc get|set' instead of 'rlc config'
+# 2014-12-21 616 1.1.1 add .ndef and n= for BlockDone expects
+# 2014-12-06 609 1.1 use .cmax and .eop; drop .cclst; (for rlink v4)
+# 2014-08-09 580 1.0 Initial version
+#
+
+#-------------------------------------------------------------------------------
+# handles the command:
+#
+# .mode rri
+# .dbaso n
+# .rlmon 0|1
+# .rbmon 0|1
+# .scntl n 0|1
+#! .sinit g8 g16 !! NOT YET !!
+# .sdef [s=g8]
+# .ndef 0|1
+# .amclr
+# .amdef name g8
+# .reset
+# .wait n
+# .wtlam n
+# .cmax n
+# .eop
+# rreg [d=g16] [s=g8]
+# wreg g16 [s=g8]
+# rblk n [n=dd] [s=g8]
+# followed by n d=g16 data check values
+# wblk n [n=dd] [s=g8]
+# followed by n g16 data values
+# stat [d=g16] [s=d8]
+# attn [d=g16] [s=d8]
+# init g16 [s=g8]
+#
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+
+use Getopt::Long;
+use FileHandle;
+
+my %opts = ();
+
+GetOptions(\%opts, "tout=s", "cmax=i"
+ )
+ or die "bad options";
+
+sub cmdlist_do;
+sub add_addr;
+sub add_data;
+sub add_edata;
+sub add_edata;
+
+sub cget_chkblank; # check for unused chars in cmd line
+sub cget_tagval2_gdat; # get tag=v1[,v2], generic base
+sub cget_tagval_gdat; # get tag=val, generic base
+sub cget_gdat; # get generic base value
+sub sget_bdat; # convert 01 string -> binary value
+sub get_line;
+
+my $cmd_line;
+my $cmd_rest;
+my $dbase = 2; # use binary as default data radix
+
+my @cmdfh;
+my @cmdlist;
+
+if (scalar(@ARGV) != 1) {
+ print STDERR "ticonv_rri-E: usage: ticonv_rri \n";
+ exit 1;
+}
+
+my $fnam = $ARGV[0];
+my $tout = $opts{tout} || 10.;
+my $cmax = $opts{cmax} || 6;
+
+my $ref_sdef = 0x00; # by default check for 'hard' errors
+my $msk_sdef = 0xf8; # ignore the status bits + attn flag
+my $chk_ndef = 1; # dcnt default check on by default
+
+my $fh = new FileHandle;
+$fh->open("<$fnam") or die "failed to open '$fnam'";
+push @cmdfh, $fh;
+
+print "set save_config_basedata [rlc get basedata]\n";
+print "set save_config_basestat [rlc get basestat]\n";
+print "rlc set basedata 8\n";
+print "rlc set basestat 2\n";
+
+while (1) {
+ my $cmd = get_line();
+ last unless defined $cmd;
+ $cmd_line = $cmd;
+ $cmd_rest = "";
+
+ # .mode mode -> accept only 'rri', quit otherwise ------------------
+ if ($cmd =~ /^\.mode\s+(.*)$/) {
+ if ($1 ne "rri") {
+ print "# FAIL: $cmd not supported\n";
+ exit 1;
+ }
+ next;
+
+ # .dbaso n ---------------------------------------------------------
+ } elsif ($cmd =~ /^\.dbaso\s+(\d+)$/) {
+ my $dbaso = $1;
+ cmdlist_do();
+ print "rlc set basedata $dbaso\n";
+
+ # .cmax n ----------------------------------------------------------
+ } elsif ($cmd =~ /^\.cmax\s+(\d+)$/) {
+ $cmax = $1;
+ next;
+
+ # .eop -------------------------------------------------------------
+ } elsif ($cmd =~ /^\.eop/) {
+ cmdlist_do();
+ next;
+
+ # .sdef s=ref[,msk] ------------------------------------------------
+ } elsif ($cmd =~ /^\.sdef\s+s=([01]+),?([01]*)/) {
+ $cmd_rest = $';
+ cmdlist_do();
+ $ref_sdef = oct("0b$1");
+ $msk_sdef = oct("0b$2");
+
+ # .ndef ------------------------------------------------------------
+ } elsif ($cmd =~ /^\.ndef\s+([01])/) {
+ $cmd_rest = $';
+ cmdlist_do();
+ $chk_ndef = $1;
+
+ # .rlmon,.rbmon ----------------------------------------------------
+ } elsif ($cmd =~ /^\.(r[lb]mon)\s+(\d)/) {
+ $cmd_rest = $';
+ cmdlist_do();
+ print "rlc oob -$1 $2\n";
+
+ # .scntl -----------------------------------------------------------
+ } elsif ($cmd =~ /^\.scntl\s+(\d+)\s+(\d)/) {
+ $cmd_rest = $';
+ cmdlist_do();
+ print "rlc oob -sbcntl $1 $2\n";
+
+ # .reset -----------------------------------------------------------
+ } elsif ($cmd =~ /^\.reset/) {
+ $cmd_rest = $';
+ cmdlist_do();
+ print "rlc exec -init 0 1\n";
+
+ # .amclr -----------------------------------------------------------
+ } elsif ($cmd =~ /^\.amclr/) {
+ $cmd_rest = $';
+ cmdlist_do();
+ print "rlc amap -clear\n";
+
+ # .amdef -----------------------------------------------------------
+ } elsif ($cmd =~ /^\.amdef\s+([0-9a-z]+)\s+([01]+)/) {
+ $cmd_rest = $';
+ cmdlist_do();
+ my $anam = $1;
+ my $aval = sprintf ('0%3.3o', oct("0b$2"));
+ print "rlc amap -insert $anam $aval\n";
+
+ # .wait n ----------------------------------------------------------
+ # Note: simply send zeros rather true idles. both are discarded anyway
+ } elsif ($cmd =~ /^(\.wait)/) {
+ $cmd_rest = $';
+ my $delay = cget_gdat(16,10,1,256);
+ cmdlist_do();
+ print "rlc log \".wait $delay\"\n";
+ print "rlc rawio -wblk {";
+ for (my $i = 0; $i < $delay; $i++) {
+ printf " 0%3.3o", 0x00;
+ }
+ print "}\n";
+
+ # .wtlam n ---------------------------------------------------------
+ # Note: ignore n, use tout here !
+ } elsif ($cmd =~ /^(\.wtlam)/) {
+ $cmd_rest = $';
+ my $delay = cget_gdat(16,10,1); # currently ignores
+ cmdlist_do();
+ printf "rlc wtlam %d\n", $tout;
+
+ # rreg [d=g16] [s=b8] ---------------------------------------
+ } elsif ($cmd =~ /^rreg/) {
+ $cmd_rest = $';
+ my $act = "-rreg";
+ $act .= add_addr();
+ $act .= add_edata($dbase);
+ $act .= add_estat();
+ push @cmdlist, $act;
+
+ # wreg|init g16 [s=b8] --------------------------------------
+ } elsif ($cmd =~ /^(wreg|init)/) {
+ $cmd_rest = $';
+ my $act = "-$1";
+ $act .= add_addr();
+ $act .= add_data($dbase);
+ $act .= add_estat();
+ push @cmdlist, $act;
+
+ # rblk n [n=dd] [s=b8] --------------------------------------
+ } elsif ($cmd =~ /^rblk/) {
+ $cmd_rest = $';
+ my $act = "-rblk";
+ $act .= add_addr();
+ my $nblk = cget_gdat(16,10,1,256);
+ $act .= " $nblk";
+ $act .= add_edone($nblk);
+ $act .= add_estat();
+ cget_chkblank();
+ my @ref_rblk;
+ my @msk_rblk;
+ my $do_msk = 0;
+ for (my $i = 0; $i < $nblk; $i++) {
+ $cmd_rest = get_line() if ($cmd_rest eq "");
+ $cmd_rest =~ s/^\s*//;
+ my ($ref,$msk) = cget_tagval2_gdat("d",16,$dbase);
+ if (not defined $ref) {
+ $ref = 0;
+ $msk = 0xffff;
+ }
+ $msk = 0 unless defined $msk;
+ $do_msk = 1 if $msk != 0;
+ push @ref_rblk, sprintf("0%6.6o", $ref);
+ push @msk_rblk, sprintf("0%6.6o", (0xffff & ~$msk));
+ }
+
+ $act .= ' -edata {' . join(' ',@ref_rblk) . '}';
+ $act .= ' {' . join(' ',@msk_rblk) . '}' if $do_msk;
+ push @cmdlist, $act;
+ cmdlist_do();
+
+ # wblk n [n=dd] [s=b8] --------------------------------------
+ } elsif ($cmd =~ /^wblk/) {
+ $cmd_rest = $';
+ my $act = "-wblk";
+ $act .= add_addr();
+ my $nblk = cget_gdat(16,10,1,256);
+ my $edone = add_edone($nblk);
+ my $estat = add_estat();
+ cget_chkblank();
+ my @dat_wblk;
+ for (my $i = 0; $i < $nblk; $i++) {
+ $cmd_rest = get_line() if ($cmd_rest eq "");
+ $cmd_rest =~ s/^\s*//;
+ push @dat_wblk, sprintf('0%6.6o', cget_gdat(16,$dbase));
+ }
+
+ $act .= ' {' . join(' ',@dat_wblk) . '}';
+ $act .= $edone;
+ $act .= $estat;
+ push @cmdlist, $act;
+ cmdlist_do();
+
+
+ # stat|attn [d=g16] [s=b8] -----------------------------------------
+ } elsif ($cmd =~ /^(stat|attn)\s+/) {
+ $cmd_rest = $';
+ my $act = "-$1";
+ $act .= add_edata($dbase);
+ $act .= add_estat();
+ push @cmdlist, $act;
+
+ # unknown commands -------------------------------------------------
+ } else {
+ print "# FAIL: no match for '$cmd'\n";
+ exit 1;
+ }
+
+ cget_chkblank();
+
+ cmdlist_do() if scalar(@cmdlist) >= $cmax;
+}
+
+cmdlist_do();
+
+print "rlc set basedata \$save_config_basedata\n";
+print "rlc set basestat \$save_config_basestat\n";
+
+exit 0;
+
+#-------------------------------------------------------------------------------
+sub add_addr {
+ my $addr;
+
+ $cmd_rest =~ s/^\s*//;
+ if ($cmd_rest =~ /^\.([[0-9a-z.]+)/) {
+ $addr = $1;
+ $cmd_rest = $';
+ } else {
+ $addr =sprintf('0x%4.4x', cget_gdat(16,2));
+ }
+ return " $addr";
+}
+
+#-------------------------------------------------------------------------------
+sub add_data {
+ my ($dbase) = @_;
+ my $data = cget_gdat(16,$dbase);
+ return sprintf(" 0%6.6o", $data);
+}
+
+#-------------------------------------------------------------------------------
+# Note: input has ignore mask, output has check mask now
+sub add_edata {
+ my ($dbase) = @_;
+ my ($ref,$msk) = cget_tagval2_gdat("d",16,$dbase);
+ return "" unless defined $ref;
+ my $str = sprintf(" -edata 0%6.6o", $ref);
+ $str .= sprintf(" 0%6.6o", (0xffff & ~$msk)) if defined $msk && $msk;
+ return $str;
+}
+
+#-------------------------------------------------------------------------------
+# Note: input has ignore mask, output has check mask now
+# -estat always added, either from s= tag or from .sdef directive
+sub add_estat {
+ my ($dat, $msk) = cget_tagval2_gdat("s",8,2);
+ unless (defined $dat) {
+ $dat = $ref_sdef;
+ $msk = $msk_sdef;
+ }
+ my $str = sprintf(" -estat 0x%2.2x", $dat);
+ $str .= sprintf(" 0x%2.2x", (0xff & ~$msk)) if defined $msk && $msk;
+ return $str;
+}
+
+#-------------------------------------------------------------------------------
+sub add_edone {
+ my ($bsize) = @_;
+ my ($nblk) = cget_tagval_gdat("n",16,10);
+ $nblk = $bsize if (not defined $nblk && $chk_ndef);
+ return "" unless defined $nblk;
+ my $str = sprintf(" -edone %d", $nblk);
+ return $str;
+}
+
+#-------------------------------------------------------------------------------
+sub cmdlist_do {
+ return unless scalar(@cmdlist);
+
+ print "rlc exec \\\n";
+ while (scalar(@cmdlist)) {
+ print " ";
+ print shift @cmdlist;
+ print " \\\n" if scalar(@cmdlist);
+ }
+ print "\n";
+ @cmdlist = ();
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub cget_chkblank { # check for unused chars in cmd line
+ $cmd_rest =~ s/^\s*//;
+ if ($cmd_rest ne "") {
+ print "ticonv_rri-E: extra data ignored: \"$cmd_rest\"\n";
+ print " for command: \"$cmd_line\"\n";
+ exit 1;
+ }
+}
+
+#-------------------------------------------------------------------------------
+
+sub cget_tagval2_gdat { # get tag=v1[,v2], generic base
+ my ($tag,$nbit,$dbase) = @_;
+ my $dat;
+ my $msk = undef;
+ $cmd_rest =~ s/^\s*//;
+ if ($cmd_rest =~ /^$tag=/) {
+ $cmd_rest = $';
+ if ($cmd_rest =~ /^-/) {
+ $cmd_rest = $';
+ my $msk = (1 << $nbit) -1;
+ return (0,$msk);
+ } else {
+ $dat = cget_gdat($nbit, $dbase);
+ if ($cmd_rest =~ /^,/) {
+ $cmd_rest = $';
+ $msk = cget_gdat($nbit, $dbase);
+ }
+ return ($dat, $msk);
+ }
+ }
+ return (undef, undef);
+}
+
+#-------------------------------------------------------------------------------
+
+sub cget_tagval_gdat { # get tag=val, generic base
+ my ($tag,$nbit,$dbase,$min,$max) = @_;
+ $cmd_rest =~ s/^\s*//;
+ if ($cmd_rest =~ /^$tag=/) {
+ $cmd_rest = $';
+ return cget_gdat($nbit, $dbase,$min,$max);
+ }
+ return undef;
+}
+
+#-------------------------------------------------------------------------------
+
+sub cget_gdat { # get generic base value
+ my ($nbit,$dbase,$min,$max) = @_;
+ my $dat;
+
+ $cmd_rest =~ s/^\s*//;
+ if ($cmd_rest =~ /^[xXoObBdD]"/) {
+ if ($cmd_rest =~ /^[xX]"([0-9a-fA-F]+)"/) {
+ $cmd_rest = $';
+ $dat = hex $1;
+ } elsif ($cmd_rest =~ /^[oO]"([0-7]+)"/) {
+ $cmd_rest = $';
+ $dat = oct $1;
+ } elsif ($cmd_rest =~ /^[bB]"([01]+)"/) {
+ $cmd_rest = $';
+ my $odat = sget_bdat($nbit, $1);
+ $dat = $odat if defined $odat;
+ } elsif ($cmd_rest =~ /^[dD]"([+-]?[0-9]+)"/) {
+ $cmd_rest = $';
+ my $odat = (int $1) & ((1<<$nbit)-1);
+ $dat = $odat;
+ }
+ } else {
+ if ($cmd_rest =~ /^([+-]?[0-9]+)\./) {
+ $cmd_rest = $';
+ my $odat = (int $1) & ((1<<$nbit)-1);
+ $dat = $odat;
+ } elsif ($dbase == 16 && $cmd_rest =~ /^([0-9a-fA-F]+)/) {
+ $cmd_rest = $';
+ $dat = hex $1;
+ } elsif ($dbase == 8 && $cmd_rest =~ /^([0-7]+)/) {
+ $cmd_rest = $';
+ $dat = oct $1;
+ } elsif ($dbase == 2 && $cmd_rest =~ /^([01]+)/) {
+ $cmd_rest = $';
+ my $odat = sget_bdat($nbit, $1);
+ $dat = $odat if defined $odat;
+ } elsif ($dbase == 10 && $cmd_rest =~ /^([0-9]+)/) {
+ $cmd_rest = $';
+ $dat = int $1;
+ }
+ }
+
+ if (not defined $dat) {
+ print "ticonv_rri-E: cget_gdat error in \"$cmd_rest\" (base=$dbase)\n";
+ exit 1;
+ }
+
+ if (defined $min && $dat < $min) {
+ print "ticonv_rri-E: cget_gdat range error, $dat < $min\n";
+ exit 1;
+ }
+ if (defined $max && $dat > $max) {
+ print "ticonv_rri-E: cget_gdat range error, $dat > $max\n";
+ exit 1;
+ }
+
+ return $dat;
+}
+
+#-------------------------------------------------------------------------------
+
+sub sget_bdat { # convert 01 string -> binary value
+ my ($nbit,$str) = @_;
+ my $nchar = length($str);
+ my $odat = 0;
+
+ if ($nchar != $nbit) {
+ print "ticonv_rri-E: sget_bdat error \'$str\' has not length $nbit\n";
+ exit 1;
+ }
+
+ for (my $i = 0; $i < $nchar; $i++) {
+ $odat *= 2;
+ $odat += 1 if substr($str, $i, 1) eq "1";
+ }
+ return $odat;
+}
+
+#-------------------------------------------------------------------------------
+
+sub get_line {
+ while (1) {
+ return undef unless scalar(@cmdfh);
+ my $fh = $cmdfh[$#cmdfh];
+ my $cmd = <$fh>;
+ if (not defined $cmd) {
+ $fh->close();
+ pop @cmdfh;
+ next;
+ }
+
+ # detect @ lines
+ if ($cmd =~ /^@(.+)/) {
+ my $fnam = $1;
+ my $fh = new FileHandle;
+ $fh->open("<$fnam") or die "failed to open '$fnam'";
+ push @cmdfh, $fh;
+ next;
+ }
+
+ # write C... comment lines to rlc log
+ if ($cmd =~ /^C(.*)/) {
+ cmdlist_do();
+ my $msg = $1;
+ $msg =~ s/"/'/g;
+ $msg =~ s/\[/\{/g;
+ $msg =~ s/\]/\}/g;
+ print "rlc log \"C $msg\"\n";
+ next;
+ }
+
+ $cmd =~ s{^\s*}{}; # remove leading blanks
+
+ next if $cmd =~ m/^#/; # ignore "# ...." lines
+ next if $cmd =~ m/^;/; # ignore "; ...." lines
+
+ $cmd =~ s{--.*}{}; # remove comments after --
+ $cmd =~ s{\s*$}{}; # remove trailing blanks
+ next if $cmd eq ""; # ignore empty lines
+
+ return $cmd;
+ }
+}
ticonv_rri
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: vbomconv
===================================================================
--- vbomconv (nonexistent)
+++ vbomconv (revision 38)
@@ -0,0 +1,1486 @@
+#!/usr/bin/perl -w
+# $Id: vbomconv 804 2016-08-28 17:33:50Z mueller $
+#
+# Copyright 2007-2016 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-08-28 804 1.17.3 xsim work dir now xsim..
+# 2016-07-02 782 1.17.2 add VBOMCONV_GHDL_OPTS and VBOMCONV_GHDL_GCOV
+# 2016-06-24 778 1.17.1 -vsyn_prj: add [rep]sim models & VBOMCONV_XSIM_LANG
+# -ghdl_(i|m|a): use --workdir
+# 2016-06-19 777 1.17 -vsyn_prj: sim and syn source sets based on -UUT
+# -vsim_prj: finally functioning tsim builds
+# 2016-04-30 766 1.16.2 use -UUT property instead of @uut
+# 2016-04-23 764 1.16.1 --vsim_prj: use 'nosort'
+# 2016-04-22 763 1.16 --vsim_prj: use bash+pipefail, check exit status
+# 2016-03-27 752 1.15 1st support for file properties (xdc -SCOPE_REF)
+# 2016-02-20 734 1.14 add [ise,viv]; add preliminary --(vsyn|vsim)_export;
+# 2016-02-14 731 1.13 add @uut tag handling;
+# 2016-02-07 728 1.12 add vivado xsim support; protect for empty xdc set
+# 2015-02-15 646 1.11 add vivado support: add -xlpath, use instead
+# of XTWI_PATH; drop --ise_path; add @lib:unimacro;
+# drop --viv_vhdl; add --vsyn_prj, --dep_vsyn;
+# drop cygwin support;
+# 2014-07-26 575 1.10.1 use XTWI_PATH now (ise/vivado switch done later)
+# 2013-10-20 543 1.10 add --viv_vhdl
+# 2012-02-05 456 1.9.4 redo filename substitution (= and :); add --get_top
+# 2012-01-02 448 1.9.3 use in ghdl_m -fexplicit also when simprim used
+# 2011-11-27 433 1.9.2 use in ghdl_m -fexplicit when unisim used
+# 2011-08-13 405 1.9.1 always write 'vhdl' into xst prj files again; for
+# -xst_export: remove opt file export, add ucf_cpp
+# handling
+# 2011-06-26 385 1.9 add --ise_path, pass it to vbomconv --xst_prj
+# 2011-06-09 383 1.8.6 fix xst_vhdl.opt logic (use rtl/vlib now)
+# 2010-07-03 312 1.8.5 add --flist action
+# 2010-06-03 299 1.8.4 generate ucf->ncd dependencies in dep_xst
+# 2010-04-26 284 1.8.3 add _[sft]sim support for ISim
+# 2009-11-28 253 1.8.2 fixup print_help...;
+# 2009-11-22 252 1.8.1 add (export|dep)_isim, full ISim support;
+# add [isim] [sim], allow tag lists like [ghdl,isim];
+# --trace and messages to STDERR;
+# 2009-11-20 251 1.8 add isim_prj, first ISim support
+# 2008-03-09 124 1.7.3 add in .dep_(ghdl|xst) all dep on vbom dependencies
+# target now also dependant on .dep_ file
+# 2008-03-02 122 1.7.2 add @lib: directive to include UNISIM
+# 2007-12-17 102 1.7.1 fix @ucf_cpp logic.
+# 2007-12-16 101 1.7 add @ucf_cpp pseudo tag (handle cpp'ed ucf files)
+# 2007-11-25 98 1.6.1 drop trailing blanks on input lines
+# 2007-11-02 94 1.6 added (xst|ghdl)_export
+# 2007-10-26 92 1.5.1 emit '--no-vital-checks' for --ghdl_m for _[sft]sim
+# 2007-10-14 98 1.5 handle .exe files under cygwin properly
+# 2007-09-15 82 1.4 handle C source objects properly
+# 2007-08-10 72 1.3 add [xst], [ghdl] prefix support
+# 2007-07-22 68 1.2 add "tag = val"; list files in 'ready to analyse'
+# order; add --ghdl_a option
+# 2007-07-08 65 1.1 add "tag : names"; inferral of _[ft]sim vboms
+# 2007-07-06 64 1.0 Initial version
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+use FileHandle;
+use Cwd 'getcwd';
+
+use Getopt::Long;
+
+my %opts = ();
+
+GetOptions(\%opts, "help", "trace", "xlpath=s",
+ "dep_ghdl",
+ "dep_xst", "dep_isim",
+ "dep_vsyn", "dep_vsim",
+ "xst_prj", "isim_prj",
+ "vsyn_prj", "vsim_prj",
+ "ghdl_a", "ghdl_a_cmd",
+ "ghdl_i", "ghdl_i_cmd",
+ "ghdl_m", "ghdl_m_cmd",
+ "ghdl_export=s",
+ "xst_export=s",
+ "isim_export=s",
+ "vsyn_export=s",
+ "vsim_export=s",
+ "get_top",
+ "flist") || exit 1;
+
+sub print_help;
+sub read_vbom;
+sub scan_vbom;
+sub do_synsim;
+sub scan_synsim;
+sub copy_edir;
+sub write_vbomdep;
+sub canon_fname;
+sub parse_props;
+sub setup_props;
+
+my @vbom_queue; # list of pending vbom's
+my @srcfile_list; # list of sources in compile order
+my @xdcfile_list; # list of xdc files
+my @srcfile_list_vhd; # all vhdl sources
+my @srcfile_list_v; # all (system) verilog sources
+my @srcfile_list_c; # all C sources
+my %vbom_files; # key=vbom; val=full file list
+my %vbom_xdc; # key=vbom; val=xdc spec list
+my %vbom_done; # key=vbom; val=done flags
+my %vbom_rank; # key=vbom; val=vbom ranks
+my %srcfile_rank; # key=source file; val=file rank
+my %srcfile_synsim; # key=source file; val=syn or sim
+my %srcfile_prop; # key=source file; hash of props
+my %para_tbl; # substitution table
+my @ucf_cpp_list;
+my $is_ghdl = 0; # ghdl simulation target
+my $is_xst = 0; # XST synthesis target
+my $is_isim = 0; # ISim simulation target
+my $is_vsyn = 0; # vivado synthesis target
+my $is_vsim = 0; # vivado simulation target
+my $is_sim = 0; # simulation target (generic)
+my $is_ise = 0; # ISE target
+my $is_viv = 0; # vivado target
+my $is_any = 0; # ignore tags (for --flist)
+my $is_bsim = 0; # is behavioural simulation
+my $is_fsim = 0; # is functional simulation
+my $is_tsim = 0; # is timing simulation
+my $is_veri = 0; # is verilog model based
+my $nactions = 0; # number of action commands
+my $top_vbom; # top level vbom (from argv)
+my $eff_vbom; # effective vbom ([fot]sim->ssim map)
+my $stem; # stem of $top_vbom
+my $top; # top level entity name
+my $top_done = 0; # @top seen
+my $uut; # uut level name
+my $has_unisim; # @lib:unisim seen or implied
+my $has_unimacro; # @lib:unimacro seen
+my $has_simprim; # @lib:simprim seen or implied
+my $sim_mode = 'bsim';
+my $do_trace = exists $opts{trace};
+my $level = 0; # vbom nesting level
+my $xst_writevhdl = 1;
+my $xlpath=$opts{xlpath};
+my $no_xlpath = ! defined $xlpath || $xlpath eq "";
+my $ghdl_opts = $ENV{VBOMCONV_GHDL_OPTS}; # ghdl extra options
+my $ghdl_gcov = $ENV{VBOMCONV_GHDL_GCOV}; # ghdl gcov enable
+my $xsim_lang = $ENV{VBOMCONV_XSIM_LANG}; # xsim model language
+
+if ($ghdl_gcov) {
+ $ghdl_opts = '' unless defined $ghdl_opts;
+ $ghdl_opts .= ' ' unless $ghdl_opts eq '';
+ $ghdl_opts .= '-Wc,-ftest-coverage -Wc,-fprofile-arcs -Wl,-lgcov';
+} else {
+ $ghdl_opts = '-O2 -g' unless defined $ghdl_opts;
+}
+
+$xsim_lang = 'verilog' unless defined $xsim_lang;
+if ($xsim_lang ne 'verilog' && $xsim_lang ne 'vhdl') {
+ print STDERR "vbomconv-E: VBOMCONV_XSIM_LANG is '$xsim_lang'\n";
+ print STDERR "vbomconv-E: VBOMCONV_XSIM_LANG must be 'verilog' or 'vhdl'\n";
+ exit 1;
+}
+$is_veri = $xsim_lang eq 'verilog';
+
+autoflush STDOUT 1; # autoflush, so nothing lost on exec later
+
+if (exists $opts{help}) {
+ print_help;
+ exit 0;
+}
+
+# ensure that one and only one vbom is specified
+
+if (scalar(@ARGV) != 1) {
+ print STDERR "vbomconv-E: only one vbom file name allowed\n\n";
+ print_help;
+ exit 1;
+}
+
+# get number of CPUs (used later....)
+my $nproc = `nproc`;
+chomp $nproc;
+
+# check that only one action is defined, mark xst, gdhl, or isim class
+
+foreach (keys %opts) {
+ $nactions += 1 unless ($_ eq "trace" || $_ eq "xlpath");
+ $is_ghdl = 1 if $_ eq "dep_ghdl";
+ $is_ghdl = 1 if $_ =~ /^ghdl_/;
+
+ $is_xst = 1 if $_ eq "dep_xst";
+ $is_xst = 1 if $_ =~ /^xst_/;
+
+ $is_isim = 1 if $_ eq "dep_isim";
+ $is_isim = 1 if $_ =~ /^isim_/;
+
+ $is_vsyn = 1 if $_ eq "dep_vsyn";
+ $is_vsyn = 1 if $_ =~ /^vsyn_/;
+
+ $is_vsim = 1 if $_ eq "dep_vsim";
+ $is_vsim = 1 if $_ =~ /^vsim_/;
+
+ $is_any = 1 if $_ eq "flist";
+}
+
+$is_sim = $is_ghdl | $is_isim | $is_vsim;
+$is_ise = $is_xst | $is_isim;
+$is_viv = $is_vsyn | $is_vsim;
+
+print STDERR "-- [ghdl] active\n" if $do_trace && $is_ghdl;
+print STDERR "-- [xst] active\n" if $do_trace && $is_xst;
+print STDERR "-- [isim] active\n" if $do_trace && $is_isim;
+print STDERR "-- [vsyn] active\n" if $do_trace && $is_vsyn;
+print STDERR "-- [vsim] active\n" if $do_trace && $is_vsim;
+print STDERR "-- [sim] active\n" if $do_trace && $is_sim;
+print STDERR "-- [ise] active\n" if $do_trace && $is_ise;
+print STDERR "-- [viv] active\n" if $do_trace && $is_viv;
+
+if ($nactions > 1) {
+ print STDERR "vbomconv-E: only one action qualifier allowed\n\n";
+ print_help;
+ exit 1;
+}
+
+$top_vbom = $ARGV[0];
+
+$top_vbom .= ".vbom" unless $top_vbom =~ m{\.vbom$};
+
+$stem = $top_vbom;
+$stem =~ s{\..*$}{};
+
+$top = $stem;
+$top =~ s{^.*/}{};
+
+# now prepare virtual _[forept]sim vbom's
+# they are inferred from the _ssim vbom's
+
+if ($top_vbom =~ m{_([sforept]sim)\.vbom$}) {
+ $sim_mode = $1;
+}
+
+$is_bsim = 1 if $sim_mode eq 'bsim';
+$is_fsim = 1 if $sim_mode =~ m/^[fsor]sim$/;
+$is_tsim = 1 if $sim_mode =~ m/^[ept]sim$/;
+
+$eff_vbom = $top_vbom;
+$eff_vbom =~ s{_[forept]sim\.vbom$}{_ssim.vbom}; # map [forept]sim -> ssim
+
+# traverse all vbom's start with command line argument
+
+push @vbom_queue, $eff_vbom;
+
+while (@vbom_queue) {
+ my $cur_vbom = shift @vbom_queue;
+ read_vbom($cur_vbom);
+}
+
+# traverse internal vbom representation to build file table
+
+$vbom_rank{$eff_vbom} = {min=>1, max=>1};
+scan_vbom($eff_vbom);
+
+# separate sym (uut) and sim (tb) parts
+do_synsim($uut);
+
+# sort file table, build file list (decreasing rank)
+# sort first by decreasing rank and second by filename
+# second sort only to get stable sequence, independent of hash keys
+
+my @srcpair_list;
+foreach (keys %srcfile_rank) {
+ push @srcpair_list, [$srcfile_rank{$_}, $_];
+}
+
+@srcfile_list = map {$_->[1]}
+ sort {$b->[0] <=> $a->[0] || $a->[1] cmp $b->[1]}
+ @srcpair_list;
+
+# setup vbom list by rank
+my @vbom_rank_list;
+foreach (sort keys %vbom_rank) {
+ push @vbom_rank_list, [$vbom_rank{$_}{min}, $vbom_rank{$_}{max}, $_];
+}
+my @vbomfile_list_min = map {$_->[2]}
+ sort {$a->[0] <=> $b->[0] || $a->[1] cmp $b->[1]}
+ @vbom_rank_list;
+
+# setup xdc files list (if one @xdc: seen)
+foreach (@vbomfile_list_min) {
+ push @xdcfile_list, @{$vbom_xdc{$_}} if exists $vbom_xdc{$_};
+}
+
+# now split source list according to languages
+foreach (@srcfile_list) {
+ if (m/\.vhd$/) {
+ push @srcfile_list_vhd, $_;
+ } elsif (m/\.(v|sv)$/) {
+ push @srcfile_list_v, $_;
+ } elsif (m/\.c$/) {
+ push @srcfile_list_c, $_;
+# } else {
+# print STDERR "unknown file type $_\n";
+ }
+}
+
+# now generate output and actions, depending on options given
+
+# --trace ------------------------------------------------------------
+
+if ($do_trace) {
+ print STDERR "\n";
+ print STDERR "filename substitution table:\n";
+ foreach (sort keys %para_tbl) {
+ print STDERR " $_ = $para_tbl{$_}\n";
+ }
+
+ print STDERR "\n";
+ print STDERR "final vbom_rank table (sort by min rank):\n";
+ print STDERR " min max var vbom-name:\n";
+ foreach (sort {$a->[0] <=> $b->[0] || $a->[2] cmp $b->[2]} @vbom_rank_list) {
+ printf STDERR " %3d %3d %3d %s\n",
+ $_->[0], $_->[1], $_->[1]-$_->[0], $_->[2];
+ }
+
+ print STDERR "\n";
+ print STDERR "final srcfile_rank table (sort by rank):\n";
+ foreach (sort {$b->[0] <=> $a->[0] || $a->[1] cmp $b->[1]} @srcpair_list) {
+ printf STDERR " %5d %s %s\n", $_->[0], $srcfile_synsim{$_->[1]}, $_->[1];
+ }
+
+ print STDERR "\n";
+ print STDERR "properties:\n";
+ print STDERR " \@top: $top\n";
+ print STDERR " \-UUT: $uut\n" if defined $uut;
+}
+
+# --ghdl_a -- ghdl analysis command ----------------------------------
+
+if (exists $opts{ghdl_a} || exists $opts{ghdl_a_cmd}) {
+ if ($no_xlpath && ($has_unisim || $has_unimacro || $has_simprim) ) {
+ print STDERR "vbomconv-E: --xlpath required with ghdl_a or ghdl_a_cmd";
+ exit 1;
+ }
+ my $workdir = "ghdl.${sim_mode}";
+
+ foreach (@srcfile_list) {
+ my $file = $_;
+ my $cmd = "ghdl -a --workdir=${workdir}";
+ $cmd .= " -P$xlpath/unisim" if $has_unisim;
+ $cmd .= " -P$xlpath/unimacro" if $has_unimacro;
+ $cmd .= " -P$xlpath/simprim" if $has_simprim;
+ $cmd .= " --ieee=synopsys";
+ $cmd .= " ${ghdl_opts}";
+ $cmd .= " $file";
+ print "$cmd\n";
+ if (exists $opts{ghdl_a}) {
+ my $wrc = system "/bin/sh", "-c", $cmd;
+ if ($wrc != 0) {
+ my $rc = int($wrc/256);
+ if ($rc == 0) {
+ my $sig = $wrc % 256;
+ print STDERR "vbomconv-I: compilation aborted by signal $sig\n";
+ exit(1);
+ } else {
+ print STDERR "vbomconv-I: compilation failed (rc=$rc) $?\n";
+ exit($rc);
+ }
+ }
+ }
+ }
+}
+
+# --ghdl_i -- ghdl inspection command --------------------------------
+
+if (exists $opts{ghdl_i} || exists $opts{ghdl_i_cmd}) {
+ my $workdir = "ghdl.${sim_mode}";
+ my %ghdl_work;
+
+ system "mkdir ${workdir}" unless -d ${workdir};
+
+ # read ghdl "work-obj93.cf" file. It has the format
+ # file . "" "" "ghdl -i or -a date>":
+ # entity at nn( nn) + nn on nn;
+ # architecture of at nn( nn) + nn on nn;
+
+ if (-r "${workdir}/work-obj93.cf") {
+ open (WFILE, "${workdir}/work-obj93.cf") or
+ die "can't open for ${workdir}/read work-obj93.cf: $!";
+ while () {
+ if (m{^file \. \"(.*?)\"}) {
+ $ghdl_work{$1} = 1;
+ }
+ }
+ close (WFILE);
+ }
+
+ my $cmd = "ghdl -i --workdir=${workdir}";
+ my $nfile = 0;
+
+ foreach (@srcfile_list) {
+ next if /\.c$/; # skip C sources, only vhd handled
+ if (not exists $ghdl_work{$_}) {
+ $cmd .= " \\\n $_";
+ $nfile += 1;
+ }
+ }
+
+ if ($nfile) {
+ print "$cmd\n";
+ if (exists $opts{ghdl_i}) {
+ exec "/bin/sh", "-c", $cmd;
+ die "failed to exec /bin/sh -c $cmd: $!";
+ }
+ } else {
+ print "# $cmd ## all files already inspected\n";
+ }
+}
+
+# --ghdl_m -- ghdl make command --------------------------------------
+# Note: the 'buildin' make used by the -m option of ghdl does not
+# check for object files linked with -Wl, e.g. vhpi objects.
+# To force a re-elaboration the old executable is deleted first.
+# If used from make with proper dependencies, this will just do
+# the right thing.
+
+if (exists $opts{ghdl_m} || exists $opts{ghdl_m_cmd} ) {
+ my $workdir = "ghdl.${sim_mode}";
+ my $cmd = "";
+
+ if ($no_xlpath && ($has_unisim || $has_unimacro || $has_simprim) ) {
+ print STDERR "vbomconv-E: --xlpath required with ghdl_m or ghdl_m_cmd";
+ exit 1;
+ }
+
+ if (-r $stem) { # check for old executable
+ $cmd .= "rm $stem\n" ; # rm to force elaboration
+ }
+
+ $cmd .= "ghdl -m --workdir=${workdir}";
+ $cmd .= " -o $stem";
+ # -fexplicit needed for ISE 13.1,13.3
+ $cmd .= ' -fexplicit' if $has_unisim or $has_unimacro or $has_simprim;
+ $cmd .= " -P$xlpath/unisim" if $has_unisim;
+ $cmd .= " -P$xlpath/unimacro" if $has_unimacro;
+ $cmd .= " -P$xlpath/simprim" if $has_simprim;
+ $cmd .= " --ieee=synopsys";
+ $cmd .= " ${ghdl_opts}";
+ $cmd .= " --no-vital-checks" if $sim_mode ne 'bsim';
+
+ foreach (@srcfile_list) {
+ next unless /\.c$/; # C source ?
+ my $ofile = $_; # copy to break alias for following s///
+ $ofile =~ s{^.*/}{}; # remove directory path
+ $ofile =~ s/\.c$/.o/; # add clause to link C source object file
+ $cmd .= " -Wl,$ofile";
+ }
+ $cmd .= " $top";
+ print "$cmd\n";
+ if (exists $opts{ghdl_m}) {
+ exec "/bin/sh", "-c", $cmd;
+ die "failed to exec /bin/sh -c $cmd: $!";
+ }
+}
+
+# --xst_prj ----------------------------------------------------------
+
+if (exists $opts{xst_prj}) {
+ ## $xst_writevhdl = 0; # needed in case "-use_new_parser yes" used
+ foreach (@srcfile_list) {
+ if ($xst_writevhdl) {
+ print "vhdl work $_\n";
+ } else {
+ print "work $_\n"; # for ISE S-6/V-6 compilations with '-ifmt VHDL'
+ }
+ }
+}
+
+# --isim_prj ---------------------------------------------------------
+
+if (exists $opts{isim_prj}) {
+ foreach (@srcfile_list) {
+ print "vhdl work $_\n";
+ }
+}
+
+# --vsyn_prj ---------------------------------------------------------
+
+if (exists $opts{vsyn_prj}) {
+ # determine source and simulation file sets
+ my @fl_syn;
+ my @fl_sim;
+ foreach my $fi (@srcfile_list) {
+ if ($srcfile_synsim{$fi} eq 'syn') {
+ push @fl_syn, $fi;
+ } else {
+ push @fl_sim, $fi;
+ }
+ }
+ print "#\n";
+ print "# setup sources for synthesis\n";
+ print "#\n";
+ print "set syn_files {\n";
+ foreach (@fl_syn) {
+ print " $_\n";
+ }
+ print "}\n";
+ print "\n";
+
+ print "set obj [get_filesets sources_1]\n";
+ print "add_files -norecurse -fileset \$obj \$syn_files\n";
+ # defined top only when not doing test bench
+ print "set_property \"top\" \"$top\" \$obj\n" unless defined $uut;
+
+ if (defined $uut) {
+ print "#\n";
+ print "# setup sources for simulation\n";
+ print "#\n";
+ print "set sim_files {\n";
+ foreach (@fl_sim) {
+ print " $_\n";
+ }
+ print "}\n";
+ print "\n";
+
+ print "set obj [get_filesets sim_1]\n";
+ print "add_files -norecurse -fileset \$obj \$sim_files\n";
+ print "set_property SOURCE_SET sources_1 \$obj\n";
+ }
+
+ # setup constraints
+ print "#\n";
+ print "# setup constraints\n";
+ print "#\n";
+
+ print "set xdc_files {\n";
+ foreach (@xdcfile_list) {
+ print " $_\n";
+ }
+ print "}\n";
+ print "\n";
+
+ # add_files does not allow adding an empty set, so protect
+ if (scalar @xdcfile_list) {
+ print "set obj [get_filesets constrs_1]\n";
+ print "add_files -norecurse -fileset \$obj \$xdc_files\n";
+ print "\n";
+ foreach my $fnam (@xdcfile_list) {
+ if (exists $srcfile_prop{$fnam}->{-SCOPE_REF}) {
+ my $target = $srcfile_prop{$fnam}->{-SCOPE_REF};
+ $target = $srcfile_prop{$fnam}->{VBstem} if $target eq '';
+ print "set_property SCOPED_TO_REF $target \\\n";
+ print " [get_files $fnam]\n";
+ }
+ }
+ }
+
+ print "\n";
+}
+
+# --vsim_prj ---------------------------------------------------------
+
+if (exists $opts{vsim_prj}) {
+ # Note: use a separate workdir for each sim_mode and each model (given
+ # by stem). This allows to have all co-existant, and to delete the workdir
+ # each time one of them is re-build.
+ my $workdir = "xsim.${sim_mode}.${stem}";
+ my $fname_forwarder = "${stem}_XSim";
+ $fname_forwarder =~ s/_([sorept]sim)_XSim/_XSim_$1/;
+
+ print "#!/bin/bash\n";
+ # pipefail ensures that in pipes like xvlog | tee ect the exits status is
+ # from the last failed command, and not simply from last command (tee).
+ # that ensures that the xvlog exit codes can be tested
+ print "set -o pipefail\n";
+ print "#\n";
+ print "# generated by vbomconv -vsim_prj $top_vbom\n";
+ print "#\n";
+
+ print "# ---------- delete old forwarder\n";
+ print "rm -f $fname_forwarder\n";
+ print "#\n";
+
+ print "# ---------- setup fresh working directory\n";
+ print "rm -rf ${workdir}\n";
+ print "mkdir ${workdir}\n";
+ print "pushd ${workdir}\n";
+ print "#\n";
+
+ # compile verilog before vhdl !
+ # currently verilog only used for DPI interface code or simulation models
+ # xvhdl relies in strict compilation order, also across languages, and fails
+ # when a not yet compiled module is instantiated via entiry work.xxx
+
+ if (scalar @srcfile_list_v) {
+ print "# ---------- xvlog step\n";
+ my $tfile_xvlog_prj = "tmp_${stem}_xvlog.prj";
+ print "cat > $tfile_xvlog_prj <&1 |\\\n";
+ print " tee xvlog_${stem}.log\n";
+ print 'exitstatus=$?' . "\n";
+ print "rm -f $tfile_xvlog_prj\n";
+ print 'if (($exitstatus > 0)); then exit $exitstatus; fi' . "\n";
+ print "#\n";
+ }
+
+ if (scalar @srcfile_list_vhd) {
+ print "# ---------- xvhdl step\n";
+ my $tfile_xvhdl_prj = "tmp_${stem}_xvhdl.prj";
+ print "cat > $tfile_xvhdl_prj <&1 |\\\n";
+ print " tee xvhdl_${stem}.log\n";
+ print 'exitstatus=$?' . "\n";
+ print "rm -f $tfile_xvhdl_prj\n";
+ print 'if (($exitstatus > 0)); then exit $exitstatus; fi' . "\n";
+ print "#\n";
+ }
+
+ if (scalar @srcfile_list_c) {
+ print "# ---------- xsc step\n";
+ print "xtwv xsc";
+ foreach (@srcfile_list_c) {
+ print " \\\n ../$_";
+ }
+ print "\n";
+ print 'exitstatus=$?' . "\n";
+ print 'if (($exitstatus > 0)); then exit $exitstatus; fi' . "\n";
+ print "#\n";
+ }
+
+ # Note: xelab -mt auto doesn't seem to work, use --mt `nproc`
+ print "# ---------- xelab step\n";
+ print "xtwv xelab --relax --debug typical --mt $nproc -m64 \\\n";
+ print " -L xil_defaultlib";
+ print " -L simprims_ver" if $is_tsim;
+ print " -L unisims_ver" if $is_veri && ! ($is_bsim || $is_tsim);
+ print " \\\n";
+ if (scalar @srcfile_list_c) {
+ print " --sv_lib dpi \\\n";
+ }
+ if ($is_tsim) {
+ print " -transport_int_delays -pulse_r 0 -pulse_int_r 0 \\\n";
+ }
+ print " --snapshot $stem \\\n";
+ print " -log xelab_${stem}.log \\\n";
+ print " xil_defaultlib.$top";
+ print " xil_defaultlib.glbl" if $is_tsim || ($is_veri && ! $is_bsim);
+ print " \n";
+ print 'exitstatus=$?' . "\n";
+ print 'if (($exitstatus > 0)); then exit $exitstatus; fi' . "\n";
+ print "#\n";
+
+ my $cwd = getcwd();
+ # use in forwarder full absolute path to relevant xsim.dir
+ # this allows to call the tb from every directory
+
+ print "# ---------- create forwarder\n";
+ print "popd\n";
+ print "if [ -x \"${workdir}/xsim.dir/${stem}/xsimk\" ]\n";
+ print "then\n";
+ print "#\n";
+ print "cat > $fname_forwarder <$ofile.dep_ghdl") or
+ die "can't write $ofile.dep_ghdl: $!";
+ print ODEPFILE "$ofile : $_\n";
+ print ODEPFILE "\t\$(COMPILE.c) \$(OUTPUT_OPTION) \$<\n";
+ close ODEPFILE;
+ } else {
+ print "$stem : $_\n";
+ }
+ }
+
+ # Notes: _fsim only for ISE useful
+ # _tsim only for VIV useful
+ if ($sim_mode eq 'ssim') {
+ foreach my $type (qw(f o r t)) {
+ my $stem_ghdl = $stem;
+ $stem_ghdl =~ s/_ssim$/_${type}sim/;
+
+ print "#\n";
+ foreach (@srcfile_list) {
+ my $file = $_; # copy to break alias for following s///
+ if (/\.c$/) {
+ $file =~ s{^.*/}{}; # remove directory path
+ $file =~ s/\.c$/.o/; # depend on object file for C sources
+ } else {
+ $file =~ s/_ssim\.vhd$/_${type}sim.vhd/;
+ }
+ print "$stem_ghdl : $file\n";
+ }
+ }
+
+ }
+
+ write_vbomdep("$stem.dep_ghdl");
+
+}
+
+# --dep_xst ----------------------------------------------------------
+
+if (exists $opts{dep_xst}) {
+ print "#\n";
+ print "$stem.ngc : $stem.dep_xst\n";
+ print "#\n";
+ foreach (@srcfile_list) {
+ print "$stem.ngc : $_\n";
+ }
+ # handle cpp preprocessed ucf's
+ foreach (@ucf_cpp_list) {
+ my $file = $_;
+ $file =~ s/\.ucf$//;
+ print "#\n";
+ print "$file.ncd : $file.ucf\n";
+ print "include $file.dep_ucf_cpp\n";
+ }
+ # handle plain ucf's
+ if (scalar(@ucf_cpp_list)==0 && -r "$stem.ucf") {
+ print "#\n";
+ print "$stem.ncd : $stem.ucf\n";
+ }
+ write_vbomdep("$stem.dep_xst");
+}
+
+# --dep_isim ---------------------------------------------------------
+
+if (exists $opts{dep_isim}) {
+ my $stem_isim = $stem . "_ISim";
+
+ $stem_isim =~ s/_ssim_ISim$/_ISim_ssim/ if ($sim_mode eq 'ssim');
+
+ my $stem_fsim_isim = $stem_isim;
+ my $stem_tsim_isim = $stem_isim;
+ $stem_fsim_isim =~ s/_ssim$/_fsim/;
+ $stem_tsim_isim =~ s/_ssim$/_tsim/;
+
+ print "#\n";
+ print "$stem_isim : $stem.dep_isim\n";
+ if ($sim_mode eq 'ssim') {
+ print "$stem_fsim_isim : $stem.dep_isim\n";
+ print "$stem_tsim_isim : $stem.dep_isim\n";
+ }
+ print "#\n";
+
+ foreach (@srcfile_list) {
+ print "$stem_isim : $_\n";
+ }
+
+ if ($sim_mode eq 'ssim') {
+
+ print "#\n";
+ foreach (@srcfile_list) {
+ my $file = $_; # copy to break alias for following s///
+ $file =~ s/_ssim\.vhd$/_fsim.vhd/;
+ print "$stem_fsim_isim : $file\n";
+ }
+
+ print "#\n";
+ foreach (@srcfile_list) {
+ my $file = $_; # copy to break alias for following s///
+ $file =~ s/_ssim\.vhd$/_tsim.vhd/;
+ print "$stem_tsim_isim : $file\n";
+ }
+
+ }
+
+ write_vbomdep("$stem.dep_isim");
+}
+
+# --dep_vsyn ---------------------------------------------------------
+
+if (exists $opts{dep_vsyn}) {
+ print "#\n";
+ print "$stem.bit : $stem.dep_vsyn\n";
+ print "#\n";
+ my @files;
+ push @files, @srcfile_list;
+ push @files, @xdcfile_list;
+ foreach (@files) {
+ print "$stem.bit : $_\n";
+ }
+ print "#\n";
+ foreach (@files) {
+ print "${stem}_syn.dcp : $_\n";
+ }
+ print "#\n";
+ foreach (@files) {
+ print "${stem}_rou.dcp : $_\n";
+ }
+ write_vbomdep("$stem.dep_vsyn");
+}
+
+# --dep_vsim ---------------------------------------------------------
+
+if (exists $opts{dep_vsim}) {
+ my $stem_vsim = $stem . "_XSim";
+
+ $stem_vsim =~ s/_ssim_XSim$/_XSim_ssim/ if ($sim_mode eq 'ssim');
+
+ print "#\n";
+ print "$stem_vsim : $stem.dep_vsim\n";
+
+ if ($sim_mode eq 'ssim') {
+ foreach my $type (qw(o r e p t)) {
+ my $stem_xsim = $stem_vsim;
+ $stem_xsim =~ s/_ssim$/_${type}sim/;
+ print "$stem_xsim : $stem.dep_vsim\n";
+ }
+ }
+ print "#\n";
+
+ foreach (@srcfile_list) {
+ print "$stem_vsim : $_\n";
+ }
+
+ if ($sim_mode eq 'ssim') {
+
+ # Note: when --dep_vsim is used for a _ssim.vbom read_vbom will remap
+ # _ssim.vhd to _ssim.v depending on $xsim_lang. [ept]sim always uses
+ # verilog, that's why there is a explict mapping below.
+
+ foreach my $type (qw(o r e p t)) {
+ my $stem_xsim = $stem_vsim;
+ $stem_xsim =~ s/_ssim$/_${type}sim/;
+
+ print "#\n";
+ foreach (@srcfile_list) {
+ my $file = $_; # copy to break alias for following s///
+ $file =~ s/_ssim\.(v|vhd)$/_${type}sim.$1/;
+ $file =~ s/_([ept])sim\.vhd$/_${1}sim.v/; # see Note above
+ print "$stem_xsim : $file\n";
+ }
+ }
+ }
+
+ write_vbomdep("$stem.dep_vsim");
+}
+
+# --ghdl_export or xst_export or isim_export -------------------------
+
+if (exists $opts{ghdl_export} or
+ exists $opts{xst_export} or
+ exists $opts{isim_export}) {
+ my $edir;
+ $edir = $opts{ghdl_export} if exists $opts{ghdl_export};
+ $edir = $opts{xst_export} if exists $opts{xst_export};
+ $edir = $opts{isim_export} if exists $opts{isim_export};
+
+ if (not -d $edir) {
+ print STDERR "vbomconv-I: create target directory $edir\n";
+ system("mkdir -p $edir") == 0 or die "mkdir failed: $?";
+ } else {
+ print STDERR "vbomconv-I: target directory $edir already exists\n";
+ }
+
+ open(PFILE, ">$edir/$stem.prj") or die "can't write open $edir/$stem.prj: $!";
+
+ foreach (@srcfile_list) {
+ my $fname = $_;
+ my $fdpath = ".";
+ if (m{(.*)/(.*)}) {
+ $fname = $2;
+ $fdpath = $1;
+ }
+ copy_edir($_, $edir);
+ print PFILE "vhdl work $fname\n";
+ }
+
+ close(PFILE);
+
+ # Note: currently no xflow opt files exported !!
+ if (exists $opts{xst_export}) {
+ open(XFILE, ">$edir/$stem.xcf") or
+ die "can't write open $edir/$stem.xcf: $!";
+ close(XFILE);
+
+ foreach (glob("*.xcf")) { copy_edir($_, $edir); }
+
+ if (-r "$stem.ucf_cpp") {
+ system "/bin/sh", "-c", "make $stem.ucf";
+ }
+
+ foreach (glob("*.ucf")) { copy_edir($_, $edir); }
+ }
+
+}
+
+# --vsyn_export or vsim_export ---------------------------------------
+
+if (exists $opts{vsyn_export} or
+ exists $opts{vsim_export}) {
+ my $edir;
+ $edir = $opts{vsyn_export} if exists $opts{vsyn_export};
+ $edir = $opts{vsim_export} if exists $opts{vsim_export};
+
+ if (not -d $edir) {
+ print STDERR "vbomconv-I: create target directory $edir\n";
+ system("mkdir -p $edir") == 0 or die "mkdir failed: $?";
+ } else {
+ print STDERR "vbomconv-I: target directory $edir already exists\n";
+ }
+
+ my @filist;
+ push @filist, @srcfile_list;
+ push @filist, @xdcfile_list;
+ my @fl_syn;
+ my @fl_sim;
+ my @fl_xdc;
+
+ foreach my $fi (@filist) {
+ my $fname = $fi;
+ my $fdpath = ".";
+ if ($fi =~ m{(.*)/(.*)}) {
+ $fname = $2;
+ $fdpath = $1;
+ }
+
+ copy_edir($fi, $edir);
+
+ if ($fname =~ m{\.(vhd|sv)$}) { # .vhd or .sv
+ if ($srcfile_synsim{$fi} eq 'syn') {
+ push @fl_syn, $fname;
+ } else {
+ push @fl_sim, $fname;
+ }
+ } elsif ($fname =~ m{\.c}) { # .c
+ printf "+++2 $fi\n";
+ push @fl_sim, $fname;
+ } elsif ($fname =~ m{\.xdc}) { # .xdc
+ push @fl_xdc, $fname;
+ } else {
+ print STDERR "vbomconv-W: file $fname not processed (unknown type)\n";
+ }
+ }
+
+ open(TFILE, ">$edir/$stem.tcl") or die "can't write open $edir/$stem.tcl: $!";
+
+ print TFILE "#\n";
+ print TFILE "# setup file lists\n";
+ print TFILE "#\n";
+
+ print TFILE "set syn_files {\n";
+ foreach (@fl_syn) {
+ print TFILE " $_\n";
+ }
+ print TFILE "}\n";
+ print TFILE "\n";
+
+ print TFILE "set sim_files {\n";
+ foreach (@fl_sim) {
+ print TFILE " $_\n";
+ }
+ print TFILE "}\n";
+ print TFILE "\n";
+
+ print TFILE "set xdc_files {\n";
+ foreach (@fl_xdc) {
+ print TFILE " $_\n";
+ }
+ print TFILE "}\n";
+ print TFILE "\n";
+
+ print TFILE 'set obj [get_filesets sources_1]' . "\n";
+ print TFILE 'add_files -norecurse -fileset $obj $syn_files' . "\n";
+ printf TFILE 'set_property "top" "%s" $obj' . "\n", $top;
+ print TFILE "\n";
+
+ if (scalar @fl_sim) {
+ print TFILE 'set obj [get_filesets sim_1]' . "\n";
+ print TFILE 'add_files -norecurse -fileset $obj $sim_files' . "\n";
+ print TFILE "\n";
+ }
+
+ if (scalar @fl_xdc) {
+ print TFILE 'set obj [get_filesets constrs_1]' . "\n";
+ print TFILE 'add_files -norecurse -fileset $obj $xdc_files' . "\n";
+ print TFILE "\n";
+ }
+
+ close(TFILE);
+
+
+}
+
+# --get_top ----------------------------------------------------------
+
+if (exists $opts{get_top}) {
+ print "$top\n";
+}
+
+# --flist ------------------------------------------------------------
+
+if (exists $opts{flist}) {
+
+ my @flist;
+
+ push @flist, @srcfile_list;
+ push @flist, sort keys %vbom_done;
+
+ if (scalar(@ucf_cpp_list)) {
+ foreach (@ucf_cpp_list) {
+ push @flist, $_."_cpp";
+ }
+ } else {
+ if (-r "$stem.ucf") {
+ push @flist, "$stem.ucf";
+ }
+ }
+
+ push @flist, @xdcfile_list;
+
+ foreach (sort @flist) {
+ my $fname = $_;
+ my $fdpath = ".";
+ if (m{(.*)/(.*)}) {
+ $fname = $2;
+ $fdpath = $1;
+ }
+ print "$fdpath/$fname\n";
+ }
+
+}
+
+#-------------------------------------------------------------------------------
+
+sub read_vbom {
+ my ($vbom) = @_;
+
+ print STDERR "-- open $vbom\n" if $do_trace;
+
+ open (IFILE, $vbom) or die "can't open for read $vbom: $!";
+
+ my $vbom_path = "";
+ my $vbom_file = $vbom;
+ if ($vbom =~ m{^(.*)/([a-zA-Z0-9_.]*)$}) {
+ $vbom_path = $1;
+ $vbom_file = $2;
+ }
+
+ $vbom_done{$vbom} += 1; # mark this vbom already read
+
+ while () {
+ chomp;
+ next if /^\s*#/; # drop comments
+ next if /^\s*$/; # drop empty lines
+
+ s/\s*$//; # drop trailing blanks
+
+ # process parameter definitions
+ if (m{([\w]+)\s*=\s*(.*)}) {
+ my $para = $1;
+ my $val = $2;
+ if ($val eq "") {
+ print STDERR "vbomconv-E: invalid \'$_\' in $vbom_file\n";
+ exit 1;
+ }
+ if (not exists $para_tbl{$para}) {
+ $para_tbl{$para} = canon_fname($vbom_path, $val);
+ print STDERR "--- define \${$para} = $val\n" if $do_trace;
+ } else {
+ print STDERR "--- ignore \${$para} = $val\n" if $do_trace;
+ }
+ next;
+ }
+
+ # process parameter substitutions
+ while (m{\$\{([\w]+)\s*(:=)?\s*(.*?)\}}) {
+ my $para = $1;
+ my $del = $2;
+ my $val = $3;
+ my $pre = $`;
+ my $post = $';
+ if (defined $del && $del eq ":=") {
+ if (not exists $para_tbl{$para}) {
+ $para_tbl{$para} = canon_fname($vbom_path, $val);
+ print STDERR "--- define \${$para := $val}\n" if $do_trace;
+ } else {
+ print STDERR "--- ignore \${$para := $val}\n" if $do_trace;
+ }
+ }
+ if (defined $para_tbl{$para}) {
+ if ($do_trace) {
+ print STDERR "--- use \${$para} -> $para_tbl{$para}\n";
+ } else {
+ ## print STDERR "vbomconv-I: \${$para} -> $para_tbl{$para}\n";
+ }
+ $_ = $pre . "!" . $para_tbl{$para} . $post;
+ } else {
+ print STDERR "vbomconv-E: undefined \${$para} in $vbom_file\n";
+ exit 1;
+ }
+ }
+
+ if (/^\[([a-z,]+)\]\s*(.+)$/) { # [xxx,yyy] tag seen
+ my $qual = $1;
+ my $name = $2;
+ my $keep = $is_any;
+ ## print STDERR "+++1 |$qual|$name|$vbom|\n";
+ foreach my $pref (split /,/,$qual) {
+ if ($pref =~ /^(ghdl|xst|isim|vsyn|vsim|sim|ise|viv)$/) {
+ $keep = 1 if ($pref eq "ghdl" && $is_ghdl);
+ $keep = 1 if ($pref eq "xst" && $is_xst);
+ $keep = 1 if ($pref eq "isim" && $is_isim);
+ $keep = 1 if ($pref eq "vsyn" && $is_vsyn);
+ $keep = 1 if ($pref eq "vsim" && $is_vsim);
+ $keep = 1 if ($pref eq "sim" && $is_sim);
+ $keep = 1 if ($pref eq "ise" && $is_ise);
+ $keep = 1 if ($pref eq "viv" && $is_viv);
+ } else {
+ print STDERR "vbomconv-W: unknown tag [$pref] in $vbom_file\n";
+ }
+ }
+ if (not $keep) {
+ print STDERR "--- drop \"$_\"\n" if $do_trace;
+ next;
+ }
+ $_ = $name; # remove [xxx] tag
+ }
+
+ my $tag;
+ my $val = $_;
+
+ # detect tag:val lines
+ if (m{^\s*(.*?)\s*:\s*(.*?)\s*$}) {
+ $tag = $1;
+ $val = $2;
+
+ # process @top: lines
+ if ($tag eq '@top') {
+ $top = $val unless $top_done;
+ next;
+
+ # process @ucf_cpp: lines
+ } elsif ($tag eq '@ucf_cpp') {
+ push @ucf_cpp_list, $val;
+ next;
+
+ # process @xdc: lines
+ } elsif ($tag eq '@xdc') {
+ my ($fname,$rphash) = parse_props($val);
+ $fname = canon_fname($vbom_path, $fname);
+ setup_props($fname, $rphash);
+ push @{$vbom_xdc{$vbom}}, $fname;
+ next;
+
+ # process @lib: lines
+ } elsif ($tag eq '@lib') {
+ if ($val eq 'unisim') {
+ $has_unisim = 1;
+ } elsif ($val eq 'unimacro') {
+ $has_unimacro = 1;
+ } elsif ($val eq 'simprim') {
+ $has_simprim = 1;
+ } else {
+ print STDERR "vbomconv-E: invalid lib type \'$tag\' in $vbom_file\n";
+ exit 1;
+ }
+ next;
+
+ # catch invalid @ tags
+ } else {
+ print STDERR "vbomconv-E: invalid \'$tag:\' line in $vbom_file\n";
+ exit 1;
+ }
+
+ }
+
+ # split in filename and property list
+ my ($fname,$rphash) = parse_props($val);
+
+ # now do model source file mapping
+ my $fname_old = $fname;
+ if ($is_ise || $is_ghdl) {
+ $fname =~ s{_ssim\.vhd$}{_fsim.vhd} if $sim_mode eq 'fsim';
+ $fname =~ s{_ssim\.vhd$}{_osim.vhd} if $sim_mode eq 'osim';
+ $fname =~ s{_ssim\.vhd$}{_rsim.vhd} if $sim_mode eq 'rsim';
+ $fname =~ s{_ssim\.vhd$}{_tsim.vhd} if $sim_mode eq 'tsim';
+ }
+ if ($is_viv) {
+ $fname =~ s{_ssim\.vhd$}{_esim.v} if $sim_mode eq 'esim';
+ $fname =~ s{_ssim\.vhd$}{_psim.v} if $sim_mode eq 'psim';
+ $fname =~ s{_ssim\.vhd$}{_tsim.v} if $sim_mode eq 'tsim';
+ if ($is_veri) {
+ $fname =~ s{_ssim\.vhd$}{_ssim.v} if $sim_mode eq 'ssim';
+ $fname =~ s{_ssim\.vhd$}{_osim.v} if $sim_mode eq 'osim';
+ $fname =~ s{_ssim\.vhd$}{_rsim.v} if $sim_mode eq 'rsim';
+ } else {
+ $fname =~ s{_ssim\.vhd$}{_osim.vhd} if $sim_mode eq 'osim';
+ $fname =~ s{_ssim\.vhd$}{_rsim.vhd} if $sim_mode eq 'rsim';
+ }
+ }
+ print STDERR "--- map $fname_old -> $fname\n"
+ if $do_trace && $fname_old ne $fname;
+
+ # process normal .vhd, .v, or .vbom file lines
+ # canonize file name unless not already done by filename substitution
+ my $fullname;
+ if ($fname =~ m{^!(.*)$}) {
+ $fullname = $1;
+ } else {
+ $fullname = canon_fname($vbom_path, $fname);
+ }
+
+ # handle properties
+ setup_props($fullname, $rphash);
+
+ # process -UUT property here, with canonized file names
+ if (exists $rphash->{-UUT}) {
+ if (defined $uut) {
+ print STDERR "vbomconv-E: duplicate -UUT:, 1st '$uut' 2nd '$val'\n";
+ exit 1;
+ }
+ $uut = $fullname;
+ }
+
+ # determine whether additional libs needed
+ if ($fullname =~ m{_[sor]sim\.vhd$}) { # is ssim, osim or rsim
+ $has_unisim = 1;
+ }
+ if ($fullname =~ m{_[ft]sim\.vhd$}) { # is fsim or tsim
+ $has_simprim = 1;
+ }
+
+ # build vbom table
+ push @{$vbom_files{$vbom}}, $fullname;
+ print STDERR "--- add $fullname\n" if $do_trace;
+
+ # if a vbom, queue if not not already read
+ if ($fullname =~ m{\.vbom$} && not exists $vbom_done{$fullname} ) {
+ push @vbom_queue, $fullname;
+ print STDERR "--- queue $fullname\n" if $do_trace;
+ }
+
+ }
+
+ $top_done = 1;
+
+ close (IFILE);
+}
+
+#-------------------------------------------------------------------------------
+
+sub scan_vbom {
+ my ($vbom) = @_;
+
+ $level += 1;
+ my $rank = 1000*$level + scalar(@{$vbom_files{$vbom}});
+ print STDERR "--> $level: $vbom\n" if $do_trace;
+
+ die "vbomcov-E excessive vbom stack depth \n" if $level>=1000;
+
+ if (exists $vbom_rank{$vbom}) {
+ $vbom_rank{$vbom}{min} = $level if $level < $vbom_rank{$vbom}{min};
+ $vbom_rank{$vbom}{max} = $level if $level > $vbom_rank{$vbom}{max};
+ } else {
+ $vbom_rank{$vbom} = {min=>$level, max=>$level};
+ }
+
+ foreach my $file (@{$vbom_files{$vbom}}) {
+ $rank -= 1;
+ if ($file =~ m{\.vbom$}) {
+ scan_vbom($file);
+ } else {
+ if (exists $srcfile_rank{$file}) {
+ if ($rank > $srcfile_rank{$file}) {
+ print STDERR " $file $srcfile_rank{$file} -> $rank\n" if $do_trace;
+ $srcfile_rank{$file} = $rank;
+ } else {
+ print STDERR " $file $srcfile_rank{$file} (keep)\n" if $do_trace;
+ }
+ } else {
+ $srcfile_rank{$file} = $rank;
+ print STDERR " $file $srcfile_rank{$file} (new)\n" if $do_trace;
+ }
+ }
+ }
+
+ print STDERR "<-- $level: $vbom\n" if $do_trace;
+ $level -= 1;
+
+}
+
+#-------------------------------------------------------------------------------
+
+sub do_synsim {
+ my ($uut) = @_;
+
+ # all is syn if no @uut defined; preset with sim when @uut defined
+ my $def = (defined $uut) ? 'sim' : 'syn';
+ foreach my $file (keys %srcfile_rank) {
+ $srcfile_synsim{$file} = $def;
+ }
+ return unless defined $uut;
+
+ # if @uut seen separate them
+ if (defined $uut) {
+ if ($uut =~ m{\.vbom}) { # uut is vbom (behavioral sim)
+ scan_synsim($uut);
+ } else { # uut is file (post syn sim)
+ $srcfile_synsim{$uut} = 'syn';
+ }
+ }
+}
+
+#-------------------------------------------------------------------------------
+
+sub scan_synsim {
+ my ($vbom) = @_;
+
+ foreach my $file (@{$vbom_files{$vbom}}) {
+ if ($file =~ m{\.vbom$}) {
+ scan_synsim($file);
+ } else {
+ $srcfile_synsim{$file} = 'syn';
+ }
+ }
+}
+
+#-------------------------------------------------------------------------------
+
+sub copy_edir {
+ my ($file, $edir) = @_;
+ print "cp -p $file $edir\n";
+ system("cp -p $file $edir")==0 or die "cp -p failed: $?";
+}
+
+#-------------------------------------------------------------------------------
+
+sub write_vbomdep {
+ my ($target) = @_;
+ print "#\n";
+ print "# .dep_* on .vbom dependencies\n";
+ print "#\n";
+ foreach (sort keys %vbom_done) {
+ print "$target : $_\n";
+ }
+}
+
+#-------------------------------------------------------------------------------
+sub canon_fname {
+ my ($vpath,$fname) = @_;
+ # get full relative file name (relative to cwd)
+ $fname = "$vpath/$fname" if $vpath ne "";
+
+ # remove 'inner' .., e.g. ../x/../y --> ../y
+ # this will also canonize the file names, thus same file same name
+
+ my @flist;
+ foreach (split "/",$fname) {
+ if (scalar(@flist) && $flist[$#flist] ne ".." && $_ eq "..") {
+ pop @flist;
+ } else {
+ push @flist, $_;
+ }
+ }
+
+ return join "/", @flist;
+}
+
+#-------------------------------------------------------------------------------
+sub parse_props {
+ my ($val) = @_;
+ my $fname = $val;
+ my %phash = ();
+ if ($val =~ /^\s*(\S+)\s+(-.+)$/) { # "fname -xxx..." seen
+ $fname = $1;
+ my $plist = $2;
+ foreach my $pitem (split /\s+/,$plist) {
+ if ($pitem =~ m/^(.*)\:(.*)$/) { # -key:val (not k=v !!)
+ $phash{$1} = $2;
+ } else {
+ $phash{$pitem} = '';
+ }
+ }
+ }
+
+ return ($fname, \%phash);
+
+}
+
+#-------------------------------------------------------------------------------
+sub setup_props {
+ my ($fname, $rphash) = @_;
+ $srcfile_prop{$fname} = $rphash;
+ my $path = '.';
+ my $name = $fname;
+ if ($fname =~ m|^(.+)/(.+)$|) {
+ $path = $1;
+ $name = $2;
+ }
+ my $stem = $name;
+ my $type = '';
+ if ($name =~ m/^(.+)(\..*)/) {
+ $stem = $1;
+ $type = $2;
+ }
+ $srcfile_prop{$fname}->{VBpath} = $path;
+ $srcfile_prop{$fname}->{VBstem} = $stem;
+ $srcfile_prop{$fname}->{VBtype} = $type;
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub print_help {
+ print "usage: vbomconf file.vbom\n";
+ print " --help this message\n";
+ print " --trace trace recursive processing of vbom's\n";
+ print " --dep_ghdl generate ghdl dependencies for make\n";
+ print " --dep_xst generate xst dependencies for make\n";
+ print " --dep_isim generate isim dependencies for make\n";
+ print " --dep_vsyn generate vsyn dependencies for make\n";
+ print " --ghdl_a generate and execute ghdl -a (analyse)\n";
+ print " --ghdl_a_cmd like ghdl_a, but only print command, no exec\n";
+ print " --ghdl_i generate and execute ghdl -i (inspect)\n";
+ print " --ghdl_i_cmd like ghdl_i, but only print command, no exec\n";
+ print " --ghdl_m generate and execute ghdl -m (make)\n";
+ print " --ghdl_m_cmd like ghdl_m, but only print command, no exec\n";
+ print " --xst_prj generate xst project file\n";
+ print " --isim_prj generate isim project file\n";
+ print " --vsyn_prj generate vivado synthesis project definition\n";
+ print " --ghdl_export=s export all ghdl source files into directory s\n";
+ print " --xst_export=s export all xst source files into directory s\n";
+ print " --isim_export=s export all isim source files into directory s\n";
+ print " --vsyn_export=s export all vsyn source files into directory s\n";
+ print " --vsim_export=s export all vsim source files into directory s\n";
+ print " --get_top return top level entity name\n";
+ print " --flist list all files touched by vbom for all tags\n";
+}
vbomconv
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xise_ghdl_simprim
===================================================================
--- xise_ghdl_simprim (nonexistent)
+++ xise_ghdl_simprim (revision 38)
@@ -0,0 +1,78 @@
+#!/bin/bash
+# $Id: xise_ghdl_simprim 782 2016-07-03 08:09:36Z mueller $
+#
+# Copyright 2007-2016 by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Revision History:
+# Date Rev Vers Comment
+# 2016-07-02 782 1.3.1 add ghdlopts as 1st option; default is -O2
+# 2015-02-03 642 1.3 remove ISE 10 legacy support
+# 2015-01-29 639 1.2 rename from xilinx_*; use XTWI_PATH rather XILINX
+# 2009-11-08 248 1.1 adopt to ISE 11.1, use VITAL models from ./primitive
+# 2007-10-26 92 1.0 Initial version
+#
+ghdlopts=${1:--O2 -g}
+#
+if [ -z "$XTWI_PATH" ]
+then
+ echo "XTWI_PATH not defined"
+ exit 1
+fi
+if [ ! -d "$XTWI_PATH/ISE_DS/ISE" ]
+then
+ echo "$XTWI_PATHISE_DS/ISE not existing"
+ exit 1
+fi
+#
+ise_path=$XTWI_PATH/ISE_DS/ISE
+#
+cd $ise_path
+echo "============================================================"
+echo "* Build ghdl SIMPRIM lib for $ise_path"
+echo "============================================================"
+#
+if [ ! -d ghdl ]
+then
+ mkdir ghdl
+fi
+#
+cd $ise_path/ghdl
+if [ ! -d simprim ]
+then
+ mkdir simprim
+fi
+cd simprim
+#
+cp $ise_path/vhdl/src/simprims/simprim_Vcomponents.vhd .
+cp $ise_path/vhdl/src/simprims/simprim_Vpackage.vhd .
+#
+if [ ! -d primitive ]
+then
+ mkdir primitive
+fi
+#
+pushd primitive
+cp -p $ise_path/vhdl/src/simprims/primitive/other/*.vhd .
+cp -p $ise_path/vhdl/src/simprims/primitive/other/vhdl_analyze_order .
+xilinx_vhdl_memcolltype_fix
+popd
+#
+echo "# ghdl ... simprim_Vcomponents.vhd"
+ghdl -a --ieee=synopsys --work=simprim --no-vital-checks $ghdlopts \
+ simprim_Vcomponents.vhd
+echo "# ghdl ... simprim_Vpackage.vhd"
+ghdl -a --ieee=synopsys --work=simprim --no-vital-checks $ghdlopts \
+ simprim_Vpackage.vhd
+
+for file in `cat primitive/vhdl_analyze_order`
+do
+ echo "# ghdl ... primitive/$file"
+ ghdl -a -fexplicit --ieee=synopsys --work=simprim \
+ --no-vital-checks $ghdlopts primitive/$file 2>&1 |\
+ tee primitive/$file.ghdl.log
+done
+#
+echo "--- scan for compilation errors:"
+find primitive -name "*.ghdl.log" | xargs grep error
+#
xise_ghdl_simprim
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xise_ghdl_unisim
===================================================================
--- xise_ghdl_unisim (nonexistent)
+++ xise_ghdl_unisim (revision 38)
@@ -0,0 +1,100 @@
+#!/bin/bash
+# $Id: xise_ghdl_unisim 782 2016-07-03 08:09:36Z mueller $
+#
+# Copyright 2007-2016 by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Revision History:
+# Date Rev Vers Comment
+# 2016-07-02 782 1.3.1 add ghdlopts as 1st option; default is -O2
+# 2015-02-03 642 1.3 remove ISE 10 legacy support; add unimacro support
+# 2015-01-29 639 1.2 rename from xilinx_*; use XTWI_PATH rather XILINX
+# 2009-11-08 248 1.1 adopt to ISE 11.1, use VITAL models from ./primitive
+# 2007-10-26 92 1.0 Initial version
+#
+ghdlopts=${1:--O2 -g}
+#
+if [ -z "$XTWI_PATH" ]
+then
+ echo "XTWI_PATH not defined"
+ exit 1
+fi
+if [ ! -d "$XTWI_PATH/ISE_DS/ISE" ]
+then
+ echo "$XTWI_PATH/ISE_DS/ISE not existing"
+ exit 1
+fi
+#
+ise_path=$XTWI_PATH/ISE_DS/ISE
+#
+cd $ise_path
+echo "============================================================"
+echo "* Build ghdl UNISIM lib for $ise_path"
+echo "============================================================"
+#
+if [ ! -d ghdl ]
+then
+ mkdir ghdl
+fi
+cd ghdl
+#
+if [ ! -d unisim ]
+then
+ mkdir unisim
+fi
+cd unisim
+#
+cp $ise_path/vhdl/src/unisims/unisim_VCOMP.vhd .
+cp $ise_path/vhdl/src/unisims/unisim_VPKG.vhd .
+#
+if [ ! -d primitive ]
+then
+ mkdir primitive
+fi
+pushd primitive
+#
+cp -p $ise_path/vhdl/src/unisims/primitive/*.vhd .
+cp -p $ise_path/vhdl/src/unisims/primitive/vhdl_analyze_order .
+#
+xilinx_vhdl_memcolltype_fix
+popd
+
+echo "# ghdl ... unisim_VCOMP.vhd"
+ghdl -a --ieee=synopsys --work=unisim $ghdlopts unisim_VCOMP.vhd
+echo "# ghdl ... unisim_VPKG.vhd"
+ghdl -a --ieee=synopsys --work=unisim $ghdlopts unisim_VPKG.vhd
+
+for file in `cat primitive/vhdl_analyze_order`
+do
+ echo "# ghdl ... primitive/$file"
+ ghdl -a -fexplicit --ieee=synopsys --work=unisim $ghdlopts \
+ --no-vital-checks primitive/$file 2>&1 |\
+ tee primitive/$file.ghdl.log
+done
+#
+echo "--- scan for compilation errors:"
+find primitive -name "*.ghdl.log" | xargs grep error
+#
+echo "============================================================"
+echo "* Build ghdl UNIMACRO lib for $XTWI_PATH/ISE_DS/ISE"
+echo "============================================================"
+#
+cd $ise_path/ghdl
+if [ ! -d unimacro ]
+then
+ mkdir unimacro
+fi
+#
+cd unimacro
+cp $ise_path/vhdl/src/unimacro/*.vhd .
+#
+for file in *.vhd
+do
+ echo "# ghdl ... $file"
+ ghdl -a -P../unisim -fexplicit --ieee=synopsys --work=unimacro $ghdlopts \
+ --no-vital-checks $file 2>&1 | tee $file.ghdl.log
+done
+#
+echo "--- scan for compilation errors:"
+find . -name "*.ghdl.log" | xargs grep error
+#
xise_ghdl_unisim
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xtwi
===================================================================
--- xtwi (nonexistent)
+++ xtwi (revision 38)
@@ -0,0 +1,80 @@
+#!/bin/bash
+# $Id: xtwi 804 2016-08-28 17:33:50Z mueller $
+#
+# Copyright 2013-2016 by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Xilinx Tool Wrapper script for ISE:
+# define XTWI_PATH
+# usage xwti
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-08-28 804 1.2 BUGFIX: add ":." to PATH even under BARE_PATH
+# 2016-02-21 735 1.1 use BARE_PATH ect to provide clean environment
+# 2013-10-12 539 1.0 Initial version
+#
+# Note: For Xilinx ISE installations with an install path holds
+# /ISE_DS dir with settings(32|64).sh
+# /ISE_DS/ISE XILINX env var will point here
+#
+
+# store arg list on vars (will be dropped later to source scripts)
+arglist_val=$@
+arglist_num=$#
+#
+# check whether ISE already setup ($XILINX defined)
+if [ -z "$XILINX" ]
+then
+ # check whether $XTWI_PATH defined
+ if [ -z "$XTWI_PATH" ]
+ then
+ echo "XTWI_PATH not defined"
+ exit 1
+ fi
+
+ # provide clean environment when BARE_PATH ect defined
+ # add only $RETROBASE/tools/bin and '.' to path
+ # '.' is needed to start ISim tb's, which usually are in cwd
+ if [ -n "$BARE_PATH" ]
+ then
+ export PATH=$BARE_PATH:$RETROBASE/tools/bin:.
+ unset LD_LIBRARY_PATH
+ if [ -n "$BARE_LD_LIBRARY_PATH" ]
+ then
+ export LD_LIBRARY_PATH=$BARE_LD_LIBRARY_PATH
+ fi
+ fi
+
+ # check whether 32 or 64 bit system (uname -m gives 'i686' or 'x86_64')
+ if [ `uname -m` = "x86_64" ]
+ then
+ settings_filename=$XTWI_PATH/ISE_DS/settings64.sh
+ else
+ settings_filename=$XTWI_PATH/ISE_DS/settings32.sh
+ fi
+ if [ ! -e "$settings_filename" ]
+ then
+ echo "can't locate init script '$settings_filename'"
+ exit 1
+ fi
+
+ # drop arg list, suppress output
+ set --
+ . $settings_filename > /dev/null
+
+ # check that XILINX defined
+ if [ -z "$XILINX" ]
+ then
+ echo "Failed to setup XILINX"
+ exit 1
+ fi
+
+else
+ echo "XILINX already defined"
+fi
+
+if [ $arglist_num != 0 ]
+then
+ exec $arglist_val
+fi
xtwi
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xviv_ghdl_unisim
===================================================================
--- xviv_ghdl_unisim (nonexistent)
+++ xviv_ghdl_unisim (revision 38)
@@ -0,0 +1,137 @@
+#!/bin/bash
+# $Id: xviv_ghdl_unisim 782 2016-07-03 08:09:36Z mueller $
+#
+# Copyright 2015-2016 by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Revision History:
+# Date Rev Vers Comment
+# 2016-07-02 782 1.1.1 add ghdlopts as 1st option; default is -O2
+# 2016-04-17 762 1.1 update for viv 2016.1
+# 2015-02-02 642 1.0 Initial version
+#
+ghdlopts=${1:--O2 -g}
+#
+if [ -z "$XTWV_PATH" ]
+then
+ echo "XTWV_PATH not defined"
+ exit 1
+fi
+if [ ! -d "$XTWV_PATH" ]
+then
+ echo "$XTWV_PATH not existing"
+ exit 1
+fi
+#
+cd $XTWV_PATH
+echo "============================================================"
+echo "* Build ghdl UNISIM lib for $XTWV_PATH"
+echo "============================================================"
+#
+if [ ! -d ghdl ]
+then
+ mkdir ghdl
+fi
+cd ghdl
+#
+if [ ! -d unisim ]
+then
+ mkdir unisim
+fi
+cd unisim
+#
+# copy VCOMP and VPKG ----------------------------
+#
+cp $XTWV_PATH/data/vhdl/src/unisims/unisim_retarget_VCOMP.vhd .
+cp $XTWV_PATH/data/vhdl/src/unisims/unisim_VPKG.vhd .
+#
+# copy 'primitive' models ------------------------
+#
+if [ ! -d primitive ]
+then
+ mkdir primitive
+fi
+pushd primitive
+#
+cp -p $XTWV_PATH/data/vhdl/src/unisims/primitive/*.vhd .
+cp -p $XTWV_PATH/data/vhdl/src/unisims/primitive/vhdl_analyze_order .
+# in Vivado 2014.4 the vhdl_analyze_order and contains two extraneous entries
+# simply drop them to avoid errors later on
+sed -i.bak -e '\|OBUFTDSE3| d' \
+ -e '\|OBUFTE3| d' \
+ vhdl_analyze_order
+#
+xilinx_vhdl_memcolltype_fix
+popd
+#
+# copy 'retarget' models -------------------------
+#
+if [ ! -d retarget ]
+then
+ mkdir retarget
+fi
+pushd retarget
+#
+cp -p $XTWV_PATH/data/vhdl/src/unisims/retarget/*.vhd .
+ls -1 *.vhd > vhdl_analyze_order
+#
+xilinx_vhdl_memcolltype_fix
+popd
+#
+# now compile all --------------------------------
+#
+echo "# ghdl ... unisim_retarget_VCOMP.vhd"
+ghdl -a --ieee=synopsys --work=unisim $ghdlopts unisim_retarget_VCOMP.vhd
+echo "# ghdl ... unisim_VPKG.vhd"
+ghdl -a --ieee=synopsys --work=unisim $ghdlopts unisim_VPKG.vhd
+
+for file in `cat primitive/vhdl_analyze_order`
+do
+ echo "# ghdl ... primitive/$file"
+ ghdl -a -fexplicit --ieee=synopsys --work=unisim $ghdlopts \
+ --no-vital-checks primitive/$file 2>&1 |\
+ tee primitive/$file.ghdl.log
+done
+#
+for file in `cat retarget/vhdl_analyze_order`
+do
+ echo "# ghdl ... retarget/$file"
+ ghdl -a -fexplicit --ieee=synopsys --work=unisim $ghdlopts \
+ --no-vital-checks retarget/$file 2>&1 |\
+ tee retarget/$file.ghdl.log
+done
+#
+echo "--- scan for compilation errors:"
+find primitive retarget -name "*.ghdl.log" | xargs grep error
+#
+#
+echo "============================================================"
+echo "* Build ghdl UNIMACRO lib for $XTWV_PATH"
+echo "============================================================"
+#
+cd $XTWV_PATH/ghdl
+if [ ! -d unimacro ]
+then
+ mkdir unimacro
+fi
+cd unimacro
+#
+cp $XTWV_PATH/data/vhdl/src/unimacro/*.vhd .
+
+if [ -r $XTWV_PATH/data/vhdl/src/unimacro/vhdl_analyze_order ]
+then
+ cp $XTWV_PATH/data/vhdl/src/unimacro/vhdl_analyze_order .
+else
+ ls -1 *.vhd > vhdl_analyze_order
+fi
+#
+for file in `cat vhdl_analyze_order`
+do
+ echo "# ghdl ... $file"
+ ghdl -a -P../unisim -fexplicit --ieee=synopsys --work=unimacro $ghdlopts \
+ --no-vital-checks $file 2>&1 | tee $file.ghdl.log
+done
+#
+echo "--- scan for compilation errors:"
+find . -name "*.ghdl.log" | xargs grep error
+#
xviv_ghdl_unisim
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xise_msg_summary
===================================================================
--- xise_msg_summary (nonexistent)
+++ xise_msg_summary (revision 38)
@@ -0,0 +1,27 @@
+#!/bin/bash
+# $Id: xise_msg_summary 772 2016-06-05 12:55:11Z mueller $
+#
+# Copyright 2016- by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Revision History:
+# Date Rev Vers Comment
+# 2016-06-05 772 1.0 Initial version
+#
+
+for f in `find -name "*.imfset" | sort`
+do
+ dnam=`dirname $f`
+ bnam=`basename $f .imfset`
+ echo ""
+ echo "####################################################################"
+ echo "### ${dnam}/${bnam} ###"
+ pushd ${dnam} > /dev/null
+ if [ ! -r ${bnam}_xst.log ]
+ then
+ echo No ${bnam}_xst.log available
+ else
+ make ${bnam}.mfsum
+ fi
+ popd > /dev/null
+done
xise_msg_summary
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: ti_w11
===================================================================
--- ti_w11 (nonexistent)
+++ ti_w11 (revision 38)
@@ -0,0 +1,356 @@
+#!/usr/bin/perl -w
+# $Id: ti_w11 776 2016-06-18 17:22:51Z mueller $
+#
+# Copyright 2013-2016 by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-06-18 776 1.3.5 use ti_rri --tout now
+# 2016-03-20 748 1.3.4 BUGFIX: add portsel oob for -fx;
+# use 120 sec timeout for simulation; add -ll,-dl,-tl
+# 2016-03-18 745 1.3.3 add arty support, add -fx
+# 2015-11-01 712 1.3.2 use sb_cntl pin 12 for tmu; add -ghw option
+# 2015-05-14 680 1.3.1 use now -f1,-f1e,-f2,-f2e (fx now f1e)
+# 2015-04-13 667 1.3 rename -fu->-fc, add -f2,-fx; setup good defaults
+# 2015-01-02 640 1.2.2 BUGFIX: allow 'M' unit in baud rates
+# 2014-12-23 619 1.2.1 use -fifo tbw option for test bench starts
+# 2014-07-13 570 1.2 BUGFIX: split options args into ti_rri opts and cmds
+# 2013-05-05 516 1.1 renamed to ti_w11
+# 2013-04-26 510 1.0 Initial version (derived from dorri)
+#
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+use FileHandle;
+
+sub print_usage;
+
+autoflush STDOUT 1; # autoflush, so nothing lost on exec later
+
+my $sysbase = "$ENV{RETROBASE}/rtl/sys_gen/w11a";
+
+my $opt_dry;
+my $opt_b;
+my $opt_io = '';
+my $opt_f = '';
+my $opt_ll = '2';
+my $opt_dl = '';
+my $opt_tl = '';
+my $opt_to = '';
+my $opt_tmu;
+my $opt_ghw;
+my $tirri;
+my $val_term;
+my $val_tb_s3 = "tbw $sysbase/s3board/tb/tb_w11a_s3 -fifo";
+my $val_tb_n2 = "tbw $sysbase/nexys2/tb/tb_w11a_n2 -fifo";
+my $val_tb_n3 = "tbw $sysbase/nexys3/tb/tb_w11a_n3 -fifo";
+my $val_tb_b3 = "tbw $sysbase/basys3/tb/tb_w11a_b3 -fifo";
+my $val_tb_n4 = "tbw $sysbase/nexys4/tb/tb_w11a_n4 -fifo";
+my $val_tb_bn4 = "tbw $sysbase/nexys4_bram/tb/tb_w11a_br_n4 -fifo";
+my $val_tb_bar = "tbw $sysbase/arty_bram/tb/tb_w11a_br_arty -fifo";
+my $val_tb;
+my $val_e;
+
+my @arglist;
+
+#
+# process ti_w11 options
+#
+while (scalar(@ARGV)) {
+ my $curarg = $ARGV[0];
+
+ if ($curarg =~ m{^-dry$} ) { # -dry
+ $opt_dry = 1;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-b$} ) { # -b
+ $opt_b = 1;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-tmu$} ) { # -tmu
+ $opt_tmu = 1;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-ghw$} ) { # -ghw
+ $opt_ghw = 1;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-s3$} ) { # -s3 (use -f2 by default)
+ $opt_io = 'f';
+ $opt_f = '2';
+ $val_tb = $val_tb_s3;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-n2$} ) { # -n2 (use -fc by default)
+ $opt_io = 'f';
+ $opt_f = 'c';
+ $val_tb = $val_tb_n2;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-n3$} ) { # -n3 (use -fc by default)
+ $opt_io = 'f';
+ $opt_f = 'c';
+ $val_tb = $val_tb_n3;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-b3$} ) { # -b3 (use -fx by default)
+ $opt_io = 'f';
+ $opt_f = 'x';
+ $val_tb = $val_tb_b3;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-n4$} ) { # -n4 (prim serport fine)
+ $opt_io = 'f';
+ $opt_f = '1';
+ $val_tb = $val_tb_n4;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-bn4$} ) { # -bn4 (prim serport fine)
+ $opt_io = 'f';
+ $opt_f = '1';
+ $val_tb = $val_tb_bn4;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-bar$} ) { # -bar (use -fx by default)
+ $opt_io = 'f';
+ $opt_f = 'x';
+ $val_tb = $val_tb_bar;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-f(c|x|1|1x|2|2x)$} ) { # -f..
+ $opt_f = $1;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-t([su])(\d?),?} ) { # -t[su]...
+ my $devnam = ($1 eq 's') ? '/dev/ttyS' : '/dev/ttyUSB';
+ my $devnum = $2;
+ my ($dev,$baud,$opt1,$opt2) = split /,/,$curarg;
+ $baud = '115k' unless defined $baud;
+
+ if ($baud !~ m{^\d*[kM]?$}) {
+ print STDERR "ti_w11-E: invalid format of -ts or -tu option\n";
+ exit 1;
+ }
+
+ $opt_io = 't';
+ $val_term = sprintf '%s%d,%s', $devnam, $devnum, $baud;
+ $val_term .= ",$opt1" if defined $opt1;
+ $val_term .= ",$opt2" if defined $opt2;
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-u$} ) { # -u
+ $opt_io = 'u';
+ shift @ARGV;
+
+ } elsif ($curarg =~ m{^-e$} ) { # -e
+ print STDERR "ti_w11-W: multiple -e options, only last taken\n"
+ if defined $val_e;
+ shift @ARGV;
+ if (scalar(@ARGV) == 0 || $ARGV[0] =~ m{^-}) {
+ print STDERR "ti_w11-E: no file name after -e option\n";
+ exit 1;
+ } else {
+ $val_e = shift @ARGV;
+ if (not -r $val_e) {
+ print STDERR "ti_w11-E: file '$val_e' not found\n";
+ exit 1;
+ }
+ }
+ } elsif ($curarg =~ m{^-ll(\d)$} ) { # -ll (setup --logl)
+ $opt_ll = $1;
+ shift @ARGV;
+ } elsif ($curarg =~ m{^-dl(\d)$} ) { # -dl (setup --dmpl)
+ $opt_dl = $1;
+ shift @ARGV;
+ } elsif ($curarg =~ m{^-tl(\d)$} ) { # -tl (setup --tiol)
+ $opt_tl = $1;
+ shift @ARGV;
+ } else {
+ last;
+ }
+}
+
+#
+# process remaining arguments, separate ti_rri options and commands
+#
+
+# handle options (all starting with -)
+my @tiopts;
+while (scalar(@ARGV)) {
+ last unless $ARGV[0] =~ m{^--};
+ push @tiopts, shift @ARGV;
+}
+
+# handle comands
+my @ticmds;
+while (scalar(@ARGV)) {
+ my $curarg = shift @ARGV;
+ if ($curarg =~ m{^@(.*)$} && ! -r $1) {
+ print STDERR "ti_w11-E: file '$1' not found\n";
+ exit 1;
+ }
+ push @ticmds,$curarg;
+}
+
+#
+# check that either -(s3|n2|n3|n4|bn4) or -t or -u given
+# setup options for either case
+#
+
+if ($opt_io eq 'f') {
+ my $fifoopts = ",noinit"; # fifo always with deferred init
+ $fifoopts .= ",xon" if $opt_f =~ m/x$/;
+ push @arglist, "--fifo=$fifoopts";
+ my $run_opts = "";
+ if ($opt_ghw) {
+ my $ghw_stem = "ti_w11";
+ $ghw_stem = $1 if ($val_tb =~ m|^.*\s+.*/(\w*)\s+|); # get stem of tb file
+ $run_opts .= " --wave=${ghw_stem}.ghw";
+ }
+ push @arglist, "--run=${val_tb}${run_opts}";
+} elsif ($opt_io eq 't') {
+ push @arglist, "--term=$val_term";
+} elsif ($opt_io eq 'u') {
+ push @arglist, '--cuff';
+} else {
+ print STDERR "ti_w11-E: neither -(s3|n2|...) nor -t,-u specified\n";
+ print_usage();
+ exit 1;
+}
+
+# setup timeout
+if ($opt_io eq 'f') {
+ $opt_to = '120.'; # 120 sec timeout for simulation
+}
+
+#
+# setup all other ti_rri options
+#
+
+push @arglist, "--logl=${opt_ll}";
+push @arglist, "--dmpl=${opt_dl}" if $opt_dl ne '';
+push @arglist, "--tiol=${opt_tl}" if $opt_tl ne '';
+push @arglist, "--tout=${opt_to}" if $opt_to ne '';
+push @arglist, '--int' unless $opt_b;
+push @arglist, '--pack=rw11';
+push @arglist, @tiopts; # add options from ARGV
+push @arglist, '--';
+
+#
+# actions prior to first exec
+# setup tmu ect
+# setup access path --> handle -f options
+#
+if ($opt_io eq 'f') {
+ if ($opt_tmu) {
+ push @arglist, 'rlc oob -sbcntl 12 1';
+ }
+ if ($opt_f eq 'c') {
+ push @arglist, 'rlc oob -sbdata 8 0x4'; # portsel = 0100 -> fx2
+ push @arglist, 'rlc oob -sbdata 16 0x4'; # swi = 0100 -> fx2
+ } elsif ($opt_f eq 'x') {
+ push @arglist, 'rlc oob -sbdata 8 0x2'; # portsel = 0010 -> 1st ser XON
+ } elsif ($opt_f eq '1x') {
+ push @arglist, 'rlc oob -sbdata 8 0x2'; # portsel = 0010 -> 1st ser XON
+ push @arglist, 'rlc oob -sbdata 16 0x2'; # swi = 0010 -> 1st ser XON
+ } elsif ($opt_f eq '2') {
+ push @arglist, 'rlc oob -sbdata 8 0x1'; # portsel = 0001 -> 2nd ser
+ push @arglist, 'rlc oob -sbdata 16 0x1'; # swi = 0001 -> 2nd ser
+ } elsif ($opt_f eq '2x') {
+ push @arglist, 'rlc oob -sbdata 8 0x3'; # portsel = 0011 -> 2nd ser XON
+ push @arglist, 'rlc oob -sbdata 16 0x3'; # swi = 0011 -> 2nd ser XON
+ }
+}
+
+#
+# --fifo always uses deferred init, so add a rlc init after the oob's
+#
+push @arglist, 'rlc init' if $opt_io eq 'f';
+
+#
+# initialize w11 cpu system
+#
+push @arglist, 'rw11::setup_sys';
+
+#
+# handle -e option
+#
+
+if (defined $val_e) {
+ if ($val_e =~ m/\.mac$/) {
+ push @arglist, "cpu0 ldasm -file $val_e -sym ldasm_sym -lst ldasm_lst";
+ } else {
+ push @arglist, "cpu0 ldabs $val_e";
+ }
+ push @arglist, 'rw11::cpumon';
+ push @arglist, 'rw11::cpucons';
+ push @arglist, 'cpu0 cp -stapc 0200';
+}
+
+push @arglist, @ticmds; # add commands from ARGV
+
+#
+# find ti_rri executable
+#
+
+$tirri=`which ti_rri`;
+chomp $tirri;
+if ($tirri eq '' || ! -e $tirri) {
+ print STDERR "ti_w11-E: failed to locate ti_rri\n";
+ exit 1;
+}
+
+#
+# print command line
+#
+if (1) {
+ print 'ti_rri ', join (' ', map {(m{\s}) ? "\"$_\"" : $_} @arglist) , "\n";
+}
+
+#
+# if dry run, stop here
+#
+exit 0 if $opt_dry;
+#
+# and do it
+#
+exec $tirri, @arglist
+ or die "failed to exec: $!";
+
+exit 1;
+
+# ----------------------------------------------------------------------------
+sub print_usage {
+ print "usage: ti_w11 ...\n";
+ print " setup options for ghdl simulation runs:\n";
+ print " -b3 start tb_w11a_b3 simulation (default: -fx)\n";
+ print " -n4 start tb_w11a_n4 simulation\n";
+ print " -bn4 start tb_w11a_br_n4 simulation\n";
+ print " -bar start tb_w11a_br_arty simulation (default: -fx)\n";
+ print " -n3 start tb_w11a_n3 simulation (default: -fc)\n";
+ print " -n2 start tb_w11a_n2 simulation (default: -fc)\n";
+ print " -s3 start tb_w11a_s3 simulation (default: -f2)\n";
+ print " -f.. simulation communication options\n";
+ print " -fc use fx2 data path (cuff)\n";
+ print " -fx use 1st serport with hardwired xon\n";
+ print " -f1 use 1st serport\n";
+ print " -f1x use 1st serport with switched xon\n";
+ print " -f2 use 2nd serport (fusp)\n";
+ print " -f2x use 2nd serport with switched xon\n";
+ print " -tmu activate trace and monitoring unit\n";
+ print " -ghw activate ghdl wave dump with --wave=.ghw\n";
+ print " setup options for FPGA connects:\n";
+ print " -u use --cuff connect\n";
+ print " -t.. use --term connect\n";
+ print " -ts*[,opts] use /dev/ttyS* (* is device number)\n";
+ print " -tu*[,opts] use /dev/ttyUSB* (* is device number)\n";
+ print " opts can be ',break', ',xon'\n";
+ print " common options:\n";
+ print " -e load and execute file\n";
+ print " file type '.mac': on the fly compile with asm-11\n";
+ print " any other file type: assume lda format\n";
+ print "\n";
+ print " either one of -s3,-n2,-n3,-b3,-n4,-bn4 must be given -> sim run\n";
+ print " or one of -t or -u must be given -> fpga run\n";
+}
ti_w11
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xviv_msg_summary
===================================================================
--- xviv_msg_summary (nonexistent)
+++ xviv_msg_summary (revision 38)
@@ -0,0 +1,27 @@
+#!/bin/bash
+# $Id: xviv_msg_summary 772 2016-06-05 12:55:11Z mueller $
+#
+# Copyright 2016- by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Revision History:
+# Date Rev Vers Comment
+# 2016-06-05 772 1.0 Initial version
+#
+
+for f in `find -name "*.vmfset" | sort`
+do
+ dnam=`dirname $f`
+ bnam=`basename $f .vmfset`
+ echo ""
+ echo "####################################################################"
+ echo "### ${dnam}/${bnam} ###"
+ pushd ${dnam} > /dev/null
+ if [ ! -r ${bnam}_syn.log ]
+ then
+ echo No ${bnam}_syn.log available
+ else
+ make ${bnam}.mfsum
+ fi
+ popd > /dev/null
+done
xviv_msg_summary
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xviv_sim_vhdl_cleanup
===================================================================
--- xviv_sim_vhdl_cleanup (nonexistent)
+++ xviv_sim_vhdl_cleanup (revision 38)
@@ -0,0 +1,16 @@
+#!/bin/bash
+# $Id: xviv_sim_vhdl_cleanup 774 2016-06-12 17:08:47Z mueller $
+#
+# Copyright 2014-2016 by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-06-12 774 1.0 Initial version
+#
+
+# cleanup vivado generated vhdl models for ghdl
+# 1. remove 'attribute RTL_KEEP' decorations
+# ghdl 0.33 does not accept decorations of port signals !
+
+sed -i.bak -e '/^ *attribute *RTL_KEEP/ d' $1
xviv_sim_vhdl_cleanup
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xviv_msg_filter
===================================================================
--- xviv_msg_filter (nonexistent)
+++ xviv_msg_filter (revision 38)
@@ -0,0 +1,270 @@
+#!/usr/bin/perl -w
+# $Id: xviv_msg_filter 772 2016-06-05 12:55:11Z mueller $
+#
+# Copyright 2016- by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-06-04 772 1.0 Initial version
+#
+
+use 5.14.0; # require Perl 5.14 or higher
+use strict; # require strict checking
+use FileHandle;
+
+use Getopt::Long;
+
+my %opts = ();
+
+GetOptions(\%opts, "help", "pacc") || exit 1;
+
+sub print_help;
+sub read_mfs;
+sub read_log;
+
+my $type = shift @ARGV;
+my $mfsnam = shift @ARGV;
+my $lognam = shift @ARGV;
+my @flist;
+my @mlist;
+my $nackcnt = 0;
+my $ackcnt = 0;
+my $imisscnt = 0;
+my $rmisscnt = 0;
+my $timebad = 0;
+my $timegood = 0;
+
+my $retrobase = $ENV{RETROBASE};
+
+autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
+
+if (exists $opts{help}) {
+ print_help;
+ exit 0;
+}
+
+if (!defined $type || !defined $mfsnam || !defined $lognam) {
+ print STDERR "xviv_msg_filter-E: one of 'type mfset log' missing \n\n";
+ print_help;
+ exit 1;
+}
+
+if ($type !~ m{^(syn|imp)$}) {
+ print STDERR "xviv_msg_filter-E: type must be syn or imp\n";
+ exit 1;
+}
+
+if (read_mfs($mfsnam)) {exit 1;}
+if (read_log($lognam)) {exit 1;}
+
+foreach my $m (@mlist) {
+ my $msev = $m->[0];
+ my $mcode = $m->[1];
+ my $mtext = $m->[2];
+ my $msgmatch = 0;
+
+ # check for timing closure
+ # bad: [Route 35-39] The design did not meet timing requirements
+ # bad: [Timing 38-282] The design failed to meet the timing ...
+ # good: [Route 35-61] The design met the timing requirement
+ $timebad += 1 if $type eq 'imp' && $mcode eq 'Route 35-39';
+ $timebad += 1 if $type eq 'imp' && $mcode eq 'Timing 38-282';
+ $timegood += 1 if $type eq 'imp' && $mcode eq 'Route 35-61';
+
+ foreach my $f (@flist) {
+ my $fmode = $f->[0];
+ my $fcode = $f->[1];
+ my $frege = $f->[2];
+ if ($frege eq '') {
+ $msgmatch = $mcode eq $fcode;
+ } else {
+ $msgmatch = $mcode eq $fcode && $mtext =~ m{$frege};
+ }
+ if ($msgmatch) {
+ #print "+++m '$fmode' '$fcode' '$frege' : '$mcode' '$mtext'\n";
+ $f->[3] += 1;
+ last;
+ }
+ }
+
+ $msgmatch = 1 if $msev eq 'INFO'; # accept all INFO
+
+ if ($msgmatch) {
+ $m->[3] += 1;
+ } else {
+ $nackcnt += 1;
+ }
+}
+
+if ($nackcnt) {
+ print "Unexpected messages of type [$type] from $lognam:\n";
+ foreach my $m (@mlist) {
+ next if $m->[3];
+
+ # now prety print the message
+ # remove $RETROBASE from file names
+ my $mtext = $m->[2];
+ $mtext =~ s/${retrobase}/.../g if defined $retrobase;
+ # and break it up into 80 character wide lines
+ my @mwl = split /\s+/,$mtext;
+ unshift @mwl, '[' . $m->[1] . ']';
+ unshift @mwl, $m->[0] . ':';
+ my $pref = ' ';
+ my $line = ' ';
+ while (scalar(@mwl)) {
+ my $word = shift @mwl;
+ if (length($line) + length($word) + 1 > 80) {
+ print "$line\n";
+ $line = $pref;
+ }
+ $line .= ' ' . $word;
+ }
+ print "$line\n" if $line ne $pref;
+ }
+ print "\n";
+}
+
+foreach my $f (@flist) {
+ if ($f->[3] != 0) { # matches seen
+ $ackcnt += 1;
+ } else { # matches not seen
+ if ($f->[0] eq 'i') { # complain if 'i'
+ $imisscnt += 1;
+ } elsif ($f->[0] eq 'r') { # complain if 'r'
+ $rmisscnt += 1;
+ }
+ }
+}
+
+if ($ackcnt && exists $opts{pacc}) {
+ print "Accepted messages for type [$type] from $lognam:\n";
+ foreach my $f (@flist) {
+ next if $f->[3] == 0;
+ printf "%4d: [%s] %s\n", $f->[3], $f->[1], $f->[2];
+ }
+ print "\n";
+}
+
+if ($imisscnt) {
+ print "Ignore filter rules with no matches for type [$type] from $lognam:\n";
+ foreach my $f (@flist) {
+ next if $f->[3] != 0;
+ printf "%4d: [%s] %s\n", $f->[3], $f->[1], $f->[2] if $f->[0] eq 'i';
+ }
+ print "\n";
+}
+
+if ($rmisscnt) {
+ print "Missed required messages for type [$type] from $lognam:\n";
+ foreach my $f (@flist) {
+ next if $f->[3] != 0;
+ printf "%4d: [%s] %s\n", $f->[3], $f->[1], $f->[2] if $f->[0] eq 'r';
+ }
+ print "\n";
+}
+
+if ($type eq 'imp' && ($timebad > 0 || $timegood == 0)) {
+ printf "!! ------------------------------ !!\n";
+ printf "!! FAILED TO REACH TIMING CLOSURE !!\n";
+ printf "!! ------------------------------ !!\n";
+}
+
+#-------------------------------------------------------------------------------
+sub read_mfs {
+ my ($fname) = @_;
+
+ if (not -r $fname) {
+ print STDERR "xviv_msg_filter-E: \'$fname\' not existing or readable\n";
+ return 1;
+ }
+
+ my $fh = new FileHandle;
+ $fh->open($fname) or die "can't open for read $fname: $!";
+
+ my $intyp = 0;
+
+ while (<$fh>) {
+ chomp;
+ s/#.*//; # remove comments after #
+ s/\s+$//; # remove trailing blanks
+ next if /^\s*$/; # drop empty lines
+
+ if (/^\@(.+)$/) { # @ found
+ my $rc = read_mfs($1);
+ return $rc if $rc;
+ next;
+ }
+
+ if (m{^\[([a-z]{3})\]$}) { # [typ] tag found
+ if ($1 eq $type) {
+ $intyp = 1;
+ } else {
+ $intyp = 0;
+ }
+ next;
+ }
+
+ next unless $intyp; # only process relevant lines
+
+ if (/^([iIr])\s+\[(.+?)\]\s*(.*)\s*$/) {
+ #print "+++0m '$1' '$2' '$3'\n";
+ my $fmode = $1;
+ my $fcode = $2;
+ my $frege = $3;
+ $frege =~ s/\[/\\\[/g;
+ $frege =~ s/\]/\\\]/g;
+ push @flist, [$fmode,$fcode,$frege, 0];
+ } else {
+ printf STDERR "xviv_msg_filter-E: bad line in mfset: '%s'\n", $_;
+ }
+ }
+
+ $fh->close();
+
+ return 0;
+}
+
+#-------------------------------------------------------------------------------
+sub read_log {
+ my ($fname) = @_;
+
+ if (not -r $fname) {
+ print STDERR "xviv_msg_filter-E: \'$fname\' not existing or readable\n";
+ return 1;
+ }
+
+ open (LFILE, $fname) or die "can't open for read $fname: $!";
+
+ while () {
+ chomp;
+ if (m{^(INFO|WARNING|CRITICAL WARNING|ERROR):\s*\[(.+?)\]\s*(.*)}) {
+ #print "+++0l '$1' '$2' '$3'\n";
+ push @mlist, [$1,$2,$3,0];
+ }
+ }
+
+ close (LFILE);
+
+ return 0;
+}
+
+#-------------------------------------------------------------------------------
+
+sub print_help {
+ print "usage: xviv_msg_filter [options] type mfset log\n";
+ print " type log file type: syn or imp\n";
+ print " mfset message filter set file\n";
+ print " log log file\n";
+ print " Options:\n";
+ print " --pacc print summary of accepted messages\n";
+ print " --help this message\n";
+}
xviv_msg_filter
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: makeise
===================================================================
--- makeise (nonexistent)
+++ makeise (revision 38)
@@ -0,0 +1,8 @@
+#!/bin/bash
+# $Id: makeise 761 2016-04-17 08:53:48Z mueller $
+#
+# Copyright 2016- by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+
+exec make -f Makefile.ise "$@"
makeise
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: rm_dep
===================================================================
--- rm_dep (nonexistent)
+++ rm_dep (revision 38)
@@ -0,0 +1,19 @@
+#!/bin/sh
+# $Id: rm_dep 727 2016-02-07 13:58:47Z mueller $
+#
+# Copyright 2010-2015 by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-02-06 727 1.2.1 add dep_vsim
+# 2015-02-14 646 1.2 add dep_vsyn
+# 2011-01-09 354 1.1.1 add *.dep for cpp depends
+# 2010-04-26 284 1.1 add xargs -r to prevent rm errors on empty lists
+# 2010-04-24 282 1.0 Initial version
+#
+for ftype in dep dep_ghdl dep_xst dep_isim dep_ucf_cpp dep_vsyn dep_vsim
+do
+ echo "---------- remove *.$ftype ----------------------------------------"
+ find -name "*.$ftype" | xargs --no-run-if-empty rm -v
+done
rm_dep
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xtwv
===================================================================
--- xtwv (nonexistent)
+++ xtwv (revision 38)
@@ -0,0 +1,77 @@
+#!/bin/bash
+# $Id: xtwv 735 2016-02-26 22:17:42Z mueller $
+#
+# Copyright 2013-2016 by Walter F.J. Mueller
+# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory
+#
+# Xilinx Tool Wrapper script for Vivado
+# define XTWV_PATH
+# usage xwtv
+#
+# Revision History:
+# Date Rev Version Comment
+# 2016-02-21 735 1.1 use BARE_PATH ect to provide clean environment
+# 2014-04-18 554 1.0.1 fake XILINX_VIVADO, 2014.1 doesn't define it anymore
+# 2013-10-12 539 1.0 Initial version (cloned from xtwi)
+#
+# Note: For Xilinx Vivado installations with an install path holds
+# dir with settings(32|64).sh
+#
+
+# store arg list on vars (will be dropped later to source scripts)
+arglist_val=$@
+arglist_num=$#
+#
+# check whether Vivado already setup ($XILINX_VIVADO defined)
+if [ -z "$XILINX_VIVADO" ]
+then
+ # check whether $XTWV_PATH defined
+ if [ -z "$XTWV_PATH" ]
+ then
+ echo "XTWV_PATH not defined"
+ exit 1
+ fi
+
+ # provide clean environment when BARE_PATH ect defined
+ # add only $RETROBASE/tools/bin to path
+ if [ -n "$BARE_PATH" ]
+ then
+ export PATH=$BARE_PATH:$RETROBASE/tools/bin
+ unset LD_LIBRARY_PATH
+ if [ -n "$BARE_LD_LIBRARY_PATH" ]
+ then
+ export LD_LIBRARY_PATH=$BARE_LD_LIBRARY_PATH
+ fi
+ fi
+
+ # check whether 32 or 64 bit system (uname -m gives 'i686' or 'x86_64')
+ if [ `uname -m` = "x86_64" ]
+ then
+ settings_filename=$XTWV_PATH/settings64.sh
+ else
+ settings_filename=$XTWV_PATH/settings32.sh
+ fi
+ if [ ! -e "$settings_filename" ]
+ then
+ echo "can't locate init script '$settings_filename'"
+ exit 1
+ fi
+
+ # drop arg list, suppress output
+ set --
+ . $settings_filename > /dev/null
+
+ # check that XILINX_VIVADO defined
+ if [ -z "$XILINX_VIVADO" ]
+ then
+ export XILINX_VIVADO=$XTWV_PATH/.
+ fi
+
+else
+ echo "XILINX_VIVADO already defined"
+fi
+
+if [ $arglist_num != 0 ]
+then
+ exec $arglist_val
+fi
xtwv
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: dmscntanal
===================================================================
--- dmscntanal (nonexistent)
+++ dmscntanal (revision 38)
@@ -0,0 +1,488 @@
+#!/usr/bin/perl -w
+# $Id: dmscntanal 721 2015-12-29 17:50:50Z mueller $
+#
+# Copyright 2015- by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2015-06-28 696 1.0 Initial version
+#
+
+use 5.14.0; # require Perl 5.14 or higher
+use strict; # require strict checking
+
+use Getopt::Long;
+
+my %opts = ();
+
+GetOptions(\%opts, "help", "raw")
+ or die "bad options";
+
+sub print_help;
+sub read_file;
+sub show_raw;
+sub add_groups;
+sub group_new;
+
+my @snum2nam;
+my %snam2num;
+my %dat_all;
+my %dat_km;
+my %dat_um;
+my $sum_all;
+my $sum_km;
+my $sum_um;
+
+autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
+
+if (exists $opts{help}) {
+ print_help;
+ exit 0;
+}
+
+foreach my $file (@ARGV) {
+ read_file($file);
+ add_groups();
+ show_raw() if exists $opts{raw};
+ show_frac();
+}
+
+#-------------------------------------------------------------------------------
+
+sub read_file {
+ my ($file) = @_;
+
+ %dat_km = ();
+ %dat_um = ();
+ %dat_all = ();
+ @snum2nam = ();
+ %snam2num = ();
+ $sum_all = 0;
+ $sum_km = 0;
+ $sum_um = 0;
+
+ open IFILE,"<$file" or die "failed to open $file";
+
+ while () {
+ chomp;
+ next if m/^#/;
+ if (m/^\s*([[:xdigit:]]+)
+ \s+(\w+)
+ \s+(\d+)
+ \s+(\d+)
+ \s+(\d+)/x) {
+ my $snum = hex($1);
+ my $snam = $2;
+ my $all = 1. * "$3.";
+ my $km = 1. * "$4.";
+ my $um = 1. * "$5.";
+
+ $snum2nam[$snum] = $snam;
+ $snam2num{$snam} = $snum;
+
+ $dat_all{$snam} += $all;
+ $dat_km{$snam} += $km;
+ $dat_um{$snam} += $um;
+
+ $sum_all += $all;
+ $sum_km += $km;
+ $sum_um += $um;
+
+ } else {
+ printf STDERR "bad line: $_\n";
+ }
+ }
+
+ close IFILE;
+
+}
+
+#-------------------------------------------------------------------------------
+
+sub show_raw {
+ print "#\n";
+ print "#sn state all km usm" .
+ " all% km% usm%\n";
+ printf "# sum_all %11.0f %11.0f %11.0f %6.2f %6.2f %6.2f\n",
+ $sum_all, $sum_km, $sum_um,
+ get_frac(100., $sum_all, $sum_all),
+ get_frac(100., $sum_km, $sum_all),
+ get_frac(100., $sum_um, $sum_all);
+
+ for (my $snum=0; $snum 0.;
+ return $fact*($nom/$denom);
+}
+
+#-------------------------------------------------------------------------------
+
+sub add_groups {
+ group_new(0x100, 'g_sum');
+ $dat_all{g_sum} = $sum_all;
+ $dat_km{g_sum} = $sum_km;
+ $dat_um{g_sum} = $sum_um;
+
+ group_new(0x110, 'g_cp',
+ 's_cp_regread',
+ 's_cp_rps',
+ 's_cp_memr_w',
+ 's_cp_memw_w');
+
+ group_new(0x111, 'g_cp_mem',
+ 's_idle',
+ 's_cp_memr_w',
+ 's_cp_memw_w',
+ '-',
+ 's_int_ext');
+
+ group_new(0x112, 'g_ifetdec',
+ 's_ifetch',
+ 's_ifetch_w',
+ 's_idecode');
+
+ group_new(0x113, 'g_srcr',
+ 's_srcr_def',
+ 's_srcr_def_w',
+ 's_srcr_inc',
+ 's_srcr_inc_w',
+ 's_srcr_dec',
+ 's_srcr_dec1',
+ 's_srcr_ind',
+ 's_srcr_ind1_w',
+ 's_srcr_ind2',
+ 's_srcr_ind2_w');
+
+ group_new(0x114, 'g_dstr',
+ 's_dstr_def',
+ 's_dstr_def_w',
+ 's_dstr_inc',
+ 's_dstr_inc_w',
+ 's_dstr_dec',
+ 's_dstr_dec1',
+ 's_dstr_ind',
+ 's_dstr_ind1_w',
+ 's_dstr_ind2',
+ 's_dstr_ind2_w');
+
+ group_new(0x115, 'g_dstw',
+ 's_dstw_def',
+ 's_dstw_def_w',
+ 's_dstw_inc',
+ 's_dstw_inc_w',
+ 's_dstw_incdef_w',
+ 's_dstw_dec',
+ 's_dstw_dec1',
+ 's_dstw_ind',
+ 's_dstw_ind_w',
+ 's_dstw_def246');
+
+ group_new(0x116, 'g_dsta',
+ 's_dsta_inc',
+ 's_dsta_incdef_w',
+ 's_dsta_dec',
+ 's_dsta_dec1',
+ 's_dsta_ind',
+ 's_dsta_ind_w');
+
+ group_new(0x120, 'g_op_rts',
+ 's_op_rts',
+ 's_op_rts_pop',
+ 's_op_rts_pop_w');
+
+ group_new(0x121, 'g_op_sob',
+ 's_op_sob',
+ 's_op_sob1');
+
+ group_new(0x122, 'g_op_gen',
+ 's_opg_gen',
+ 's_opg_gen_rmw_w');
+
+ group_new(0x123, 'g_op_mul',
+ 's_opg_mul',
+ 's_opg_mul1');
+
+ group_new(0x124, 'g_op_div',
+ 's_opg_div',
+ 's_opg_div_cn',
+ 's_opg_div_cr',
+ 's_opg_div_sq',
+ 's_opg_div_sr',
+ 's_opg_div_quit');
+
+ group_new(0x125, 'g_op_ash',
+ 's_opg_ash',
+ 's_opg_ash_cn');
+
+ group_new(0x126, 'g_op_ashc',
+ 's_opg_ashc',
+ 's_opg_ashc_cn',
+ 's_opg_ashc_wl');
+
+ group_new(0x127, 'g_op_jsr',
+ 's_opa_jsr',
+ 's_opa_jsr1',
+ 's_opa_jsr_push',
+ 's_opa_jsr_push_w',
+ 's_opa_jsr2');
+
+ group_new(0x128, 'g_op_mtp',
+ 's_opa_mtp',
+ 's_opa_mtp_pop_w',
+ 's_opa_mtp_reg',
+ 's_opa_mtp_mem',
+ 's_opa_mtp_mem_w');
+
+ group_new(0x129, 'g_op_mfp',
+ 's_opa_mfp_reg',
+ 's_opa_mfp_mem',
+ 's_opa_mfp_mem_w',
+ 's_opa_mfp_dec',
+ 's_opa_mfp_push',
+ 's_opa_mfp_push_w');
+
+ group_new(0x12a, 'g_int',
+ 's_int_ext',
+ 's_int_getpc',
+ 's_int_getpc_w',
+ 's_int_getps',
+ 's_int_getps_w',
+ 's_int_getsp',
+ 's_int_decsp',
+ 's_int_pushps',
+ 's_int_pushps_w',
+ 's_int_pushpc',
+ 's_int_pushpc_w');
+
+ group_new(0x12b, 'g_rti',
+ 's_rti_getpc',
+ 's_rti_getpc_w',
+ 's_rti_getps',
+ 's_rti_getps_w',
+ 's_rti_newpc');
+
+ group_new(0x130, 'g_op_jsrrts',
+ 'g_op_jsr',
+ 'g_op_rts');
+
+ group_new(0x131, 'g_flow',
+ 's_op_br',
+ 's_op_sob',
+ 's_opa_jmp',
+ 's_opa_jsr',
+ 's_op_rts');
+
+ group_new(0x13a, 'g_intrti',
+ 'g_int',
+ 'g_rti');
+
+ group_new(0x101, 'g_sum_noidle',
+ 'g_sum',
+ '-',
+ 'g_cp_mem',
+ 's_op_wait');
+
+ group_new(0x102, 'g_sum_exec',
+ 'g_sum_noidle',
+ '-',
+ 'g_int',
+ 'g_rti');
+
+ group_new(0x140, 'g_ifetch_wextra',
+ 's_ifetch_w',
+ '-',
+ 's_ifetch');
+
+ group_new(0x141, 'g_srcr_wextra',
+ 's_srcr_def_w',
+ 's_srcr_inc_w',
+ 's_srcr_ind1_w',
+ 's_srcr_ind2_w',
+ '-',
+ 's_srcr_def',
+ 's_srcr_inc',
+ 's_srcr_ind',
+ 's_srcr_ind2');
+
+ group_new(0x142, 'g_dstr_wextra',
+ 's_dstr_def_w',
+ 's_dstr_inc_w',
+ 's_dstr_ind1_w',
+ 's_dstr_ind2_w',
+ '-',
+ 's_dstr_def',
+ 's_dstr_inc',
+ 's_dstr_ind',
+ 's_dstr_ind2');
+
+ group_new(0x143, 'g_dstw_wextra',
+ 's_dstw_def_w',
+ 's_dstw_inc_w',
+ 's_dstw_incdef_w',
+ 's_dstw_ind_w',
+ '-',
+ 's_dstw_def',
+ 's_dstw_inc',
+ 's_dstw_ind',
+ 's_dstw_def246');
+
+ group_new(0x144, 'g_dsta_wextra',
+ 's_dsta_incdef_w',
+ 's_dsta_ind_w',
+ '-',
+ 's_dsta_inc',
+ 's_dsta_ind');
+
+ group_new(0x145, 'g_op_rts_wextra',
+ 's_op_rts_pop_w',
+ '-',
+ 's_op_rts_pop');
+
+ group_new(0x146, 'g_op_jsr_wextra',
+ 's_opa_jsr_push_w',
+ '-',
+ 's_opa_jsr_push');
+
+ group_new(0x147, 'g_op_mtp_wextra',
+ 's_opa_mtp_pop_w',
+ 's_opa_mtp_mem_w',
+ '-',
+ 's_opa_mtp',
+ 's_opa_mtp_mem');
+
+ group_new(0x148, 'g_op_mfp_wextra',
+ 's_opa_mfp_mem_w',
+ 's_opa_mfp_push_w',
+ '-',
+ 's_opa_mfp_mem',
+ 's_opa_mfp_push');
+
+ group_new(0x149, 'g_int_wextra',
+ 's_int_getpc_w',
+ 's_int_getps_w',
+ 's_int_pushps_w',
+ 's_int_pushpc_w',
+ '-',
+ 's_int_getpc',
+ 's_int_getps',
+ 's_int_pushps',
+ 's_int_pushpc');
+
+ group_new(0x14a, 'g_rti_wextra',
+ 's_rti_getpc_w',
+ 's_rti_getps_w',
+ '-',
+ 's_rti_getpc',
+ 's_rti_getps');
+
+ group_new(0x14f, 'g_all_wextra',
+ 'g_ifetch_wextra',
+ 'g_srcr_wextra',
+ 'g_dstr_wextra',
+ 'g_dstw_wextra',
+ 'g_dsta_wextra',
+ 'g_op_rts_wextra',
+ 'g_op_jsr_wextra',
+ 'g_op_mtp_wextra',
+ 'g_op_mfp_wextra',
+ 'g_int_wextra',
+ 'g_rti_wextra');
+}
+
+#-------------------------------------------------------------------------------
+
+sub group_new {
+ my $snum = shift @_;
+ my $snam = shift @_;
+
+ die "group_new: bad snum '$snum'" if defined $snum2nam[$snum];
+ die "group_new: bad snam '$snam'" if defined $snam2num{$snam};
+
+ $snum2nam[$snum] = $snam;
+ $snam2num{$snam} = $snum;
+ $dat_all{$snam} = 0;
+ $dat_km{$snam} = 0;
+ $dat_um{$snam} = 0;
+ my $sign = 1.;
+
+ foreach my $val (@_) {
+ if ($val eq '+') { $sign = 1.; next;}
+ if ($val eq '-') { $sign = -1.; next;}
+ die "bad action '$val'" unless defined $snam2num{$val};
+ $dat_all{$snam} += $sign * $dat_all{$val};
+ $dat_km{$snam} += $sign * $dat_km{$val};
+ $dat_um{$snam} += $sign * $dat_um{$val};
+ }
+}
+
+#-------------------------------------------------------------------------------
+
+sub print_help {
+ print "usage: dmscntanal file\n";
+ print " --help this message\n";
+}
dmscntanal
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: tmuconv
===================================================================
--- tmuconv (nonexistent)
+++ tmuconv (revision 38)
@@ -0,0 +1,948 @@
+#!/usr/bin/perl -w
+# $Id: tmuconv 712 2015-11-01 22:53:45Z mueller $
+#
+# Copyright 2008-2015 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2015-11-01 712 1.1.1 BUGFIX: fix '.' handling for br/sob instructions
+# BUGFIX: correct xor (now r,dst, and not src,r)
+# br/sob offsets now octal; assume --t_id if no opts
+# 2015-07-03 697 1.1 adapt to new DM_STAT_(SY|VM); add rhrp vector
+# 2010-10-22 334 1.0.9 adapt to ibus V2 signals: req,we,dip->aval,re,we,rmw
+# 2010-06-26 309 1.0.8 add ibimres.cacc/racc handling
+# 2010-04-26 284 1.0.7 add error check for GetOptions
+# 2009-09-19 240 1.0.6 add more VFETCH addr defs; add 2nd DL11 defs
+# 2009-06-04 223 1.0.5 add IIST and PC11 defs
+# 2009-05-03 212 1.0.4 add defs for mmu par/pdr's and some unibus dev's
+# 2008-12-14 177 1.0.3 add -t_ru; use dp_ireg_we_last; add ibus names
+# 2008-11-30 174 1.0.2 SPUSH and VFETCH tags for em cycles; psw in id lines
+# 2008-04-25 138 1.0.1 show ccc/scc for code 000257/000277 in disassembler
+# 2008-04-19 137 1.0 Initial version
+#
+# Current fields in tmu_ofile:
+# clkcycle:d
+# cpu:o
+# dp.pc:o
+# dp.psw:o
+# dp.ireg:o
+# dp.ireg_we:b
+# dp.ireg_we_last:b
+# dp.dsrc:o
+# dp.ddst:o
+# dp.dtmp:o
+# dp.dres:o
+# dp.gpr_adst:o
+# dp.gpr_mode:o
+# dp.gpr_bytop:b
+# dp.gpr_we:b
+# vm.ibmreq.aval:b
+# vm.ibmreq.re:b
+# vm.ibmreq.we:b
+# vm.ibmreq.rmw:b
+# vm.ibmreq.be0:b
+# vm.ibmreq.be1:b
+# vm.ibmreq.cacc:b
+# vm.ibmreq.racc:b
+# vm.ibmreq.addr:o
+# vm.ibmreq.din:o
+# vm.ibsres.ack:b
+# vm.ibsres.busy:b
+# vm.ibsres.dout:o
+# vm.emmreq.req:b
+# vm.emmreq.we:b
+# vm.emmreq.be:b
+# vm.emmreq.cancel:b
+# vm.emmreq.addr:o
+# vm.emmreq.din:o
+# vm.emsres.ack_r:b
+# vm.emsres.ack_w:b
+# vm.emsres.dout:o
+# co.cpugo:b
+# co.cpususp:b
+# co.suspint:b
+# co.suspext:b
+# sy.chit:b
+#
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+use FileHandle;
+
+use Getopt::Long;
+
+my %opts = ();
+
+GetOptions(\%opts, "help", "dump", "cdump",
+ "t_id", "t_ru", "t_em", "t_ib")
+ or die "bad options";
+
+sub print_help;
+sub do_file;
+sub code2mnemo;
+sub regmod;
+
+my @var_name;
+my @var_type;
+my @var_dec;
+my @var_oct;
+my %name;
+
+my @val_curr_text;
+my @val_curr;
+my @val_last;
+
+my @reg_05 = ("------","------","------","------","------","------", # set 0
+ "------","------","------","------","------","------",); # set 1
+my @reg_sp = ("------","------","------","------"); # ksp,ssp,???,usp
+
+my $ind_dp_pc;
+my $ind_dp_psw;
+my $ind_dp_ireg;
+my $ind_dp_ireg_we;
+my $ind_dp_ireg_we_last;
+my $ind_dp_dres;
+my $ind_dp_gpr_adst;
+my $ind_dp_gpr_mode;
+my $ind_dp_gpr_bytop;
+my $ind_dp_gpr_we;
+
+my $ind_vm_ibmreq_aval;
+my $ind_vm_ibmreq_re;
+my $ind_vm_ibmreq_we;
+my $ind_vm_ibmreq_rmw;
+my $ind_vm_ibmreq_be0;
+my $ind_vm_ibmreq_be1;
+my $ind_vm_ibmreq_cacc;
+my $ind_vm_ibmreq_racc;
+my $ind_vm_ibmreq_addr;
+my $ind_vm_ibmreq_din;
+my $ind_vm_ibsres_ack;
+my $ind_vm_ibsres_busy;
+my $ind_vm_ibsres_dout;
+
+my $ind_vm_emmreq_req;
+my $ind_vm_emmreq_we;
+my $ind_vm_emmreq_be;
+my $ind_vm_emmreq_cancel;
+my $ind_vm_emmreq_addr;
+my $ind_vm_emmreq_din;
+my $ind_vm_emsres_ack_r;
+my $ind_vm_emsres_ack_w;
+my $ind_vm_emsres_dout;
+
+my $ind_sy_chit;
+
+my @pdp11_opcode_tbl = (
+ {code=>0000000, mask=>0000000, name=>"halt", type=>"0arg"},
+ {code=>0000001, mask=>0000000, name=>"wait", type=>"0arg"},
+ {code=>0000002, mask=>0000000, name=>"rti ", type=>"0arg"},
+ {code=>0000003, mask=>0000000, name=>"bpt ", type=>"0arg"},
+ {code=>0000004, mask=>0000000, name=>"iot ", type=>"0arg"},
+ {code=>0000005, mask=>0000000, name=>"reset",type=>"0arg"},
+ {code=>0000006, mask=>0000000, name=>"rtt ", type=>"0arg"},
+ {code=>0000007, mask=>0000000, name=>"!!mfpt", type=>"0arg"},
+ {code=>0000100, mask=>0000077, name=>"jmp ", type=>"1arg"},
+ {code=>0000200, mask=>0000007, name=>"rts ", type=>"1reg"},
+ {code=>0000230, mask=>0000007, name=>"spl ", type=>"spl"},
+ {code=>0000240, mask=>0000017, name=>"cl", type=>"ccop"},
+ {code=>0000260, mask=>0000017, name=>"se", type=>"ccop"},
+ {code=>0000300, mask=>0000077, name=>"swab", type=>"1arg"},
+ {code=>0000400, mask=>0000377, name=>"br ", type=>"br"},
+ {code=>0001000, mask=>0000377, name=>"bne ", type=>"br"},
+ {code=>0001400, mask=>0000377, name=>"beq ", type=>"br"},
+ {code=>0002000, mask=>0000377, name=>"bge ", type=>"br"},
+ {code=>0002400, mask=>0000377, name=>"blt ", type=>"br"},
+ {code=>0003000, mask=>0000377, name=>"bgt ", type=>"br"},
+ {code=>0003400, mask=>0000377, name=>"ble ", type=>"br"},
+ {code=>0004000, mask=>0000777, name=>"jsr ", type=>"rsrc"},
+ {code=>0005000, mask=>0000077, name=>"clr ", type=>"1arg"},
+ {code=>0005100, mask=>0000077, name=>"com ", type=>"1arg"},
+ {code=>0005200, mask=>0000077, name=>"inc ", type=>"1arg"},
+ {code=>0005300, mask=>0000077, name=>"dec ", type=>"1arg"},
+ {code=>0005400, mask=>0000077, name=>"neg ", type=>"1arg"},
+ {code=>0005500, mask=>0000077, name=>"adc ", type=>"1arg"},
+ {code=>0005600, mask=>0000077, name=>"sbc ", type=>"1arg"},
+ {code=>0005700, mask=>0000077, name=>"tst ", type=>"1arg"},
+ {code=>0006000, mask=>0000077, name=>"ror ", type=>"1arg"},
+ {code=>0006100, mask=>0000077, name=>"rol ", type=>"1arg"},
+ {code=>0006200, mask=>0000077, name=>"asr ", type=>"1arg"},
+ {code=>0006300, mask=>0000077, name=>"asl ", type=>"1arg"},
+ {code=>0006400, mask=>0000077, name=>"mark", type=>"mark"},
+ {code=>0006500, mask=>0000077, name=>"mfpi", type=>"1arg"},
+ {code=>0006600, mask=>0000077, name=>"mtpi", type=>"1arg"},
+ {code=>0006700, mask=>0000077, name=>"sxt ", type=>"1arg"},
+ {code=>0007000, mask=>0000077, name=>"!!csm", type=>"1arg"},
+ {code=>0007200, mask=>0000077, name=>"!!tstset",type=>"1arg"},
+ {code=>0007300, mask=>0000077, name=>"!!wrtlck",type=>"1arg"},
+ {code=>0010000, mask=>0007777, name=>"mov ", type=>"2arg"},
+ {code=>0020000, mask=>0007777, name=>"cmp ", type=>"2arg"},
+ {code=>0030000, mask=>0007777, name=>"bit ", type=>"2arg"},
+ {code=>0040000, mask=>0007777, name=>"bic ", type=>"2arg"},
+ {code=>0050000, mask=>0007777, name=>"bis ", type=>"2arg"},
+ {code=>0060000, mask=>0007777, name=>"add ", type=>"2arg"},
+ {code=>0070000, mask=>0000777, name=>"mul ", type=>"rdst"},
+ {code=>0071000, mask=>0000777, name=>"div ", type=>"rdst"},
+ {code=>0072000, mask=>0000777, name=>"ash ", type=>"rdst"},
+ {code=>0073000, mask=>0000777, name=>"ashc", type=>"rdst"},
+ {code=>0074000, mask=>0000777, name=>"xor ", type=>"rsrc"},
+ {code=>0077000, mask=>0000777, name=>"sob ", type=>"sob"},
+ {code=>0100000, mask=>0000377, name=>"bpl ", type=>"br"},
+ {code=>0100400, mask=>0000377, name=>"bmi ", type=>"br"},
+ {code=>0101000, mask=>0000377, name=>"bhi ", type=>"br"},
+ {code=>0101400, mask=>0000377, name=>"blos", type=>"br"},
+ {code=>0102000, mask=>0000377, name=>"bvc ", type=>"br"},
+ {code=>0102400, mask=>0000377, name=>"bvs ", type=>"br"},
+ {code=>0103000, mask=>0000377, name=>"bcc ", type=>"br"},
+ {code=>0103400, mask=>0000377, name=>"bcs ", type=>"br"},
+ {code=>0104000, mask=>0000377, name=>"emt ", type=>"trap"},
+ {code=>0104400, mask=>0000377, name=>"trap", type=>"trap"},
+ {code=>0105000, mask=>0000077, name=>"clrb", type=>"1arg"},
+ {code=>0105100, mask=>0000077, name=>"comb", type=>"1arg"},
+ {code=>0105200, mask=>0000077, name=>"incb", type=>"1arg"},
+ {code=>0105300, mask=>0000077, name=>"decb", type=>"1arg"},
+ {code=>0105400, mask=>0000077, name=>"negb", type=>"1arg"},
+ {code=>0105500, mask=>0000077, name=>"adcb", type=>"1arg"},
+ {code=>0105600, mask=>0000077, name=>"sbcb", type=>"1arg"},
+ {code=>0105700, mask=>0000077, name=>"tstb", type=>"1arg"},
+ {code=>0106000, mask=>0000077, name=>"rorb", type=>"1arg"},
+ {code=>0106100, mask=>0000077, name=>"rolb", type=>"1arg"},
+ {code=>0106200, mask=>0000077, name=>"asrb", type=>"1arg"},
+ {code=>0106300, mask=>0000077, name=>"aslb", type=>"1arg"},
+ {code=>0106400, mask=>0000077, name=>"!!mtps", type=>"1arg"},
+ {code=>0106500, mask=>0000077, name=>"mfpd", type=>"1arg"},
+ {code=>0106600, mask=>0000077, name=>"mtpd", type=>"1arg"},
+ {code=>0106700, mask=>0000077, name=>"!!mfps", type=>"1arg"},
+ {code=>0110000, mask=>0007777, name=>"movb", type=>"2arg"},
+ {code=>0120000, mask=>0007777, name=>"cmpb", type=>"2arg"},
+ {code=>0130000, mask=>0007777, name=>"bitb", type=>"2arg"},
+ {code=>0140000, mask=>0007777, name=>"bicb", type=>"2arg"},
+ {code=>0150000, mask=>0007777, name=>"bisb", type=>"2arg"},
+ {code=>0160000, mask=>0007777, name=>"sub ", type=>"2arg"},
+ {code=>0170000, mask=>0000000, name=>"!!cfcc", type=>"0arg"},
+ {code=>0170001, mask=>0000000, name=>"!!setf", type=>"0arg"},
+ {code=>0170011, mask=>0000000, name=>"!!setd", type=>"0arg"},
+ {code=>0170002, mask=>0000000, name=>"!!seti", type=>"0arg"},
+ {code=>0170012, mask=>0000000, name=>"!!setl", type=>"0arg"},
+ {code=>0170100, mask=>0000077, name=>"!!ldfps",type=>"1fpp"},
+ {code=>0170200, mask=>0000077, name=>"!!stfps",type=>"1fpp"},
+ {code=>0170300, mask=>0000077, name=>"!!stst", type=>"1fpp"},
+ {code=>0170400, mask=>0000077, name=>"!!clrf", type=>"1fpp"},
+ {code=>0170500, mask=>0000077, name=>"!!tstf", type=>"1fpp"},
+ {code=>0170600, mask=>0000077, name=>"!!absf", type=>"1fpp"},
+ {code=>0170700, mask=>0000077, name=>"!!negf", type=>"1fpp"},
+ {code=>0171000, mask=>0000377, name=>"!!mulf", type=>"rfpp"},
+ {code=>0171400, mask=>0000377, name=>"!!modf", type=>"rfpp"},
+ {code=>0172000, mask=>0000377, name=>"!!addf", type=>"rfpp"},
+ {code=>0172400, mask=>0000377, name=>"!!ldf", type=>"rfpp"},
+ {code=>0173000, mask=>0000377, name=>"!!subf", type=>"rfpp"},
+ {code=>0173400, mask=>0000377, name=>"!!cmpf", type=>"rfpp"},
+ {code=>0174000, mask=>0000377, name=>"!!stf", type=>"rfpp"},
+ {code=>0174400, mask=>0000377, name=>"!!divf", type=>"rfpp"},
+ {code=>0175000, mask=>0000377, name=>"!!stexp",type=>"rfpp"},
+ {code=>0175400, mask=>0000377, name=>"!!stcif",type=>"rfpp"},
+ {code=>0176000, mask=>0000377, name=>"!!stcfd",type=>"rfpp"},
+ {code=>0176400, mask=>0000377, name=>"!!ldexp",type=>"rfpp"},
+ {code=>0177000, mask=>0000377, name=>"!!ldcif",type=>"rfpp"},
+ {code=>0177400, mask=>0000377, name=>"!!ldcdf",type=>"rfpp"}
+ );
+
+my %pdp11_regs = ( # use simh naming convention
+ 177776=> "psw",
+ 177774=> "stklim",
+ 177772=> "pirq",
+ 177770=> "mbrk",
+ 177766=> "cpuerr",
+ 177764=> "sysid",
+ 177600=> "uipdr0",
+ 177602=> "uipdr1",
+ 177604=> "uipdr2",
+ 177606=> "uipdr3",
+ 177610=> "uipdr4",
+ 177612=> "uipdr5",
+ 177614=> "uipdr6",
+ 177616=> "uipdr7",
+ 177620=> "udpdr0",
+ 177622=> "udpdr1",
+ 177624=> "udpdr2",
+ 177626=> "udpdr3",
+ 177630=> "udpdr4",
+ 177632=> "udpdr5",
+ 177634=> "udpdr6",
+ 177636=> "udpdr7",
+ 177640=> "uipar0",
+ 177642=> "uipar1",
+ 177644=> "uipar2",
+ 177646=> "uipar3",
+ 177650=> "uipar4",
+ 177652=> "uipar5",
+ 177654=> "uipar6",
+ 177656=> "uipar7",
+ 177660=> "udpar0",
+ 177662=> "udpar1",
+ 177664=> "udpar2",
+ 177666=> "udpar3",
+ 177670=> "udpar4",
+ 177672=> "udpar5",
+ 177674=> "udpar6",
+ 177676=> "udpar7",
+ 177576=> "mmr2",
+ 177574=> "mmr1",
+ 177572=> "mmr0",
+ 177570=> "sdreg", # not a simh name !!
+ 177560=> "tia.csr",
+ 177562=> "tia.buf",
+ 177564=> "toa.csr",
+ 177566=> "toa.buf",
+ 177550=> "pr.csr",
+ 177552=> "pr.buf",
+ 177554=> "pp.csr",
+ 177556=> "pp.buf",
+ 177546=> "kl.csr",
+ 177514=> "lp.csr",
+ 177516=> "lp.buf",
+ 177500=> "ii.acr",
+ 177502=> "ii.adr",
+ 177400=> "rk.ds ",
+ 177402=> "rk.er ",
+ 177404=> "rk.cs ",
+ 177406=> "rk.wc ",
+ 177410=> "rk.ba ",
+ 177412=> "rk.da ",
+ 177414=> "rk.mr ",
+ 177416=> "rk.db ",
+ 177060=> "xor.cs", # XOR Tester
+ 176700=> "rp.cs1",
+ 176702=> "rp.wc ",
+ 176704=> "rp.ba ",
+ 176706=> "rp.da ",
+ 176710=> "rp.cs2",
+ 176712=> "rp.ds ",
+ 176714=> "rp.er1",
+ 176716=> "rp.as ",
+ 176720=> "rp.la ",
+ 176722=> "rp.db ",
+ 176724=> "rp.mr1",
+ 176726=> "rp.dt ",
+ 176730=> "rp.sn ",
+ 176732=> "rp.of ",
+ 176734=> "rp.dc ",
+ 176736=> "rp.m13",
+ 176740=> "rp.m14",
+ 176742=> "rp.m15",
+ 176744=> "rp.ec1",
+ 176746=> "rp.ec2",
+ 176750=> "rp.bae",
+ 176752=> "rp.cs3",
+ 176500=> "tib.cs",
+ 176502=> "tib.bu",
+ 176504=> "tob.cs",
+ 176506=> "tob.bu",
+ 174400=> "rl.cs ",
+ 174402=> "rl.ba ",
+ 174404=> "rl.da ",
+ 174406=> "rl.mp ",
+ 172540=> "kp.csr",
+ 172542=> "kp.buf",
+ 172544=> "kp.cnt",
+ 172520=> "tm.sr",
+ 172522=> "tm.cr",
+ 172524=> "tm.bc",
+ 172526=> "tm.ba",
+ 172530=> "tm.db",
+ 172532=> "tm.rl",
+ 172516=> "mmr3",
+ 172200=> "sipdr0",
+ 172202=> "sipdr1",
+ 172204=> "sipdr2",
+ 172206=> "sipdr3",
+ 172210=> "sipdr4",
+ 172212=> "sipdr5",
+ 172214=> "sipdr6",
+ 172216=> "sipdr7",
+ 172220=> "sdpdr0",
+ 172222=> "sdpdr1",
+ 172224=> "sdpdr2",
+ 172226=> "sdpdr3",
+ 172230=> "sdpdr4",
+ 172232=> "sdpdr5",
+ 172234=> "sdpdr6",
+ 172236=> "sdpdr7",
+ 172240=> "sipar0",
+ 172242=> "sipar1",
+ 172244=> "sipar2",
+ 172246=> "sipar3",
+ 172250=> "sipar4",
+ 172252=> "sipar5",
+ 172254=> "sipar6",
+ 172256=> "sipar7",
+ 172260=> "sdpar0",
+ 172262=> "sdpar1",
+ 172264=> "sdpar2",
+ 172266=> "sdpar3",
+ 172270=> "sdpar4",
+ 172272=> "sdpar5",
+ 172274=> "sdpar6",
+ 172276=> "sdpar7",
+ 172300=> "kipdr0",
+ 172302=> "kipdr1",
+ 172304=> "kipdr2",
+ 172306=> "kipdr3",
+ 172310=> "kipdr4",
+ 172312=> "kipdr5",
+ 172314=> "kipdr6",
+ 172316=> "kipdr7",
+ 172320=> "kdpdr0",
+ 172322=> "kdpdr1",
+ 172324=> "kdpdr2",
+ 172326=> "kdpdr3",
+ 172330=> "kdpdr4",
+ 172332=> "kdpdr5",
+ 172334=> "kdpdr6",
+ 172336=> "kdpdr7",
+ 172340=> "kipar0",
+ 172342=> "kipar1",
+ 172344=> "kipar2",
+ 172346=> "kipar3",
+ 172350=> "kipar4",
+ 172352=> "kipar5",
+ 172354=> "kipar6",
+ 172356=> "kipar7",
+ 172360=> "kdpar0",
+ 172362=> "kdpar1",
+ 172364=> "kdpar2",
+ 172366=> "kdpar3",
+ 172370=> "kdpar4",
+ 172372=> "kdpar5",
+ 172374=> "kdpar6",
+ 172376=> "kdpar7",
+ 160100=> "dz.csr",
+ 160102=> "dz.mp2",
+ 160104=> "dz.tcr",
+ 160106=> "dz.mp6"
+);
+
+autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
+
+if (exists $opts{help}) {
+ print_help;
+ exit 0;
+}
+
+my $nopts = 0; # count options
+$nopts += 1 if $opts{dump};
+$nopts += 1 if $opts{cdump};
+$nopts += 1 if $opts{t_id};
+$nopts += 1 if $opts{t_ru};
+$nopts += 1 if $opts{t_em};
+$nopts += 1 if $opts{t_ib};
+
+$opts{t_id} = 1 if $nopts == 0; # if no opts, assume t_id
+
+foreach my $file (@ARGV) {
+ do_file($file);
+}
+
+
+#-------------------------------------------------------------------------------
+
+sub do_file {
+ my ($file) = @_;
+
+ open IFILE,"<$file" or die "failed to open $file";
+
+ my $idec_cyc = 0;
+ my $change_cyc = 0;
+ my $emreq_cyc = 0;
+ my $emreq_str = "";
+ my $ibreq_cyc = 0;
+ my $ibreq_typ = "";
+ my $ibreq_str = "";
+ my $ibreq_nam = "";
+
+ my $emcurr_we = 0; # curr em write enable (or undef)
+ my $emcurr_addr = undef; # curr em address
+ my $emlast_we = 0; # prev em write enable (or undef)
+ my $emlast_addr = undef; # prev em address
+
+ while () {
+ chomp;
+ if (/^#\s+/) {
+ @var_name = ();
+ @var_type = ();
+ my $dsc_str = $';
+ my @dsc_list = split /\s+/,$dsc_str;
+ foreach my $dsc (@dsc_list) {
+ if ($dsc =~ /^(.*):([bdo])$/) {
+ my $ind = scalar(@var_name);
+ $name{$1} = {ind=>$ind,
+ typ=>$2};
+ push @var_name, $1;
+ push @var_type, $2;
+ push @var_dec, $ind if $2 eq "d";
+ push @var_oct, $ind if $2 eq "o";
+ } else {
+ print "tmuconv-E: bad descriptor $dsc\n";
+ }
+ }
+
+ $ind_dp_pc = $name{'dp.pc'}->{ind};
+ $ind_dp_psw = $name{'dp.psw'}->{ind};
+ $ind_dp_ireg = $name{'dp.ireg'}->{ind};
+ $ind_dp_ireg_we = $name{'dp.ireg_we'}->{ind};
+ $ind_dp_ireg_we_last = $name{'dp.ireg_we_last'}->{ind};
+ $ind_dp_dres = $name{'dp.dres'}->{ind};
+ $ind_dp_gpr_adst = $name{'dp.gpr_adst'}->{ind};
+ $ind_dp_gpr_mode = $name{'dp.gpr_mode'}->{ind};
+ $ind_dp_gpr_bytop = $name{'dp.gpr_bytop'}->{ind};
+ $ind_dp_gpr_we = $name{'dp.gpr_we'}->{ind};
+
+ $ind_vm_ibmreq_aval = $name{'vm.ibmreq.aval'}->{ind};
+ $ind_vm_ibmreq_re = $name{'vm.ibmreq.re'}->{ind};
+ $ind_vm_ibmreq_we = $name{'vm.ibmreq.we'}->{ind};
+ $ind_vm_ibmreq_rmw = $name{'vm.ibmreq.rmw'}->{ind};
+ $ind_vm_ibmreq_be0 = $name{'vm.ibmreq.be0'}->{ind};
+ $ind_vm_ibmreq_be1 = $name{'vm.ibmreq.be1'}->{ind};
+ $ind_vm_ibmreq_cacc = $name{'vm.ibmreq.cacc'}->{ind};
+ $ind_vm_ibmreq_racc = $name{'vm.ibmreq.racc'}->{ind};
+ $ind_vm_ibmreq_addr = $name{'vm.ibmreq.addr'}->{ind};
+ $ind_vm_ibmreq_din = $name{'vm.ibmreq.din'}->{ind};
+ $ind_vm_ibsres_ack = $name{'vm.ibsres.ack'}->{ind};
+ $ind_vm_ibsres_busy = $name{'vm.ibsres.busy'}->{ind};
+ $ind_vm_ibsres_dout = $name{'vm.ibsres.dout'}->{ind};
+
+ $ind_vm_emmreq_req = $name{'vm.emmreq.req'}->{ind};
+ $ind_vm_emmreq_we = $name{'vm.emmreq.we'}->{ind};
+ $ind_vm_emmreq_be = $name{'vm.emmreq.be'}->{ind};
+ $ind_vm_emmreq_cancel = $name{'vm.emmreq.cancel'}->{ind};
+ $ind_vm_emmreq_addr = $name{'vm.emmreq.addr'}->{ind};
+ $ind_vm_emmreq_din = $name{'vm.emmreq.din'}->{ind};
+ $ind_vm_emsres_ack_r = $name{'vm.emsres.ack_r'}->{ind};
+ $ind_vm_emsres_ack_w = $name{'vm.emsres.ack_w'}->{ind};
+ $ind_vm_emsres_dout = $name{'vm.emsres.dout'}->{ind};
+
+ $ind_sy_chit = $name{'sy.chit'}->{ind};
+
+ } else {
+ @val_last = @val_curr;
+ my $notfirst = scalar(@val_last) > 0;
+
+ $_ =~ s/^\s*//;
+ $_ =~ s/\s*$//;
+ @val_curr = split /\s+/,$_;
+ if (scalar(@val_curr) != scalar(@var_name)) {
+ printf "tmuconv-E: value list length mismatch, seen %d, expected %d\n",
+ scalar(@val_curr), scalar(@var_name);
+ for (my $i=0; $i>11 & 01;
+ $ru_str = sprintf "%o %o%o %6.6o", $bytop, $rset, $adst, $dres;
+ $ru_str .= " ";
+ if ($adst eq "7") {
+ $ru_str .= "pc";
+ } elsif ($adst eq "6") {
+ $reg_sp[$mode] = sprintf "%6.6o",$dres;
+ $ru_str .= $reg_sp[0];
+ $ru_str .= ($mode == 0) ? "*" : " ";
+ $ru_str .= $reg_sp[1];
+ $ru_str .= ($mode == 1) ? "*" : " ";
+ $ru_str .= $reg_sp[3];
+ $ru_str .= ($mode == 3) ? "*" : " ";
+ $ru_str .= " ksp" if $mode eq "0";
+ $ru_str .= " ssp" if $mode eq "1";
+ $ru_str .= " usp" if $mode eq "3";
+ } else {
+ my $rbase = ($rset==0) ? 0 : 6;
+ $reg_05[$rbase+$adst] = sprintf "%6.6o",$dres;
+ for (my $i=0; $i<6; $i++) {
+ $ru_str .= $reg_05[$rbase+$i];
+ $ru_str .= ($adst==$i) ? "*" : " ";
+ }
+ $ru_str .= sprintf " r%o%o", $rset, $adst;
+ }
+ }
+ }
+#
+# handle t_em
+# uses cycles with vm_emmreq_req = '1'
+# vm_emsres_ack_r = '1'
+# vm_emsres_ack_w = '1'
+# vm_emsreq_cancel = '1'
+#
+ if (exists $opts{t_em}) {
+ if ($val_curr[$ind_vm_emmreq_req]) {
+ $emreq_cyc = $cyc_curr;
+ $emreq_str = sprintf "%s %s %8.8o",
+ ($val_curr[$ind_vm_emmreq_we] ? "w" : "r"),
+ $val_curr[$ind_vm_emmreq_be],
+ $val_curr[$ind_vm_emmreq_addr];
+ $emcurr_we = $val_curr[$ind_vm_emmreq_we];
+ $emcurr_addr = $val_curr[$ind_vm_emmreq_addr];
+ if ($emcurr_we) {
+ $emreq_str .= sprintf " %6.6o", $val_curr[$ind_vm_emmreq_din];
+ } else {
+ $emreq_str .= " " x 7;
+ }
+ }
+ if ($val_curr[$ind_vm_emsres_ack_r] ||
+ $val_curr[$ind_vm_emsres_ack_w] ||
+ $val_curr[$ind_vm_emmreq_cancel]) {
+ $emres_str = sprintf "%s%s%s%s",
+ $val_curr[$ind_vm_emmreq_cancel],
+ $val_curr[$ind_vm_emsres_ack_r],
+ $val_curr[$ind_vm_emsres_ack_w],
+ $val_curr[$ind_sy_chit];
+ if ($val_curr[$ind_vm_emmreq_cancel]) {
+ $emreq_str .= " cancel";
+ $emcurr_we = undef;
+ } else {
+ if ($val_curr[$ind_vm_emsres_ack_r]) {
+ $emreq_str .= sprintf " %6.6o", $val_curr[$ind_vm_emsres_dout];
+ } else {
+ $emreq_str .= " " x 7;
+ }
+ if (defined $emlast_we && $emcurr_we == $emlast_we) {
+ if ($emcurr_we && $emcurr_addr == $emlast_addr-2) {
+ $emtyp_str = "SPUSH";
+ } elsif ((not $emcurr_we) && $emcurr_addr == $emlast_addr+2 &&
+ $emcurr_addr < 0400 && ($emcurr_addr % 04) == 02) {
+ $emtyp_str = "VFETCH";
+ $emtyp_str .= " 004 ill.inst" if ($emlast_addr == 0004);
+ $emtyp_str .= " 010 res.inst" if ($emlast_addr == 0010);
+ $emtyp_str .= " 014 BPT" if ($emlast_addr == 0014);
+ $emtyp_str .= " 020 IOT" if ($emlast_addr == 0020);
+ $emtyp_str .= " 030 EMT" if ($emlast_addr == 0030);
+ $emtyp_str .= " 034 TRAP" if ($emlast_addr == 0034);
+ $emtyp_str .= " 060 DL11-TTI" if ($emlast_addr == 0060);
+ $emtyp_str .= " 064 DL11-TTO" if ($emlast_addr == 0064);
+ $emtyp_str .= " 070 PC11-PTR" if ($emlast_addr == 0070);
+ $emtyp_str .= " 074 PC11-PTP" if ($emlast_addr == 0074);
+ $emtyp_str .= " 100 KW11-L" if ($emlast_addr == 0100);
+ $emtyp_str .= " 104 KW11-P" if ($emlast_addr == 0104);
+ $emtyp_str .= " 160 RL11" if ($emlast_addr == 0160);
+ $emtyp_str .= " 200 LP11" if ($emlast_addr == 0200);
+ $emtyp_str .= " 220 RK11" if ($emlast_addr == 0220);
+ $emtyp_str .= " 224 TM11" if ($emlast_addr == 0224);
+ $emtyp_str .= " 240 PIRQ" if ($emlast_addr == 0240);
+ $emtyp_str .= " 244 FPP exp" if ($emlast_addr == 0244);
+ $emtyp_str .= " 250 MMU trap" if ($emlast_addr == 0250);
+ $emtyp_str .= " 254 RHRP" if ($emlast_addr == 0254);
+ $emtyp_str .= " 260 IIST" if ($emlast_addr == 0260);
+ $emtyp_str .= " 300 DL11-2-TTI" if ($emlast_addr == 0300);
+ $emtyp_str .= " 304 DL11-2-TTO" if ($emlast_addr == 0304);
+ }
+ }
+ }
+ $emlast_we = $emcurr_we;
+ $emlast_addr = $emcurr_addr;
+ }
+ }
+#
+# handle t_ib
+# uses cycles with sy_ibmreq_re = '1' or sy_ibmreq_we = '1'
+# sy_ibsres_ack = '1'
+# vm_ibsres_busy '1' -> '0' transition
+#
+ if (exists $opts{t_ib}) {
+ if ($val_curr[$ind_vm_ibmreq_re] || $val_curr[$ind_vm_ibmreq_we]) {
+ my $addr_str = sprintf "%6.6o", $val_curr[$ind_vm_ibmreq_addr];
+ $ibreq_cyc = $cyc_curr;
+ $ibreq_typ = sprintf "%s%s",
+ ($val_curr[$ind_vm_ibmreq_cacc] ? "c" : "-"),
+ ($val_curr[$ind_vm_ibmreq_racc] ? "r" : "-");
+ $ibreq_str = sprintf "%s%s%s%s %s",
+ ($val_curr[$ind_vm_ibmreq_we] ? "w" : "r"),
+ ($val_curr[$ind_vm_ibmreq_rmw] ? "m" : " "),
+ $val_curr[$ind_vm_ibmreq_be1],
+ $val_curr[$ind_vm_ibmreq_be0],
+ $addr_str;
+ $ibreq_we = $val_curr[$ind_vm_ibmreq_we];
+ $ibreq_act = 1;
+ if ($ibreq_we) {
+ $ibreq_str .= sprintf " %6.6o", $val_curr[$ind_vm_ibmreq_din];
+ } else {
+ $ibreq_str .= " " x 7;
+ }
+ $ibreq_nam = $pdp11_regs{$addr_str};
+ $ibreq_nam = "" if not defined $ibreq_nam;
+ }
+
+ if ($val_curr[$ind_vm_ibsres_ack]) {
+ $ibreq_act = 0;
+ $ibres_str .= sprintf " %s", $val_curr[$ind_vm_ibsres_ack];
+ if (not $ibreq_we) {
+ $ibreq_str .= sprintf " %6.6o", $val_curr[$ind_vm_ibsres_dout];
+ } else {
+ $ibreq_str .= " " x 7;
+ }
+ }
+
+ if ($ibreq_act && $val_curr[$ind_vm_ibsres_busy]==0) {
+ $ibres_str .= "no ACK, no BUSY";
+ $ibreq_act = 0;
+ }
+ }
+
+ print "$cyc_str id $id_str\n" if $id_str;
+ print "$cyc_str ru $ru_str\n" if $ru_str;
+ if ($emres_str) {
+ printf "$cyc_str em $emreq_str $emres_str (%d) $emtyp_str\n",
+ $cyc_curr-$emreq_cyc;
+ }
+ if ($ibres_str) {
+ printf "$cyc_str ib %s $ibreq_str $ibres_str (%d) $ibreq_nam\n",
+ $ibreq_typ, $cyc_curr-$ibreq_cyc;
+ }
+ }
+ }
+
+ close IFILE;
+}
+
+#-------------------------------------------------------------------------------
+
+sub code2mnemo {
+ my ($code) = @_;
+
+ foreach my $ele (@pdp11_opcode_tbl) {
+ if (($code & (~($ele->{mask})) ) == $ele->{code}) {
+ my $name = $ele->{name};
+ my $type = $ele->{type};
+ my $str = $name;
+ if ($type eq "0arg") {
+ return $name;
+
+ } elsif ($type eq "1arg" or $type eq "1fpp") {
+ my $dst = $code & 077;
+ my $dst_str = regmod($dst);
+ return "$name $dst_str";
+
+ } elsif ($type eq "2arg") {
+ my $src = ($code>>6) & 077;
+ my $dst = $code & 077;
+ my $src_str = regmod($src);
+ my $dst_str = regmod($dst);
+ return "$name $src_str,$dst_str";
+
+ } elsif ($type eq "rdst") {
+ my $reg = ($code>>6) & 07;
+ my $src = $code & 077;
+ my $src_str = regmod($src);
+ return "$name $src_str,r$reg";
+
+ } elsif ($type eq "1reg") {
+ my $reg = $code & 07;
+ my $reg_str = "r$reg";
+ $reg_str = "sp" if $reg == 6;
+ $reg_str = "pc" if $reg == 7;
+ return "$name $reg_str";
+
+ } elsif ($type eq "br") {
+ # Note: in MACRO-11 syntax . refers to the address of the instruction
+ # the opcode has offset relative to PC after instruction fetch
+ # so 000776 --> br .-2
+ # 000777 --> br .
+ # 000400 --> br .+2
+ #
+ my $off = $code & 0177;
+ my $sign = "?";
+ if ($code & 0200) { # negative offsets
+ $sign = "-";
+ $off = ((~$off) & 0177)+1;
+ $off = $off - 1; # refer to address of instruction
+ } else { # positive offsets
+ $sign = "+";
+ $off = $off + 1; # refer to address of instruction
+ }
+ return sprintf "$name .%s%o", $sign, abs(2*$off);
+
+ } elsif ($type eq "sob") {
+ # Note: like in br type instructions, asm syntax and opcode differ by one
+ my $reg = ($code>>6) & 07;
+ my $off = $code & 077;
+ return sprintf "$name r%d,.-%o", $reg, 2*($off-1);
+
+ } elsif ($type eq "trap") {
+ my $off = $code & 0377;
+ return sprintf "$name %3.3o", $off;
+
+ } elsif ($type eq "spl") {
+ my $off = $code & 07;
+ return sprintf "$name %d", $off;
+
+ } elsif ($type eq "ccop") {
+ my $cc = $code & 017;
+ return "nop" if ($cc == 0);
+ return "ccc" if ($code == 0257);
+ return "scc" if ($code == 0277);
+ my $str = "";
+ my $del = "";
+ if ($code & 010) { $str .= $del . $name . "n", $del = "+" }
+ if ($code & 004) { $str .= $del . $name . "z", $del = "+" }
+ if ($code & 002) { $str .= $del . $name . "v", $del = "+" }
+ if ($code & 001) { $str .= $del . $name . "c", $del = "+" }
+ return $str;
+
+ } elsif ($type eq "rsrc") {
+ my $reg = ($code>>6) & 07;
+ my $dst = $code & 077;
+ my $dst_str = regmod($dst);
+ return "$name r$reg,$dst_str";
+
+ } elsif ($type eq "mark") {
+ my $off = $code & 077;
+ return sprintf "$name %3.3o", $off;
+
+ } elsif ($type eq "rfpp") {
+ my $reg = ($code>>6) & 03;
+ my $dst = $code & 077;
+ my $dst_str = regmod($dst,"f");
+ return "$name f$reg,$dst_str";
+
+ } else {
+ return "?type?";
+ }
+ }
+ }
+ return "=inval=";
+}
+
+#-------------------------------------------------------------------------------
+sub regmod {
+ my ($regmod,$pref) = @_;
+ my $mod = ($regmod>>3) & 07;
+ my $reg = $regmod & 07;
+
+ $pref = "r" if not defined $pref or $reg>5;
+
+ my $reg_str = "r$reg";
+ $reg_str = "sp" if $reg == 6;
+ $reg_str = "pc" if $reg == 7;
+
+ if ($mod == 0) { # mode 0: Rx { Fx for float }
+ $reg_str = "f$reg" if defined $pref && $pref eq "f" && $reg<=5;
+ return $reg_str;
+ } elsif ($mod == 1) { # mode 1: (Rx)
+ return "($reg_str)";
+ } elsif ($mod == 2 || $mod == 3) { # mode 2/3: (Rx)+ @(Rx)+
+ my $ind = ($mod == 3) ? "@" : "";
+ if ($reg != 7) { # if reg != pc
+ return "$ind($reg_str)+";
+ } else { # if reg == pc
+ my $str = sprintf "$ind#nnn"; # 27 -> #nnn; 37 -> @#nnn
+ return $str;
+ }
+ } elsif ($mod == 4 || $mod == 5) { # mode 4/5: -(Rx) @-(Rx)
+ my $ind = ($mod == 5) ? "@" : "";
+ return "$ind-($reg_str)";
+ } elsif ($mod == 6 || $mod == 7) { # mode 6/7: nn(Rx) @nn(Rx)
+ my $ind = ($mod == 7) ? "@" : "";
+ return "${ind}nnn($reg_str)";
+ }
+}
+
+#-------------------------------------------------------------------------------
+
+sub print_help {
+ print "usage: tmuconf file\n";
+ print " --help this message\n";
+ print " --dump dump all information\n";
+ print " --cdump dump only changes relative to prev cycle\n";
+ print " --t_id trace instruction decodes\n";
+ print " --t_ru trace register updates\n";
+ print " --t_em trace em transactions\n";
+ print " --t_ib trace ib transactions\n";
+}
tmuconv
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: asm-11
===================================================================
--- asm-11 (nonexistent)
+++ asm-11 (revision 38)
@@ -0,0 +1,2488 @@
+#!/usr/bin/perl -w
+# $Id: asm-11 712 2015-11-01 22:53:45Z mueller $
+#
+# Copyright 2013-2015 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2015-11-01 712 1.0.4 BUGFIX: fix '.' handling in instructions
+# 2014-07-26 575 1.0.3 add 'call' and 'return' to pst (as in macro-11)
+# 2013-04-07 503 1.0.2 list dot for .even,.dot,.blkb,.blkw
+# 2013-04-01 502 1.0.1 BUGFIX: -2(r0),@-2(r0) was broken, parser fixed
+# add -lsm (lsmem format) output; add implicit .word
+# 2013-03-29 501 1.0 Initial version
+# 2013-03-22 498 0.5 Second draft (functional, but limited...)
+# 2013-03-07 496 0.1 First draft
+#
+
+use 5.10.0; # require Perl 5.10 or higher
+use strict; # require strict checking
+use FileHandle;
+
+use Getopt::Long;
+
+use constant TMASK_STRING => 0x0001;
+use constant TMASK_STRINGEXP => 0x0002;
+
+my %opts = ();
+
+GetOptions(\%opts, "help",
+ "tpass1", "tpass2",
+ "dsym1", "dsym2",
+ "ttoken", "tparse", "temit", "tout",
+ "I=s@",
+ "lst", "olst=s",
+ "lda", "olda=s",
+ "cof", "ocof=s",
+ "lsm", "olsm=s"
+ )
+ or exit 1;
+
+unshift @{$opts{I}}, "."; # ./ is first in include path
+push @{$opts{I}}, "$ENV{RETROBASE}/tools/asm-11" if defined $ENV{RETROBASE};
+
+sub create_fname;
+sub read_file;
+sub parse_line;
+sub walign;
+sub add_err;
+sub prt_err;
+sub setdot;
+sub incdot;
+sub getdot;
+sub setsym;
+sub getsym;
+sub lst_checkmdef;
+sub eval_exp;
+sub check_llbl;
+sub check_reg;
+sub check_token;
+sub pushback_token;
+sub get_token;
+sub get_token1;
+sub to_rad50;
+sub pass2;
+sub pass2_out;
+sub pass2_lst_beg;
+sub pass2_lst_end;
+sub pass2_lst_line;
+sub out_w;
+sub out_wop;
+sub out_b;
+sub out_opcode;
+sub out_opcode_n;
+sub out_opcode_o;
+sub out_opdata;
+sub emitw;
+sub emitb;
+sub write_lda;
+sub write_cof;
+sub write_lsm;
+sub dump_rl;
+sub dump_sym;
+sub prt76o;
+sub prt43o;
+sub save66o;
+sub savestr;
+sub savestr1;
+sub print_help;
+
+# Permanant symbol table
+my %pst = (
+# directives
+ '.include' => {typ=>'dir'}, #
+ '.word' => {typ=>'dir'}, #
+ '.byte' => {typ=>'dir'}, #
+ '.blkw' => {typ=>'dir'}, #
+ '.blkb' => {typ=>'dir'}, #
+ '.ascii' => {typ=>'dir'}, #
+ '.asciz' => {typ=>'dir'}, #
+ '.even' => {typ=>'dir'}, #
+ '.odd' => {typ=>'dir'}, #
+ '.asect' => {typ=>'dir'}, #
+ '.end' => {typ=>'dir'}, #
+#register defs
+ 'r0' => {typ=>'reg', val=>0},
+ 'r1' => {typ=>'reg', val=>1},
+ 'r2' => {typ=>'reg', val=>2},
+ 'r3' => {typ=>'reg', val=>3},
+ 'r4' => {typ=>'reg', val=>4},
+ 'r5' => {typ=>'reg', val=>5},
+ 'sp' => {typ=>'reg', val=>6},
+ 'pc' => {typ=>'reg', val=>7},
+#opcodes
+ 'halt' => {typ=>'op', val=>0000000, fmt=>'-' },
+ 'wait' => {typ=>'op', val=>0000001, fmt=>'-' },
+ 'rti' => {typ=>'op', val=>0000002, fmt=>'-' },
+ 'bpt' => {typ=>'op', val=>0000003, fmt=>'-' },
+ 'iot' => {typ=>'op', val=>0000004, fmt=>'-' },
+ 'reset' => {typ=>'op', val=>0000005, fmt=>'-' },
+ 'rtt' => {typ=>'op', val=>0000006, fmt=>'-' },
+ 'mfpt' => {typ=>'op', val=>0000007, fmt=>'-' },
+ 'jmp' => {typ=>'op', val=>0000100, fmt=>'g' },
+ 'rts' => {typ=>'op', val=>0000200, fmt=>'r' },
+ 'return' => {typ=>'op', val=>0000207, fmt=>'-' }, # alias for rts pc
+ 'spl' => {typ=>'op', val=>0000230, fmt=>'n3' },
+ 'nop' => {typ=>'op', val=>0000240, fmt=>'-' },
+ 'clc' => {typ=>'op', val=>0000241, fmt=>'-' },
+ 'clv' => {typ=>'op', val=>0000242, fmt=>'-' },
+ 'clz' => {typ=>'op', val=>0000244, fmt=>'-' },
+ 'cln' => {typ=>'op', val=>0000250, fmt=>'-' },
+ 'ccc' => {typ=>'op', val=>0000257, fmt=>'-' },
+ 'sec' => {typ=>'op', val=>0000261, fmt=>'-' },
+ 'sev' => {typ=>'op', val=>0000262, fmt=>'-' },
+ 'sez' => {typ=>'op', val=>0000264, fmt=>'-' },
+ 'sen' => {typ=>'op', val=>0000270, fmt=>'-' },
+ 'scc' => {typ=>'op', val=>0000277, fmt=>'-' },
+ 'swab' => {typ=>'op', val=>0000300, fmt=>'g' },
+ 'br' => {typ=>'op', val=>0000400, fmt=>'s8' },
+ 'bne' => {typ=>'op', val=>0001000, fmt=>'s8' },
+ 'beq' => {typ=>'op', val=>0001400, fmt=>'s8' },
+ 'bge' => {typ=>'op', val=>0002000, fmt=>'s8' },
+ 'blt' => {typ=>'op', val=>0002400, fmt=>'s8' },
+ 'bgt' => {typ=>'op', val=>0003000, fmt=>'s8' },
+ 'ble' => {typ=>'op', val=>0003400, fmt=>'s8' },
+ 'jsr' => {typ=>'op', val=>0004000, fmt=>'rg' },
+ 'call' => {typ=>'op', val=>0004700, fmt=>'g' }, # alias for jsr pc,
+ 'clr' => {typ=>'op', val=>0005000, fmt=>'g' },
+ 'com' => {typ=>'op', val=>0005100, fmt=>'g' },
+ 'inc' => {typ=>'op', val=>0005200, fmt=>'g' },
+ 'dec' => {typ=>'op', val=>0005300, fmt=>'g' },
+ 'neg' => {typ=>'op', val=>0005400, fmt=>'g' },
+ 'adc' => {typ=>'op', val=>0005500, fmt=>'g' },
+ 'sbc' => {typ=>'op', val=>0005600, fmt=>'g' },
+ 'tst' => {typ=>'op', val=>0005700, fmt=>'g' },
+ 'ror' => {typ=>'op', val=>0006000, fmt=>'g' },
+ 'rol' => {typ=>'op', val=>0006100, fmt=>'g' },
+ 'asr' => {typ=>'op', val=>0006200, fmt=>'g' },
+ 'asl' => {typ=>'op', val=>0006300, fmt=>'g' },
+ 'mark' => {typ=>'op', val=>0006400, fmt=>'n6' },
+ 'mfpi' => {typ=>'op', val=>0006500, fmt=>'g' },
+ 'mtpi' => {typ=>'op', val=>0006600, fmt=>'g' },
+ 'sxt' => {typ=>'op', val=>0006700, fmt=>'g' },
+ 'csm' => {typ=>'op', val=>0007000, fmt=>'g' },
+ 'tstset' => {typ=>'op', val=>0007200, fmt=>'g' },
+ 'wrtlck' => {typ=>'op', val=>0007300, fmt=>'g' },
+ 'mov' => {typ=>'op', val=>0010000, fmt=>'gg' },
+ 'cmp' => {typ=>'op', val=>0020000, fmt=>'gg' },
+ 'bit' => {typ=>'op', val=>0030000, fmt=>'gg' },
+ 'bic' => {typ=>'op', val=>0040000, fmt=>'gg' },
+ 'bis' => {typ=>'op', val=>0050000, fmt=>'gg' },
+ 'add' => {typ=>'op', val=>0060000, fmt=>'gg' },
+ 'mul' => {typ=>'op', val=>0070000, fmt=>'gr' },
+ 'div' => {typ=>'op', val=>0071000, fmt=>'gr' },
+ 'ash' => {typ=>'op', val=>0072000, fmt=>'gr' },
+ 'ashc' => {typ=>'op', val=>0073000, fmt=>'gr' },
+ 'xor' => {typ=>'op', val=>0074000, fmt=>'rg' },
+ 'sob' => {typ=>'op', val=>0077000, fmt=>'ru6'},
+ 'bpl' => {typ=>'op', val=>0100000, fmt=>'s8' },
+ 'bmi' => {typ=>'op', val=>0100400, fmt=>'s8' },
+ 'bhi' => {typ=>'op', val=>0101000, fmt=>'s8' },
+ 'blos' => {typ=>'op', val=>0101400, fmt=>'s8' },
+ 'bvc' => {typ=>'op', val=>0102000, fmt=>'s8' },
+ 'bvs' => {typ=>'op', val=>0102400, fmt=>'s8' },
+ 'bcc' => {typ=>'op', val=>0103000, fmt=>'s8' },
+ 'bhis' => {typ=>'op', val=>0103000, fmt=>'s8' }, #alias
+ 'bcs' => {typ=>'op', val=>0103400, fmt=>'s8' },
+ 'blo' => {typ=>'op', val=>0103400, fmt=>'s8' }, #alias
+ 'emt' => {typ=>'op', val=>0104000, fmt=>'n8' },
+ 'trap' => {typ=>'op', val=>0104400, fmt=>'n8' },
+ 'clrb' => {typ=>'op', val=>0105000, fmt=>'g' },
+ 'comb' => {typ=>'op', val=>0105100, fmt=>'g' },
+ 'incb' => {typ=>'op', val=>0105200, fmt=>'g' },
+ 'decb' => {typ=>'op', val=>0105300, fmt=>'g' },
+ 'negb' => {typ=>'op', val=>0105400, fmt=>'g' },
+ 'adcb' => {typ=>'op', val=>0105500, fmt=>'g' },
+ 'sbcb' => {typ=>'op', val=>0105600, fmt=>'g' },
+ 'tstb' => {typ=>'op', val=>0105700, fmt=>'g' },
+ 'rorb' => {typ=>'op', val=>0106000, fmt=>'g' },
+ 'rolb' => {typ=>'op', val=>0106100, fmt=>'g' },
+ 'asrb' => {typ=>'op', val=>0106200, fmt=>'g' },
+ 'aslb' => {typ=>'op', val=>0106300, fmt=>'g' },
+ 'mtps' => {typ=>'op', val=>0106400, fmt=>'g' },
+ 'mfpd' => {typ=>'op', val=>0106500, fmt=>'g' },
+ 'mtpd' => {typ=>'op', val=>0106600, fmt=>'g' },
+ 'mfps' => {typ=>'op', val=>0106700, fmt=>'g' },
+ 'movb' => {typ=>'op', val=>0110000, fmt=>'gg' },
+ 'cmpb' => {typ=>'op', val=>0120000, fmt=>'gg' },
+ 'bitb' => {typ=>'op', val=>0130000, fmt=>'gg' },
+ 'bicb' => {typ=>'op', val=>0140000, fmt=>'gg' },
+ 'bisb' => {typ=>'op', val=>0150000, fmt=>'gg' },
+ 'sub' => {typ=>'op', val=>0160000, fmt=>'gg' },
+ 'cfcc' => {typ=>'op', val=>0170000, fmt=>'-' ,fpp=>1 },
+ 'setf' => {typ=>'op', val=>0170001, fmt=>'-' ,fpp=>1 },
+ 'setd' => {typ=>'op', val=>0170011, fmt=>'-' ,fpp=>1 },
+ 'seti' => {typ=>'op', val=>0170002, fmt=>'-' ,fpp=>1 },
+ 'setl' => {typ=>'op', val=>0170012, fmt=>'-' ,fpp=>1 },
+ 'ldfps' => {typ=>'op', val=>0170100, fmt=>'g' ,fpp=>1 },
+ 'stfps' => {typ=>'op', val=>0170200, fmt=>'g' ,fpp=>1 },
+ 'stst' => {typ=>'op', val=>0170300, fmt=>'g' ,fpp=>1 },
+ 'clrf' => {typ=>'op', val=>0170400, fmt=>'g' ,fpp=>1 },
+ 'clrd' => {typ=>'op', val=>0170400, fmt=>'g' ,fpp=>1 }, # alias
+ 'tstf' => {typ=>'op', val=>0170500, fmt=>'g' ,fpp=>1 },
+ 'tstd' => {typ=>'op', val=>0170500, fmt=>'g' ,fpp=>1 }, # alias
+ 'absf' => {typ=>'op', val=>0170600, fmt=>'g' ,fpp=>1 },
+ 'absd' => {typ=>'op', val=>0170600, fmt=>'g' ,fpp=>1 }, # alias
+ 'negf' => {typ=>'op', val=>0170700, fmt=>'g' ,fpp=>1 },
+ 'negd' => {typ=>'op', val=>0170700, fmt=>'g' ,fpp=>1 }, # alias
+ 'mulf' => {typ=>'op', val=>0171000, fmt=>'gr' ,fpp=>1 },
+ 'muld' => {typ=>'op', val=>0171000, fmt=>'gr' ,fpp=>1 }, # alias
+ 'modf' => {typ=>'op', val=>0171400, fmt=>'gr' ,fpp=>1 },
+ 'modd' => {typ=>'op', val=>0171400, fmt=>'gr' ,fpp=>1 }, # alias
+ 'addf' => {typ=>'op', val=>0172000, fmt=>'gr' ,fpp=>1 },
+ 'addd' => {typ=>'op', val=>0172000, fmt=>'gr' ,fpp=>1 }, # alias
+ 'ldf' => {typ=>'op', val=>0172400, fmt=>'gr' ,fpp=>1 },
+ 'ldd' => {typ=>'op', val=>0172400, fmt=>'gr' ,fpp=>1 }, # alias
+ 'subf' => {typ=>'op', val=>0173000, fmt=>'gr' ,fpp=>1 },
+ 'subd' => {typ=>'op', val=>0173000, fmt=>'gr' ,fpp=>1 }, # alias
+ 'cmpf' => {typ=>'op', val=>0173400, fmt=>'gr' ,fpp=>1 },
+ 'cmpd' => {typ=>'op', val=>0173400, fmt=>'gr' ,fpp=>1 }, # alias
+ 'stf' => {typ=>'op', val=>0174000, fmt=>'rg' ,fpp=>1 },
+ 'std' => {typ=>'op', val=>0174000, fmt=>'rg' ,fpp=>1 }, # alias
+ 'divf' => {typ=>'op', val=>0174400, fmt=>'gr' ,fpp=>1 },
+ 'divd' => {typ=>'op', val=>0174400, fmt=>'gr' ,fpp=>1 }, # alias
+ 'stexp' => {typ=>'op', val=>0175000, fmt=>'rg' ,fpp=>1 },
+ 'stcfi' => {typ=>'op', val=>0175400, fmt=>'rg' ,fpp=>1 },
+ 'stcfl' => {typ=>'op', val=>0175400, fmt=>'rg' ,fpp=>1 }, # alias
+ 'stcdi' => {typ=>'op', val=>0175400, fmt=>'rg' ,fpp=>1 }, # alias
+ 'stcdl' => {typ=>'op', val=>0175400, fmt=>'rg' ,fpp=>1 }, # alias
+ 'stcfd' => {typ=>'op', val=>0176000, fmt=>'rg' ,fpp=>1 },
+ 'stcdf' => {typ=>'op', val=>0176000, fmt=>'rg' ,fpp=>1 }, # alias
+ 'ldexp' => {typ=>'op', val=>0176400, fmt=>'gr' ,fpp=>1 },
+ 'ldcif' => {typ=>'op', val=>0177000, fmt=>'gr' ,fpp=>1 },
+ 'ldcid' => {typ=>'op', val=>0177000, fmt=>'gr' ,fpp=>1 }, # alias
+ 'ldclf' => {typ=>'op', val=>0177000, fmt=>'gr' ,fpp=>1 }, # alias
+ 'ldcld' => {typ=>'op', val=>0177000, fmt=>'gr' ,fpp=>1 }, # alias
+ 'ldcdf' => {typ=>'op', val=>0177400, fmt=>'gr' ,fpp=>1 },
+ 'ldcfd' => {typ=>'op', val=>0177400, fmt=>'gr' ,fpp=>1 } # alias
+);
+
+# operand formats
+my %opfmt = (
+ '-' => [], # halt,...
+ 'n3' => [{typ=>'e', pref=>''}], # spl
+ 'n6' => [{typ=>'e', pref=>''}], # mark
+ 'n8' => [{typ=>'e', pref=>''}], # trap,emt
+ 'r' => [{typ=>'r', pref=>'o1'}], # rts
+ 'g' => [{typ=>'g', pref=>'o1'}], # inc,...
+ 'rg' => [{typ=>'r', pref=>'o1'}, {typ=>'g', pref=>'o2'}], # xor,jsr
+ 'gr' => [{typ=>'g', pref=>'o2'}, {typ=>'r', pref=>'o1'}], # ash,...
+ 'gg' => [{typ=>'g', pref=>'o1'}, {typ=>'g', pref=>'o2'}], # add,...
+ 's8' => [{typ=>'e', pref=>''}], # br,...
+ 'ru6' => [{typ=>'r', pref=>'o1'}, {typ=>'e', pref=>''}] # sob
+);
+
+# psect table
+my %psect =
+('.abs.' => {dot=>0, dotmax=>0}
+);
+my $cur_psect = '.abs.'; # current psect
+
+# local symbol table
+my %lst =
+('.' => {name=>'.', typ=>'dot', val=>0, psect=>'.abs.'}
+);
+my $llbl_scope = '0'; # current local label scope
+my $llbl_ascope = 0; # annonymous local label scope count
+
+# macro table
+my %mst;
+
+my @flist; # list of filenames
+my $fstem; # stem or last file name
+my $lst_do; # generate listing
+my $lst_fname; # listing file name
+my $lda_do; # generate lda output
+my $lda_fname; # lda file name
+my $cof_do; # generate cof output
+my $cof_fname; # cof file name
+my $lsm_do; # generate lsm output
+my $lsm_fname; # lsm file name
+
+my @src;
+my %errcnt; # error tag counter
+my $errcnt_tot=0; # total error count
+my $pass;
+
+my @t_pushback;
+
+my $defincdot = 0; # defered increment for '.'
+my $out_dot; # current . for output
+my @out_data; # output data
+my $out_start = 1; # absolute start address
+
+autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
+
+if (exists $opts{help}) {
+ print_help;
+ exit 0;
+}
+
+if (scalar(@ARGV) == 0) {
+ print STDERR "asm-11-F: no input files specified, quiting..\n";
+ print_help;
+ exit 1;
+}
+
+# find stem of last file name
+$fstem = $ARGV[-1];
+$fstem =~ s|^.*/||; # drop leading dirs
+$fstem =~ s|\.mac$||; # drop trailing '.mac'
+
+if ($opts{lst} || $opts{olst}) {
+ $lst_do = 1;
+ $lst_fname = create_fname($opts{olst},'.lst');
+}
+
+if ($opts{lda} || $opts{olda}) {
+ $lda_do = 1;
+ $lda_fname = create_fname($opts{olda},'.lda');
+}
+
+if ($opts{cof} || $opts{ocof}) {
+ $cof_do = 1;
+ $cof_fname = create_fname($opts{ocof},'.cof');
+}
+
+if ($opts{lsm} || $opts{olsm}) {
+ $lsm_do = 1;
+ $lsm_fname = create_fname($opts{olsm},'.lsm');
+}
+
+# do pass 1
+$pass = 1;
+foreach my $fname (@ARGV) {
+ read_file($fname);
+}
+dump_sym() if $opts{dsym1};
+
+# prepare pass 2
+
+foreach (keys %psect) {
+ $psect{$_}{dot} = 0;
+}
+
+$lst{'.'}->{val} = 0;
+$lst{'.'}->{psect} = '.abs.';
+
+$cur_psect = '.abs.';
+$llbl_scope = '0';
+
+# do pass 2
+$pass = 2;
+pass2();
+dump_sym() if $opts{dsym2};
+
+# create object output files
+write_lda($lda_fname) if $lda_do;
+write_cof($cof_fname) if $cof_do;
+write_lsm($lsm_fname) if $lsm_do;
+
+# and exit
+if ($errcnt_tot > 0) {
+ print "asm-11-E: compilation errors:";
+ foreach my $err (sort keys %errcnt) {
+ printf " %s: %d", $err, $errcnt{$err};
+ }
+ print "\n";
+ exit 1;
+}
+exit 0;
+
+#-------------------------------------------------------------------------------
+
+sub create_fname {
+ my ($fname,$suff) = @_;
+ if (defined $fname) {
+ $fname =~ s|\%|$fstem|;
+ return $fname;
+ }
+ $fname = $fstem;
+ $fname .= $suff unless $fname eq '-';
+ return $fname;
+}
+
+#-------------------------------------------------------------------------------
+
+sub read_file {
+ my ($fname) = @_;
+ my $fh;
+ if ($fname eq "-") {
+ $fh = *STDIN;
+ } else {
+ if (not -r $fname) {
+ print STDERR "asm-11-F: '$fname' not found or readable, quiting..\n";
+ exit 1;
+ }
+ $fh = new FileHandle;
+ $fh->open($fname) or die "failed to open '$fname'";
+ }
+
+ push @flist, $fname;
+
+ my $lineno = 0;
+ my $fileno = scalar(@flist);
+ while (<$fh>) {
+ chomp;
+ my $line = $_;
+ $lineno += 1;
+ my $rl = parse_line($fileno, $lineno, $line);
+ dump_rl($rl) if $opts{tpass1};
+ push @src, $rl;
+
+ # handle .include
+ if (defined $$rl{oper} && $$rl{oper} eq '.include' && defined $$rl{ifile}) {
+ my $fnam = $$rl{ifile};
+ unless ($fnam =~ m|^/|) {
+ foreach (@{$opts{I}}) {
+ if (-r "$_/$fnam") {
+ $fnam = "$_/$fnam";
+ last;
+ }
+ }
+ }
+ read_file($fnam);
+ }
+
+ }
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub parse_line {
+ my ($fileno,$lineno,$line) = @_;
+
+ my %l = ( fileno => $fileno, # file number
+ lineno => $lineno, # line number
+ line => $line, # line
+ cl => [split '',$line], # char list
+ tl => [], # token list
+ err => '', # error tags
+ psect => $cur_psect, # current psect
+ dot => getdot(), # current dot
+ outw => [], # output: words
+ outb => [] # output: bytes
+ );
+
+ my $state = 'start'; # parser state
+
+ my $op_code; # op code
+ my $op_fmt; # op format
+ my $op_fpp; # true if floating opcode
+ my @op_ops; # list of operands
+ my $op_rop; # ref of current operand dsc
+
+ my $s_incok;
+ my $op_ibeg;
+ my $op_creg;
+ my $op_cmod;
+ my $op_cmod_def;
+
+ my @e_pbeg;
+ my $e_ibeg;
+ my $e_iend;
+
+ my $a_sym;
+ my $a_typ;
+
+ my $d_dire;
+ my @d_elist;
+
+ my $c;
+ my $rt;
+ my $tmask = 0;
+
+ my @stack;
+
+ @t_pushback = ();
+
+ printf "-- parse: '$line'\n" if $opts{tparse} || $opts{ttoken};
+
+ # quit if invalid character found (non 7 bit ascii in asm-11)
+ foreach my $c (@{$l{cl}}) {
+ if (ord($c) > 127) {
+ add_err(\%l, 'I');
+ return \%l;
+ }
+ }
+
+ while (1) {
+ if ($opts{tparse}) {
+ printf "-- state = $state";
+ printf ", nest = %d", scalar(@e_pbeg) if $state =~ m/^e_/;
+ print "\n";
+ }
+
+ if ($state eq 'start') { # state: start -------------------
+ $rt = get_token(\%l, $tmask);
+
+ # end of line seen ?
+ if ($$rt{tag} eq 'EOL') {
+ last;
+
+ # name seen
+ } elsif ($$rt{tag} eq 'SYM') {
+ # directive name seen ?
+ if (exists $pst{$$rt{val}} && $pst{$$rt{val}}{typ} eq 'dir') {
+ $state = 'oper';
+
+ # otherwise check for label or assignment
+ } else {
+ my $isllbl = check_llbl($$rt{val});
+ $rt = get_token(\%l, $tmask);
+ # handle local labels
+ if ($isllbl) {
+ if ($$rt{tag} eq 'LBL') {
+ setsym(\%l, 'lbl' ,$l{tl}[-2]{val}, getdot());
+ $l{lscope} = $llbl_scope;
+ $l{label} = $l{tl}[-2]{val};
+ $state = 'start1';
+ } else {
+ $state = 'q';
+ }
+ # handle assignments
+ } elsif ($$rt{tag} eq 'ASS') {
+ $a_sym = $l{tl}[-2]{val};
+ $a_typ = $l{tl}[-1]{val};
+ push @stack, 'a_end';
+ $state = 'e_beg';
+ # handle normal labels
+ } elsif ($$rt{tag} eq 'LBL') {
+ setsym(\%l, 'lbl' ,$l{tl}[-2]{val}, getdot());
+ $llbl_scope = $l{tl}[-2]{val};
+ $l{lscope} = $l{tl}[-2]{val};
+ $l{label} = $l{tl}[-2]{val};
+ $state = 'start1';
+ # if neither label or assigmnent, handle as operation or directive
+ } else {
+ pushback_token(\%l);
+ $state = 'oper';
+ }
+ }
+
+ # anything else seen, treat a implicit .word
+ } else {
+ pushback_token(\%l);
+ $state = 'iword';
+ }
+
+ } elsif ($state eq 'start1') { # state: start1 ------------------
+ $rt = get_token(\%l, $tmask);
+ if ($$rt{tag} eq 'EOL') {
+ last;
+ } elsif ($$rt{tag} eq 'SYM') {
+ $state = 'oper';
+ } else { # not symbol -> implicit .word
+ pushback_token(\%l);
+ $state = 'iword';
+ }
+
+ } elsif ($state eq 'oper') { # state: oper --------------------
+ # Note: state oper is entered with token already on tl list !!
+ my $rt0 = $l{tl}[-1];
+ my $op = $$rt0{val};
+ $l{oper} = $op;
+ if (exists $pst{$op}) {
+ my $rs = $pst{$op};
+ if ($$rs{typ} eq 'dir') { # directives ------------------
+ $d_dire = $op;
+ if ($op eq '.word' || # .word
+ $op eq '.byte') { # .byte
+ $state = 'dl_beg';
+
+ } elsif ($op eq '.blkw' || # .blkw
+ $op eq '.blkb') { # .blkb
+ $state = 'dl_beg';
+
+ } elsif ($op eq '.ascii' || # .ascii
+ $op eq '.asciz') { # .asciz
+ $tmask = TMASK_STRING;
+ $state = 'al_next';
+
+ } elsif ($op eq '.even' || # .even
+ $op eq '.odd') { # .odd
+ my $dot = getdot();
+ my $inc = 0;
+ $inc = 1 if $op eq '.even' && ($dot&01)==1;
+ $inc = 1 if $op eq '.odd' && ($dot&01)==0;
+ incdot(1) if $inc;
+ $l{typ} = 'data';
+ $l{incdot} = $inc;
+ $l{lstdot} = 1;
+ $state = 'end';
+
+ } elsif ($op eq '.asect') { # .asect
+ # .asect is currently a noop because asect is start default
+ $l{lstdot} = 1;
+ $state = 'end';
+
+ } elsif ($op eq '.include') { # .include
+ $rt = get_token(\%l, TMASK_STRING);
+ if ($$rt{tag} eq 'STR') {
+ my $ifile = $$rt{val};
+ my $rt = get_token(\%l, TMASK_STRING);
+ if ($$rt{tag} eq 'EOL') {
+ $l{ifile} = substr($ifile,1,-1) unless $l{err} ne '';
+ $state = 'end';
+ } else {
+ $state = 'q';
+ }
+ } else {
+ $state = 'q';
+ }
+
+ } elsif ($op eq '.end') { # .end
+ $state = 'dl_beg';
+
+ } else {
+ die "BUGCHECK: op = '$op' in pst but no handler";
+ }
+
+ } elsif ($$rs{typ} eq 'op') { # or opcodes ------------------
+ walign(\%l);
+ $l{typ} = 'code';
+ $op_code = $$rs{val};
+ $op_fmt = $$rs{fmt};
+ $op_fpp = $$rs{fpp};
+ die "BUGCHECK: op_fmt = '$op_fmt' unknown in opfmt"
+ unless defined $opfmt{$op_fmt};
+
+ $l{opcode} = $op_code;
+ $l{opfmt} = $op_fmt;
+
+ @op_ops = @{$opfmt{$op_fmt}};
+
+ if (scalar(@op_ops) == 0) {
+ incdot(2);
+ $state = 'end';
+ } else {
+ $op_rop = shift @op_ops;
+ $state = 'op_beg';
+ }
+
+ }
+ } else { # oper noy in pst --> implicit .word
+ pushback_token(\%l);
+ $state = 'iword';
+ }
+
+ } elsif ($state eq 'op_beg') { # state: op_beg ------------------
+ $op_ibeg = scalar(@{$l{tl}});
+ $op_creg = undef;
+ $op_cmod = undef;
+ $op_cmod_def = undef;
+ $e_ibeg = undef;
+ $e_iend = undef;
+ if ($$op_rop{typ} eq 'r') { # operand: register
+ $rt = get_token(\%l, $tmask);
+ $op_creg = check_reg($rt);
+ if (defined $op_creg) {
+ if ($op_fpp && $op_creg > 3) { # fpp ac must be r0:r3
+ $op_creg &= 03;
+ add_err(\%l, 'T');
+ }
+ $op_cmod = 0;
+ $state = 'op_end';
+ } else {
+ $state = 'q';
+ }
+ } elsif ($$op_rop{typ} eq 'e') { # operand: expression
+ push @stack, 'op_end';
+ $state = 'e_beg';
+ } elsif ($$op_rop{typ} eq 'g') { # operand: general
+ push @stack, 'op_end';
+ $state = 'g_beg';
+ } else {
+ die "BUGCHECK: unexpected op typ '$$op_rop{typ}'";
+ }
+
+ } elsif ($state eq 'op_end') { # state: op_end ------------------
+ my $op_iend = scalar(@{$l{tl}})-1;
+ $l{tl}[$op_ibeg]->{om} = '<';
+ $l{tl}[$op_iend]->{om} = ($l{tl}[$op_iend]->{om}) ? '<>' : '>';
+
+ my $pref = $$op_rop{pref};
+ if ($$op_rop{typ} =~ m/^[gr]$/) {
+ $l{$pref.'reg'} = $op_creg;
+ $l{$pref.'mod'} = $op_cmod;
+ if (defined $e_ibeg) {
+ $l{$pref.'ebeg'} = $e_ibeg;
+ $l{$pref.'eend'} = $e_iend;
+ }
+ } elsif ($$op_rop{typ} eq 'e') {
+ if (defined $e_ibeg) {
+ $l{ebeg} = $e_ibeg;
+ $l{eend} = $e_iend;
+ }
+ }
+
+ if (scalar(@op_ops)) { # second operand
+ $rt = get_token(\%l, $tmask);
+ if (check_token($rt, 'DEL', ',')) {
+ $op_rop = shift @op_ops;
+ $state = 'op_beg';
+ } else {
+ $state = 'q';
+ }
+
+ } else { # all operands seen
+ my $nword = 1;
+ $nword += 1 if defined $l{o1ebeg};
+ $nword += 1 if defined $l{o2ebeg};
+ incdot(2*$nword);
+ $state = 'end';
+ }
+
+ } elsif ($state eq 'g_beg') { # state: g_beg -------------------
+ $rt = get_token(\%l, $tmask);
+ if (defined check_reg($rt)) { # R !
+ $op_creg = check_reg($rt);
+ $op_cmod = 0;
+ $state = 'g_end';
+ } elsif (check_token($rt, 'DEL', '(')) { # ( R),R)+
+ $state = 'g_inc1';
+ } elsif (check_token($rt, 'OP', '@')) { # @ R,(R)+,-(R),E(R),#E,E
+ $op_cmod_def = 1;
+ $state = 'g_def1';
+ } elsif (check_token($rt, 'OP', '-')) { # - (R)
+ $rt = get_token(\%l, $tmask);
+ if (check_token($rt, 'DEL', '(')) { # next (
+ pushback_token(\%l);
+ $state = 'g_dec1'; # go for -(R)
+ } else {
+ pushback_token(\%l);
+ pushback_token(\%l);
+ push @stack, 'g_ind1'; # otherwise -E..
+ $state = 'e_beg';
+ }
+ } elsif (check_token($rt, 'OP', '#')) { # # E
+ push @stack, 'g_imm1';
+ $state = 'e_beg';
+ } else {
+ pushback_token(\%l);
+ push @stack, 'g_ind1'; # E ! (R)
+ $state = 'e_beg';
+ }
+
+ } elsif ($state eq 'g_inc1') { # state: g_inc1 ------------------
+ $rt = get_token(\%l, $tmask);
+ $op_creg = check_reg($rt);
+ if (defined $op_creg) {
+ $rt = get_token(\%l, $tmask);
+ if (check_token($rt, 'DEL', ')')) {
+ $rt = get_token(\%l, $tmask);
+ if (check_token($rt, 'OP', '+')) {
+ $op_cmod = $op_cmod_def ? 3 : 2;
+ $state = 'g_end';
+ } else {
+ if ($op_cmod_def) {
+ $state = 'q';
+ } else {
+ pushback_token(\%l);
+ $op_cmod = 1;
+ $state = 'g_end';
+ }
+ }
+ } else {
+ $state = 'q';
+ }
+ } else {
+ $state = 'q';
+ }
+
+ } elsif ($state eq 'g_def1') { # state: g_def1 ------------------
+ $rt = get_token(\%l, $tmask);
+ if (defined check_reg($rt)) { # R
+ $op_creg = check_reg($rt);
+ $op_cmod = 1;
+ $state = 'g_end';
+ } elsif (check_token($rt, 'DEL', '(')) { # ( -> R+
+ $state = 'g_inc1';
+ } elsif (check_token($rt, 'OP', '-')) { # - -> (R)
+ $rt = get_token(\%l, $tmask);
+ if (check_token($rt, 'DEL', '(')) { # next (
+ pushback_token(\%l);
+ $state = 'g_dec1'; # go for -(R)
+ } else {
+ pushback_token(\%l);
+ pushback_token(\%l);
+ push @stack, 'g_ind1'; # otherwise -E..
+ $state = 'e_beg';
+ }
+ } elsif (check_token($rt, 'OP', '#')) { # # -> #
+ push @stack, 'g_imm1';
+ $state = 'e_beg';
+ } else { # E -> !, (R)
+ pushback_token(\%l);
+ push @stack, 'g_ind1';
+ $state = 'e_beg';
+ }
+
+ } elsif ($state eq 'g_ind1') { # state: g_ind1 ------------------
+ $rt = get_token(\%l, $tmask);
+ if (check_token($rt, 'DEL', '(')) {
+ $rt = get_token(\%l, $tmask);
+ $op_creg = check_reg($rt);
+ if (defined $op_creg) {
+ $rt = get_token(\%l, $tmask);
+ $op_cmod = $op_cmod_def ? 7 : 6;
+ $state = check_token($rt, 'DEL', ')') ? 'g_end' : 'q';
+ } else {
+ $state = 'q';
+ }
+ } else {
+ pushback_token(\%l);
+ $op_creg = 7;
+ $op_cmod = $op_cmod_def ? 7 : 6;
+ $state = 'g_end';
+ }
+
+ } elsif ($state eq 'g_dec1') { # state: g_dec1 ------------------
+ $rt = get_token(\%l, $tmask);
+ if (check_token($rt, 'DEL', '(')) {
+ $rt = get_token(\%l, $tmask);
+ $op_creg = check_reg($rt);
+ if (defined $op_creg) {
+ $rt = get_token(\%l, $tmask);
+ $op_cmod = $op_cmod_def ? 5 : 4;
+ $state = check_token($rt, 'DEL', ')') ? 'g_end' : 'q';
+ } else {
+ $state = 'q';
+ }
+ } else {
+ $state = 'q';
+ }
+
+ } elsif ($state eq 'g_imm1') { # state: g_imm1 ------------------
+ $op_creg = 7;
+ $op_cmod = $op_cmod_def ? 3 : 2;
+ $state = 'g_end';
+
+ } elsif ($state eq 'g_end') { # state: g_end -------------------
+ $state = pop @stack;
+
+ } elsif ($state eq 'e_beg') { # state: e_beg -------------------
+ $e_ibeg = scalar(@{$l{tl}});
+ @e_pbeg = ();
+ $state = 'e_uop';
+
+ } elsif ($state eq 'e_uop') { # state: e_uop -------------------
+ $rt = get_token(\%l, $tmask);
+ if ($$rt{tag} eq 'OP' && $$rt{typ}=~'u') { # OP(u)
+ $$rt{typ}='u';
+ $state = 'e_uop';
+ } elsif ($$rt{tag} eq 'NUM' || $$rt{tag} eq 'SYM') {
+ $state = 'e_bop';
+ } elsif (check_token($rt, 'DEL', '<')) {
+ push @e_pbeg, scalar(@{$l{tl}})-1;
+ $state = 'e_uop';
+ } else {
+ $state = 'q';
+ }
+
+ } elsif ($state eq 'e_bop') { # state: e_bop -------------------
+ $rt = get_token(\%l, $tmask);
+ if ($$rt{tag} eq 'OP' && $$rt{typ}=~'b') { # OP(b)
+ $$rt{typ}='b';
+ $state = 'e_bop1';
+ } elsif (check_token($rt, 'DEL', '>')) {
+ if (scalar(@e_pbeg) == 0) {
+ $state = 'q';
+ } else {
+ my $pbeg = pop @e_pbeg;
+ $l{tl}[$pbeg]->{pend} = scalar(@{$l{tl}})-1;
+ if ($tmask & TMASK_STRINGEXP) {
+ $state = 'e_end';
+ } else {
+ $state = 'e_bop';
+ }
+ }
+ } else {
+ pushback_token(\%l);
+ $state = 'e_end';
+ }
+
+ } elsif ($state eq 'e_bop1') { # state: e_bop1 ------------------
+ $rt = get_token(\%l, $tmask);
+ if ($$rt{tag} eq 'NUM' || $$rt{tag} eq 'SYM') {
+ $state = 'e_bop';
+ } elsif (check_token($rt, 'DEL', '<')) {
+ push @e_pbeg, scalar(@{$l{tl}})-1;
+ $state = 'e_uop';
+ } else {
+ $state = 'q';
+ }
+
+ } elsif ($state eq 'e_end') { # state: e_end -------------------
+ $e_iend = scalar(@{$l{tl}})-1;
+ $l{tl}[$e_ibeg]->{em} = '<>';
+ if ($e_iend != $e_ibeg) {
+ $l{tl}[$e_ibeg]->{em} = '<';
+ $l{tl}[$e_iend]->{em} = '>';
+ }
+ $state = (scalar(@e_pbeg)==0) ? pop @stack : 'q';
+
+ } elsif ($state eq 'a_end') { # state: a_end -------------------
+ my $val = eval_exp(\%l, $e_ibeg, $e_iend);
+ my $typ = ($a_typ =~ m/:/) ? 'pass' : 'ass';
+ setsym(\%l, $typ, $a_sym, $val);
+ $l{typ} = 'ass';
+ $l{atyp} = $typ;
+ $l{asym} = $a_sym;
+ $l{ebeg} = $e_ibeg;
+ $l{eend} = $e_iend;
+ $state = 'end';
+
+ } elsif ($state eq 'dl_beg') { # state: dl_beg ------------------
+ $rt = get_token(\%l, $tmask);
+ if ($$rt{tag} eq 'EOL') {
+ $state = 'dl_end';
+ } elsif (check_token($rt, 'DEL', ',')) {
+ pushback_token(\%l);
+ $e_ibeg = undef;
+ $e_iend = undef;
+ $state = 'dl_next';
+ } else {
+ pushback_token(\%l);
+ $e_ibeg = undef;
+ $e_iend = undef;
+ push @stack, 'dl_next';
+ $state = 'e_beg';
+ }
+
+ } elsif ($state eq 'dl_next') { # state: dl_next -----------------
+ push @d_elist, {ibeg=>$e_ibeg, iend=>$e_iend};
+ $rt = get_token(\%l, $tmask);
+ if ($$rt{tag} eq 'EOL') {
+ $state = 'dl_end';
+ } elsif (check_token($rt, 'DEL', ',')) {
+ $rt = get_token(\%l, $tmask);
+ if ($$rt{tag} eq 'EOL' || check_token($rt, 'DEL', ',')) {
+ pushback_token(\%l);
+ $e_ibeg = undef;
+ $e_iend = undef;
+ $state = 'dl_next';
+ } else {
+ pushback_token(\%l);
+ $e_ibeg = undef;
+ $e_iend = undef;
+ push @stack, 'dl_next';
+ $state = 'e_beg';
+ }
+ } else {
+ $state = 'q';
+ }
+
+ } elsif ($state eq 'dl_end') { # state: dl_end ------------------
+ $state = 'end';
+ if ($d_dire eq '.word') {
+ walign(\%l);
+ if (scalar(@d_elist)) {
+ $l{typ} = 'data';
+ $l{delist} = \@d_elist;
+ incdot(2*scalar(@d_elist));
+ } else {
+ $state = 'q';
+ }
+ } elsif ($d_dire eq '.byte') {
+ if (scalar(@d_elist)) {
+ $l{typ} = 'data';
+ $l{delist} = \@d_elist;
+ incdot(1*scalar(@d_elist));
+ } else {
+ $state = 'q';
+ }
+ } elsif ($d_dire eq '.blkw' || $d_dire eq '.blkb') {
+ $l{lstdot} = 1;
+ walign(\%l) if $d_dire eq '.blkw';
+ my $val;
+ if (scalar(@d_elist) == 0) {
+ $val = 1;
+ } elsif (scalar(@d_elist) == 1) {
+ $val = eval_exp(\%l, $d_elist[0]{ibeg}, $d_elist[0]{iend});
+ } else {
+ $state = 'q';
+ }
+
+ if (defined $val) {
+ my $size = ($d_dire eq '.blkw') ? 2 : 1;
+ incdot($size * $val);
+ $l{typ} = 'data';
+ $l{incdot} = $size * $val;
+ } else {
+ add_err(\%l, 'A');
+ }
+
+ } elsif ($d_dire eq '.end') {
+ my $val;
+ if (scalar(@d_elist) == 0) {
+ $val = 1;
+ } elsif (scalar(@d_elist) == 1) {
+ $val = eval_exp(\%l, $d_elist[0]{ibeg}, $d_elist[0]{iend});
+ } else {
+ $state = 'q';
+ }
+ if (defined $val) {
+ $l{lstval} = $val; # set aval to get it in listing
+ $out_start = $val;
+ } else {
+ $l{lstval} = 0;
+ add_err(\%l, 'U');
+ }
+
+ } else {
+ die "BUGCHECK: unexpected d_dire = '$d_dire'";
+ }
+
+ } elsif ($state eq 'al_next') { # state: al_next -----------------
+ $rt = get_token(\%l, $tmask);
+ if ($$rt{tag} eq 'STR') {
+ push @d_elist, {str=>$$rt{val}};
+ } elsif ($$rt{tag} eq 'EOL') {
+ $state = 'al_end';
+ } elsif (check_token($rt, 'DEL', '<')) {
+ pushback_token(\%l);
+ $tmask = TMASK_STRINGEXP;
+ push @stack, 'al_exp';
+ $e_ibeg = undef;
+ $e_iend = undef;
+ $state = 'e_beg';
+ } else {
+ $state = 'q';
+ }
+
+ } elsif ($state eq 'al_exp') { # state: al_exp ------------------
+ push @d_elist, {ibeg=>$e_ibeg, iend=>$e_iend};
+ $tmask = TMASK_STRING;
+ $state = 'al_next';
+
+ } elsif ($state eq 'al_end') { # state: al_end ------------------
+ my $size = 0;
+ foreach (@d_elist) {
+ if (defined $$_{str}) {
+ $size += length($$_{str}) - 2;
+ } else {
+ $size += 1;
+ }
+ }
+ $size += 1 if $d_dire eq '.asciz';
+ incdot($size);
+ $l{typ} = 'data';
+ $l{delist} = \@d_elist;
+ $state = 'end';
+
+ } elsif ($state eq 'iword') { # state: iword -------------------
+ $l{oper} = $d_dire = '.word'; # setup implicit .word directive
+ $state = 'dl_beg';
+
+ } elsif ($state eq 'end') { # state: end ---------------------
+ # unless EOL already seen fetch next token
+ if (scalar(@{$l{tl}}) && $l{tl}[-1]{tag} eq 'EOL') {
+ $rt = $l{tl}[-1];
+ } else {
+ $rt = get_token(\%l, $tmask);
+ }
+ # if at EOL fine, otherwise mark syntax error
+ if ($$rt{tag} eq 'EOL') {
+ last;
+ } else {
+ $state = 'q';
+ }
+
+ } elsif ($state eq 'q') { # state: q -----------------------
+ add_err(\%l, 'Q'); # set Q error flag
+ last; # and quit this line
+
+ } else {
+ die "BUGCHECK: unexpected state '$state'\n";
+ }
+ }
+
+ return \%l;
+}
+
+#-------------------------------------------------------------------------------
+
+sub walign {
+ my ($rl) = @_;
+ my $dot = getdot();
+ if ($dot & 0x1) { # odd address ?
+ incdot(1);
+ add_err($rl, 'B');
+ $$rl{dot} = getdot() if ($pass == 2); # fixup . in rl context in pass 2
+ }
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub add_err {
+ my ($rl,$err) = @_;
+ return if index($$rl{err}, $err) >= 0; # prevent multiple error tags
+ $$rl{err} .= $err; # set error tag
+ $errcnt{$err} += 1; # and count them
+ $errcnt_tot += 1;
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub prt_err {
+ my ($rl) = @_;
+ return join '', sort split '', $$rl{err};
+}
+
+#-------------------------------------------------------------------------------
+
+sub setdot {
+ my ($val) = @_;
+ return unless defined $val;
+ $lst{'.'}->{val} = $val;
+ $psect{$cur_psect}{dot} = $val;
+ $psect{$cur_psect}{dotmax} = $val if $psect{$cur_psect}{dotmax} < $val;
+ ## printf "-- setdot %6.6o\n", $val if $opts{tparse};
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub incdot {
+ my ($inc) = @_;
+ return unless defined $inc;
+ setdot(getdot() + $inc);
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub getdot {
+ ## printf "-- getdot %6.6o\n", $lst{'.'}{val} if $opts{tparse};
+ return $lst{'.'}{val};
+}
+
+#-------------------------------------------------------------------------------
+
+sub setsym {
+ my ($rl,$typ,$name,$val) = @_;
+ ##print "+++set: pass=$pass; $llbl_scope : $name; typ=$typ\n";
+ if ($name eq '.') {
+ if ($typ eq 'ass') {
+ setdot($val);
+ } else {
+ add_err($rl, 'A');
+ }
+ return;
+ }
+
+ my $isllbl = check_llbl($name);
+ if (check_llbl($name)) {
+ if ($typ eq 'lbl') {
+ $name = $llbl_scope . ':' . $name if $isllbl;
+ $typ = 'llbl';
+ } else {
+ die "BUGCHECK: name looks like local label, but typ=$typ";
+ }
+ }
+
+ my $namelc = lc($name);
+
+ if ($typ ne 'ass' && exists $lst{$namelc} &&
+ $lst{$namelc}{typ} ne 'udef' && $pass==1) {
+ # Note: 'M' etaging done in pass 2!
+ $lst{$namelc}{mdef} = 1;
+ return;
+ }
+
+ $lst{$namelc}{name} = $name;
+ $lst{$namelc}{val} = $val;
+ $lst{$namelc}{typ} = $typ;
+ $lst{$namelc}{psect} = $cur_psect;
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub getsym {
+ my ($rl, $name, $noxref) = @_;
+ ##print "+++get: pass=$pass; $llbl_scope : $name\n";
+ $name = $llbl_scope . ':' . $name if check_llbl($name);
+ my $namelc = lc($name);
+
+ # if not yet defined, add it in lst with typ='udef'
+ if (not exists $lst{$namelc}) { # not yet in lst
+ if (exists $pst{$namelc} && # but known as opcode
+ $pst{$namelc}{typ} eq 'op') {
+ return $pst{$namelc}{val}; # return that value
+ } else {
+ $lst{$namelc} = { name => $name,
+ val => undef,
+ typ => 'udef',
+ psect => ''
+ };
+ return undef;
+ }
+ }
+
+ unless ($noxref) {
+ if ($lst{$namelc}{mdef}) {
+ add_err($rl, 'D');
+ }
+ }
+
+ return $lst{$namelc}{val};
+}
+
+#-------------------------------------------------------------------------------
+
+sub lst_checkmdef {
+ my ($name) = @_;
+ $name = $llbl_scope . ':' . $name if check_llbl($name);
+ my $namelc = lc($name);
+ return $lst{$namelc}{mdef};
+}
+
+#-------------------------------------------------------------------------------
+
+sub eval_exp {
+ my ($rl,$ibeg,$iend,$nest) = @_;
+ my $rtl = $$rl{tl};
+ my @uop;
+ my $bop;
+ my @val;
+
+ return undef unless defined $ibeg && defined $iend;
+ return undef unless defined $$rtl[$ibeg] || $nest; # FIXME_code: test em !!
+
+ for (my $i=$ibeg; $i<=$iend; $i++) {
+ my $rt = $$rtl[$i];
+ my $do_uop = 0;
+ if ($$rt{tag} eq 'NUM') {
+ push @val, $$rt{nval};
+
+ } elsif ($$rt{tag} eq 'SYM') {
+ push @val, getsym($rl, $$rt{val});
+
+ } elsif ($$rt{tag} eq 'OP' && $$rt{typ} eq 'u') {
+ push @uop, $$rt{val};
+
+ } elsif ($$rt{tag} eq 'OP' && $$rt{typ} eq 'b') {
+ $bop = $$rt{val};
+
+ } elsif ($$rt{val} eq '<') {
+ my $pend = $$rt{pend};
+ die "BUGCHECK: pend not found for rtl[$i]" unless defined $pend;
+ push @val, eval_exp($rl,$i+1,$pend-1,1);
+ $i = $pend;
+
+ } else {
+ die "BUGCHECK: tag='$$rt{tag}', val='$$rt{val}'\n";
+ }
+
+ # if stack non-empty: return undef on undef, apply unary operators
+ if (scalar(@val) > 0) {
+ return undef unless defined $val[-1];
+ my $o;
+ while($o = pop @uop) {
+ my $v = pop @val;
+ if ($o eq '+') {
+ } elsif ($o eq '-') {
+ $v = -$v;
+ } elsif ($o eq '^c') {
+ $v = ~$v;
+ } else {
+ die "BUGCHECK: tag='OP(u)', val='$o'\n";
+ }
+ push @val, (0177777 & $v);
+ }
+ }
+
+ # if stack has 2 operands: apply binary operator
+ if (scalar(@val) == 2) {
+ die "BUGCHECK: bop not defined" unless defined $bop;
+ my $v2 = pop @val;
+ my $v1 = pop @val;
+ return undef unless defined $v1 && defined $v2;
+ if ($bop eq '+') {
+ push @val, int($v1) + int($v2);
+ } elsif ($bop eq '-') {
+ push @val, int($v1) - int($v2);
+ } elsif ($bop eq '*') {
+ push @val, int($v1) * int($v2);
+ } elsif ($bop eq '/') {
+ push @val, int(int($v1) / int($v2));
+ } elsif ($bop eq '&') {
+ push @val, int($v1) & int($v2);
+ } elsif ($bop eq '!') {
+ push @val, int($v1) | int($v2);
+ } else {
+ die "BUGCHECK: tag='OP(b)', val='$bop'\n";
+ }
+ $bop = undef;
+ }
+
+ }
+ return pop @val;
+}
+
+#-------------------------------------------------------------------------------
+# returns true if symbol looks like a local label (1234$)
+
+sub check_llbl {
+ my ($name) = @_;
+ return ($name =~ m/^\d+\$/) ? 1 : 0;
+}
+
+#-------------------------------------------------------------------------------
+# returns register number if register symbol, or undef
+
+sub check_reg {
+ my ($rt) = @_;
+ return undef unless $$rt{tag} eq 'SYM';
+ my $pse = $pst{$$rt{val}};
+ return undef unless defined $pse;
+ return undef unless $$pse{typ} eq 'reg';
+ return $$pse{val};
+}
+
+#-------------------------------------------------------------------------------
+# returns true if token has specific tag/val
+
+sub check_token {
+ my ($rt, $tag, $val) = @_;
+ return undef unless $$rt{tag} eq $tag;
+ return $$rt{val} eq $val;
+}
+
+#-------------------------------------------------------------------------------
+
+sub pushback_token {
+ my ($rl) = @_;
+
+ my $rt = pop @{$$rl{tl}};
+ push @t_pushback, $rt;
+
+ if ($opts{ttoken}) {
+ printf "-- token-back: tag=%-3s val='%s'\n",
+ $$rt{tag}, savestr($$rt{val});
+ }
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub get_token {
+ my ($rl, $tmask) = @_;
+ my $rt;
+
+ if (scalar(@t_pushback)) {
+ $rt = pop @t_pushback;
+ if ($opts{ttoken}) {
+ printf "-- token-reget: tag=%-3s val='%s'\n",
+ $$rt{tag}, savestr($$rt{val});
+ }
+
+ } else {
+ $rt = get_token1($rl, $tmask);
+ if ($opts{ttoken}) {
+ printf "-- token-get: tag=%-3s val='%s'\n",
+ $$rt{tag}, savestr($$rt{val});
+ }
+ }
+
+ push @{$$rl{tl}}, $rt;
+
+ return $rt;
+}
+
+#-------------------------------------------------------------------------------
+
+sub finish_token {
+ my $rt = shift @_;
+ while (scalar(@_)) {
+ my $tag = shift @_;
+ my $val = shift @_;
+ $$rt{$tag} = $val;
+ }
+ return $rt;
+}
+
+#-------------------------------------------------------------------------------
+
+sub get_token1 {
+ my ($rl, $tmask) = @_;
+ my $rcl = $$rl{cl};
+
+ my $val;
+ my $ws = '';
+
+ # drop any leading whitespace
+ while (scalar(@$rcl)) {
+ last if ($$rcl[0] !~ m/\s/);
+ $ws .= shift @$rcl;
+ }
+
+ my %t = (mask => $tmask,
+ ws => $ws
+ );
+
+ # end of line ?
+ unless (scalar(@$rcl)) {
+ return finish_token(\%t, tag=>'EOL', val=>$val);
+ }
+
+ # get leading char
+ my $c = $$rcl[0];
+
+ # comment ? treated similar to end of line, comment saved in val
+ if($c eq ';') {
+ $val = join('',@$rcl);
+ @$rcl = ();
+ return finish_token(\%t, tag=>'EOL', val=>$val);
+ }
+
+ # here context dependent tokens
+ if ($tmask & TMASK_STRING) {
+ my $del = shift @$rcl;
+ if ($del eq '<') {
+ return finish_token(\%t, tag=> 'DEL', val=> $del);
+ } else {
+ my $str = $del;
+ while (scalar(@$rcl)) {
+ my $c = shift @$rcl;
+ $str .= $c;
+ return finish_token(\%t, tag=> 'STR', val=> $str) if $c eq $del;
+ }
+ add_err($rl, 'A');
+ return finish_token(\%t, tag=> 'STR', val=> $str);
+ }
+ }
+
+ # looks like symbol ?
+ if ($c =~ m/[a-zA-Z\$\.]/) {
+ while (scalar(@$rcl)) {
+ last if ($$rcl[0] !~ m/[a-zA-Z0-9\$\.]/);
+ $val .= shift @$rcl;
+ }
+ return finish_token(\%t, tag=> 'SYM', val=> $val);
+ }
+
+ # looks like number or local label ?
+ if ($c =~ m/[0-9]/) {
+ while (scalar(@$rcl)) {
+ last if ($$rcl[0] !~ m/[0-9]/);
+ $val .= shift @$rcl;
+ }
+ # check for local label
+ if (scalar(@$rcl) && $$rcl[0] eq '$') {
+ # FIXME_code: reject labels with numbers >64k-1
+ $val .= shift @$rcl;
+ return finish_token(\%t, tag=> 'SYM', val=> $val);
+ }
+ # looks like numerical constant
+ my $nval = undef;
+ # if trailing '.' seen, add and handle as decimal, otherwise as octal
+ if (scalar(@$rcl) && $$rcl[0] eq '.') {
+ $nval =int($val);
+ $val .= shift @$rcl;
+ if ($nval > 65535) {
+ add_err($rl, 'T');
+ $nval &= 0177777;
+ }
+ } else {
+ $nval = 0;
+ foreach my $cc (split '',$val) {
+ $nval = ($nval<<3) + int($cc);
+ add_err($rl, 'N') unless $cc =~ m/[0-7]/;
+ add_err($rl, 'T') unless $nval <= 0177777;
+ $nval &= 0177777;
+ }
+ }
+ return finish_token(\%t, tag=> 'NUM', val=> $val, nval=>$nval);
+ }
+
+ # looks like label delimiter (':' or '::') ?
+ if ($c eq ':') {
+ $val .= shift @$rcl;
+ $val .= shift @$rcl if (scalar(@$rcl) && $$rcl[0] eq ':');
+ return finish_token(\%t, tag=> 'LBL', val=> $val);
+ }
+
+ # looks assignment delimiter ('=','=:','==','==:') ?
+ if ($c eq '=') {
+ $val .= shift @$rcl;
+ $val .= shift @$rcl if (scalar(@$rcl) && $$rcl[0] eq '=');
+ $val .= shift @$rcl if (scalar(@$rcl) && $$rcl[0] eq ':');
+ return finish_token(\%t, tag=> 'ASS', val=> $val);
+ }
+
+ # operators
+ if ($c =~ m/^(\+|\-)$/ ) { # unary/binary operators
+ return finish_token(\%t, tag=> 'OP', typ=> 'ub', val=> shift @$rcl);
+ }
+ if ($c =~ m/^(\*|\/|\&|\!)$/ ) { # binary operators
+ return finish_token(\%t, tag=> 'OP', typ=> 'b', val=> shift @$rcl);
+ }
+ if ($c =~ m/^(\#|\@)$/ ) { # unary operators
+ return finish_token(\%t, tag=> 'OP', typ=> 'u', val=> shift @$rcl);
+ }
+
+ # ' and " operator
+ if ($c eq "'") {
+ $val .= shift @$rcl;
+ $c = shift @$rcl;
+ if (not defined $c) {
+ return finish_token(\%t, tag=> 'BAD', val=> $val);
+ }
+ $val .= $c;
+ return finish_token(\%t, tag => 'NUM', val=> $val, nval=>ord($c));
+ }
+
+ if ($c eq '"') {
+ $val .= shift @$rcl;
+ my $c1 = shift @$rcl;
+ my $c2 = shift @$rcl;
+ if (! defined $c1 || ! defined $c2) {
+ return finish_token(\%t, tag=> 'BAD', val=> $val);
+ }
+ $val .= $c1;
+ $val .= $c2;
+ return finish_token(\%t, tag => 'NUM', val=> $val,
+ nval=>ord($c2)<<8|ord($c1));
+ }
+
+ # universal ^ operator
+ if ($c eq '^') {
+ $val .= shift @$rcl;
+ $c = shift @$rcl;
+ if (not defined $c) {
+ return finish_token(\%t, tag=> 'BAD', val=> $val);
+ }
+ $val .= $c;
+ $c = lc($c);
+ if ($c eq 'c') {
+ return finish_token(\%t, tag=> 'OP', typ=> 'u', val=> $val);
+
+ } elsif ($c eq 'b') {
+ my $nval = 0;
+ while (scalar(@$rcl)) {
+ last if ($$rcl[0] !~ m/[0-9]/);
+ my $cc = shift @$rcl;
+ $nval = ($nval<<1) + int($cc);
+ add_err($rl, 'N') unless $cc =~ m/[0-1]/;
+ add_err($rl, 'T') unless $nval <= 0177777;
+ $nval &= 0177777;
+ $val .= $cc;
+ }
+ return finish_token(\%t, tag=> 'NUM', val=> $val, nval=> $nval);
+
+ } elsif ($c eq 'o') {
+ my $nval = 0;
+ while (scalar(@$rcl)) {
+ last if ($$rcl[0] !~ m/[0-9]/);
+ my $cc = shift @$rcl;
+ $nval = ($nval<<3) + int($cc);
+ add_err($rl, 'N') unless $cc =~ m/[0-7]/;
+ add_err($rl, 'T') unless $nval <= 0177777;
+ $nval &= 0177777;
+ $val .= $cc;
+ }
+ return finish_token(\%t, tag=> 'NUM', val=> $val, nval=> $nval);
+
+ } elsif ($c eq 'd') {
+ my $nval = 0;
+ while (scalar(@$rcl)) {
+ last if ($$rcl[0] !~ m/[0-9]/);
+ my $cc = shift @$rcl;
+ $nval = 10*$nval + int($cc);
+ add_err($rl, 'T') unless $nval <= 0177777;
+ $nval &= 0177777;
+ $val .= $cc;
+ }
+ return finish_token(\%t, tag=> 'NUM', val=> $val, nval=> $nval);
+
+ } elsif ($c eq 'x') {
+ my $nval = 0;
+ while (scalar(@$rcl)) {
+ last if ($$rcl[0] !~ m/[0-9a-fA-F]/);
+ my $cc = shift @$rcl;
+ $nval = ($nval<<4) + hex($cc);
+ add_err($rl, 'T') unless $nval <= 0177777;
+ $nval &= 0177777;
+ $val .= $cc;
+ }
+ return finish_token(\%t, tag=> 'NUM', val=> $val, nval=> $nval);
+
+ } elsif ($c eq 'r') {
+ my $nval = 0;
+ for (my $i=0; $i<3; $i++) {
+ last unless defined $$rcl[0];
+ last unless $$rcl[0] =~ m/^[0-9a-zA-Z\.\$\ ]$/;
+ $nval = 050 * $nval + to_rad50($$rcl[0]);
+ $val .= shift @$rcl;
+ }
+ return finish_token(\%t, tag=> 'NUM', val=> $val, nval=>$nval);
+
+ } else {
+ return finish_token(\%t, tag=> 'BAD', val=> $val);
+ }
+ }
+
+ # delimiters
+ if ($c =~ m|^[\(\)\,\<\>]$|) {
+ return finish_token(\%t, tag=> 'DEL', val=> shift @$rcl);
+ }
+
+ # can't handle stuff
+ $val = join('',@$rcl);
+ @$rcl = ();
+ return finish_token(\%t, tag=> 'BAD', val=> $val);
+}
+
+#-------------------------------------------------------------------------------
+
+sub to_rad50 {
+ my ($c) = @_;
+ return undef unless defined $c;
+ $c = lc($c);
+ return 0 if $c eq ' ';
+ return 001 + ord($c)-ord('a') if $c =~ m/^[a-z]$/;
+ return 033 if $c eq '$';
+ return 034 if $c eq '.';
+ return 036 + ord($c)-ord('0') if $c =~ m/^[0-9]$/;
+ return undef;
+}
+
+#-------------------------------------------------------------------------------
+
+sub pass2 {
+
+ my $fh;
+ if ($lst_do) {
+ if ($lst_fname eq "-") {
+ $fh = *STDOUT;
+ } else {
+ $fh = new FileHandle;
+ unless (open($fh, ">", $lst_fname)) {
+ print STDERR "asm-11-F: '$lst_fname' not writable, quiting..\n";
+ exit 1;
+ }
+ }
+ }
+
+ pass2_lst_beg($fh) if $lst_do;
+
+ foreach my $rl (@src) {
+
+ $$rl{dot} = getdot();
+ $llbl_scope = $$rl{lscope} if defined $$rl{lscope};
+
+ # handle label definitions
+ if (defined $$rl{label}) {
+ if (lst_checkmdef($$rl{label})) {
+ add_err($rl, 'M');
+ } else {
+ my $val = getsym($rl, $$rl{label}, 1);
+ if (! defined $val || $val != getdot()) {
+ add_err($rl, 'P');
+ }
+ }
+ }
+
+ # generate output data
+ pass2_out($rl);
+ # listing requested
+ pass2_lst_line($rl, $fh) if $lst_do;
+ # pass 2 dump requested
+ dump_rl($rl) if $opts{tpass2};
+
+ }
+
+ pass2_lst_end($fh) if $lst_do;
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub pass2_out {
+ my ($rl) = @_;
+
+ # quit without code generation for 'questionable syntax' lines
+ return if $$rl{err} =~ m/[IQ]/;
+
+ # return if no pass2 action (typ not defined)
+ return unless defined $$rl{typ};
+
+ # generate code
+ if ($$rl{typ} eq 'code') {
+ walign($rl);
+ my $opcode = $$rl{opcode};
+ my $opfmt = $$rl{opfmt};
+
+ # printf "+++1 $$rl{typ},$$rl{oper},%s,%s\n",
+ # savestr($opcode), savestr($opfmt);
+
+ if ($opfmt eq '-') {
+ out_opcode($rl, $opcode);
+
+ } elsif ($opfmt eq 'g') {
+ out_opcode($rl, $opcode | $$rl{o1mod}<<3 | $$rl{o1reg});
+ out_opdata($rl, $$rl{o1mod}, $$rl{o1reg},
+ $$rl{o1ebeg}, $$rl{o1eend});
+
+ } elsif ($opfmt eq 'gg') {
+ out_opcode($rl, $opcode | $$rl{o1mod}<<9 | $$rl{o1reg}<<6 |
+ $$rl{o2mod}<<3 | $$rl{o2reg});
+ out_opdata($rl, $$rl{o1mod}, $$rl{o1reg},
+ $$rl{o1ebeg}, $$rl{o1eend});
+ out_opdata($rl, $$rl{o2mod}, $$rl{o2reg},
+ $$rl{o2ebeg}, $$rl{o2eend});
+ } elsif ($opfmt eq 'r') {
+ out_opcode($rl, $opcode | $$rl{o1reg});
+ } elsif ($opfmt eq 'rg' || $opfmt eq 'gr') {
+ out_opcode($rl, $opcode | $$rl{o1reg}<<6 |
+ $$rl{o2mod}<<3 | $$rl{o2reg});
+ out_opdata($rl, $$rl{o2mod}, $$rl{o2reg},
+ $$rl{o2ebeg}, $$rl{o2eend});
+ } elsif ($opfmt eq 'n3') {
+ out_opcode_n($rl, $opcode, 07, $$rl{ebeg}, $$rl{eend});
+ } elsif ($opfmt eq 'n6') {
+ out_opcode_n($rl, $opcode, 077, $$rl{ebeg}, $$rl{eend});
+ } elsif ($opfmt eq 'n8') {
+ out_opcode_n($rl, $opcode, 0377, $$rl{ebeg}, $$rl{eend});
+ } elsif ($opfmt eq 's8') {
+ out_opcode_o($rl, $opcode, 's8', $$rl{ebeg}, $$rl{eend});
+ } elsif ($opfmt eq 'ru6') {
+ out_opcode_o($rl, $opcode|($$rl{o1reg}<<6), 'u6',
+ $$rl{ebeg}, $$rl{eend});
+ } else {
+ die "BUGCHECK: unknown opfmt '$opfmt'";
+ }
+
+ incdot($defincdot); # inc '.' after instruction done !
+ $defincdot = 0;
+
+ # generate data
+ } elsif ($$rl{typ} eq 'data') {
+ if ($$rl{oper} eq '.word' || $$rl{oper} eq '.byte' ) {
+ walign($rl) if $$rl{oper} eq '.word';
+ my $size = ($$rl{oper} eq '.word') ? 2 : 1;
+ my $mask = ($size == 2) ? 0177777 : 0377;
+ foreach (@{$$rl{delist}}) {
+ my $ibeg = $$_{ibeg};
+ my $iend = $$_{iend};
+ my $val = 0;
+ if (defined $ibeg) {
+ $val = eval_exp($rl, $ibeg, $iend);
+ if (not defined $val) {
+ $val = 0;
+ add_err($rl, 'U');
+ }
+ }
+ # FIXME_code: handle T error here !!
+ $val &= $mask;
+ if ($$rl{oper} eq '.word') {
+ out_w($rl, $val);
+ } else {
+ out_b($rl, $val);
+ }
+ }
+
+ } elsif ($$rl{oper} eq '.blkw' || $$rl{oper} eq '.blkb' ) {
+ walign($rl) if $$rl{oper} eq '.blkw';
+ incdot($$rl{incdot});
+
+ } elsif ($$rl{oper} eq '.ascii' || $$rl{oper} eq '.asciz' ) {
+ foreach my $rd (@{$$rl{delist}}) {
+ if (defined $$rd{str}) {
+ my @chr = split '',$$rd{str};
+ shift @chr;
+ pop @chr;
+ foreach (@chr) {
+ push @{$$rl{outb}}, ord($_);
+ }
+ } else {
+ my $val = eval_exp($rl, $$rd{ibeg}, $$rd{iend});
+ if (not defined $val) {
+ $val = 0;
+ add_err($rl, 'U');
+ }
+ if ($val < 0 || $val > 0377) {
+ $val &= 0377;
+ add_err($rl, 'T');
+ }
+ push @{$$rl{outb}}, $val;
+ }
+ }
+ push @{$$rl{outb}}, 0 if $$rl{oper} eq '.asciz';
+ incdot(scalar(@{$$rl{outb}}));
+
+ } elsif ($$rl{oper} eq '.even' || $$rl{oper} eq '.odd' ) {
+ if ($$rl{incdot}) {
+ push @{$$rl{outb}}, 0;
+ incdot(1);
+ }
+
+ } else {
+ die "BUGCHECK: unknown data oper '$$rl{oper}'";
+ }
+
+ # handle assignments
+ } elsif ($$rl{typ} eq 'ass') {
+ my $val = eval_exp($rl, $$rl{ebeg}, $$rl{eend});
+ if (defined $val) {
+ $$rl{lstval} = $val;
+ setsym($rl, $$rl{atyp}, $$rl{asym}, $val);
+ } else {
+ $$rl{lstval} = 0;
+ add_err($rl, 'U');
+ }
+
+ } else {
+ die "BUGCHECK: unknown line typ '$$rl{typ}'";
+ }
+
+ if (scalar(@{$$rl{outw}})) {
+ emitw($$rl{dot}, $$rl{outw});
+ } elsif (scalar(@{$$rl{outb}})) {
+ emitb($$rl{dot}, $$rl{outb});
+ }
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub pass2_lst_beg {
+ my ($fh) = @_;
+ printf $fh "; Input file list:\n";
+ my $fileno = 1;
+ foreach my $fname (@flist) {
+ $fname =~ s/^$ENV{RETROBASE}/\$RETROBASE/;
+ printf $fh "; %2d: %s\n", $fileno, $fname;
+ $fileno += 1;
+ }
+ print $fh ";\n";
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub pass2_lst_end {
+ my ($fh) = @_;
+ if ($errcnt_tot) {
+ print $fh ";\n";
+ print $fh "; Error summary:\n";
+ foreach my $err (sort keys %errcnt) {
+ printf $fh "; %s: %3d\n", $err, $errcnt{$err};
+ }
+ }
+ return;
+}
+
+#-------------------------------------------------------------------------------
+# line format is
+# er fn lnum dot source
+# .. dd dddd oooooo oooooo oooooo oooooo
+# .. ooo ooo ooo ooo ooo
+
+sub pass2_lst_line {
+ my ($rl,$fh) = @_;
+
+ my @ow = @{$$rl{outw}};
+ my @ob = @{$$rl{outb}};
+ my $str = '';
+ $str .= sprintf("%-2s", prt_err($rl));
+ $str .= sprintf(" %2d", $$rl{fileno});
+ $str .= sprintf(" %4d", $$rl{lineno});
+
+ # print dot if data is generated for this line, or label
+ my $prtdot = defined $$rl{lstdot} ||
+ scalar(@{$$rl{outw}}) ||
+ scalar(@{$$rl{outb}}) ||
+ $$rl{label};
+ if ($prtdot) {
+ $str .= prt76o($$rl{dot});
+ } else {
+ $str .= ' ';
+ }
+
+ if (defined $$rl{lstval}) {
+ $str .= prt76o($$rl{lstval});
+ $str .= ' ' x 14;
+ } elsif (scalar(@ow)) {
+ for (my $i=0; $i<3; $i++) { $str .= prt76o(shift @ow); }
+ } elsif (scalar(@ob)) {
+ for (my $i=0; $i<5; $i++) { $str .= prt43o(shift @ob); }
+ $str .= ' ';
+ } else {
+ $str .= ' ' x 21;
+ }
+
+ $str .= ' ' . $$rl{line} . "\n";
+ print $fh $str;
+ if (1) {
+ while (scalar(@ow)) {
+ $str = ' ';
+ for (my $i=0; $i<3; $i++) { $str .= prt76o(shift @ow); }
+ print $fh $str . "\n";
+ }
+ while (scalar(@ob)) {
+ $str = ' ';
+ for (my $i=0; $i<5; $i++) { $str .= prt43o(shift @ob); }
+ print $fh $str . "\n";
+ }
+ }
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub out_w {
+ my ($rl,$word) = @_;
+ push @{$$rl{outw}}, $word;
+ incdot(2);
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub out_wop {
+ my ($rl,$word) = @_;
+ push @{$$rl{outw}}, $word;
+ $defincdot += 2;
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub out_b {
+ my ($rl,$byte) = @_;
+ push @{$$rl{outb}}, $byte;
+ incdot(1);
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub out_opcode {
+ my ($rl,$code) = @_;
+ out_wop($rl, $code);
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub out_opcode_n {
+ my ($rl,$code,$mask,$ebeg,$eend) = @_;
+ # FIXME_code: shouldn't we die here ?
+ return unless defined $ebeg;
+
+ my $val = eval_exp($rl,$ebeg,$eend);
+ unless (defined $val) {
+ $val = 0;
+ add_err($rl, 'A');
+ }
+ if ($val & ~$mask) {
+ $val &= $mask;
+ add_err($rl, 'T');
+ }
+ out_wop($rl, $code|$val);
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub out_opcode_o {
+ my ($rl,$code,$typ,$ebeg,$eend) = @_;
+ # FIXME_code: shouldn't we die here ?
+ return unless defined $ebeg;
+
+ my $val = eval_exp($rl,$ebeg,$eend);
+ my $off;
+ if (defined $val) {
+ $off = ($val - (getdot()+2)) / 2;
+ } else {
+ $off = -1;
+ add_err($rl, 'U');
+ }
+
+ if ($typ eq 's8') {
+ if ($off > 127 || $off < -128) {
+ add_err($rl, 'A');
+ }
+ $off &= 0377;
+ } else {
+ $off = -$off;
+ if ($off > 63 || $off < 0) {
+ add_err($rl, 'A');
+ }
+ $off &= 0077;
+ }
+ out_wop($rl, $code|$off);
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub out_opdata {
+ my ($rl,$mod,$reg,$ebeg,$eend) = @_;
+ # FIXME_code: shouldn't we die here ?
+ return unless defined $ebeg;
+
+ my $val = eval_exp($rl,$ebeg,$eend);
+ unless (defined $val) {
+ out_wop($rl, 0);
+ add_err($rl, 'U');
+ return;
+ }
+ if ($mod>=6 && $reg==7) { # handle pc relative offsets
+ $val = ($val - (getdot()+$defincdot+2)) & 0177777;
+ }
+ out_wop($rl, $val);
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub emitw {
+ my ($baddr,$rwl) = @_;
+ if ($opts{temit}) {
+ printf "-- emit: w %6.6o:", $baddr;
+ foreach my $w (@$rwl) { printf " %6.6o", $w; }
+ print "\n";
+ }
+ return unless scalar(@$rwl);
+
+ if ((! defined $out_dot) || $out_dot!=$baddr || $out_data[-1]->{typ} ne 'w') {
+ push @out_data, {typ=> 'w', addr=>$baddr, data=>[@$rwl]};
+ } else {
+ my $rdata = $out_data[-1]->{data};
+ push @$rdata, @$rwl;
+ }
+ $out_dot = $baddr+2;
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub emitb {
+ my ($baddr,$rbl) = @_;
+ if ($opts{temit}) {
+ printf "-- emit: b %6.6o:", $baddr;
+ foreach my $b (@$rbl) { printf " %3.3o", $b; }
+ print "\n";
+ }
+ return unless scalar(@$rbl);
+
+ if ((! defined $out_dot) || $out_dot!=$baddr || $out_data[-1]->{typ} ne 'b') {
+ push @out_data, {typ=> 'b', addr=>$baddr, data=>[@$rbl]};
+ } else {
+ my $rdata = $out_data[-1]->{data};
+ push @$rdata, @$rbl;
+ }
+ $out_dot = $baddr+1;
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub write_lda_frame {
+ my ($fh,$addr,$rblist) = @_;
+ my $len = 6 + scalar(@$rblist);
+ my @f;
+ push @f, 0x01;
+ push @f, 0x00;
+ push @f, $len & 0xff;
+ push @f, ($len>>8) & 0xff;
+ push @f, $addr & 0xff;
+ push @f, ($addr>>8) & 0xff;
+ push @f, @$rblist if $len;
+ my $csum = 0;
+ foreach (@f) { $csum = ($csum + $_) & 0xff; }
+ push @f, (-$csum) & 0xff;
+
+ if ($opts{tout}) {
+ my $nval = 0;
+ printf "-- out: %6.6o:", $addr;
+ foreach (@f) {
+ if ($nval == 16) {
+ printf "\n ";
+ $nval = 0;
+ }
+ printf " %3.3o", $_;
+ $nval += 1;
+ }
+ printf "\n";
+ }
+
+ my $buf = pack("C*", @f);
+ my $rc = syswrite($fh, $buf, length($buf));
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub write_lda {
+ my ($fname) = @_;
+ my $fh;
+ if ($fname eq "-") {
+ $fh = *STDOUT;
+ } else {
+ $fh = new FileHandle;
+ unless (open($fh, ">:raw", $fname)) {
+ print STDERR "asm-11-F: '$fname' not writable, quiting..\n";
+ exit 1;
+ }
+ }
+
+ my @blist;
+ my $base;
+ my $dot;
+ foreach my $rl (@src) {
+ die "BUGCHECK: both outb and outw contain data"
+ if scalar(@{$$rl{outb}}) && scalar(@{$$rl{outw}});
+
+ my @byt = @{$$rl{outb}};
+ foreach (@{$$rl{outw}}) {
+ push @byt, $_ & 0xff;
+ push @byt, ($_>>8) & 0xff;
+ }
+
+ next unless scalar(@byt);
+
+ # flush frame if new data not adjacent to old
+ if (scalar(@blist) && $dot!=$$rl{dot}) {
+ write_lda_frame($fh, $base, \@blist);
+ @blist = ();
+ $base = undef;
+ $dot = undef;
+ }
+
+ $dot = $base = $$rl{dot} unless defined $base;
+
+ foreach (@byt) {
+ if (scalar(@blist) >= 2*168) {
+ write_lda_frame($fh, $base, \@blist);
+ @blist = ();
+ $base = $dot;
+ }
+ push @blist, $_ & 0xff;
+ $dot += 1;
+ }
+
+ }
+
+ # flush buffer
+ write_lda_frame($fh, $base, \@blist) if scalar(@blist);
+ @blist = ();
+
+ # write terminating frame
+ write_lda_frame($fh, $out_start, \@blist);
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub write_cof_frame {
+ my ($fh,$typ,$addr,$rlist) = @_;
+ my $fmt = ($typ eq 'w') ? '%6.6o' : '%3.3o';
+ my $max = ($typ eq 'w') ? 10 : 20 ;
+
+ printf $fh "$typ %6.6o {\n", $addr;
+ my $i = 0;
+ foreach (@$rlist) {
+ $i += 1;
+ printf $fh "$fmt ", $_;
+ print $fh "\n" if $i%$max == 0;
+ }
+ print $fh "\n" unless $i%$max == 0;
+ print $fh "}\n";
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub write_cof {
+ my ($fname) = @_;
+ my $fh;
+ if ($fname eq "-") {
+ $fh = *STDOUT;
+ } else {
+ $fh = new FileHandle;
+ unless (open($fh, ">:raw", $fname)) {
+ print STDERR "asm-11-F: '$fname' not writable, quiting..\n";
+ exit 1;
+ }
+ }
+
+ print $fh "sym {\n";
+ foreach my $key (sort keys %lst) {
+ next unless $lst{$key}{typ} =~ m/^(lbl|llbl)$/;
+ printf $fh "%s => %s\n", $lst{$key}{name}, save66o($lst{$key}{val});
+ }
+ print $fh "}\n";
+ print $fh "dat {\n";
+
+ my @list;
+ my $typ;
+ my $base;
+ my $dot;
+
+ foreach my $rl (@src) {
+
+ if (scalar(@{$$rl{outb}})) {
+ if (scalar(@list) && ($typ ne 'b' || $dot != $$rl{dot})) {
+ write_cof_frame($fh, $typ, $base, \@list);
+ @list = ();
+ }
+ unless (scalar(@list)) {
+ $typ = 'b';
+ $base = $dot = $$rl{dot};
+ }
+ push @list, @{$$rl{outb}};
+ $dot += scalar(@{$$rl{outb}});
+ }
+
+ if (scalar(@{$$rl{outw}})) {
+ if (scalar(@list) && ($typ ne 'w' || $dot != $$rl{dot})) {
+ write_cof_frame($fh, $typ, $base, \@list);
+ @list = ();
+ }
+ unless (scalar(@list)) {
+ $typ = 'w';
+ $base = $dot = $$rl{dot};
+ }
+ push @list, @{$$rl{outw}};
+ $dot += 2 * scalar(@{$$rl{outw}});
+ }
+ }
+
+ write_cof_frame($fh, $typ, $base, \@list)
+ if scalar(@list);
+
+ print $fh "}\n";
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub write_lsm {
+ my ($fname) = @_;
+ my $fh;
+ if ($fname eq "-") {
+ $fh = *STDOUT;
+ } else {
+ $fh = new FileHandle;
+ unless (open($fh, ">:raw", $fname)) {
+ print STDERR "asm-11-F: '$fname' not writable, quiting..\n";
+ exit 1;
+ }
+ }
+
+ my %mem;
+
+ foreach my $rl (@src) {
+
+ my $dot = $$rl{dot};
+ if (scalar(@{$$rl{outb}})) {
+ foreach my $byte (@{$$rl{outb}}) {
+ my $addr = sprintf "%6.6o", $dot & 0xfffe;
+ $mem{$addr} = 0 unless exists $mem{$addr};
+ if ($dot & 0x1) { # odd byte
+ $mem{$addr} = (($byte&0xff)<<8) | ($mem{$addr} & 0xff);
+ } else { # even byte
+ $mem{$addr} = ($mem{$addr} & 0xff00) | ($byte&0xff);
+ }
+ $dot += 1;
+ }
+ }
+
+ if (scalar(@{$$rl{outw}})) {
+ foreach my $word (@{$$rl{outw}}) {
+ my $addr = sprintf "%6.6o", $dot;
+ $mem{$addr} = $word;
+ $dot += 2;
+ }
+ }
+ }
+
+ foreach my $addr (sort keys %mem) {
+ printf $fh "%s : %6.6o\n", $addr, $mem{$addr};
+ }
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub dump_rl {
+ my ($rl) = @_;
+
+ printf "-- line: '%s'\n", $$rl{line};
+ printf " err=%-3s, typ=%-4s, oper=%-6s, lineno=%3d, psect=%-6s, .=%6.6o\n",
+ prt_err($rl), savestr($$rl{typ}), savestr($$rl{oper}), $$rl{lineno},
+ $$rl{psect}, $$rl{dot};
+ my $i = 0;
+ foreach my $rt (@{$$rl{tl}}) {
+ printf " tl[%2d]: tag=%-4s, om=%-2s, em=%-2s, val='%s'",
+ $i, $$rt{tag}, savestr1($$rt{om}), savestr1($$rt{em}),
+ savestr($$rt{val});
+ printf ", nval=%6.6o",$$rt{nval} if defined $$rt{nval};
+ printf ", pend=%d",$$rt{pend} if defined $$rt{pend};
+ printf "\n";
+ $i += 1;
+ }
+ if (defined $$rl{delist}) {
+ $i = 0;
+ my $rdl = $$rl{delist};
+ foreach my $rd (@$rdl) {
+ printf " dl[%2d]:", $i;
+ printf " str='%s'",$$rd{str} if defined $$rd{str};
+ printf " ibeg=%s, iend=%s", savestr($$rd{ibeg}), savestr($$rd{iend})
+ if exists $$rd{ibeg};
+ printf "\n";
+ $i += 1;
+ }
+ }
+ if (defined $$rl{opcode}) {
+ printf " code: %6.6o,fmt=%-2s", $$rl{opcode}, $$rl{opfmt};
+ if (defined $$rl{o1mod}) {
+ printf ", o1=%s%s", $$rl{o1mod},$$rl{o1reg};
+ printf ",ei=%d:%d,val=%s", $$rl{o1ebeg}, $$rl{o1eend},
+ save66o(eval_exp($rl, $$rl{o1ebeg}, $$rl{o1eend}))
+ if defined $$rl{o1ebeg};
+ }
+ if (defined $$rl{o2mod}) {
+ printf ", o2=%s%s", $$rl{o2mod},$$rl{o2reg};
+ printf ",ei=%d:%d,val=%s", $$rl{o2ebeg}, $$rl{o2eend},
+ save66o(eval_exp($rl, $$rl{o2ebeg}, $$rl{o2eend}))
+ if defined $$rl{o2ebeg};
+ }
+ printf " ex=%d:%d,val=%s", $$rl{ebeg}, $$rl{eend},
+ save66o(eval_exp($rl, $$rl{ebeg}, $$rl{eend}))
+ if defined $$rl{ebeg};
+ print "\n";
+ }
+ if (scalar(@{$$rl{outw}})) {
+ print " outw:";
+ foreach (@{$$rl{outw}}) { printf " %6.6o", $_; }
+ print "\n";
+ }
+ if (scalar(@{$$rl{outb}})) {
+ print " outb:";
+ foreach (@{$$rl{outb}}) { printf " %3.3o", $_; }
+ print "\n";
+ }
+ foreach my $key (sort keys %{$rl}) {
+ next if $key =~ m/^(line|err|typ|oper|lineno|psect|dot|opcode|opfmt|o[12](mod|reg|ebeg|eend)|ebeg|eend|tl|delist|outw|outb)$/;
+ printf " %-6s: %s\n", $key, savestr($$rl{$key});
+ }
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub dump_sym {
+ print "\n";
+ print " psect dot dotmax\n";
+ print "------ ------ ------\n";
+ foreach my $ps (sort keys %psect) {
+ printf "%-6s %6.6o %6.6o\n", $ps, $psect{$ps}{dot}, $psect{$ps}{dotmax};
+ }
+
+ print "\n";
+ print "scope symbol typ psect val\n";
+ print "------ ------ ---- ------ ------\n";
+ foreach my $key (sort keys %lst) {
+ my $sym = $lst{$key}{name};
+ my $scope = '';
+ my $name = $sym;
+ if ($sym =~ m/^(.+):(.+)$/) {
+ $scope = $1;
+ $name = $2;
+ }
+ printf "%-6s %-6s %-4s %-6s %s\n", $scope, $name, $lst{$key}{typ},
+ $lst{$key}{psect}, save66o($lst{$key}{val});
+ }
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub prt76o {
+ my ($val) = @_;
+ return ' ' unless defined $val;
+ return sprintf " %6.6o", $val;
+}
+
+#-------------------------------------------------------------------------------
+
+sub prt43o {
+ my ($val) = @_;
+ return ' ' unless defined $val;
+ return sprintf " %3.3o", $val;
+}
+
+#-------------------------------------------------------------------------------
+
+sub save66o {
+ my ($val) = @_;
+ return '' unless defined $val;
+ return sprintf "%6.6o", $val;
+}
+
+#-------------------------------------------------------------------------------
+
+sub savestr {
+ my ($str) = @_;
+ return '' unless defined $str;
+ return $str;
+}
+
+#-------------------------------------------------------------------------------
+
+sub savestr1 {
+ my ($str) = @_;
+ return '-' unless defined $str;
+ return $str;
+}
+
+#-------------------------------------------------------------------------------
+
+sub print_help {
+ print "usage: asm-11 [OPTIONS]... [FILE]...\n";
+ print " --I=path adds path to the .include search path\n";
+ print " --lst create listing (default file name)\n";
+ print " --olst=fnam create listing (concrete file name)\n";
+ print " --lda create absolute loader output (default file name)\n";
+ print " --olda create absolute loader output (concrete file name)\n";
+ print " --cof create compound output (default file name)\n";
+ print " --ocof=fnam create compound output (concrete file name)\n";
+ print " --tpass1 trace line context in pass 1\n";
+ print " --tpass2 trace line context in pass 2\n";
+ print " --dsym1 dump psect and ust tables after pass 1\n";
+ print " --dsym2 dump psect and ust tables after pass 2\n";
+ print " --ttoken trace tokenizer\n";
+ print " --tparse trace parser\n";
+ print " --temit trace code emit\n";
+ print " --tout trace output file write\n";
+ print " --help print this text and exit\n";
+ return;
+}
asm-11
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: dmscntconv
===================================================================
--- dmscntconv (nonexistent)
+++ dmscntconv (revision 38)
@@ -0,0 +1,182 @@
+#!/usr/bin/perl -w
+# $Id: dmscntconv 721 2015-12-29 17:50:50Z mueller $
+#
+# Copyright 2015- by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2015-12-28 721 1.0.1 adopt to new syntax of STATE2SNUM mapper
+# 2015-06-27 695 1.0 Initial version
+#
+
+use 5.14.0; # require Perl 5.14 or higher
+use strict; # require strict checking
+
+use Getopt::Long;
+
+my %opts = ();
+
+GetOptions(\%opts, "help", "src=s")
+ or die "bad options";
+
+sub print_help;
+sub do_src;
+sub do_file;
+
+my @snum2nam;
+my %snam2num;
+my %dat_all;
+my %dat_km;
+my %dat_um;
+
+autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
+
+if (exists $opts{help}) {
+ print_help;
+ exit 0;
+}
+
+if (scalar(@ARGV) == 0) {
+ print STDERR "dmscntconv-E: no input file specified\n";
+ print_help;
+ exit 1;
+}
+
+$opts{src} = $ENV{RETROBASE} . "/rtl/w11a/pdp11_sequencer.vhd"
+ unless defined $opts{src};
+
+do_src($opts{src});
+
+foreach my $file (@ARGV) {
+ do_file($file);
+}
+
+print "#sn state all km usm" .
+ " all% km% usm%\n";
+
+my $sum_all = 0;
+my $sum_km = 0;
+my $sum_um = 0;
+
+foreach (keys %dat_all) {
+ $sum_all += $dat_all{$_};
+ $sum_km += $dat_km{$_};
+ $sum_um += $dat_um{$_};
+}
+
+my $div_all = ($sum_all>0.) ? $sum_all : 1.;
+my $div_km = ($sum_km >0.) ? $sum_km : 1.;
+my $div_um = ($sum_um >0.) ? $sum_um : 1.;
+
+printf "# sum_all %11.0f %11.0f %11.0f %6.2f %6.2f %6.2f\n",
+ $sum_all, $sum_km, $sum_um,
+ 100., 100.*($sum_km/$sum_all), 100.*($sum_um/$sum_all);
+
+for (my $snum=0; $snum) {
+ chomp;
+ if (m/^\s*-- STATE2SNUM mapper begin/) {
+ $begin_seen = 1;
+ next;
+ }
+ next unless $begin_seen;
+ last if m/^\s*-- STATE2SNUM mapper end/;
+ next if m/^\s*$/;
+ if (m/^\s+when
+ \s+(\w+)
+ \s+=>\s*isnum\s*:=
+ \s*x"([[:xdigit:]]+)";/x) {
+ my $snam=$1;
+ my $snum=hex($2);
+ $snum2nam[$snum] = $snam;
+ $snam2num{$snam} = $snum;
+ } else {
+ printf STDERR "bad line: $_\n";
+ }
+
+ }
+
+ close SFILE;
+}
+
+#-------------------------------------------------------------------------------
+
+sub do_file {
+ my ($file) = @_;
+
+ %dat_km = ();
+ %dat_um = ();
+ %dat_all = ();
+
+ open IFILE,"<$file" or die "failed to open $file";
+
+ while () {
+ chomp;
+ next if m/^#/;
+ if (m/^\s*([[:xdigit:]]+)
+ \s+([[:xdigit:]]+)
+ \s+([[:xdigit:]]+)
+ \s+([[:xdigit:]]+)\s*$/x) {
+ my $sn = hex($1);
+ my $d2 = hex($2);
+ my $d1 = hex($3);
+ my $d0 = hex($4);
+ my $cnt = 1. * $d0;
+ $cnt += 65536. * $d1;
+ $cnt += 65536.*65536.* $d2;
+ my $snum = $sn % 256;
+ my $km = $sn < 256;
+ my $snam = $snum2nam[$snum];
+ if (defined $snam) {
+ $dat_all{$snam} += $cnt;
+ if ($km) {
+ $dat_km{$snam} += $cnt;
+ } else {
+ $dat_um{$snam} += $cnt;
+ }
+ } else {
+ printf STDERR "bad snum: $_\n" if $cnt;
+ }
+ } else {
+ printf STDERR "bad line: $_\n";
+ }
+ }
+
+ close IFILE;
+
+}
+
+#-------------------------------------------------------------------------------
+
+sub print_help {
+ print "usage: dmscntconv [--src=source] file\n";
+ print " --help this message\n";
+}
dmscntconv
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: create_disk
===================================================================
--- create_disk (nonexistent)
+++ create_disk (revision 38)
@@ -0,0 +1,283 @@
+#!/usr/bin/perl -w
+# $Id: create_disk 692 2015-06-21 11:53:24Z mueller $
+#
+# Copyright 2013-2014 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2015-06-21 692 1.1.2 use sysseek rather seek; add RM80
+# 2015-04-06 665 1.1.1 add alias RM03 (for RM02) and RP05 (for RP04)
+# 2014-06-14 562 1.1 BUGFIX: repair --boot; add RM02,RM05,RP04,RP07
+# 2013-05-20 521 1.0 First draft
+#
+
+use 5.10.0; # require Perl 5.10 or higher
+use strict; # require strict checking
+
+use Getopt::Long;
+use FileHandle;
+use Fcntl qw(:seek);
+
+my %opts = ();
+
+GetOptions(\%opts, "help", "typ=s", "ini=s", "bad", "boot"
+ )
+ or exit 1;
+
+sub do_inipatt;
+sub do_badtable;
+sub do_boot;
+sub print_help;
+
+# disk type table
+my %disktype = (
+ RK05 => {cyl=> 203, hd=> 2, sec=> 12, bps=> 512, bad=>0},
+ RL01 => {cyl=> 256, hd=> 2, sec=> 40, bps=> 256, bad=>1},
+ RL02 => {cyl=> 512, hd=> 2, sec=> 40, bps=> 256, bad=>1},
+ RM03 => {cyl=> 823, hd=> 5, sec=> 32, bps=> 512, bad=>1},
+ RM05 => {cyl=> 823, hd=> 19, sec=> 32, bps=> 512, bad=>1},
+ RM80 => {cyl=> 559, hd=> 14, sec=> 31, bps=> 512, bad=>1},
+ RP05 => {cyl=> 411, hd=> 19, sec=> 22, bps=> 512, bad=>1},
+ RP06 => {cyl=> 815, hd=> 19, sec=> 22, bps=> 512, bad=>1},
+ RP07 => {cyl=> 630, hd=> 32, sec=> 50, bps=> 512, bad=>1}
+);
+
+autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
+
+if (exists $opts{help}) {
+ print_help(1);
+ exit 0;
+}
+
+if (scalar(@ARGV) != 1) {
+ print STDERR "create_disk-E: specify one and only one output file\n";
+ print_help(0);
+ exit 1;
+}
+
+my $fnam = shift @ARGV;
+
+if (-e $fnam) {
+ print STDERR "create_disk-E: file '$fnam' exists already\n";
+ exit 1;
+}
+
+my $typ = uc($opts{typ});
+
+$typ = "RM03" if defined $typ && $typ eq "RM02"; # RM02 is equivalent to RM03
+$typ = "RP05" if defined $typ && $typ eq "RP04"; # RM04 is equivalent to RP05
+
+unless (defined $typ && exists $disktype{$typ}) {
+ print STDERR "create_disk-E: no or invalid --typ specification, use --help\n";
+ exit 1;
+}
+
+my $cyl = $disktype{$typ}{cyl};
+my $hd = $disktype{$typ}{hd};
+my $sec = $disktype{$typ}{sec};
+my $bps = $disktype{$typ}{bps};
+my $bad = $disktype{$typ}{bad};
+
+if ($opts{bad} && !$bad) {
+ print STDERR "create_disk-E: --bad not supported for type '$typ', abort\n";
+ exit 1;
+}
+
+my $nblk = $cyl*$hd*$sec;
+my $cap = $nblk * $bps;
+
+my $fh = new FileHandle;
+sysopen($fh, $fnam, O_RDWR|O_CREAT)
+ or die "failed to create '$fnam': $!";
+
+# seek to end, write 1 byte at end
+my $rc = sysseek($fh, $cap-1, SEEK_SET);
+if (not $rc) {die "seek failed: $!";}
+my $buf = pack('C1',0);
+$rc = syswrite($fh, $buf, length($buf));
+if ($rc<=0) {die "write failed: $!";}
+
+# handle init patterns
+do_inipatt if $opts{ini};
+
+# handle factory bad block table
+do_badtable if $opts{bad};
+
+# write dummy boot block
+do_boot if $opts{boot};
+
+#-------------------------------------------------------------------------------
+
+sub do_inipatt {
+ my $ini = $opts{ini};
+
+ if ($ini eq 'zero' || $ini eq 'ones' || $ini eq 'dead') {
+ my @dat;
+ for (my $i=0; $i<$bps/4; $i++) {
+ push @dat, 0,0 if $ini eq 'zero';
+ push @dat, -1,-1 if $ini eq 'ones';
+ push @dat, 0xdead,0xbeaf if $ini eq 'dead';
+ }
+ my $buf = pack('v*',@dat);
+ my $rc = sysseek($fh, 0, SEEK_SET);
+ if (not $rc) {die "seek failed: $!";}
+ for (my $i=0; $i<$nblk; $i++) {
+ $rc = syswrite($fh, $buf, length($buf));
+ if ($rc<=0) {die "write failed: $!";}
+ }
+
+ } elsif ($ini eq 'test') {
+ my $addr = 0;
+ my $cur_sec = 0;
+ my $cur_trk = 0;
+ my $cur_cyl = 0;
+ my $rc = sysseek($fh, 0, SEEK_SET);
+ if (not $rc) {die "seek failed: $!";}
+ for (my $i=0; $i<$nblk; $i++) {
+ my @dat;
+ for (my $i=0; $i<$bps/16; $i++) {
+ push @dat, ($addr & 0xffff);
+ push @dat, (($addr>>16) & 0xffff);
+ push @dat, $cur_cyl, $cur_trk, $cur_sec;
+ push @dat, $cyl, $hd, $sec;
+ $addr += 16;
+ }
+ my $buf = pack('v*',@dat);
+ $rc = syswrite($fh, $buf, length($buf));
+ if ($rc<=0) {die "write failed: $!";}
+ $cur_sec += 1;
+ if ($cur_sec >= $sec) {
+ $cur_sec = 0;
+ $cur_trk += 1;
+ if ($cur_trk >= $hd) {
+ $cur_trk = 0;
+ $cur_cyl += 1;
+ }
+ }
+ }
+
+ } else {
+ print STDERR "create_disk-W: unknown --ini mode '$ini', --ini ignored\n";
+ }
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub do_badtable {
+ my @dat;
+ push @dat, 012345, 012345; # pack number
+ push @dat, 0,0; # dummy c/s/h spec
+ for (my $i=4; $i<$bps/2; $i++) {
+ push @dat, -1; # end of table
+ }
+ my $buf = pack('v*',@dat);
+
+ my $pos = $cap - $sec*$bps; # position of last track
+ my $rc = sysseek($fh, $pos, SEEK_SET);
+ if (not $rc) {die "seek failed: $!";}
+ my $nsec = ($sec > 10) ? 10 : $sec; # write last track, at most 10 sec
+ for (my $i=0; $i<$nsec; $i++) {
+ $rc = syswrite($fh, $buf, length($buf));
+ if ($rc<=0) {die "write failed: $!";}
+ }
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub do_boot {
+ my @dat;
+
+ push @dat, 0012700, 0000100; # start: mov #text, r0
+ push @dat, 0105710; # 1$: tstb (r0)
+ push @dat, 0001406; # beq 3$
+ push @dat, 0105737, 0177564; # 2$: tstb @#XCSR
+ push @dat, 0100375; # bpl 2$
+ push @dat, 0112037, 0177566; # movb (r0)+,@#XBUF
+ push @dat, 0000770; # br 1$
+ push @dat, 0000000; # 3$: halt
+
+ my $buf = pack('v*',@dat);
+ my $rc = sysseek($fh, 0, SEEK_SET);
+ if (not $rc) {die "seek failed: $!";}
+ $rc = syswrite($fh, $buf, length($buf));
+ if ($rc<=0) {die "write failed: $!";}
+
+ $buf = "\r\n";
+ $buf .= "\r\n";
+ $buf .= "++======================================++\r\n";
+ $buf .= "|| This is not a hardware bootable disk ||\r\n";
+ $buf .= "++======================================++\r\n";
+ $buf .= "\r\n";
+ $buf .= "Disk image created with 'create_disk --typ=$typ':\r\n";
+ $buf .= sprintf " number of cylinders: %7d\r\n", $cyl;
+ $buf .= sprintf " tracks per cylinder: %7d\r\n", $hd;
+ $buf .= sprintf " sectors per track: %7d\r\n", $sec;
+ $buf .= sprintf " block size: %7d\r\n", $bps;
+ $buf .= sprintf " total number of sectors:%7d\r\n", $nblk;
+ $buf .= sprintf " capacity in kByte: %7d\r\n", $cap/1024;
+ $buf .= "\r\n";
+ $buf .= "CPU WILL HALT\r\n";
+ $buf .= "\r\n";
+
+ # NOTE: the text above almost fills the first 512 bytes !!
+ # don't add more text, all has been said anyway !!
+
+ $rc = sysseek($fh ,0100, SEEK_SET);
+ if (not $rc) {die "seek failed: $!";}
+ $rc = syswrite($fh, $buf, length($buf));
+ if ($rc<=0) {die "write failed: $!";}
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub print_help {
+ my ($ptyp) = @_;
+ print "usage: create_disk [options] \n";
+ print " --typ= specified disk type, must be specified\n";
+ print " --ini= initialization pattern, can be\n";
+ print " --bad create factory bad block table on last track\n";
+ print " --boot write dummy boot block, print volume info and HALT\n";
+ print " --help print full help, with list --typ and --ini options\n";
+ return unless $ptyp;
+
+ print "\n";
+ print "currently supported disk types:\n";
+ print " type #cyl #trk #sec bps tot_sec blocks -bad\n";
+ foreach my $typ (sort keys %disktype) {
+ my $cyl = $disktype{$typ}{cyl};
+ my $hd = $disktype{$typ}{hd};
+ my $sec = $disktype{$typ}{sec};
+ my $bps = $disktype{$typ}{bps};
+ printf " %4s %4d %4d %4d %4d %7d %7d %3s\n",
+ $typ, $cyl, $hd, $sec, $bps,
+ ($cyl*$hd*$sec), ($cyl*$hd*$sec*$bps)/1024,
+ ($disktype{$typ}{bad} ? 'yes' : ' no');
+ }
+
+ print "\n";
+ print " RM02 is accepted as an alias for RM03 (same capacity)\n";
+ print " RP04 is accepted as an alias for RP05 (same capacity)\n";
+
+ print "\n";
+ print "currently supported initialization patterns:\n";
+ print " zero all zero (will cause explicit disk space allocation)\n";
+ print " ones all ones\n";
+ print " dead alternating 0xdead 0xbeaf pattern\n";
+ print " test writes unique groups of 8 16bit words\n";
+ print "\n";
+ print "For further details consults the create_disk man page.\n";
+ return;
+}
create_disk
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: tap2file
===================================================================
--- tap2file (nonexistent)
+++ tap2file (revision 38)
@@ -0,0 +1,129 @@
+#!/usr/bin/perl -w
+# $Id: tap2file 686 2015-06-04 21:08:08Z mueller $
+#
+# Copyright 2015- by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2015-06-03 686 1.0.1 add print_usage; cleanups
+# 2015-05-24 684 1.0 Initial version
+#
+# Expand a simh tape container file (.tap) to a set of files
+#
+# Usage: tap2file [--pref=pref] file
+#
+use 5.14.0; # require Perl 5.14 or higher
+use strict; # require strict checking
+
+use Getopt::Long;
+
+my %opts = ();
+
+GetOptions(\%opts, "pref=s", "help")
+ or die "bad options";
+
+sub close_ofile;
+sub print_usage;
+
+if (scalar(@ARGV) == 0 || exists $opts{help}) {
+ print_usage;
+ exit 0;
+}
+
+my $ifile = shift @ARGV;
+exit 0 unless defined $ifile;
+
+open(IFILE, "<$ifile") || die("Can't open $ifile: $!");
+
+my $basename = $ifile;
+$basename = $1 if $ifile =~ m|.*/(.*)|;
+my $fstem = $basename;
+$fstem = $1 if $basename =~ m|(.*)\..*|;
+
+my $pref = (exists $opts{pref}) ? $opts{pref} : "${fstem}_";
+
+my $nfile = 0;
+my $nrec = 0;
+my $rlmin = 0;
+my $rlmax = 0;
+my $ofile = "";
+
+my $block;
+my $nb;
+
+while ($nb = read(IFILE, $block, 4)) {
+ my $metabeg = unpack("V", $block);
+
+ if ($metabeg == 0x00000000) {
+ close_ofile;
+ $nfile += 1;
+ next;
+ }
+ if ($metabeg == 0xffffffff) {
+ last;
+ }
+
+ unless (defined fileno OFILE) {
+ $ofile = sprintf("%s%02d.dat", $pref,$nfile);
+ open(OFILE, ">$ofile") || die("Can't open $ofile: $!");
+ }
+
+ $nb = read(IFILE, $block, $metabeg);
+ print OFILE $block;
+ if ($nrec == 0) {
+ $rlmin = $metabeg;
+ $rlmax = $metabeg;
+ } else {
+ $rlmin = $metabeg if $metabeg < $rlmin;
+ $rlmax = $metabeg if $metabeg > $rlmin;
+ }
+ $nrec += 1;
+
+ $nb = read(IFILE, $block, 4);
+ my $metaend = unpack("V", $block);
+ if ($nb != 4 || not defined $metaend) {
+ printf "bad meta tag: beg=%8.8x\n", $metabeg;
+ last;
+ }
+ if ($metaend != $metabeg) {
+ printf "bad meta tags: beg=%8.8x end=%8.8x\n", $metabeg,$metaend;
+ last;
+ }
+}
+
+close_ofile;
+exit 0;
+
+# ----------------------------------------------------------------------------
+sub close_ofile {
+ return unless (defined fileno OFILE);
+ close(OFILE);
+ if ($rlmin == $rlmax) {
+ printf "%s: %6d records, length %5d\n",
+ $ofile, $nrec, $rlmin;
+ } else {
+ printf "%s: %6d records, length min=%5d, max=%5d\n",
+ $ofile, $nrec, $rlmin, $rlmax;
+ }
+ $nrec = 0;
+ $rlmin = 0;
+ $rlmax = 0;
+}
+
+# ----------------------------------------------------------------------------
+sub print_usage {
+ print "usage: tap2file [options] ifile\n";
+ print " ifile input tap file\n";
+ print " Options\n";
+ print " --pref=p use p as prefix for generated files\n";
+ print " --help this message\n";
+}
tap2file
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: file2tap
===================================================================
--- file2tap (nonexistent)
+++ file2tap (revision 38)
@@ -0,0 +1,119 @@
+#!/usr/bin/perl -w
+# $Id: file2tap 686 2015-06-04 21:08:08Z mueller $
+#
+# Copyright 2008-2015 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2015-06-03 686 1.1 fix -a option; support eom at end
+# 2008-12-07 175 1.0.1 remove some upperfluous 'my'
+# 2008-11-29 174 1.0 Initial version (import from tbird backup)
+#
+#
+# Create a simh tape container file (.tap) from a set of files
+#
+# Usage: file2tap -c name -b n file1 ... filen
+#
+# if -c name is omitted, stdout is used
+#
+
+use strict;
+use Fcntl qw(:seek O_RDWR);
+
+my $arg;
+my $cdone;
+my $blocksize = 512;
+my $nfile = 0;
+
+while ($arg = shift) {
+
+ if ($arg eq "-c") {
+ if (@ARGV) {
+ $arg = shift;
+ open(OFILE, ">$arg") || die ("Can't open output file $arg: $!");
+ $cdone = 1;
+ }
+
+ } elsif ($arg eq "-a") {
+ if (@ARGV) {
+ $arg = shift;
+ sysopen OFILE, $arg, O_RDWR || die ("Can't open output file $arg: $!");
+ my $buf;
+ my $len;
+
+ # check for EOM mark at end, if found, truncate it away
+ sysseek OFILE, -4, SEEK_END;
+ $len = sysread OFILE, $buf, 4;
+ if ($buf eq "\xff\xff\xff\xff") {
+ truncate OFILE, sysseek(OFILE, -4, SEEK_END);
+ }
+
+ # check for two EOF marks at end, if found, truncate 2nd away
+ sysseek OFILE, -8, SEEK_END;
+ $len = sysread OFILE, $buf, 8;
+ if ($buf ne "\x00\x00\x00\x00\x00\x00\x00\x00") {
+ die ("Didn't find double EOF at end of tap file");
+ }
+ truncate OFILE, sysseek(OFILE, -4, SEEK_END);
+
+ close OFILE;
+ open(OFILE, ">>$arg") || die ("Can't append to output file $arg: $!");
+ $cdone = 1;
+ }
+
+ } elsif ($arg eq "-b") {
+ if (@ARGV) {
+ $arg = shift;
+ $blocksize = 512 * int $arg;
+ }
+
+ } else {
+ if (!$cdone) {
+ open(OFILE, ">-") || die ("Can't open stdout: $!");
+ }
+
+ my @flist = split(",",$arg);
+ my $file;
+ foreach $file (@flist) {
+ add_file($file, $blocksize);
+ }
+ $nfile += 1;
+ end_file();
+ }
+}
+end_file();
+
+# ----------------------------------------------------------------------------
+sub end_file {
+ print OFILE "\x00\x00\x00\x00";
+}
+
+# ----------------------------------------------------------------------------
+sub add_file {
+ my($filename, $blocksize) = @_;
+ my($block, $bytes_read, $length, $nb);
+
+ open(FILE, $filename) || die("Can't open $filename: $!");
+ while($bytes_read = read(FILE, $block, $blocksize)) {
+ if($bytes_read < $blocksize) {
+ $block .= "\x00" x ($blocksize - $bytes_read);
+ }
+ $length = pack("V", $blocksize);
+ print OFILE $length, $block, $length;
+ $nb += 1;
+ }
+ close(FILE);
+ if ($cdone) {
+ printf "file: %3d records: %5d length: %5d file: $filename\n",
+ $nfile, $nb, $blocksize;
+ }
+}
file2tap
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xise_msg_filter
===================================================================
--- xise_msg_filter (nonexistent)
+++ xise_msg_filter (revision 38)
@@ -0,0 +1,214 @@
+#!/usr/bin/perl -w
+# $Id: xise_msg_filter 646 2015-02-15 12:04:55Z mueller $
+#
+# Copyright 2011-2015 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2015-01-30 640 1.1.2 renamed from isemsg_filter
+# 2014-02-01 550 1.1.1 rename --pack to --pacc (accepted is meant here)
+# 2012-01-04 450 1.1 preliminary check for par 'all constraints met'
+# 2011-08-14 406 1.0 Initial version
+#
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+use FileHandle;
+
+use Getopt::Long;
+
+my %opts = ();
+
+GetOptions(\%opts, "help", "pacc") || exit 1;
+
+sub print_help;
+sub read_mfs;
+sub read_log;
+
+my $type = shift @ARGV;
+my $mfsnam = shift @ARGV;
+my $lognam = shift @ARGV;
+my @flist;
+my @mlist;
+my $nackcnt = 0;
+my $ackcnt = 0;
+my $misscnt = 0;
+
+
+autoflush STDOUT 1; # autoflush, so nothing lost on exec later
+
+if (exists $opts{help}) {
+ print_help;
+ exit 0;
+}
+
+if (!defined $type || !defined $mfsnam || !defined $lognam) {
+ print STDERR "xise_msg_filter-E: one of 'type mfset log' missing \n\n";
+ print_help;
+ exit 1;
+}
+
+if ($type !~ m{^(xst|tra|map|par|twr|bgn)$}) {
+ print STDERR "xise_msg_filter-E: type must be xst,tra,map,par,twr, or bgn\n";
+ exit 1;
+}
+
+if (read_mfs()) {exit 1;}
+if (read_log()) {exit 1;}
+
+foreach (@mlist) {
+ my $msgorig = $_->[0];
+ my $msgflat = $_->[1];
+ my $msgmatch = 0;
+ foreach (@flist) {
+ my $filt = $_->[0];
+ if ($msgflat =~ m{$filt}) {
+ $_->[1] += 1;
+ $msgmatch = 1;
+ last;
+ }
+ }
+ if ($msgmatch) {
+ $_->[2] += 1;
+ } else {
+ $nackcnt += 1;
+ }
+}
+
+if ($nackcnt) {
+ print "Unexpected messages of type [$type] from $lognam:\n";
+ foreach (@mlist) {
+ next if $_->[2];
+ print $_->[0] . "\n";
+ }
+ print "\n";
+}
+
+foreach (@flist) {
+ if ($_->[1]) {
+ $ackcnt += 1;
+ } else {
+ $misscnt += 1;
+ }
+}
+
+if ($ackcnt && exists $opts{pacc}) {
+ print "Accepted messages of type [$type] from $lognam:\n";
+ foreach (@flist) {
+ next if $_->[1] == 0;
+ printf "%4d: %s\n", $_->[1], $_->[0];
+ }
+ print "\n";
+}
+
+if ($misscnt) {
+ print "Missed messages of type [$type] from $lognam:\n";
+ foreach (@flist) {
+ next if $_->[1] != 0;
+ printf "%4d: %s\n", $_->[1], $_->[0];
+ }
+ print "\n";
+}
+
+#-------------------------------------------------------------------------------
+sub read_mfs {
+ if (not -r $mfsnam) {
+ print STDERR "xise_msg_filter-E: \'$mfsnam\' not existing or readable\n";
+ return 1;
+ }
+
+ open (FFILE, $mfsnam) or die "can't open for read $mfsnam: $!";
+
+ my $intyp = 0;
+
+ while () {
+ chomp;
+ next if /^\s*#/; # drop comments
+ next if /^\s*$/; # drop empty lines
+
+ if (m{^\[([a-z]{3})\]$}) {
+ if ($1 eq $type) {
+ $intyp = 1;
+ } else {
+ $intyp = 0;
+ }
+ } else {
+ if ($intyp) {
+ push @flist, [$_, 0];
+ }
+ }
+ }
+
+ close (FFILE);
+
+ return 0;
+}
+
+#-------------------------------------------------------------------------------
+sub read_log {
+ if (not -r $lognam) {
+ print STDERR "xise_msg_filter-E: \'$lognam\' not existing or readable\n";
+ return 1;
+ }
+
+ open (LFILE, $lognam) or die "can't open for read $lognam: $!";
+
+ my $msgorig = "";
+ my $msgflat = "";
+ my $inmsg = 0;
+ my $parallmet = 0;
+
+ while () {
+ chomp;
+
+ $parallmet = 1 if ($type eq "par" && m/All c/);
+
+ if (m{^(INFO|WARNING|ERROR):}) {
+ if ($inmsg) {push @mlist, [$msgorig, $msgflat, 0];}
+ $inmsg = 1;
+ $msgorig = $_;
+ $msgflat = $_;
+ } elsif ($inmsg && m{^\s\s\s\S}) {
+ $msgorig .= "\n" . $_;
+ my $txt = $_;
+ $txt =~ s{\s\s}{}; # replace 3 leading blanks by one !
+ $msgflat .= $txt;
+ } else {
+ if ($inmsg) {push @mlist, [$msgorig, $msgflat, 0];}
+ $inmsg = 0;
+ }
+ }
+
+ if ($inmsg) {push @mlist, [$msgorig, $msgflat, 0];}
+
+ close (LFILE);
+
+ if ($type eq "par" && $parallmet==0) {
+ printf "!! ----------------------------------- !!\n";
+ printf "!! par: FAILED TO REACH TIMING CLOSURE !!\n";
+ printf "!! ----------------------------------- !!\n";
+ }
+
+ return 0;
+}
+
+#-------------------------------------------------------------------------------
+
+sub print_help {
+ print "usage: xise_msg_filter [options] type mfset log\n";
+ print " type log file type: xst,tra,map,par,twr, or bgn\n";
+ print " mfset message filter set file\n";
+ print " log log file\n";
+ print " Options:\n";
+ print " --pacc print summary of accepted messages\n";
+ print " --help this message\n";
+}
xise_msg_filter
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: svn_set_ignore
===================================================================
--- svn_set_ignore (nonexistent)
+++ svn_set_ignore (revision 38)
@@ -0,0 +1,112 @@
+#!/usr/bin/perl -w
+# $Id: svn_set_ignore 601 2014-11-07 22:44:43Z mueller $
+#
+# Copyright 2007-2014 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Vers Comment
+# 2014-11-04 601 1.1 use 'svn info' rather /.svn check for svn >= 1.7
+# 2010-04-26 284 1.0.1 add error check for GetOptions
+# 2007-06-16 56 1.0 Initial version
+#
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+
+use Getopt::Long;
+
+sub do_dir;
+
+my @dirlist;
+my @def_ipat;
+
+my %opts = ();
+
+GetOptions(\%opts, "dry-run")
+ or die "bad options";
+
+if (@ARGV) {
+ push @dirlist, @ARGV;
+} else {
+ @dirlist = `find -type d | grep -v "\.svn"`;
+ die "bad find|grep" if $?;
+}
+
+open (CVSIG, ".cvsignore") or die "no top level .cvsigore found";
+@def_ipat = grep /.+/, ;
+close (CVSIG);
+
+foreach (@dirlist) { chomp; do_dir($_); }
+
+#-------------------------------------------------------------------------------
+
+sub do_dir {
+ my ($dirname) = @_;
+ my @cur_ipat;
+ my @loc_ipat;
+ my @sum_ipat;
+ my @new_ipat;
+ my %ipat;
+
+ # skip ise directories (they have sometimes strange chars in dir names
+ return if $dirname =~ m|/ise/|;
+ # check for svn working directory
+ my $svn_info = `svn info $dirname 2>&1`;
+ return if $?;
+
+ print "$dirname\n";
+ open (SVN, "svn pg svn:ignore $dirname|") or die "failed to open svn pg pipe";
+ @cur_ipat = grep /.+/, ; # prop get and drop empty lines
+ close (SVN);
+
+ if ($dirname ne "." && -r "$dirname/.cvsignore") {
+ open (CVSIG, "$dirname/.cvsignore")
+ or die "failed to read local .cvsignore";
+ @loc_ipat = grep /.+/, ;
+ close (CVSIG);
+ }
+
+ push @sum_ipat, @def_ipat;
+ push @sum_ipat, @loc_ipat;
+
+ foreach (@sum_ipat) {
+ if (exists $ipat{$_}) {
+ my $pat = $_;
+ chomp $pat;
+ print "duplicate ignore: $pat in $dirname\n";
+ } else {
+ $ipat{$_} = 1;
+ push @new_ipat, $_;
+ }
+ }
+
+ if (join("",@cur_ipat) ne join("",@new_ipat)) {
+ print "update svn:ignore for $dirname\n";
+ print "old svn:ignore:\n";
+ print " ", join " ",@cur_ipat if @cur_ipat;
+ print "local .cvsignore:\n";
+ print " ", join " ",@loc_ipat if @loc_ipat;
+ print "new svn:ignore:\n";
+ print " ", join " ",@new_ipat if @new_ipat;
+
+ if (not exists $opts{"dry-run"}) {
+ open (TMP, ">/tmp/svn_set_ignore_$$") or die "failed to open tmp file";
+ print TMP join "",@new_ipat;
+ close (TMP);
+ print `svn ps svn:ignore -F /tmp/svn_set_ignore_$$ $dirname`;
+ die "bad svn ps" if $?;
+ unlink "/tmp/svn_set_ignore_$$" or die "failed to delete tmp file";
+ }
+
+ }
+
+}
svn_set_ignore
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: fx2load_wrapper
===================================================================
--- fx2load_wrapper (nonexistent)
+++ fx2load_wrapper (revision 38)
@@ -0,0 +1,262 @@
+#!/usr/bin/perl -w
+# $Id: fx2load_wrapper 604 2014-11-16 22:33:09Z mueller $
+#
+# Copyright 2011-2014 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2014-08-10 581 1.1 use _ic instead of _as as default firmware
+# 2012-02-11 457 1.0.1 use RETRO_FX2_VID/PID; check iProduct string
+# 2011-12-29 446 1.0 Initial version
+#
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+use FileHandle;
+use Time::HiRes qw(usleep);
+
+use Getopt::Long;
+
+my %opts = ();
+
+GetOptions(\%opts, "help", "dry_run", "force", "cycfx2prog",
+ "board=s", "file=s", "ihx_path=s")
+ or exit 1;
+
+#
+# setup defaults for board and file
+#
+if (not defined $opts{board}) {
+ $opts{board} = "nexys2";
+}
+if (not defined $opts{file}) {
+ $opts{file} = "nexys2_jtag_2fifo_ic.ihx" if $opts{board} eq "nexys2";
+ $opts{file} = "nexys3_jtag_2fifo_ic.ihx" if $opts{board} eq "nexys3";
+ $opts{file} = "nexys3_jtag_2fifo_ic.ihx" if $opts{board} eq "atlys";
+}
+if (not defined $opts{ihx_path}) {
+ unless (exists $ENV{RETROBASE}) {
+ print STDERR "fx2load_wrapper-F: RETROBASE not set\n";
+ exit 1;
+ }
+ $opts{ihx_path} = $ENV{RETROBASE} . "/tools/fx2/bin";
+}
+
+sub print_help;
+sub run_command;
+sub get_usb_id;
+sub get_usb_prodinfo;
+
+autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
+
+if (exists $opts{help}) {
+ print_help;
+ exit 0;
+}
+
+my $board = $opts{board};
+my $ifile = $opts{file};
+
+# setup digilent default usb id's
+
+my $usbid_digi;
+
+if ($board eq "nexys2") { $usbid_digi = "1443:0005";}
+elsif ($board eq "nexys3") { $usbid_digi = "1443:0007";}
+elsif ($board eq "atlys") { $usbid_digi = "1443:0007";}
+else {
+ print STDERR
+ "fx2load_wrapper-E: only nexys2,3/atlys supported\n";
+ exit 1;
+}
+
+# handle USB VID/PID of board
+# taken from RETRO_FX2_VID and RETRO_FX2_PID environment variables
+# in the retro11 project the default is:
+# VID: 16c0 (VOTI)
+# PID: 03ef (VOTI free for internal lab use 1007)
+#
+# !! Important Note on Usage of this USB VID/PID !!
+# This VID/PID is owned by VOTI, a small dutch company. Usage is granted
+# for 'internal lab use only' by VOTI under the conditions:
+# - the gadgets in which you use those PIDs do not leave your desk
+# - you won't complain to VOTI if you get in trouble with duplicate PIDs
+# (for instance because someone else did not follow the previous rule).
+# See also http://www.voti.nl/pids/pidfaq.html
+#
+
+my $fx2_vid = $ENV{RETRO_FX2_VID};
+my $fx2_pid = $ENV{RETRO_FX2_PID};
+$fx2_vid = "16c0" unless defined $fx2_vid;
+$fx2_pid = "03ef" unless defined $fx2_pid;
+
+my $usbid_retro = "$fx2_vid:$fx2_pid";
+my $n_digi = 0;
+my $n_retro = 0;
+
+my $fx2_bus;
+my $fx2_dev;
+my $fx2_id;
+my $fx2_prodinfo;
+
+($n_digi, $n_retro, $fx2_bus, $fx2_dev, $fx2_id) = get_usb_id();
+
+if ($n_digi+$n_retro == 0) {
+ print STDERR "fx2load_wrapper-E no board detected\n";
+ exit 1;
+}
+if ($n_digi+$n_retro > 1) {
+ print STDERR "fx2load_wrapper-E more than one board detected\n";
+ exit 1;
+}
+
+if ($n_retro > 0) {
+ $fx2_prodinfo = get_usb_prodinfo($fx2_id);
+}
+
+if ($n_retro == 1 &&
+ $opts{file} eq $fx2_prodinfo . ".ihx" &&
+ (not defined $opts{force}) ) {
+ print "fx2load_wrapper-I board already configured with $fx2_prodinfo.ihx\n";
+ exit 0;
+}
+
+my $full_file = $opts{ihx_path} . "/" . $opts{file};
+unless (-r $full_file) {
+ print STDERR "fx2load_wrapper-E: ihx file \'$full_file\' not found\n";
+ exit 1;
+}
+
+my $fx2_path = "/dev/bus/usb/$fx2_bus/$fx2_dev";
+
+unless ( -r $fx2_path && -w $fx2_path) {
+ print STDERR
+ "fx2load_wrapper-E: usb device \'$fx2_path\' not user accessible\n";
+ exit 1;
+}
+
+my $cmd;
+
+if ($opts{cycfx2prog}) {
+ my $proc = `which cycfx2prog`;
+ chomp $proc;
+ unless (-x $proc) {
+ print STDERR "fx2load_wrapper-E: cycfx2prog not found or executable\n";
+ exit 1;
+ }
+ $cmd = "cycfx2prog -id=$fx2_id prg:$full_file run";
+
+} else {
+ my $proc = `which fxload`;
+ chomp $proc;
+ $proc = "/sbin/fxload" if ($proc eq "");
+ unless (-x $proc) {
+ print STDERR "fx2load_wrapper-E: fxload not found or executable\n";
+ exit 1;
+ }
+ $cmd = "$proc -t fx2 -I $full_file -D $fx2_path";
+}
+
+my $rc = 0;
+if (defined $opts{dry_run}) {
+ print "$cmd\n";
+} else {
+ print "fx2load_wrapper-I: loading $opts{file}\n";
+ $rc = run_command($cmd);
+ print "fx2load_wrapper-I: loaded $opts{file}\n";
+ usleep(1500000);
+}
+
+exit $rc;
+
+#-------------------------------------------------------------------------------
+
+sub run_command {
+
+ my ($cmd) = @_;
+
+ my $wrc = system "/bin/sh", "-c", "$cmd";
+
+ my $rc = 0;
+ if ($wrc != 0) {
+ my $rc = int($wrc/256);
+ if ($rc == 0) {
+ my $sig = $wrc % 256;
+ print STDERR "fx2load_wrapper-E \'$cmd\' aborted by signal $sig\n";
+ $rc = 1;
+ } else {
+ print STDERR "fx2load_wrapper-E \'$cmd\' failed (rc=$rc) $?\n";
+ }
+ }
+
+ return $rc;
+}
+
+#-------------------------------------------------------------------------------
+
+sub print_help {
+ print "usage: fx2load_wrapper [--board=b] [--file=f] [OPTIONS]\n";
+ print " --help this message\n";
+ print " --dry_run print command only\n";
+ print " --force reload even when proper firmware detected\n";
+ print " --cycfx2prog use cycfx2prog instead of fxload\n";
+ print " --board=b type of board (default nexys2)\n";
+ print " --file=f ihx file to load (default 2fifo_as)\n";
+ print " --ihx_path=p path to ihx files\n";
+}
+
+#-------------------------------------------------------------------------------
+
+sub get_usb_id {
+ my @lsusb = `lsusb`;
+
+ my $n_digi = 0;
+ my $n_retro = 0;
+ my $fx2_bus;
+ my $fx2_dev;
+ my $fx2_id;
+
+ foreach (@lsusb) {
+ if (/^Bus\s+(\d+)\s+Device\s+(\d+):\s+ID\s+([:0-9a-f]+)\s+(.*)$/) {
+ my ($bus,$dev,$id,$text) = ($1,$2,$3,$4);
+ my $match = 0;
+ if ($id eq $usbid_digi) {
+ $n_digi += 1;
+ $match = 1;
+ } elsif ($id eq $usbid_retro) {
+ $n_retro += 1;
+ $match = 1;
+ }
+ if ($match) {
+ $fx2_bus = $bus;
+ $fx2_dev = $dev;
+ $fx2_id = $id;
+ }
+ }
+ }
+
+ return ($n_digi, $n_retro, $fx2_bus, $fx2_dev, $fx2_id);
+
+}
+
+#-------------------------------------------------------------------------------
+
+sub get_usb_prodinfo {
+ my ($fx2_id) = @_;
+ my @lsusb = `lsusb -d $fx2_id -v`;
+ foreach (@lsusb) {
+ if (/^\s*iProduct\s*\d*\s*(.*)$/) {
+ return $1;
+ }
+ }
+ return "";
+}
fx2load_wrapper
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: console_starter
===================================================================
--- console_starter (nonexistent)
+++ console_starter (revision 38)
@@ -0,0 +1,100 @@
+#!/usr/bin/perl -w
+# $Id: console_starter 581 2014-08-10 21:48:46Z mueller $
+#
+# Copyright 2009-2014 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Vers Comment
+# 2014-08-10 581 1.1 rename to console_starter
+# 2010-07-04 312 1.0.3 correct telnet_wrapper path
+# 2010-04-26 284 1.0.2 add error check for GetOptions
+# 2009-11-08 248 1.0.1 proper -h handling & text; add -t support;
+# 2009-11-07 247 1.0 Initial version
+#
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+
+use Getopt::Long;
+
+my %opts = ();
+GetOptions(\%opts, "h", "t:s", "d:s", "s", "w", "l")
+ or die "bad options";
+
+if (exists $opts{h}) {
+ print "usage: console_starter [-h] [-t type] [-d type] [-s] [-w] [-l]\n";
+ print " -h help, print this text and quit\n";
+ print " -t term set terminal type, vt100 or vt52 (def: vt100)\n";
+ print " -d dev set device type, DLx or DZx for x'the line (def: DL0)\n";
+ print " -s use simh ports, default is to use rri ports\n";
+ print " -w use wide 132 column screen (default 80 columns)\n";
+ print " -l use long 48 lines screen (default 24 lines)\n";
+ exit 0;
+}
+
+my $emu = "xterm";
+my $telnet = $ENV{"RETROBASE"} . "/tools/bin/telnet_wrapper";
+
+my @args;
+my $term = "vt100";
+my $dev = "DL";
+my $line = 0;
+my $port;
+my $title;
+
+if (exists $opts{t}) {
+ if ($opts{t} =~ m{^(vt100|vt52)$} ) {
+ $term = $opts{t};
+ } else {
+ printf "unsupported terminal type: %s\n", $opts{t};
+ exit 1;
+ }
+}
+
+if (exists $opts{d}) {
+ if ($opts{d} =~ m{^(DL|DZ)(\d*)$}i ) {
+ $dev = uc $1;
+ $line = int $2;
+ } else {
+ printf "unsupported device type: %s\n", $opts{d};
+ exit 1;
+ }
+}
+
+if (exists $opts{s}) { # simh ports
+ $port = 5670 if ($dev eq "DL");
+ $port = 5671 if ($dev eq "DZ");
+ $title = sprintf "\"%s %s\"", $dev, $term;
+} else { # rri ports
+ $port = 8000+$line if ($dev eq "DL");
+ $port = 8002+$line if ($dev eq "DZ");
+ $title = sprintf "\"%s%d %s\"", $dev, $line, $term;
+}
+
+my $geo_w = 80;
+my $geo_l = 24;
+$geo_w = 132 if exists $opts{w};
+$geo_l = 48 if exists $opts{l};
+
+push @args, "-j", "-rightbar", "-sb", "-sl", "500";
+push @args, "-bg", "gray90", "-fg", "black";
+push @args, "-ti", $term;
+push @args, "-geo", sprintf("%dx%d", $geo_w, $geo_l);
+push @args, "-T", $title;
+push @args, "-e", $telnet, "localhost", sprintf("%d",$port);
+
+print $emu, " ", join " ",@args, "\n";
+
+my $rc = system $emu, @args;
+if ($rc != 0) {
+ print STDERR "xterm failed with rc=$rc\n";
+}
console_starter
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: .cvsignore
===================================================================
--- .cvsignore (nonexistent)
+++ .cvsignore (revision 38)
@@ -0,0 +1,2 @@
+cycfx2prog
+tclshcpp
Index: telnet_wrapper
===================================================================
--- telnet_wrapper (nonexistent)
+++ telnet_wrapper (revision 38)
@@ -0,0 +1,55 @@
+#!/usr/bin/perl -w
+# $Id: telnet_wrapper 547 2013-12-29 13:10:07Z mueller $
+#
+# Copyright 2009-2013 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Vers Comment
+# 2009-11-07 246 1.0 Initial version
+#
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+
+if (scalar(@ARGV) != 2) {
+ print STDERR "usage: telnet_wrapper host port\n";
+ exit 1;
+}
+
+my $host = $ARGV[0];
+my $port = $ARGV[1];
+
+print "$host $port\n";
+
+my $telnet = `which telnet`;
+chomp $telnet;
+
+while(1) {
+ my $rc = system $telnet, $host, $port;
+ if ($rc != 0) {
+ print STDERR "telnet failed with rc=$rc\n";
+ }
+ print "enter q or <^D> to quit, otherwise hit to reconnect: ";
+ my $buf;
+ my $nc = read STDIN, $buf, 1;
+ if (not defined $nc) {
+ print "\n";
+ exit 1;
+ }
+ if ($nc == 0) {
+ print "\n";
+ exit 0;
+ }
+ if ($buf eq "q") {
+ exit 0;
+ }
+}
telnet_wrapper
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: config_wrapper
===================================================================
--- config_wrapper (nonexistent)
+++ config_wrapper (revision 38)
@@ -0,0 +1,283 @@
+#!/usr/bin/perl -w
+# $Id: config_wrapper 534 2013-09-22 21:37:24Z mueller $
+#
+# Copyright 2010-2013 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2013-09-21 534 1.1.8 add nexys4 support
+# 2013-01-02 467 1.1.7 jconfig: prepend '0x' to support 'jtag #2007'
+# 2012-02-11 457 1.1.6 jconfig: use RETRO_FX2_VID/PID for USB VID/PID
+# 2011-12-03 435 1.1.5 add nexys3 support;
+# 2011-08-04 402 1.1.4 add atlys support;
+# 2011-07-25 399 1.1.3 add nexys2-500 support; bsdl path for sp605
+# 2011-07-18 395 1.1.2 cleanup bsdl path creation for jtag
+# 2011-07-17 394 1.1.1 add bit->svf conversion and config with jtag
+# 2011-07-11 393 1.1 renamed from impact_wrapper; add function parameter,
+# old action with 'iconfig'
+# 2011-07-01 386 1.0.3 support sp605/xc6slx45t
+# 2010-05-24 294 1.0.2 support nexys2/xc3s1200e
+# 2010-04-24 282 1.0.1 proper error exit for GetOptions()
+# 2010-04-24 281 1.0 Initial version
+#
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+use FileHandle;
+
+use Getopt::Long;
+
+my %opts = ();
+
+GetOptions(\%opts, "help", "dry_run", "board=s", "path=s") or exit 1;
+
+# setup defaults for board and path
+if (not defined $opts{board}) {
+ $opts{board} = "s3board";
+}
+if (not defined $opts{path}) {
+ $opts{path} = "xc3s1000" if $opts{board} eq "s3board";
+ $opts{path} = "xc3s1200e" if $opts{board} eq "nexys2";
+ $opts{path} = "xc6slx16" if $opts{board} eq "nexys3";
+ $opts{path} = "xc7a100t" if $opts{board} eq "nexys4";
+ $opts{path} = "xc6slx45" if $opts{board} eq "atlys";
+ $opts{path} = "xc6slx45t" if $opts{board} eq "sp605";
+}
+
+sub print_help;
+sub run_command;
+
+
+autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
+
+if (exists $opts{help}) {
+ print_help;
+ exit 0;
+}
+
+my $board = $opts{board};
+my $ipath = $opts{path};
+
+$ipath =~ s/-.*$//; # trim all after first '-'
+
+# now setup JTAG chain config
+
+my @plist;
+my $pfpga;
+
+#
+# Note: when new targets are added update also the blist logic below
+#
+if ($board eq "s3board" && $ipath eq "xc3s200") { # S3BOARD-200
+ @plist = ($ipath, "xcf02s");
+ $pfpga = 1;
+} elsif ($board eq "s3board" && $ipath eq "xc3s1000") { # S3BOARD-1200
+ @plist = ($ipath, "xcf04s");
+ $pfpga = 1;
+
+} elsif ($board eq "nexys2" && $ipath eq "xc3s1200e") { # nexys2-1200
+ @plist = ($ipath, "xcf04s");
+ $pfpga = 1;
+} elsif ($board eq "nexys2" && $ipath eq "xc3s500e") { # nexys2-500
+ @plist = ($ipath, "xcf04s");
+ $pfpga = 1;
+
+} elsif ($board eq "nexys3" && $ipath eq "xc6slx16") { # nexys3
+ @plist = ($ipath);
+ $pfpga = 1;
+
+} elsif ($board eq "nexys4" && $ipath eq "xc7a100t") { # nexys4
+ @plist = ($ipath);
+ $pfpga = 1;
+
+} elsif ($board eq "atlys" && $ipath eq "xc6slx45") { # atlys
+ @plist = ($ipath);
+ $pfpga = 1;
+
+} elsif ($board eq "sp605" && $ipath eq "xc6slx45t") { # sp605
+ @plist = ("xccace", $ipath);
+ $pfpga = 2;
+} else {
+ print STDERR
+ "config_wrapper-E: only s3board/nexys2,3/atlys/sp605 supported\n";
+ exit 1;
+}
+
+my @blist;
+foreach my $part (@plist) {
+ if ($part =~ m/^xcf/) { push @blist, "xcf/data" } # proms
+ elsif ($part =~ m/^xc3s\d*$/) { push @blist, "spartan3/data" } # s-3
+ elsif ($part =~ m/^xc3s\d*e$/) { push @blist, "spartan3e/data" } # s-3e
+ elsif ($part =~ m/^xc6slx\d*t?$/) { push @blist, "spartan6/data" }# s-6 lx
+ elsif ($part =~ m/^xc7a\d*t?$/) { push @blist, "artix7/data" } # 7-a
+ elsif ($part =~ m/^xccace$/) { push @blist, "acempm/data" } # sys-ace
+ else {
+ print STDERR "config_wrapper-E: no bsdl path known for $part\n";
+ exit 1;
+ }
+}
+
+my $cmd = shift @ARGV;
+my $file = shift @ARGV;
+
+if (! defined $cmd) {
+ print STDERR "config_wrapper-E: no command specified\n";
+ exit 1;
+}
+
+if (! defined $file) {
+ print STDERR "config_wrapper-E: no bit or svf file specified\n";
+ exit 1;
+}
+if (! -r $file) {
+ print STDERR "config_wrapper-E: input file not found or readable\n";
+ exit 1;
+}
+
+my $xilpath = $ENV{XILINX};
+if (! defined $xilpath) {
+ print STDERR "config_wrapper-E: XILINX environment variable not defined\n";
+ exit 1;
+}
+
+# ----- iconfig action --------------------------------------------------------
+if ($cmd eq "iconfig") {
+
+ my $tmpfile = "tmp_config_wrapper.cmd";
+ open (OFILE, ">$tmpfile") or die "Couldn't open tmp cmd file: $!";
+
+ print OFILE "setMode -bs\n";
+ print OFILE "setCable -p auto\n";
+ for (my $i = 0; $i<=$#plist; $i++) {
+ printf OFILE "addDevice -p %d -part %s\n", $i+1, $plist[$i];
+ }
+ printf OFILE "assignFile -p %d -file %s\n", $pfpga, $file;
+ printf OFILE "program -p %d -verify\n", $pfpga;
+ print OFILE "quit\n";
+
+ close (OFILE) or die "Couldn't close tmp cmd file: $!";
+
+ my $rc = run_command("impact -batch", $tmpfile);
+ exit $rc;
+
+# ----- jconfig action --------------------------------------------------------
+} elsif ($cmd eq "jconfig") {
+
+ my $bpath = join ";", map "$xilpath/$_",@blist;
+
+ my $tmpfile = "tmp_config_wrapper.cmd";
+ open (OFILE, ">$tmpfile") or die "Couldn't open tmp cmd file: $!";
+
+ # the UrJtag and Xilinx impact have different chain and part number schemes
+ # impact: 1-based, 1 is first in chain;
+ # UrJtag: 0-based, 0 is last in chain;
+ # e.g. on Digilent Nexys2:
+ # impact: (1) FPGA (2) PROM
+ # UrJtag: (1) FPGA (0) PROM
+
+ my $jtag_part = $#plist + 1 - $pfpga;
+
+ # handle USB VID/PID of board
+ # taken from RETRO_FX2_VID and RETRO_FX2_PID environment variables
+ # in the retro11 project the default is:
+ # VID: 16c0 (VOTI)
+ # PID: 03ef (VOTI free for internal lab use 1007)
+ #
+ # !! Important Note on Usage of this USB VID/PID !!
+ # This VID/PID is owned by VOTI, a small dutch company. Usage is granted
+ # for 'internal lab use only' by VOTI under the conditions:
+ # - the gadgets in which you use those PIDs do not leave your desk
+ # - you won't complain to VOTI if you get in trouble with duplicate PIDs
+ # (for instance because someone else did not follow the previous rule).
+ # See also http://www.voti.nl/pids/pidfaq.html
+ #
+
+ my $fx2_vid = $ENV{RETRO_FX2_VID};
+ my $fx2_pid = $ENV{RETRO_FX2_PID};
+ $fx2_vid = "16c0" unless defined $fx2_vid;
+ $fx2_pid = "03ef" unless defined $fx2_pid;
+
+ # give vid/pid with 0x prefix. jtag #2007 requires this, #1502 tolerates
+ print OFILE "cable usbblaster vid=0x$fx2_vid pid=0x$fx2_pid\n";
+ printf OFILE "bsdl path %s\n", $bpath;
+ print OFILE "detect\n";
+ printf OFILE "part %d\n", $jtag_part;
+ printf OFILE "svf %s\n", $file;
+
+ close (OFILE) or die "Couldn't close tmp cmd file: $!";
+
+ my $rc = run_command("jtag", $tmpfile);
+ exit $rc;
+
+# ----- bit2svf action --------------------------------------------------------
+} elsif ($cmd eq "bit2svf") {
+ my $ofile = $file;
+ $ofile =~ s/\.bit/\.svf/;
+
+ my $tmpfile = "tmp_config_wrapper.cmd";
+ open (OFILE, ">$tmpfile") or die "Couldn't open tmp cmd file: $!";
+
+ print OFILE "setMode -bs\n";
+ printf OFILE "setCable -port svf -file %s\n", $ofile;
+ printf OFILE "addDevice -p 1 -file %s\n", $file;
+ print OFILE "program -p 1\n";
+ print OFILE "quit\n";
+
+ close (OFILE) or die "Couldn't close tmp cmd file: $!";
+
+ my $rc = run_command("impact -batch", $tmpfile);
+ exit $rc;
+}
+
+print STDERR "config_wrapper-E: command must be bit2svf, iconfig or jconfig\n";
+exit 1;
+
+#-------------------------------------------------------------------------------
+
+sub run_command {
+
+ my ($cmd, $tmpfile) = @_;
+
+ my $wrc;
+ if (defined $opts{dry_run}) {
+ print STDOUT "$cmd\n";
+ $wrc = system "/bin/sh", "-c", "cat $tmpfile";
+ } else {
+ $wrc = system "/bin/sh", "-c", "$cmd $tmpfile";
+ }
+
+ my $rc = 0;
+ if ($wrc != 0) {
+ my $rc = int($wrc/256);
+ if ($rc == 0) {
+ my $sig = $wrc % 256;
+ print STDERR "config_wrapper-I $cmd aborted by signal $sig\n";
+ $rc = 1;
+ } else {
+ print STDERR "config_wrapper-I $cmd failed (rc=$rc) $?\n";
+ }
+ }
+
+ unlink $tmpfile or die "Couldn't delete tmp cmd file: $!";
+ return $rc;
+}
+
+#-------------------------------------------------------------------------------
+
+sub print_help {
+ print "usage: config_wrapper [--help] [--board=b] [--path=p] cmd file\n";
+ print " cmd bit2svf or iconfig or jconfig\n";
+ print " --help this message\n";
+ print " --dry_run print impact command list\n";
+ print " --board=b type of board\n";
+ print " --path=p type of fpga\n";
+}
config_wrapper
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: asm-11_expect
===================================================================
--- asm-11_expect (nonexistent)
+++ asm-11_expect (revision 38)
@@ -0,0 +1,298 @@
+#!/usr/bin/perl -w
+# $Id: asm-11_expect 501 2013-03-30 13:53:39Z mueller $
+#
+# Copyright 2013- by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2013-03-29 500 1.0 Initial version
+# 2013-03-24 499 0.1 First draft
+#
+
+use 5.10.0; # require Perl 5.10 or higher
+use strict; # require strict checking
+use FileHandle;
+
+use Getopt::Long;
+
+my %opts = ();
+
+GetOptions(\%opts, "help",
+ "tline", "tcheck"
+ )
+ or exit 1;
+
+sub do_help;
+sub print_help;
+
+my $errcnt; # total error count
+
+autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
+
+if (exists $opts{help}) {
+ print_help;
+ exit 0;
+}
+
+if (scalar(@ARGV) == 0) {
+ print STDERR "asm-11_expect-F: no input files specified, quiting..\n";
+ print_help;
+ exit 1;
+}
+
+foreach my $fname (@ARGV) {
+ do_file($fname);
+}
+
+exit 1 if $errcnt > 0;
+exit 0;
+
+#-------------------------------------------------------------------------------
+#
+#; Input file list:
+# 1 6 ; comment
+# 1 17 000000 zero:
+# 1 23 002000 000101 w0: .word 101
+# 1 17 001011 377 .byte ^c0
+# 1 70 001206 046374 001234 001234 bic 1234(r3),@1234(r4)
+# 1 24 001036 067527 066162 020544 .word "Wo,"rl,"d!,0
+# 000000
+#EEfnolinno dot... word1. word2. word2.
+#
+# 1 2 3
+#0123456789012345678901234567890123456789
+#
+
+sub do_file {
+ my ($fname) = @_;
+ my $fh;
+ if ($fname eq "-") {
+ $fh = *STDIN;
+ } else {
+ if (not -r $fname) {
+ print STDERR "asm-11_expect-F: '$fname' not found or readable. EXIT\n";
+ exit 1;
+ }
+ $fh = new FileHandle;
+ $fh->open($fname) or die "failed to open '$fname'";
+ }
+
+ my @errmsg; # error message list
+ my $echeck = 0;
+ my $c_string;
+ my $c_pend;
+
+ while (<$fh>) {
+ chomp;
+ next if m/^;/;
+
+ print "$_\n" if $opts{tline};
+
+ my $line = $_;
+ my $rest = $_;
+ my $err;
+ if (substr($rest,2,1) =~ m/^[A-Z]$/) {
+ $rest =~ m/^([A-Z]+)$/;
+ $err = $1;
+ $rest = $';
+ } else {
+ $err = substr($rest,0,2);
+ $err =~ s/\s//g;
+ $rest = substr($rest,2);
+ }
+
+ my $fileno;
+ my $lineno;
+
+ if (substr($rest,0,8) =~ m/^\s+(\d+)\s+(\d+)$/) {
+ $fileno = int($1);
+ $lineno = int($2);
+ $rest = substr($rest,8);
+ } else {
+ next;
+ }
+
+ my $dot;
+ if (substr($rest,0,7) eq ' ') {
+ $rest = substr($rest,7);
+ } elsif (substr($rest,0,7) =~ m/^\s([0-7]{6})/) {
+ $dot = oct($1);
+ $rest = substr($rest,7);
+ } else {
+ next;
+ }
+
+ my @dat;
+ my $isbyte;
+
+ # words ?
+ if ($rest =~ m/^(\s([0-7]{6})){1,3}/) {
+ for (my $i=0; $i<3; $i++) {
+ last unless substr($rest,1,6) =~ m/[0-7]{6}/;
+ push @dat, oct(substr($rest,1,6));
+ $rest = substr($rest,7);
+ }
+ # bytes ?
+ } elsif ($rest =~ m/^(\s([0-7]{3})){1,5}/) {
+ for (my $i=0; $i<5; $i++) {
+ last unless substr($rest,1,3) =~ m/[0-7]{3}/;
+ $isbyte = 1;
+ push @dat, oct(substr($rest,1,3));
+ $rest = substr($rest,4);
+ }
+ $rest = substr($rest,1);
+ }
+
+ # look for expect condition (unless one is pending)
+ if ($c_pend) {
+ $c_pend = undef;
+ } else {
+ if ($rest =~ m/;;!!(.*)$/) {
+ $c_string = $1;
+ if ($rest =~ m/^\s*;;!!/) {
+ $c_pend = 1;
+ next;
+ }
+ }
+ }
+
+ # no expect condition defined: look for unexpected etags
+ unless (defined $c_string) {
+ if ($err ne '') {
+ push @errmsg,
+ {msg => sprintf("unexpected error '%s'", $err),
+ line => $line};
+ }
+ next;
+ }
+
+ # expect condition defined: parse it
+ my $c_err;
+ my $c_dot;
+ my @c_dat;
+
+ my $c_rest = $c_string;
+ if ($c_rest =~ m/^\s*([A-Z]+)/) {
+ $c_err = $1;
+ $c_rest = $';
+ }
+ if ($c_rest =~ m/^\s*([0-7]{6}:)/) {
+ $c_dot = oct($1);
+ $c_rest = $';
+ }
+ while (length($c_rest)) {
+ last unless $c_rest =~ m/^\s*([0-7]+)/;
+ push @c_dat, oct($1);
+ $c_rest = $';
+ }
+
+ unless ($c_rest =~ m/^\s*$/) {
+ push @errmsg,
+ {msg => sprintf("can't parse expect, rest='%s'", $c_rest),
+ line => ';;!! ' . $c_string};
+ $c_string = undef;
+ next;
+ }
+
+ if ($opts{tcheck}) {
+ print "exp: ";
+ printf " err=%s", $c_err if defined $c_err;
+ printf " dot=%6.6o", $c_dot if defined $c_dot;
+ if (scalar(@c_dat)) {
+ print " dat=";
+ foreach (@c_dat) {
+ printf "%6.6o ", $_;
+ }
+ }
+ print "\n";
+ }
+
+ if (defined $c_err) {
+ if ($c_err ne $err) {
+ push @errmsg,
+ {msg => sprintf("error mismatch: found='%s', expect='%s'",
+ $err, $c_err),
+ line => $line};
+ }
+ }
+
+ if (defined $c_dot) {
+ if (defined $dot) {
+ if ($c_dot != $dot) {
+ push @errmsg,
+ {msg => sprintf(". mismatch: found=%6.6o, expect=%6.6o",
+ $dot, $c_dot),
+ line => $line};
+ }
+ } else {
+ push @errmsg,
+ {msg => sprintf(". check miss: nothing found, expect=%6.6o",
+ $c_dot),
+ line => $line};
+ }
+ }
+
+ if (scalar(@c_dat)) {
+ my $nc = scalar(@c_dat);
+ $nc = scalar(@dat) if $nc < scalar(@dat);
+ for (my $i=0; $i<$nc; $i++) {
+ if (defined $c_dat[$i] && defined $dat[$i]) {
+ if ($c_dat[$i] != $dat[$i]) {
+ push @errmsg,
+ {msg => sprintf("data %d mismatch: found=%6.6o, expect=%6.6o",
+ $i, $dat[$i], $c_dat[$i]),
+ line => $line};
+ }
+ } elsif (defined $c_dat[$i] && ! defined $dat[$i]) {
+ push @errmsg,
+ {msg => sprintf("data %d mismatch: nothing found, expected=%6.6o",
+ $i, $c_dat[$i]),
+ line => $line};
+ } elsif (! defined $c_dat[$i] && defined $dat[$i]) {
+ push @errmsg,
+ {msg => sprintf("data %d mismatch: found=%6.6o, nothing expected",
+ $i, $dat[$i]),
+ line => $line};
+ }
+ }
+ }
+
+ # trace expects
+ if ($opts{tcheck} && $echeck != scalar(@errmsg)) {
+ $echeck = scalar(@errmsg);
+ printf "FAIL: %s\n", $errmsg[-1]{msg};
+ }
+
+ # invalidate expect condition
+ $c_string = undef;
+ }
+
+ # done with file
+ my $verdict = scalar(@errmsg) ? 'FAILED' : 'OK';
+ printf "asm-11_expect: %s %s\n", $fname, $verdict;
+ foreach (@errmsg) {
+ printf " FAIL: %s\n in: %s\n", $$_{msg}, $$_{line};
+ }
+
+ $errcnt += scalar(@errmsg);
+
+ return;
+}
+
+#-------------------------------------------------------------------------------
+
+sub print_help {
+ print "usage: asm-11_expect \n";
+ print " --tline trace input lines\n";
+ print " --tcheck trace expect checks\n";
+ return;
+}
asm-11_expect
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xilinx_vhdl_memcolltype_fix
===================================================================
--- xilinx_vhdl_memcolltype_fix (nonexistent)
+++ xilinx_vhdl_memcolltype_fix (revision 38)
@@ -0,0 +1,21 @@
+#!/bin/sh
+# $Id: xilinx_vhdl_memcolltype_fix 93 2007-10-28 21:24:44Z mueller $
+#
+# remove the lines
+#
+# variable Write_A_Write_B : memory_collision_type := Write_A_Write_B;
+# variable Read_A_Write_B : memory_collision_type := Read_A_Write_B;
+# variable Write_A_Read_B : memory_collision_type := Write_A_Read_B;
+# variable Write_B_Write_A : memory_collision_type := Write_B_Write_A;
+# variable Read_B_Write_A : memory_collision_type := Read_B_Write_A;
+# variable Write_B_Read_A : memory_collision_type := Write_B_Read_A;
+#
+# from vhd sources. These self-referencial init are wrong and cause ghdl to
+# choke. The awk script checks quite closely for this patterns.
+
+for file in `egrep -l 'variable.*(Read|Write)_(A|B)_(Read|Write)_(A|B)' *.vhd`
+do
+ echo "# strip 'variable.. memory_collision_type..' in $file"
+ mv $file $file.old
+ awk '! /variable.*(Read|Write)_(A|B)_(Read|Write)_(A|B).*memory_collision_type.*(Read|Write)_(A|B)_(Read|Write)_(A|B)/ {print $0}' $file.old > $file
+done
xilinx_vhdl_memcolltype_fix
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xilinx_tsim_xon
===================================================================
--- xilinx_tsim_xon (nonexistent)
+++ xilinx_tsim_xon (revision 38)
@@ -0,0 +1,99 @@
+#!/usr/bin/perl -w
+# $Id: xilinx_tsim_xon 314 2010-07-09 17:38:41Z mueller $
+#
+# Copyright 2010- by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2010-05-06 289 1.0 Initial version
+#
+#
+# Add "XON => false," defs in X_FF and X_SFF instances when name of the
+# instance is matched by a regexp found in a descriptor file.
+#
+# Logic:
+# looks for lines like
+# : X_FF
+# generic map(
+# and adds
+# XON => false, -- added by xilinx_tsim_xon tool --
+# if is matched by a regexp found in file stem..tsim_xon_dat
+#
+# all old 'XON => false' lines in input file are removed first, so this
+# tool can be rerun with changing desciptor files.
+#
+
+use strict;
+
+my $stem = shift;
+
+if (not defined $stem) {
+ print "xilinx_tsim_xon-E: call with file stem\n";
+ exit 1;
+}
+
+my $file_vhd = $stem . "_tsim.vhd";
+my $file_dsc = $stem . ".tsim_xon_dat";
+
+if (! -r $file_vhd) {
+ print "xilinx_tsim_xon-E: $file_vhd not found or readable\n";
+ exit 1;
+}
+if (! -r $file_dsc) {
+ print "xilinx_tsim_xon-E: $file_dsc not found or readable\n";
+ exit 1;
+}
+
+my @dsc_list;
+open(DFILE, "<$file_dsc") || die ("Can't open descriptor file $file_dsc: $!");
+while () {
+ chomp;
+ s/^\s*//;
+ s/\s*$//;
+ next if m/^#/;
+ next if m/^$/;
+ push @dsc_list, $_;
+}
+close(DFILE);
+
+my $file_tmp = $stem . "_tsim_new.vhd";
+open(OFILE, ">$file_tmp") || die ("Can't open output file $file_tmp: $!");
+open(IFILE, "<$file_vhd") || die ("Can't open input file $file_vhd: $!");
+
+my $match_1 = 0;
+my $name_1;
+
+while () {
+ my $line = $_;
+ next if m/-- added by xilinx_tsim_xon tool --$/;
+ print OFILE $line;
+ my $match = 0;
+ my $name;
+ if ($line =~ m/\s*([a-zA-Z0-9_]+)\s*:\s*(X_FF|X_SFF)/) {
+ $name = $1;
+ foreach my $pat (@dsc_list) {
+ $match = 1 if ($name =~ m/^$pat$/);
+ }
+ }
+ if ($match_1 && $line =~ m/generic map/) {
+ ## print "xilinx_tsim_xon-I: XON=>false for $name_1\n";
+ print OFILE
+ " XON => false, -- added by xilinx_tsim_xon tool --\n";
+ }
+ $match_1 = $match;
+ $name_1 = $name;
+}
+
+close(IFILE);
+close(OFILE);
+
+rename $file_tmp, $file_vhd or die ("Can't rename $file_tmp: $!");
xilinx_tsim_xon
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: xst_count_bels
===================================================================
--- xst_count_bels (nonexistent)
+++ xst_count_bels (revision 38)
@@ -0,0 +1,106 @@
+#!/usr/bin/perl -w
+# $Id: xst_count_bels 314 2010-07-09 17:38:41Z mueller $
+#
+# Copyright 2007-2010 by Walter F.J. Mueller
+#
+# This program is free software; you may redistribute and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation, either version 2, or at your option any later version.
+#
+# 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 complete details.
+#
+# Revision History:
+# Date Rev Version Comment
+# 2010-04-26 284 1.2.1 add error check for GetOptions
+# 2007-10-28 93 1.2 added -xsts (_ssim based device summary)
+# 2007-06-30 62 1.1 fixed parser, now all bels counted
+# 2007-06-16 57 1.0 Initial version
+
+use 5.005; # require Perl 5.005 or higher
+use strict; # require strict checking
+
+use Getopt::Long;
+
+sub do_file;
+
+my %opts = ();
+
+GetOptions(\%opts, "xstl", "xsts")
+ or die "bad options";
+
+my $do_xstl = defined $opts{xstl};
+my $do_xsts = defined $opts{xsts};
+my $do_plain = not ($do_xstl or $do_xsts);
+
+foreach (@ARGV) { do_file($_); }
+
+#-------------------------------------------------------------------------------
+
+sub do_file {
+ my ($filename) = @_;
+ my %bels;
+ my $cur_bel;
+
+ open (IFILE, $filename) or die "can't open for read $filename";
+ while() {
+ chomp;
+ if (m{^\s*[a-zA-Z0-9_]+\s*:\s*([a-zA-Z0-9_]+)\s*$}) {
+ $cur_bel = $1;
+ } elsif (m{\s*(generic|port)\s+map\s*\(\s*}) {
+ $bels{$cur_bel} += 1 if $cur_bel;
+ } else {
+ $cur_bel = "";
+ }
+ }
+ close (IFILE);
+
+ if ($do_plain) {
+ foreach (sort keys %bels) {
+ printf "%16s : %5d\n", $_, $bels{$_};
+ }
+ }
+
+ if ($do_xsts) {
+ my $n_flop = 0;
+ my $n_luts = 0;
+ my $n_luts_log = 0;
+ my $n_luts_ram = 0;
+ my $n_bram = 0;
+ my $n_mult = 0;
+ my $n_iob = 0;
+
+ foreach (sort keys %bels) {
+ if (/^FD/) {
+ $n_flop += $bels{$_};
+ } elsif (/^LUT/) {
+ $n_luts += $bels{$_};
+ $n_luts_log += $bels{$_};
+ } elsif (/^RAMB/) {
+ $n_bram += $bels{$_};
+ } elsif (/^RAM\d*X.*D$/) {
+ $n_luts += 2 * $bels{$_};
+ $n_luts_ram += 2 * $bels{$_};
+ } elsif (/^RAM\d*X.*S$/) {
+ $n_luts += $bels{$_};
+ $n_luts_ram += $bels{$_};
+ } elsif (/^[IO]BUF$/) {
+ $n_iob += $bels{$_};
+ } elsif (/^MULT/) {
+ $n_mult += $bels{$_};
+ }
+ }
+
+ print "Device utilization summary (_ssim BELS scan):\n";
+ print "---------------------------------------------\n";
+ printf " Number of Flip Flops: %5d\n", $n_flop;
+ printf " Number of LUTs: %5d\n", $n_luts;
+ printf " Number used as logic: %5d\n", $n_luts_log;
+ printf " Number used as RAMs: %5d\n", $n_luts_ram;
+ printf " Number of bonded IOBs: %5d\n", $n_iob;
+ printf " Number of BRAMs: %5d\n", $n_bram;
+ printf " Number of MULT18X18s: %5d\n", $n_mult;
+ }
+}
xst_count_bels
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: .
===================================================================
--- . (nonexistent)
+++ . (revision 38)
.
Property changes :
Added: svn:ignore
## -0,0 +1,44 ##
+*.gz
+*.tar
+*.tgz
+*.dep_*
+work-obj93.cf
+*.vcd
+*.ghw
+*.sav
+*.tmp
+*.exe
+ise
+xflow.his
+*.ngc
+*.ncd
+*.pcf
+*.bit
+*.msk
+*.svf
+*.log
+isim
+*_[sfot]sim.vhd
+*_tsim.sdf
+rlink_cext_fifo_[rt]x
+rlink_cext_conf
+tmu_ofile
+*.dsk
+*.tap
+*.lst
+*.cof
+.Xil
+project_mflow
+xsim.dir
+webtalk_*
+*_[sfot]sim
+*_[IX]Sim
+*_[IX]Sim_[sfot]sim
+*.dcp
+*.jou
+*.pb
+*.prj
+*.rpt
+*.wdb
+cycfx2prog
+tclshcpp