OpenCores

/create_disk

0,0 → 1,283

create_disk Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: tap2file =================================================================== --- tap2file (nonexistent) +++ tap2file (revision 33) @@ -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 33) @@ -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: tbrun_tbwrri =================================================================== --- tbrun_tbwrri (nonexistent) +++ tbrun_tbwrri (revision 33) @@ -0,0 +1,177 @@ +#!/bin/bash +# $Id: tbrun_tbwrri 666 2015-04-12 21:17:54Z mueller $ +# +# Copyright 2014-2015 by Walter F.J. Mueller +# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory +# +# Revision History: +# Date Rev Version Comment +# 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 () +{ + echo "$1" + if [[ -z "$optdry" ]] ; then + eval "$1" + fi +} + +optdry="" +optlsuf="" +optstack="" +optghw="" +opttbw="" +optpack="" +optrri="" +optpcom="" +optcuff="" +optfusp="" +optxon="" + +# handle options +while (( $# > 0 )) ; do + case $1 in + -dry|--dry) optdry=$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 ;; + -xon|--xon) optxon=$1 ; shift 1 ;; + -pcom|--pcom) optpcom=$1 ; shift 1 ;; + -\?|-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 " --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 " --xon use xon with 1st serport" + echo " --pcom print test comments" + 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 "$optxon" ]] ; then ncfxcount=$(($ncfxcount+1)); fi + +if (( $ncfxcount > 1 )) ; then + echo "tbrun_tbwrri-E: only one of --cuff,-fusp,--xon allowed" + exit 1 +fi + +tbench=$1 +shift 1 + +tbenchname=$(basename $tbench) +tbenchpath=$(dirname $tbench) + +# check for ghdl with _ssim, _fsim, _tsim +isghdlxsim="" +if [[ $tbench =~ _[sft]sim$ ]] ; then + isghdlxsim=true + logsuff="" +fi + +# issue makes +if [[ -n "$isghdlxsim" ]] ; then docmd "make -C $tbenchpath ghdl_tmp_clean"; fi +docmd "make -C $tbenchpath $tbenchname" +exitstat=$? +if [[ -n "$isghdlxsim" ]] ; then docmd "make -C $tbenchpath ghdl_tmp_clean"; fi + +if (( $exitstat > 0 )) ; then exit $exitstat; fi + +# determine logfile name +logsuff="_dsim" +if [[ $tbenchname =~ _[sft]sim$ ]] ; then logsuff=""; fi +if [[ -n "$optlsuf" ]] ; then logsuff="_$optlsuf"; fi + +logfile="${tbenchname}${logsuff}.log" + +# now build actual test command +cmd="time ti_rri --run=\"tbw $tbench -fifo" +if [[ -n "$opttbw" ]] ; then cmd+=" $opttbw"; fi +if [[ -n "$optstack" ]] ; then cmd+=" --stack-max-size=$optstack"; fi +if [[ -n "$optghw" ]] ; then + if [[ "$optghw" != *.ghw ]]; then optghw="$optghw.ghw"; fi + cmd+=" --wave=$optghw"; +fi +cmd+=" 2>&1 | ghdl_assert_filter\"" + +# Note: the following ensurs that we always have 'fifo=, 0 )) ; then fifoopts+=",noinit"; fi + +if [[ -n "$fifoopts" ]] ; then + cmd+=" --fifo=$fifoopts" +else + cmd+=" --fifo" +fi + +cmd+=" --logl=3" + +if [[ -n "$optpack" ]] ; then cmd+=" --pack=$optpack"; fi +if [[ -n "$optrri" ]] ; then cmd+=" $optrri"; fi + +cmd+=" --" + +if [[ -n "$optcuff" ]] ; then + cmd+=" \"rlc oob -sbdata 8 0x4\"" # portsel = 0100 -> fx2 + cmd+=" \"rlc oob -sbdata 16 0x4\"" # swi = 0100 -> fx2 +fi + +if [[ -n "$optfusp" ]] ; then + cmd+=" \"rlc oob -sbdata 8 0x1\"" # portsel = 0001 -> 2nd ser + cmd+=" \"rlc oob -sbdata 16 0x1\"" # swi = 0001 -> 2nd ser +fi + +if [[ -n "$optxon" ]] ; then + cmd+=" \"rlc oob -sbdata 8 0x2\"" # portsel = 0010 -> 1st ser XON + cmd+=" \"rlc oob -sbdata 16 0x2\"" # swi = 0010 -> 1st ser XON +fi + +if (( $ncfxcount > 0 )) ; then cmd+=" \"rlc init\""; fi + +while (( $# > 0 )) ; do + cmd+=" " + if [[ $1 =~ " " ]] ; then cmd+="\""; fi + cmd+="$1" + if [[ $1 =~ " " ]] ; then cmd+="\""; fi + shift 1 +done +cmd+=" | tee $logfile" + +pcomtag="" +if [[ -n "$optpcom" ]] ; then pcomtag="^\#|"; fi +# FAIL, PASS, DONE come from tbs +cmd+=" | egrep \"(${pcomtag}-[EFW]:|FAIL|PASS|DONE)\"" +docmd "$cmd"

