#!/usr/bin/perl
|
#!/usr/bin/perl
|
|
# Part of Blue 8 by Al Williams http://blue.hotsolder.com
|
# V2 supports # constant syntax
|
# V2 supports # constant syntax
|
# we used to support multiple files on command line
|
# we used to support multiple files on command line
|
# but now that the driver script uses cpp, assume 1 file only
|
# but now that the driver script uses cpp, assume 1 file only
|
|
|
|
|
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
|
if $running_under_some_shell;
|
if $running_under_some_shell;
|
# this emulates #! processing on NIH machines.
|
# this emulates #! processing on NIH machines.
|
# (remove #! line above if indigestible)
|
# (remove #! line above if indigestible)
|
|
|
eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_0-9]+=)(.*)/ && shift;
|
eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_0-9]+=)(.*)/ && shift;
|
# process any FOO=bar switches
|
# process any FOO=bar switches
|
|
|
|
|
|
|
|
|
$[ = 1; # set array base to 1
|
$[ = 1; # set array base to 1
|
$, = ' '; # set output field separator
|
$, = ' '; # set output field separator
|
$\ = "\n"; # set output record separator
|
$\ = "\n"; # set output record separator
|
|
|
$pass = 1;
|
$pass = 1;
|
$location = 0;
|
$location = 0;
|
|
|
|
|
%opmap = ('dw', 0, 'hlt', 0, 'nop', 1,
|
%opmap = ('dw', 0, 'hlt', 0, 'nop', 1,
|
'add' ,0x1000,'xor',0x2000, 'and', 0x3000,
|
'add' ,0x1000,'xor',0x2000, 'and', 0x3000,
|
'ior', 0x4000, 'not', 2,'lda', 0x6000, 'sta', 0x7000,
|
'ior', 0x4000, 'not', 2,'lda', 0x6000, 'sta', 0x7000,
|
'call', 0x8000, 'jmp', 0xa000, 'ldx', 0xb000,
|
'call', 0x8000, 'jmp', 0xa000, 'ldx', 0xb000,
|
'ral', 3, 'org', -1,
|
'ral', 3, 'org', -1,
|
'equ', -1, 'end', -1, 'inca', 5, 'deca', 6, 'sz', 0x12, 'snz', 0x1a,
|
'equ', -1, 'end', -1, 'inca', 5, 'deca', 6, 'sz', 0x12, 'snz', 0x1a,
|
"spos", 0x21, "sneg", 0x20, "qon", 0x23, "qoff", 0x22, "qtog", 0x24,
|
"spos", 0x21, "sneg", 0x20, "qon", 0x23, "qoff", 0x22, "qtog", 0x24,
|
'sub', 0x9000, 'cmp', 0x5000, 'ldi', 0x25,
|
'sub', 0x9000, 'cmp', 0x5000, 'ldi', 0x25,
|
'so', 0x0011, 'sz',0x0012, 'szo', 0x0013, 'sc', 0x0014, 'sco', 0x0015,
|
'so', 0x0011, 'sz',0x0012, 'szo', 0x0013, 'sc', 0x0014, 'sco', 0x0015,
|
'scz', 0x0016, 'sczo', 0x0017, 'sno', 0x0019, 'snz', 0x001a, 'snzo', 0x001b,
|
'scz', 0x0016, 'sczo', 0x0017, 'sno', 0x0019, 'snz', 0x001a, 'snzo', 0x001b,
|
'snc', 0x001c, 'snco', 0x001d, 'sncz', 0x001e, 'snczo', 0x001f,
|
'snc', 0x001c, 'snco', 0x001d, 'sncz', 0x001e, 'snczo', 0x001f,
|
'ldax', 0xe000, 'stax', 0xf000, 'incx', 0x0030, 'decx', 0x0031,
|
'ldax', 0xe000, 'stax', 0xf000, 'incx', 0x0030, 'decx', 0x0031,
|
'stx', 0x0032, 'jmpa', 0x0033, 'swap', 0x0034, 'lds', 0xc000,
|
'stx', 0x0032, 'jmpa', 0x0033, 'swap', 0x0034, 'lds', 0xc000,
|
'push', 0x0050, 'pop', 0x0040, 'ret', 0x0041, 'popx', 0x0042, 'pushx', 0x52,
|
'push', 0x0050, 'pop', 0x0040, 'ret', 0x0041, 'popx', 0x0042, 'pushx', 0x52,
|
'pushf', 0x0053, 'popf', 0x0043, 'frame', 0x0008, 'rar', 0x0007, 'ldxa', 0x0009
|
'pushf', 0x0053, 'popf', 0x0043, 'frame', 0x0008, 'rar', 0x0007, 'ldxa', 0x0009
|
);
|
);
|
|
|
%adda = ( 'dw', 1, 'hlt',0, 'nop', 0,
|
%adda = ( 'dw', 1, 'hlt',0, 'nop', 0,
|
'add', 1, 'and',1, 'ior',1,
|
'add', 1, 'and',1, 'ior',1,
|
'not', 0, 'lda', 1, 'sta', 1, 'call', 1, 'jmp', 1,
|
'not', 0, 'lda', 1, 'sta', 1, 'call', 1, 'jmp', 1,
|
'ldx', 1, 'ral', 0, 'inca', 0, 'deca', 0,
|
'ldx', 1, 'ral', 0, 'inca', 0, 'deca', 0,
|
'sz', 0, 'snz', 0, "spos", 0, "sneg", 0, "qon", 0, "qoff", 0, "qtog", 0,
|
'sz', 0, 'snz', 0, "spos", 0, "sneg", 0, "qon", 0, "qoff", 0, "qtog", 0,
|
'sub', 1, 'cmp', 1, 'ldi', 2,
|
'sub', 1, 'cmp', 1, 'ldi', 2,
|
'so', 0, 'sz',0, 'szo', 0, 'sc', 0, 'sco', 0,
|
'so', 0, 'sz',0, 'szo', 0, 'sc', 0, 'sco', 0,
|
'scz', 0, 'sczo', 0, 'sno', 0, 'snz', 0, 'snzo', 0,
|
'scz', 0, 'sczo', 0, 'sno', 0, 'snz', 0, 'snzo', 0,
|
'snc', 0, 'snco', 0, 'sncz', 0, 'snczo', 0,
|
'snc', 0, 'snco', 0, 'sncz', 0, 'snczo', 0,
|
'ldax', 1, 'stax', 1, 'incx', 0, 'decx', 0, 'stx', 0, 'jmpa', 0, 'swap', 0,
|
'ldax', 1, 'stax', 1, 'incx', 0, 'decx', 0, 'stx', 0, 'jmpa', 0, 'swap', 0,
|
'lds', 1, 'push', 0, 'pop', 0, 'ret', 0, 'popx', 0, 'pushx', 0, 'pushf', 0,
|
'lds', 1, 'push', 0, 'pop', 0, 'ret', 0, 'popx', 0, 'pushx', 0, 'pushf', 0,
|
'popf', 0, 'frame', 0, 'rar', 0, 'ldxa', 0
|
'popf', 0, 'frame', 0, 'rar', 0, 'ldxa', 0
|
);
|
);
|
|
|
|
|
floop: while (@ARGV) {
|
floop: while (@ARGV) {
|
$file=shift;
|
$file=shift;
|
&procfile($file);
|
&procfile($file);
|
}
|
}
|
print '// Symbols';
|
print '// Symbols';
|
foreach $v (keys %symtab) {
|
foreach $v (keys %symtab) {
|
if ($v ne '_location_') { printf( "// %s: %04x\n", $v, $symtab{$v}); }
|
if ($v ne '_location_') { printf( "// %s: %04x\n", $v, $symtab{$v}); }
|
}
|
}
|
print '// End Symbols';
|
print '// End Symbols';
|
|
|
|
|
# need to localize
|
# need to localize
|
# so we can call recursively (for INCLUDE)
|
# so we can call recursively (for INCLUDE)
|
sub procfile {
|
sub procfile {
|
local ($file)=@_;
|
local ($file)=@_;
|
local($base);
|
local($base);
|
unless (open(F,$file)) { # may have to close and reopen before recurse?
|
unless (open(F,$file)) { # may have to close and reopen before recurse?
|
print STDERR "Can't open $file.\n";
|
print STDERR "Can't open $file.\n";
|
exit(1);
|
exit(1);
|
}
|
}
|
$base=$location;
|
$base=$location;
|
line: while (<F>) {
|
line: while (<F>) {
|
line0:
|
line0:
|
@lines=split(/\|/);
|
@lines=split(/\|/);
|
foreach (@lines) {
|
foreach (@lines) {
|
$f=&procline($_);
|
$f=&procline($_);
|
if ($f==0) { return; }
|
if ($f==0) { return; }
|
if ($f==2) { seek(F,0,0); next; }
|
if ($f==2) { seek(F,0,0); next; }
|
}
|
}
|
if (eof(F)) {
|
if (eof(F)) {
|
if ($pass==1) {
|
if ($pass==1) {
|
print STDERR "Warning: Missing end in $file";
|
print STDERR "Warning: Missing end in $file";
|
print "//! Warning: Missing end in $file";
|
print "//! Warning: Missing end in $file";
|
}
|
}
|
$_=" END";
|
$_=" END";
|
goto line0;
|
goto line0;
|
}
|
}
|
|
|
}
|
}
|
# the only way to get here is if no end, so warn and fake the end
|
# the only way to get here is if no end, so warn and fake the end
|
# if ($pass==1) {
|
# if ($pass==1) {
|
# print STDERR "warning: Missing end in $file";
|
# print STDERR "warning: Missing end in $file";
|
# &procline(" END");
|
# &procline(" END");
|
# seek(F,0,0);
|
# seek(F,0,0);
|
# goto line;
|
# goto line;
|
# }
|
# }
|
# if ($pass==2) {&procline(" END"); }
|
# if ($pass==2) {&procline(" END"); }
|
}
|
}
|
|
|
sub procline {
|
sub procline {
|
chomp; # strip record separator
|
chomp; # strip record separator
|
|
|
pline:
|
pline:
|
s/;.*$//g;
|
s/;.*$//g;
|
|
|
$theLine = $_;
|
$theLine = $_;
|
if (/^[ \t]*$/) {
|
if (/^[ \t]*$/) {
|
return 1;
|
return 1;
|
}
|
}
|
@Fld = split(' ', $_, 9999);
|
@Fld = split(' ', $_, 9999);
|
|
|
|
|
$clabel = '';
|
$clabel = '';
|
|
|
if (/^[a-zA-Z_][a-zA-Z_0-9]*[:]/) {
|
if (/^[a-zA-Z_][a-zA-Z_0-9]*[:]/) {
|
$t=$Fld[1];
|
$t=$Fld[1];
|
$s = ':', $Fld[1] =~ s/$s//;
|
$s = ':', $Fld[1] =~ s/$s//;
|
$clabel = &toLOWER($Fld[1]);
|
$clabel = &toLOWER($Fld[1]);
|
$s = $t, s/$s//g;
|
$s = $t, s/$s//g;
|
$lvalue = $location;
|
$lvalue = $location;
|
@Fld = split(' ', $_, 9999);
|
@Fld = split(' ', $_, 9999);
|
}
|
}
|
|
|
# must resolve in 1st pass!
|
# must resolve in 1st pass!
|
if ($pass == 1) {
|
if ($pass == 1) {
|
$opcode = &toLOWER($Fld[1]);
|
$opcode = &toLOWER($Fld[1]);
|
if ($Fld[2]!~/['"]/) { $afield = &toLOWER($Fld[2]); }
|
if ($Fld[2]!~/['"]/) { $afield = &toLOWER($Fld[2]); }
|
else {
|
else {
|
s/^[^'"#]*(['"#])/\1/; # get whole string
|
s/^[^'"#]*(['"#])/\1/; # get whole string
|
$afield=$_;
|
$afield=$_;
|
}
|
}
|
# we need to check for psuedo op
|
# we need to check for psuedo op
|
# end, org, equ
|
# end, org, equ
|
if ($opcode eq 'org') {
|
if ($opcode eq 'org') {
|
$location = &xeval($afield);
|
$location = &xeval($afield);
|
}
|
}
|
# must resolve in 1st pass!
|
# must resolve in 1st pass!
|
if ($opcode eq 'equ') {
|
if ($opcode eq 'equ') {
|
$lvalue = &xeval($afield);
|
$lvalue = &xeval($afield);
|
}
|
}
|
if ($clabel =~ /^[a-zA-Z_]/ && $symtab{$clabel} ne '') {
|
if ($clabel =~ /^[a-zA-Z_]/ && $symtab{$clabel} ne '') {
|
print STDERR $clabel . ': Multiple definition';
|
print STDERR $clabel . ': Multiple definition';
|
print "//!" . $clabel . ': Multiple definition';
|
print "//!" . $clabel . ': Multiple definition';
|
}
|
}
|
# if ($lvalue eq "\$") {
|
# if ($lvalue eq "\$") {
|
# $lvalue = $location;
|
# $lvalue = $location;
|
# }
|
# }
|
if ($clabel =~ /^[a-zA-Z_]/) {
|
if ($clabel =~ /^[a-zA-Z_]/) {
|
$symtab{$clabel} = $lvalue;
|
$symtab{$clabel} = $lvalue;
|
}
|
}
|
if ($opcode eq 'ds') {
|
if ($opcode eq 'ds') {
|
&dostring($_);
|
&dostring($_);
|
return 1;
|
return 1;
|
}
|
}
|
|
|
if ($opcode eq 'end') {
|
if ($opcode eq 'end') {
|
foreach $c (keys %con) {
|
foreach $c (keys %con) {
|
if ($symtab{$c} eq '') {
|
if ($symtab{$c} eq '') {
|
$symtab{$c} = $location;
|
$symtab{$c} = $location;
|
$con2{$location}=$c;
|
$con2{$location}=$c;
|
&emit(0,-1); #placeholder
|
&emit(0,-1); #placeholder
|
}
|
}
|
}
|
}
|
$pass = 2;
|
$pass = 2;
|
$location = $base;
|
$location = $base;
|
return 2;
|
return 2;
|
}
|
}
|
if ($opcode eq '') { } else {
|
if ($opcode eq '') { } else {
|
# need to process afield in case of constant
|
# need to process afield in case of constant
|
if ($opmap{$opcode}>=0) { $location=$location+1; &xeval($afield); }
|
if ($opmap{$opcode}>=0) { $location=$location+1; &xeval($afield); }
|
if ($adda{$opcode}==2) { $location=$location+1; }
|
if ($adda{$opcode}==2) { $location=$location+1; }
|
}
|
}
|
return 1; # end pass 1
|
return 1; # end pass 1
|
}
|
}
|
|
|
if ($pass == 2) {
|
if ($pass == 2) {
|
$opcode = &toLOWER($Fld[1]);
|
$opcode = &toLOWER($Fld[1]);
|
if ($Fld[2]!~/['"]/) {
|
if ($Fld[2]!~/['"]/) {
|
$afield = &toLOWER($Fld[2]);
|
$afield = &toLOWER($Fld[2]);
|
}
|
}
|
else {
|
else {
|
s/^[^'"#]*(['"#])/\1/; # get whole string
|
s/^[^'"#]*(['"#])/\1/; # get whole string
|
$afield=$_;
|
$afield=$_;
|
}
|
}
|
$afield = &xeval($afield);
|
$afield = &xeval($afield);
|
if ($opcode eq 'org') {
|
if ($opcode eq 'org') {
|
$location = &xeval($afield);
|
$location = &xeval($afield);
|
printf("@ %03x\n",$location);
|
printf("@ %03x\n",$location);
|
return 1;
|
return 1;
|
}
|
}
|
|
|
if ($opcode eq 'ds') {
|
if ($opcode eq 'ds') {
|
&dostring($_);
|
&dostring($_);
|
return 1;
|
return 1;
|
}
|
}
|
if ($opcode eq 'end') {
|
if ($opcode eq 'end') {
|
while ($con2{$location} ne '') {
|
while ($con2{$location} ne '') {
|
&emit($con{$con2{$location}},-1);
|
&emit($con{$con2{$location}},-1);
|
}
|
}
|
$pass=1;
|
$pass=1;
|
close F;
|
close F;
|
|
|
return 0;
|
return 0;
|
}
|
}
|
if ($opcode ne '') {
|
if ($opcode ne '') {
|
$v=$opmap{$opcode};
|
$v=$opmap{$opcode};
|
if ($v eq "") {
|
if ($v eq "") {
|
print STDERR ("Bad opcode $opcode");
|
print STDERR ("Bad opcode $opcode");
|
print "//! Bad opcode $opcode";
|
print "//! Bad opcode $opcode";
|
}
|
}
|
if ($adda{$opcode}==1) { $v+=$afield; }
|
if ($adda{$opcode}==1) { $v+=$afield; }
|
if ($v ne -1) { &emit($v); }
|
if ($v ne -1) { &emit($v); }
|
if ($adda{$opcode}==2) { &emit($afield,-1); }
|
if ($adda{$opcode}==2) { &emit($afield,-1); }
|
}
|
}
|
return 1;
|
return 1;
|
}
|
}
|
|
|
|
|
|
|
|
|
|
|
sub emit {
|
sub emit {
|
local($n,$flag) = @_;
|
local($n,$flag) = @_;
|
if ($pass == 2) {
|
if ($pass == 2) {
|
if ($flag==-1) {
|
if ($flag==-1) {
|
printf("%04x // (%03x)\n",$n,$location);
|
printf("%04x // (%03x)\n",$n,$location);
|
} else {
|
} else {
|
printf("%04x // (%03x)%s\n",$n,$location,$theLine);
|
printf("%04x // (%03x)%s\n",$n,$location,$theLine);
|
}
|
}
|
}
|
}
|
$location = $location + 1;
|
$location = $location + 1;
|
}
|
}
|
|
|
|
|
sub toLOWER {
|
sub toLOWER {
|
local ($s)=@_;
|
local ($s)=@_;
|
$s=~s/([^\W0-9_])/\l$1/g;
|
$s=~s/([^\W0-9_])/\l$1/g;
|
return $s;
|
return $s;
|
}
|
}
|
|
|
sub xeval {
|
sub xeval {
|
local ($S)=@_;
|
local ($S)=@_;
|
$SERR=$S;
|
$SERR=$S;
|
$symtab{'_location_'}=$location;
|
$symtab{'_location_'}=$location;
|
# handle immediate constant '#xxx'
|
# handle immediate constant '#xxx'
|
if ($S=~/^#/) {
|
if ($S=~/^#/) {
|
$S=~s/#(.*)/\1/;
|
$S=~s/#(.*)/\1/;
|
$sv=&xeval($S);
|
$sv=&xeval($S);
|
$con{"_con_" . $sv}=$sv;
|
$con{"_con_" . $sv}=$sv;
|
return $symtab{"_con_" . $sv};
|
return $symtab{"_con_" . $sv};
|
}
|
}
|
# need to interpret string literals
|
# need to interpret string literals
|
if ($S=~/'/) {
|
if ($S=~/'/) {
|
$S=~s/'(.*)'/\$tstr="\1"/;
|
$S=~s/'(.*)'/\$tstr="\1"/;
|
eval($S);
|
eval($S);
|
if (length($tstr)==1) { $S=sprintf("%d",ord($tstr)); }
|
if (length($tstr)==1) { $S=sprintf("%d",ord($tstr)); }
|
else { $S=sprintf("%d",ord(substr($tstr,1,1))*256+ord(substr($tstr,2,1))); }
|
else { $S=sprintf("%d",ord(substr($tstr,1,1))*256+ord(substr($tstr,2,1))); }
|
|
|
} elsif ($S=~/"/) {
|
} elsif ($S=~/"/) {
|
$S=~s/"(.*)"/\$tstr="\1"/;
|
$S=~s/"(.*)"/\$tstr="\1"/;
|
eval($S);
|
eval($S);
|
if (length($tstr)==1) { $S=sprintf("%d",ord($tstr)); }
|
if (length($tstr)==1) { $S=sprintf("%d",ord($tstr)); }
|
else { $S=sprintf("%d",ord(substr($tstr,1,1))*256+ord(substr($tstr,2,1))); }
|
else { $S=sprintf("%d",ord(substr($tstr,1,1))*256+ord(substr($tstr,2,1))); }
|
} else {
|
} else {
|
$S=~s/(^|\W)([A-zA-Z_][a-zA-Z_0-9]*)/\1\$symtab{'\2'}/g;
|
$S=~s/(^|\W)([A-zA-Z_][a-zA-Z_0-9]*)/\1\$symtab{'\2'}/g;
|
}
|
}
|
$rv= eval($S);
|
$rv= eval($S);
|
# Would like to detect undefined symbols here but tough to do
|
# Would like to detect undefined symbols here but tough to do
|
if ($pass==2 && $rv eq "" & $S ne "") {
|
if ($pass==2 && $rv eq "" & $S ne "") {
|
print STDERR "Undefined: " . $SERR;
|
print STDERR "Undefined: " . $SERR;
|
print "//! Undefined: $SERR";
|
print "//! Undefined: $SERR";
|
}
|
}
|
return $rv;
|
return $rv;
|
}
|
}
|
}
|
}
|
|
|
|
|
sub dostring {
|
sub dostring {
|
local ($S)=@_;
|
local ($S)=@_;
|
$S=~s/^[^'"]*(['"])/\1/;
|
$S=~s/^[^'"]*(['"])/\1/;
|
$type=substr($S,1,1); # ' or "
|
$type=substr($S,1,1); # ' or "
|
$S=~s/['"](.*)['"]/\$tstr="\1"/;
|
$S=~s/['"](.*)['"]/\$tstr="\1"/;
|
eval($S);
|
eval($S);
|
$l=length($tstr);
|
$l=length($tstr);
|
$j=1;
|
$j=1;
|
if ($type eq '"') { $j=2; }
|
if ($type eq '"') { $j=2; }
|
$tstr="$tstr "; # space pad odd string
|
$tstr="$tstr "; # space pad odd string
|
for ($i=1;$i<=$l;$i=$i+$j) {
|
for ($i=1;$i<=$l;$i=$i+$j) {
|
$c=ord(substr($tstr,$i,1));
|
$c=ord(substr($tstr,$i,1));
|
if ($j==2) { $c=$c*256+ord(substr($tstr,$i+1,1)); }
|
if ($j==2) { $c=$c*256+ord(substr($tstr,$i+1,1)); }
|
&emit($c,$i==1?0:-1);
|
&emit($c,$i==1?0:-1);
|
}
|
}
|
}
|
}
|
|
|