Subversion Repositories blue

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