tbrun_tbwrri Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: ticonv_pdpcp =================================================================== --- ticonv_pdpcp (nonexistent) +++ ticonv_pdpcp (revision 33) @@ -0,0 +1,275 @@ +#!/usr/bin/perl -w +# $Id: ticonv_pdpcp 675 2015-05-08 21:05:08Z 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-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=f", "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: vbomconv =================================================================== --- vbomconv (nonexistent) +++ vbomconv (revision 33) @@ -0,0 +1,964 @@ +#!/usr/bin/perl -w +# $Id: vbomconv 672 2015-05-02 21:58:28Z mueller $ +# +# Copyright 2007-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-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 Getopt::Long; + +my %opts = (); + +GetOptions(\%opts, "help", "trace", "xlpath=s", + "dep_ghdl", "dep_xst", "dep_isim", "dep_vsyn", + "xst_prj", "isim_prj", + "vsyn_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", + "get_top", + "flist") || exit 1; + +sub print_help; +sub read_vbom; +sub scan_vbom; +sub copy_edir; +sub write_vbomdep; +sub canon_fname; + +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 %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 %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_any = 0; # ignore tags (for --flist) +my $nactions = 0; # number of action commands +my $top_vbom; # top level vbom (from argv) +my $stem; # stem of $top_vbom +my $top; # top level entity name +my $top_done = 0; # @top seen +my $has_unisim; # @lib:unisim seen or implied +my $has_unimacro; # @lib:unimacro seen +my $has_simprim; # @lib:simprim seen or implied +my $is_ssim; +my $is_fsim; +my $is_tsim; +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 ""; + +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; +} + +# 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_any = 1 if ($_ eq "flist"); +} + +$is_sim = $is_ghdl | $is_isim | $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; + +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 _fsim and _tsim vbom's +# they are inferred from the _ssim vbom's + +if ($top_vbom =~ m{_ssim\.vbom$}) { # detect _ssim + $is_ssim = 1; +} +if ($top_vbom =~ m{_fsim\.vbom$}) { # map _fsim -> _ssim + $is_fsim = 1; + $top_vbom =~ s{_fsim\.vbom$}{_ssim.vbom}; +} +if ($top_vbom =~ m{_tsim\.vbom$}) { # map _tsim -> _ssim + $is_tsim = 1; + $top_vbom =~ s{_tsim\.vbom$}{_ssim.vbom}; +} + +# traverse all vbom's start with command line argument + +push @vbom_queue, $top_vbom; + +while (@vbom_queue) { + my $cur_vbom = shift @vbom_queue; + read_vbom($cur_vbom); +} + +# traverse internal vbom representation to build file table + +$vbom_rank{$top_vbom} = {min=>1, max=>1}; +scan_vbom($top_vbom); + +# 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 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\n", $_->[0], $_->[1]; + } + + print STDERR "\n"; + print STDERR "properties:\n"; + print STDERR " \@top: $top\n"; +} + +# --ghdh_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; + } + + foreach (@srcfile_list) { + my $file = $_; + my $cmd = "ghdl -a"; + $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 .= " $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); + } + } + } + } +} + +# --ghdh_i -- ghdl inspection command -------------------------------- + +if (exists $opts{ghdl_i} || exists $opts{ghdl_i_cmd}) { + my %ghdl_work; + + # 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 "work-obj93.cf") { + open (WFILE, "work-obj93.cf") or + die "can't open for read work-obj93.cf: $!"; + while () { + if (m{^file \. \"(.*?)\"}) { + $ghdl_work{$1} = 1; + } + } + close (WFILE); + } + + my $cmd = "ghdl -i"; + 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"; + } +} + +# --ghdh_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 $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"; + $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 .= " --no-vital-checks" if $is_ssim or $is_fsim or $is_tsim; + + 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}) { + # setup sources + print "#\n"; + print "# setup sources\n"; + print "#\n"; + print "set src_files {\n"; + foreach (@srcfile_list) { + print " $_\n"; + } + print "}\n"; + print "\n"; + + print "set obj [get_filesets sources_1]\n"; + print "add_files -norecurse -fileset \$obj \$src_files\n"; + print "set_property \"top\" \"$top\" \$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"; + + print "set obj [get_filesets constrs_1]\n"; + print "add_files -norecurse -fileset \$obj \$xdc_files\n"; + + print "\n"; +} + +# --dep_ghdl --------------------------------------------------------- + +if (exists $opts{dep_ghdl}) { + + my $stem_fsim = $stem; + my $stem_tsim = $stem; + $stem_fsim =~ s/_ssim$/_fsim/; + $stem_tsim =~ s/_ssim$/_tsim/; + + print "#\n"; + print "$stem : $stem.dep_ghdl\n"; + if ($is_ssim) { + print "$stem_fsim : $stem.dep_ghdl\n"; + print "$stem_tsim : $stem.dep_ghdl\n"; + } + print "#\n"; + + foreach (@srcfile_list) { + if (/\.c$/) { + my $ofile = $_; # copy to break alias for following s/// + $ofile =~ s{^.*/}{}; # remove directory path + $ofile =~ s/\.c$/.o/; # object file name + print "$stem : $ofile\n"; # depend on C source object file + # C source object compilation dependence + open (ODEPFILE, ">$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"; + } + } + + if ($is_ssim) { + + 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$/_fsim.vhd/; + } + print "$stem_fsim : $file\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$/_tsim.vhd/; + } + print "$stem_tsim : $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 ($is_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 ($is_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 ($is_ssim) { + + foreach (@srcfile_list) { + my $file = $_; # copy to break alias for following s/// + $file =~ s/_ssim\.vhd$/_fsim.vhd/; + print "$stem_fsim_isim : $file\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"); +} + +# --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); } + } + +} + +# --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)$/) { + $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); + } 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; + + # process @ucf_cpp: lines + } elsif ($tag eq '@ucf_cpp') { + push @ucf_cpp_list, $val; + + # process @xdc: lines + } elsif ($tag eq '@xdc') { + push @{$vbom_xdc{$vbom}}, canon_fname($vbom_path, $val); + + # 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; + } + + # catch invalid @ tags + } else { + print STDERR "vbomconv-E: invalid \'$tag:\' line in $vbom_file\n"; + exit 1; + } + next; + } + + # now do _fsim, _tsim mapping + $val =~ s{_ssim\.vhd$}{_fsim.vhd} if $is_fsim; + $val =~ s{_ssim\.vhd$}{_tsim.vhd} if $is_tsim; + + # process normal .vhd or .vbom file lines + # canonize file name unless not already done by filename substitution + my $fullname; + if ($val =~ m{^!(.*)$}) { + $fullname = $1; + } else { + $fullname = canon_fname($vbom_path, $val); + } + + # determine whether additional libs needed + if ($fullname =~ m{_ssim\.vhd$}) { # ends in _ssim.vhd + $has_unisim = 1; + } + if ($fullname =~ m{_[ft]sim\.vhd$}) { # ends in _fsim.vhd or _tsim.vhd + $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 (@{$vbom_files{$vbom}}) { + my $file = $_; + $rank -= 1; + if (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 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 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 " --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: tmuconv =================================================================== --- tmuconv (nonexistent) +++ tmuconv (revision 33) @@ -0,0 +1,920 @@ +#!/usr/bin/perl -w +# $Id: tmuconv 676 2015-05-09 16:31:54Z 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 +# 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 +# co.cpugo:b +# co.cpususp:b +# co.suspint:b +# co.suspext:b +# sy.emmreq.req:b +# sy.emmreq.we:b +# sy.emmreq.be:b +# sy.emmreq.cancel:b +# sy.emmreq.addr:o +# sy.emmreq.din:o +# sy.emsres.ack_r:b +# sy.emsres.ack_w:b +# sy.emsres.dout:o +# 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_sy_emmreq_req; +my $ind_sy_emmreq_we; +my $ind_sy_emmreq_be; +my $ind_sy_emmreq_cancel; +my $ind_sy_emmreq_addr; +my $ind_sy_emmreq_din; +my $ind_sy_emsres_ack_r; +my $ind_sy_emsres_ack_w; +my $ind_sy_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=>"swap", 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=>"jsr"}, + {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=>"rdst"}, + {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=> "ti.csr", + 177562=> "ti.buf", + 177564=> "to.csr", + 177566=> "to.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=> "rpa.cs1", + 176702=> "rpa.wc ", + 176704=> "rpa.ba ", + 176706=> "rpa.da ", + 176710=> "rpa.cs2", + 176712=> "rpa.ds ", + 176714=> "rpa.er1", + 176716=> "rpa.as ", + 176720=> "rpa.la ", + 176722=> "rpa.db ", + 176724=> "rpa.mr1", + 176726=> "rpa.dt ", + 176730=> "rpa.sn ", + 176732=> "rpa.of ", + 176734=> "rpa.dc ", + 176736=> "rpa.m13", + 176740=> "rpa.m14", + 176742=> "rpa.m15", + 176744=> "rpa.ec1", + 176746=> "rpa.ec2", + 176750=> "rpa.bae", + 176752=> "rpa.cs3", + 176500=> "ti2.cs", + 176502=> "ti2.bu", + 176504=> "to2.cs", + 176506=> "to2.bu", + 174400=> "rl.cs ", + 174402=> "rl.ba ", + 174404=> "rl.da ", + 174406=> "rl.mp ", + 172540=> "kp.csr", + 172542=> "kp.buf", + 172544=> "kp.cnt", + 172520=> "tm.mts", + 172522=> "tm.mtc", + 172524=> "tm.brc", + 172526=> "tm.cma", + 172530=> "tm.mtd", + 172532=> "tm.rda", + 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; +} + +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_sy_emmreq_req = $name{'sy.emmreq.req'}->{ind}; + $ind_sy_emmreq_we = $name{'sy.emmreq.we'}->{ind}; + $ind_sy_emmreq_be = $name{'sy.emmreq.be'}->{ind}; + $ind_sy_emmreq_cancel = $name{'sy.emmreq.cancel'}->{ind}; + $ind_sy_emmreq_addr = $name{'sy.emmreq.addr'}->{ind}; + $ind_sy_emmreq_din = $name{'sy.emmreq.din'}->{ind}; + $ind_sy_emsres_ack_r = $name{'sy.emsres.ack_r'}->{ind}; + $ind_sy_emsres_ack_w = $name{'sy.emsres.ack_w'}->{ind}; + $ind_sy_emsres_dout = $name{'sy.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 sy_emmreq_req = '1' +# sy_emsres_ack_r = '1' +# sy_emsres_ack_w = '1' +# sy_emsreq_cancel = '1' +# + if (exists $opts{t_em}) { + if ($val_curr[$ind_sy_emmreq_req]) { + $emreq_cyc = $cyc_curr; + $emreq_str = sprintf "%s %s %8.8o", + ($val_curr[$ind_sy_emmreq_we] ? "w" : "r"), + $val_curr[$ind_sy_emmreq_be], + $val_curr[$ind_sy_emmreq_addr]; + $emcurr_we = $val_curr[$ind_sy_emmreq_we]; + $emcurr_addr = $val_curr[$ind_sy_emmreq_addr]; + if ($emcurr_we) { + $emreq_str .= sprintf " %6.6o", $val_curr[$ind_sy_emmreq_din]; + } else { + $emreq_str .= " " x 7; + } + } + if ($val_curr[$ind_sy_emsres_ack_r] || + $val_curr[$ind_sy_emsres_ack_w] || + $val_curr[$ind_sy_emmreq_cancel]) { + $emres_str = sprintf "%s%s%s%s", + $val_curr[$ind_sy_emmreq_cancel], + $val_curr[$ind_sy_emsres_ack_r], + $val_curr[$ind_sy_emsres_ack_w], + $val_curr[$ind_sy_chit]; + if ($val_curr[$ind_sy_emmreq_cancel]) { + $emreq_str .= " cancel"; + $emcurr_we = undef; + } else { + if ($val_curr[$ind_sy_emsres_ack_r]) { + $emreq_str .= sprintf " %6.6o", $val_curr[$ind_sy_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 .= " 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") { + my $off = $code & 0177; + my $sign = "+"; + if ($code & 0200) { + $off = -(((~$off) & 0177)+1); + $sign = "-"; + } + return sprintf "$name .%s%d.", $sign, abs(2*$off); + + } elsif ($type eq "sob") { + my $reg = ($code>>6) & 07; + my $off = $code & 077; + return sprintf "$name r%d,.-%d.", $reg, 2*$off; + + } 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 "jsr") { + 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 33) @@ -0,0 +1,2471 @@ +#!/usr/bin/perl -w +# $Id: asm-11 659 2015-03-22 23:15:51Z 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 +# 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_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 $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; + return; +} + +#------------------------------------------------------------------------------- + +sub incdot { + my ($inc) = @_; + return unless defined $inc; + setdot(getdot() + $inc); + return; +} + +#------------------------------------------------------------------------------- + +sub getdot { + 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'"; + } + + # 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_b { + my ($rl,$byte) = @_; + push @{$$rl{outb}}, $byte; + incdot(1); + return; +} + +#------------------------------------------------------------------------------- + +sub out_opcode { + my ($rl,$code) = @_; + out_w($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_w($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_w($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_w($rl, 0); + add_err($rl, 'U'); + return; + } + if ($mod>=6 && $reg==7) { + $val = ($val - (getdot()+2)) & 0177777; + } + out_w($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: ti_w11 =================================================================== --- ti_w11 (nonexistent) +++ ti_w11 (revision 33) @@ -0,0 +1,307 @@ +#!/usr/bin/perl -w +# $Id: ti_w11 680 2015-05-14 13:29:46Z mueller $ +# +# Copyright 2013-2015 by Walter F.J. Mueller +# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory +# +# Revision History: +# Date Rev Version Comment +# 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_tmu; +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; +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{^-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 -f1x by default) + $opt_io = 'f'; + $opt_f = '1x'; + $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{^-f(c|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; + } + } + } 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 eq 'x'; + push @arglist, "--fifo=$fifoopts"; + push @arglist, "--run=$val_tb"; +} 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|n3|b3|n4|bn4) nor -t,-u specified\n"; + print_usage(); + exit 1; +} + +# +# setup all other ti_rri options +# + +push @arglist, '--logl=2'; +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 13 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 '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: -f1x)\n"; + print " -n4 start tb_w11a_n4 simulation\n"; + print " -bn4 start tb_w11a_br_n4 simulation\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 " -f1 use 1st serport\n"; + print " -f1x use 1st serport with xon\n"; + print " -f2 use 2nd serport (fusp)\n"; + print " -f2x use 2nd serport with xon\n"; + print " -tmu activate trace and monitoring unit\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: xise_msg_filter =================================================================== --- xise_msg_filter (nonexistent) +++ xise_msg_filter (revision 33) @@ -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: ti_rri =================================================================== --- ti_rri (nonexistent) +++ ti_rri (revision 33) @@ -0,0 +1,338 @@ +#! /usr/bin/env tclshcpp +# -*- tcl -*- +# $Id: ti_rri 631 2015-01-09 21:36:51Z 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-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 +# --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 + 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_) } + ^--?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 { --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_) + +# 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 "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 "aborting..." + break + } + # handle @file.dat ect --> not yet supported + } else { + puts "-E: only tcl supported but $filename found" + puts "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 "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: xise_ghdl_unisim =================================================================== --- xise_ghdl_unisim (nonexistent) +++ xise_ghdl_unisim (revision 33) @@ -0,0 +1,98 @@ +#!/bin/bash +# $Id: xise_ghdl_unisim 642 2015-02-06 18:53:12Z mueller $ +# +# Copyright 2007-2015 by Walter F.J. Mueller +# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory +# +# Revision History: +# Date Rev Vers Comment +# 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 +# + +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 unisim_VCOMP.vhd +echo "# ghdl ... unisim_VPKG.vhd" +ghdl -a --ieee=synopsys --work=unisim unisim_VPKG.vhd + +for file in `cat primitive/vhdl_analyze_order` +do + echo "# ghdl ... primitive/$file" + ghdl -a -fexplicit --ieee=synopsys --work=unisim \ + --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 \ + --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 33) @@ -0,0 +1,65 @@ +#!/bin/bash +# $Id: xtwi 641 2015-02-01 22:12:15Z mueller $ +# +# Copyright 2013- 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 +# 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 + + # 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: tbw =================================================================== --- tbw (nonexistent) +++ tbw (revision 33) @@ -0,0 +1,290 @@ +#!/usr/bin/perl -w +# $Id: tbw 642 2015-02-06 18:53:12Z mueller $ +# +# Copyright 2007-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-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; + +my $tb_code; +my $is_isim; +my $is_isim_run; +my $is_fifo; +my $is_verbose; + +my @args_pos; # list of positional args +my @args_nam; # list of named args +my @file_dsc; # file descriptors from tbw.dat + +sub print_usage; + +autoflush STDOUT 1; # autoflush, so nothing lost on exec later + +if (scalar(@ARGV) && $ARGV[0] =~ /^-*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; +} + +$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; +} + +my $tb_code_stem = $tb_code_name; +$tb_code_stem =~ s/_[fst]sim$//; # drop _ssim,_fsim, or _tsim + +if ($tb_code_stem =~ /_ISim$/) { # is it an ISim executable ? + $is_isim = 1; + $tb_code_stem =~ s/_ISim$//; # drop _ISim + if (scalar(@ARGV) && $ARGV[0] eq "-run") { + $is_isim_run = 1; + shift @ARGV; + } +} + +if (scalar(@ARGV) && $ARGV[0] eq "-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=>''}; + $is_fifo = 1; + shift @ARGV; +} +if (scalar(@ARGV) && $ARGV[0] eq "-verbose") { + $is_verbose = 1; + shift @ARGV; +} + +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 ((!$is_fifo) && -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"; + } + } +} + +# +# if no tbw.dat or no matching stanza found, setup defaults +# + +if (!$is_fifo) { + unless (scalar (@file_dsc)) { + push @file_dsc, {tag=>$tb_code_stem . "_stim", + val=>$tb_code_stem . "_stim.dat"}; + } +} else { + push @file_dsc, {tag=>"rlink_cext_fifo_rx", + val=>""}; +} + +# +# 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 ($is_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 + } + + 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: $!"; + } + } + } +} + +# +# 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 + exec $tb_code,@ARGV + or die "failed to exec: $!"; +} + +# ---------------------------------------------------------------------------- +sub print_usage { + print "usage: tbw [opts] [filedefs] [ghdl-opts]\n"; + print " opts\n"; + print " -run for _ISim tb's, runs the tb with a '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: tbrun_tbw =================================================================== --- tbrun_tbw (nonexistent) +++ tbrun_tbw (revision 33) @@ -0,0 +1,100 @@ +#!/bin/bash +# $Id: tbrun_tbw 641 2015-02-01 22:12:15Z mueller $ +# +# Copyright 2014- by Walter F.J. Mueller +# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory +# +# Revision History: +# Date Rev Version Comment +# 2014-12-27 622 1.0.1 add --stack, --ghw, --tbw, --pcom +# 2014-12-26 621 1.0 Initial version +# + +docmd () +{ + echo "$1" + if [[ -z "$optdry" ]] ; then + eval "$1" + fi +} + +optdry="" +optlsuf="" +optstack="" +optghw="" +opttbw="" +optpcom="" + +# handle options +while (( $# > 0 )) ; do + case $1 in + -dry|--dry) optdry=$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 " --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" + exit 1 +fi + +# check for ISim +isisim="" +if [[ $tbench =~ _ISim ]] ; then + isisim=true +fi + +# check for ghdl with _ssim, _fsim, _tsim +isghdlxsim="" +if [[ "$isisim" == "" ]] && [[ $tbench =~ _[sft]sim$ ]] ; then + isghdlxsim=true + logsuff="" +fi + +# issue makes +if [[ -n "$isghdlxsim" ]] ; then docmd "make ghdl_tmp_clean"; fi +docmd "make $tbench" +exitstat=$? +if [[ -n "$isghdlxsim" ]] ; then docmd "make ghdl_tmp_clean"; fi + +if (( $exitstat > 0 )) ; then exit $exitstat; fi + +# determine logfile name +logsuff="_dsim" +if [[ $tbench =~ _[sft]sim$ ]] ; then logsuff=""; fi +if [[ -n "$optlsuf" ]] ; then logsuff="_$optlsuf"; fi + +logfile="${tbench}${logsuff}.log" + +# now build actual test command (a tbw|filter|tee|egrep pipe) +cmd="time tbw $tbench" +if [[ -n "$isisim" ]] ; then cmd+=" -run"; fi +if [[ -n "$stimfile" ]] ; then cmd+=" $stimfile"; fi +if [[ -n "$opttbw" ]] ; then cmd+=" $opttbw"; fi +if [[ -n "$optstack" ]] ; then cmd+=" --stack-max-size=$optstack"; fi +if [[ -n "$optghw" ]] ; then cmd+=" --wave=$optghw.ghw"; fi +cmd+=" 2>&1" +if [[ -z "$isisim" ]] ; then cmd+=" | ghdl_assert_filter"; fi +cmd+=" | tee $logfile" + +pcomtag="" +if [[ -n "$optpcom" ]] ; then pcomtag="^C|"; fi +# FAIL, PASS, DONE come from tbs; ERROR comes from ISim +cmd+=" | egrep \"(${pcomtag}-[EFW]:|ERROR|FAIL|PASS|DONE)\"" +docmd "$cmd"

tbrun_tbw Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: rm_dep =================================================================== --- rm_dep (nonexistent) +++ rm_dep (revision 33) @@ -0,0 +1,18 @@ +#!/bin/sh +# $Id: rm_dep 646 2015-02-15 12:04:55Z 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 +# 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 +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: xise_ghdl_simprim =================================================================== --- xise_ghdl_simprim (nonexistent) +++ xise_ghdl_simprim (revision 33) @@ -0,0 +1,74 @@ +#!/bin/bash +# $Id: xise_ghdl_simprim 642 2015-02-06 18:53:12Z mueller $ +# +# Copyright 2007-2015 by Walter F.J. Mueller +# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory +# +# Revision History: +# Date Rev Vers Comment +# 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 +# + +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 simprim_Vcomponents.vhd +echo "# ghdl ... simprim_Vpackage.vhd" +ghdl -a --ieee=synopsys --work=simprim --no-vital-checks 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 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: xtwv =================================================================== --- xtwv (nonexistent) +++ xtwv (revision 33) @@ -0,0 +1,64 @@ +#!/bin/bash +# $Id: xtwv 641 2015-02-01 22:12:15Z mueller $ +# +# Copyright 2013- 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 +# 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 + + # 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: xviv_ghdl_unisim =================================================================== --- xviv_ghdl_unisim (nonexistent) +++ xviv_ghdl_unisim (revision 33) @@ -0,0 +1,127 @@ +#!/bin/bash +# $Id: xviv_ghdl_unisim 642 2015-02-06 18:53:12Z mueller $ +# +# Copyright 2015- by Walter F.J. Mueller +# License disclaimer see LICENSE_gpl_v2.txt in $RETROBASE directory +# +# Revision History: +# Date Rev Vers Comment +# 2015-02-02 642 1.0 Initial version +# + +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 unisim_retarget_VCOMP.vhd +echo "# ghdl ... unisim_VPKG.vhd" +ghdl -a --ieee=synopsys --work=unisim unisim_VPKG.vhd + +for file in `cat primitive/vhdl_analyze_order` +do + echo "# ghdl ... primitive/$file" + ghdl -a -fexplicit --ieee=synopsys --work=unisim \ + --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 \ + --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 . +# +for file in *.vhd +do + echo "# ghdl ... $file" + ghdl -a -P../unisim -fexplicit --ieee=synopsys --work=unimacro \ + --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: ghdl_assert_filter =================================================================== --- ghdl_assert_filter (nonexistent) +++ ghdl_assert_filter (revision 33) @@ -0,0 +1,29 @@ +#!/usr/bin/perl -w +# $Id: ghdl_assert_filter 620 2014-12-25 10:48:35Z mueller $ +# +# Copyright 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-12-23 620 1.0 Initial version + +use 5.10.0; # require Perl 5.10 or higher +use strict; # require strict checking + +autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe +autoflush STDOUT 1 if (-t STDOUT); # autoflush if output into term + +while (<>) { + next if /:\@0ms:$assertion warning$: NUMERIC_STD.*metavalue detected/; + next if /:\@0ms:$assertion warning$: CONV_INTEGER: There is an 'U'/; + print; +}

ghdl_assert_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 33) @@ -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 33) @@ -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 33) @@ -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 33) @@ -0,0 +1,2 @@ +cycfx2prog +tclshcpp Index: telnet_wrapper =================================================================== --- telnet_wrapper (nonexistent) +++ telnet_wrapper (revision 33) @@ -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 33) @@ -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 33) @@ -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 33) @@ -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 33) @@ -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 33) @@ -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 33)

. Property changes : Added: svn:ignore ## -0,0 +1,35 ## +*.dep_ghdl +*.dep_isim +*.dep_xst +work-obj93.cf +*.vcd +*.ghw +*.sav +*.tmp +*.exe +ise +xflow.his +*.ngc +*.ncd +*.pcf +*.bit +*.msk +isim +isim.log +isim.wdb +fuse.log +*_[sft]sim.vhd +*_tsim.sdf +*_xst.log +*_tra.log +*_twr.log +*_map.log +*_par.log +*_tsi.log +*_pad.log +*_bgn.log +*_svn.log +*_sum.log +*_[dsft]sim.log +cycfx2prog +tclshcpp

Browse

Tools

Subversion Repositories w11

Compare Revisions

Rev 32 → Rev 33