/lib/version.pod
/lib/version
/libperl.a
+/mad/tmp.xml
+/mad/tmp.yml
/makedepend
/makefile
/makefile.old
my $arg = $$self{Kids}[0];
push @newkids, $arg->ast($self, @_) if defined $arg;
}
- push @newkids, $self->madness(')');
+ push @newkids, $self->madness(') ;'); # Nick added ;
return $self->newtype()->new(Kids => [@newkids]);
}
}
push @newkids, shift @subkids;
unshift @newkids, @subkids;
+ push @newkids, $self->madness(';'); # Nick
return P5AST::condmod->new(Kids => [@newkids])
},
'P' => sub { # package declaration
if ($kind eq '=') { # stealth readline
unshift(@newkids, shift(@subkids));
push(@newkids, @subkids);
+ push @newkids, $self->madness(';'); # Nick
return P5AST::op_aassign->new(Kids => [@newkids])
}
else {
@newkids,
$self->madness(')')
);
+ push @{$newself->{Kids}}, $self->madness(';'); # Nick
return $newself;
}
},
my $left = $$self{Kids}[0];
push @newkids, $left->ast($self, @_);
+ push @newkids, $self->madness(';'); # Nick
+
return $self->newtype->new(Kids => [@newkids]);
}
my $left = $$self{Kids}[0];
push @newkids, $left->ast($self, @_);
+ push @newkids, $self->madness(';'); # Nick
+
return $self->newtype->new(Kids => [@newkids]);
}
# Nothing.
package P5AST::op_null; @ISA = 'P5AST::baseop';
+package P5AST::op_padrange; @ISA = 'P5AST::baseop'; # Nick
package P5AST::op_stub; @ISA = 'P5AST::baseop';
package P5AST::op_scalar; @ISA = 'P5AST::baseop_unop';
sub args { '' }
+# Nick
+
+package PLXML::op_padrange;
+
+our @ISA = ('PLXML::baseop');
+
+sub key { 'padrange' }
+sub desc { 'padrange operation' }
+sub check { 'ck_padrange' }
+sub flags { '0' }
+sub args { '' }
+
+
package PLXML::op_stub;
our @ISA = ('PLXML::baseop');
--- /dev/null
+#!/usr/bin/env python3
+
+import sys
+import yaml
+
+def any_constructor(loader, tag_suffix, node):
+ if isinstance(node, yaml.MappingNode):
+ result = loader.construct_mapping(node)
+ result['tag_suffix'] = tag_suffix
+ elif isinstance(node, yaml.SequenceNode):
+ result = loader.construct_sequence(node)
+ elif isinstance(node, yaml.ScalarNode):
+ result = loader.construct_scalar(node)
+ else:
+ assert False
+ return result
+yaml.add_multi_constructor('', any_constructor, Loader = yaml.SafeLoader)
+
+#def empty(node):
+# if 'uni' in node:
+# value = node['uni']
+# return isinstance(value, str) and len(value) == 0
+# if 'Kids' in node:
+# return all([empty(i) for i in node['Kids']])
+# assert False
+
+def dump(node):
+ #if empty(node):
+ # return ''
+ if 'uni' in node:
+ kids = str(node['uni']).replace('&', '&').replace('<', '<').replace('>', '>')
+ elif 'Kids' in node:
+ kids = ''.join([dump(i) for i in node['Kids']])
+ else:
+ assert False
+
+ tag_suffix = node['tag_suffix']
+ assert tag_suffix[:28] == 'tag:yaml.org,2002:perl/hash:'
+ tag_suffix = tag_suffix[28:].replace('::', '_').replace(':', '_')
+ if tag_suffix[:3] == 'p5_':
+ return kids
+
+ if tag_suffix[:6] == 'P5AST_':
+ tag_suffix = tag_suffix[6:]
+ kids_lstrip = kids.lstrip()
+ kids_lwhite = kids[:len(kids) - len(kids_lstrip)]
+ kids_lstrip_rstrip = kids_lstrip.rstrip()
+ kids_rwhite = kids_lstrip[len(kids_lstrip_rstrip):]
+ return (
+ kids_lwhite +
+ '<' +
+ tag_suffix +
+ '>' +
+ kids_lstrip_rstrip +
+ '</' +
+ tag_suffix +
+ '>' +
+ kids_rwhite
+ )
+
+with open('tmp.yml') as fin:
+ ast = yaml.safe_load(fin)
+sys.stdout.write(dump(ast))
--- /dev/null
+#!/usr/local/bin/perl
+
+use Nomad;
+
+my $output = Nomad::xml_to_p5( input => "tmp.xml", YAML => 1 );
+open my $outfile, "> tmp.yml";
+$outfile->print($output);
+close $outfile;
--- /dev/null
+#!/usr/bin/env perl
+#
+# Dump a binary PDP-7 file where a word is encoded as three bytes,
+# with sixbits are stored big-endian in each of the three byte.
+#
+use strict;
+use warnings;
+
+die("Usage: $0 binaryfile\n") if (@ARGV==0);
+
+open(my $IN, "<", $ARGV[0]) || die("Can't open $ARGV[0]: $!\n");
+while (1) {
+ # Convert three bytes into one 18-bit word
+ my $result= read($IN, my $three, 3);
+ last if ($result != 3); # Not enough bytes read
+ my ($b1, $b2, $b3)= unpack("CCC", $three);
+ my $word= (($b1 & 077) << 12) | (($b2 & 077) << 6) | ($b3 & 077);
+
+ my $c1= ($word >> 9) & 0777;
+ $c1= (($c1 >= 32) && ($c1 <= 126)) ? chr($c1) : ' ';
+ my $c2= $word & 0777;
+ $c2= (($c2 >= 32) && ($c2 <= 126)) ? chr($c2) : ' ';
+ printf("%06o %s%s\n", $word, $c1, $c2)
+}
+close($IN);
+exit(0);
--- /dev/null
+#!/usr/bin/env perl
+#
+# a7out: user-mode simulator for PDP-7 Unix applications
+#
+# (c) 2016 Warren Toomey, GPL3
+#
+use strict;
+use warnings;
+use Fcntl qw(:seek);
+use DateTime;
+use Data::Dumper;
+
+### Global variables ###
+my $debug = 0; # Debug flag
+my $singlestep = 0; # Are we running in single-step mode?
+my $coverage = 0; # Print out code coverage
+my %Breakpoint; # Hash of defined breakpoints
+my @Mem; # 8K 18-bit words of main memory
+my %Addr2Name; # Map addresses to names
+my %Name2Addr; # Map names to addresses
+my @CC; # Code coverage: what addrs executed instructions
+my @FD; # Array of open filehandles
+my @ISBINARY; # Array of filehandle flags: ASCII or binary files?
+
+# Registers
+my $PC = 010000; # Program counter
+my $AC = 0; # Accumulator
+my $LINK = 0; # Link register, either 0 or LINKMASK
+my $MQ = 0; # MQ register
+
+# Constants
+use constant MAXINT => 0777777; # Biggest unsigned integer
+use constant MAXPOSINT => 0377777; # Biggest signed integer
+use constant MAXADDR => 017777; # Largest memory address
+use constant LINKMASK => 01000000; # Mask for LINK register
+use constant EAESTEP => 077; # EAE step count mask
+use constant EAEIMASK => 0777700; # EAE instruction mask
+use constant SIGN => 0400000; # Sign bit
+
+use constant EPSILON => 99; # max delta for symbol display
+
+### Main program ###
+
+# Get any optional arguments
+while ( defined( $ARGV[0] ) && ( $ARGV[0] =~ m{^-} ) ) {
+
+ # -d: debug mode
+ if ( $ARGV[0] eq "-d" ) {
+ $debug = 1;
+ shift(@ARGV);
+ }
+
+ # -b: set a breakpoint
+ if ( $ARGV[0] eq "-b" ) {
+ shift(@ARGV);
+ $Breakpoint{ lookup( shift(@ARGV) ) } = 1;
+ }
+
+ # -c: print out code coverage
+ if ( $ARGV[0] eq "-c" ) {
+ shift(@ARGV);
+ $coverage= 1;
+ }
+
+ # -n: read a namelist file
+ if ( $ARGV[0] eq "-n" ) {
+ shift(@ARGV);
+ load_names( shift(@ARGV) );
+ }
+}
+
+# Check the arguments
+die("Usage: $0 [-c] [-d] [-b breakpoint] [-n namelist] a.outfile [arg1 arg2 ...]\n")
+ if ( @ARGV < 1 );
+
+# Load the a.out file into memory
+# and simulate it
+load_code( $ARGV[0] );
+set_arguments();
+
+#dump_memory(0, MAXADDR, 0);
+#exit(0);
+simulate();
+print_coverage() if ($coverage);
+exit(0);
+
+# Print out the code coverage
+sub print_coverage {
+ foreach my $addr (0 .. MAXADDR ) {
+ printf("%06o: %d\n", $addr, $CC[$addr]) if ($CC[$addr]);
+ }
+}
+
+### Load the a.out file into memory
+sub load_code {
+ my $filename = shift;
+
+ # Fill all the 8K words in memory with zeroes
+ foreach my $i ( 0 .. MAXADDR ) {
+ $Mem[$i] = 0;
+ }
+
+ # Set up some open filehandles
+ $FD[0] = \*STDIN;
+ $FD[1] = \*STDOUT;
+ $FD[8] = \*STDERR; # According to cat.s (uses d8 == 8)
+
+ # Open up the PDP-7 executable file
+ open( my $IN, "<", $filename ) || die("Unable to open $filename: $!\n");
+ my $c = getc($IN);
+ seek $IN, 0, 0;
+ if ((ord($c) & 0300) == 0200) { # handle "binary paper tape" format
+ my $addr = 010000; # user programs loaded at 4K mark
+ while ($addr <= 017777) {
+ my $result = read_word($IN);
+ last if ($result == -1);
+ $Mem[$addr++] = $result;
+ }
+ close($IN);
+ return;
+ }
+ while (<$IN>) {
+ chomp;
+
+ # Lose any textual stuff after a tab character
+ $_ =~ s{\t.*}{};
+
+ # Split into location and value, both in octal
+ my ( $loc, $val ) = split( /:\s+/, $_ );
+
+ # Convert from octal and save
+ $loc = oct($loc);
+ $val = oct($val);
+ $Mem[$loc] = $val;
+ }
+ close($IN);
+}
+
+### read a word from a file in paper tape binary format
+### return -1 on EOF
+sub read_word {
+ my $F = shift;
+ # Convert three bytes into one 18-bit word
+ return -1 if ( read( $F, my $three, 3 ) != 3 ); # Not enough bytes read
+ my ( $b1, $b2, $b3 ) = unpack( "CCC", $three );
+ return ((($b1 & 077) << 12 ) |
+ (($b2 & 077) << 6 ) |
+ ($b3 & 077));
+}
+
+### Copy the arguments into the PDP-7 memory space, and build
+### an array of pointers to these arguments. Build a pointer
+### at MAXADDR that points at the array.
+###
+### Each argument string is four words long and space padded if the
+### string is not eight characters long. These are stored below
+### address MAXADDR. Below this is the count of words in the strings.
+### Address MAXADDR points at the word count. Graphically (for two arguments):
+###
+### +------------+
+### +--| | Location 017777 (MAXADDR)
+### | +------------+
+### | |............|
+### | |............| argv[2]
+### | |............|
+### | +------------+
+### | |............|
+### | |............| argv[1]
+### | |............|
+### | +------------+
+### | |............|
+### | |............| argv[0]
+### | |............|
+### | +------------+
+### +->| argc=12 |
+### +------------+
+###
+sub set_arguments {
+
+ # Get the number of arguments including the command name
+ my $argc = scalar(@ARGV);
+
+ # We now know that argc will appear in memory
+ # 4*argc +1 below location MAXADDR
+ # Set argc to the number of words
+ my $addr = MAXADDR - ( 4 * $argc + 1 );
+ $Mem[MAXADDR] = $addr;
+ $Mem[ $addr++ ] = $argc * 4;
+
+ # Now start saving the arguments
+ foreach (@ARGV) {
+
+ # Truncate and/or space pad the argument
+ my $str = sprintf( "%-8s", substr( $_, 0, 8 ) );
+
+ # XXX: use ascii2words
+ # Store pairs of characters into memory
+ for ( my $i = 0 ; $i < length($str) ; $i += 2 ) {
+ my $c1 = substr( $str, $i, 1 ) || "";
+ my $c2 = substr( $str, $i + 1, 1 ) || "";
+
+ #printf("Saving %06o to %s\n", (ord($c1) << 9 ) | ord($c2), addr($addr));
+ $Mem[ $addr++ ] = ( ord($c1) << 9 ) | ord($c2);
+ }
+ }
+}
+
+### Load a namelist file
+sub load_names {
+ my $filename = shift;
+ open( my $IN, "<", $filename ) || die("Unable to open $filename: $!\n");
+ while (<$IN>) {
+ chomp;
+ if ($_ =~ m{([a-z0-9.]+)\s+([0-7]+)}) {
+ my $i = oct($2);
+ $Name2Addr{$1} = $i;
+ $Addr2Name{$i} = $1;
+ }
+ }
+ close ($IN);
+}
+
+### Format an address
+sub addr {
+ my $addr = shift;
+ my $oct = sprintf("%06o", $addr);
+ if (%Addr2Name) {
+ return "$oct ($Addr2Name{$addr})" if ($Addr2Name{$addr});
+ # XXX keep Addr2Name as a sorted array?
+ # prefer after to before
+ for (my $epsilon = 1; $epsilon <= EPSILON; $epsilon++) {
+ my $n = $Addr2Name{$addr-$epsilon};
+ return "$oct ($n+$epsilon)" if (defined($n));
+ }
+ for (my $epsilon = 1; $epsilon <= EPSILON; $epsilon++) {
+ my $n = $Addr2Name{$addr+$epsilon};
+ return "$oct ($n-$epsilon)" if (defined($n));
+ }
+ }
+ return $oct;
+}
+
+### convert string (symbol or octal) to address
+sub lookup {
+ my $x = shift;
+ return oct($x) if ($x =~ m/^[0-7]+$/);
+ return $Name2Addr{$x} if (defined($Name2Addr{$x}));
+ return 0;
+}
+
+### Simulate the machine code loaded into memory
+sub simulate {
+
+ # List of opcodes that we can simulate
+ my %Oplist = (
+ oct("000") => \&cal,
+ oct("004") => \&dac,
+ oct("010") => \&jms,
+ oct("014") => \&dzm,
+ oct("020") => \&lac,
+ oct("030") => \&add,
+ oct("024") => \&xor,
+ oct("034") => \&tad,
+ oct("044") => \&isz,
+ oct("050") => \&and,
+ oct("054") => \&sad,
+ oct("060") => \&jmp,
+ oct("064") => \&eae,
+ oct("074") => \&opr,
+ );
+
+ # List of opcodes that DON'T auto-increment
+ # locations 10-17 when we have the indirect bit
+ my %NoIncr = (
+ oct("000") => 1, # cal
+ oct("064") => 1, # eae
+ oct("074") => 1 # opr
+ );
+
+ # Loop indefinitely
+ while (1) {
+
+ # Get the instruction pointed to by PC and decode it
+ # Also do code coverage
+ my $instruction = $Mem[$PC]; $CC[$PC]++;
+ my $opcode = ( $instruction >> 12 ) & 074;
+ my $indirect = ( $instruction >> 13 ) & 1;
+ my $addr = $instruction & MAXADDR;
+
+ # Auto-increment locations 010 to 017 if $indirect
+ # and this is an instruction that does increment
+ if ( $indirect
+ && ( $addr >= 010 )
+ && ( $addr <= 017 )
+ && !defined( $NoIncr{$opcode} ) )
+ {
+ $Mem[$addr]++;
+ $Mem[$addr] &= MAXINT;
+ }
+
+ # Work out what any indirect address would be
+ my $indaddr = ($indirect) ? $Mem[$addr] & MAXADDR : $addr;
+
+ # If this is a breakpoint, stop now and get a user command
+ if ( defined( $Breakpoint{$PC} ) ) {
+ $singlestep = 1;
+ printf( "break at PC %s\n", addr($PC) )
+ if ( ($debug) || ($singlestep) );
+ }
+ get_user_command() if ($singlestep);
+ printf( "PC %-20.20s L.AC %d.%06o MQ %06o: ", addr($PC),
+ ($LINK ? 1 : 0), $AC & 0777777, $MQ )
+ if ( ($debug) || ($singlestep) );
+
+ #dprintf("PC %06o: instr %06o, op %03o, in %o, addr %06o indaddr %06o\n",
+ # $PC, $instruction, $opcode, $indirect, $addr, $indaddr );
+
+ # Simulate the instruction. Each subroutine updates the $PC
+ if ( defined( $Oplist{$opcode} ) ) {
+ $Oplist{$opcode}->( $instruction, $addr, $indaddr );
+ }
+ else {
+ printf( STDERR "Unknown instruction 0%06o at location %s\n",
+ $instruction, addr($PC) );
+ exit(1);
+ }
+ }
+}
+
+# Debug code: dump memory contents
+# Print from $start to $end.
+# Print empty locations if $yeszero
+sub dump_memory {
+ my ( $start, $end, $yeszero ) = @_;
+ foreach my $i ( $start .. $end ) {
+
+ # Convert the word into possibly two ASCII characters
+ my $c1 = ( $Mem[$i] >> 9 ) & 0777;
+ $c1 = ( $c1 < 0200 ) ? chr($c1) : " ";
+ my $c2 = $Mem[$i] & 0777;
+ $c2 = ( $c2 < 0200 ) ? chr($c2) : " ";
+ printf( STDERR "%06o: %06o %s%s\n", $i, $Mem[$i], $c1, $c2 )
+ if ( $yeszero || $Mem[$i] != 0 );
+ }
+}
+
+# Load AC
+sub lac {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "lac %s (value %06o) into AC\n", addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+ $AC = $Mem[$indaddr];
+ $PC++;
+}
+
+# Deposit AC
+sub dac {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "dac AC (value %06o) into %s\n", $AC, addr($indaddr) )
+ if ( ($debug) || ($singlestep) );
+
+ # Catch writes below the process' memory range
+ if ($indaddr < 010000 && !($indaddr >= 010 && $indaddr <= 020) ) {
+ $singlestep = 1;
+ dprintf("(****WRITE TO LOW MEMORY 0%o ****)\n", $indaddr);
+ printf( "break at PC %s\n", addr($PC) )
+ if ( ($debug) || ($singlestep) );
+ }
+ $Mem[$indaddr] = $AC;
+ $PC++;
+}
+
+# Add to AC, twos complement
+sub tad {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "tad AC (value %06o) with addr %s (%06o)\n",
+ $AC, addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+ $AC = $AC + $Mem[$indaddr];
+ $LINK = ( $LINK ^ $AC ) & LINKMASK;
+ $AC = $AC & MAXINT;
+ $PC++;
+}
+
+# Add to AC, ones complement
+sub add {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "add AC (value %06o) with addr %s (%06o)\n",
+ $AC, addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+
+ # This logic shamelessly borrowed from SimH
+ # https://github.com/simh/simh/blob/master/PDP18B/pdp18b_cpu.c
+ my $sum = $AC + $Mem[$indaddr];
+ if ( $sum > MAXINT ) { # end around carry
+ $sum = ( $sum + 1 ) & MAXINT;
+ }
+ if ( ( ( ~$AC ^ $sum ) & ( $AC ^ $sum ) ) & SIGN ) { # overflow?
+ $LINK = LINKMASK; # set link
+ }
+ $AC = $sum;
+ $PC++;
+}
+
+# And AC and Y
+sub and {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "and AC (value %06o) with addr %s (%06o)\n",
+ $AC, addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+ $AC &= $Mem[$indaddr];
+ $PC++;
+}
+
+# Xor AC and Y
+sub xor {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ dprintf( "xor %s (%06o)\n",
+ addr($indaddr), $Mem[$indaddr] );
+ $AC ^= $Mem[$indaddr];
+ $PC++;
+}
+
+# Skip if AC different to Y
+sub sad {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "sad %s (%06o)\n", addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+ if ($AC != $Mem[$indaddr]) {
+ dprintf( " adding 2 to PC\n");
+ } else {
+ dprintf( " adding 1 to PC\n");
+ }
+ $PC += ( $AC != $Mem[$indaddr] ) ? 2 : 1;
+}
+
+# Deposit zero in memory
+sub dzm {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "dzm %s\n", addr($indaddr) )
+ if ( ($debug) || ($singlestep) );
+ $Mem[$indaddr] = 0;
+ $PC++;
+}
+
+# Index and skip if zero
+sub isz {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "isz %s (value %06o)\n", addr($indaddr), $Mem[$indaddr] )
+ if ( ($debug) || ($singlestep) );
+ $Mem[$indaddr]++;
+ $Mem[$indaddr] &= MAXINT;
+ $PC += ( $Mem[$indaddr] == 0 ) ? 2 : 1;
+}
+
+# Jump
+sub jmp {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "jmp %s\n", addr($indaddr) )
+ if ( ($debug) || ($singlestep) );
+ $PC = $indaddr;
+}
+
+# Jump to subroutine
+sub jms {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ printf( "jms %s\n", addr($indaddr) )
+ if ( ($debug) || ($singlestep) );
+
+ # Save the LINK and current PC into the $indaddr location
+ $Mem[ $indaddr++ ] = $PC + 1 | ( ($LINK) ? 0400000 : 0 );
+ $PC = $indaddr;
+}
+
+# OPR instructions
+sub opr {
+ my ( $instruction, $addr, $indaddr ) = @_;
+
+ # hlt: halt simulation
+ if ( $instruction == 0740040 ) {
+ printf( STDERR "PC %s: program halted\n", addr($PC) );
+ dump_memory( 0, MAXADDR, 0 ) if ($debug);
+ exit(1);
+ }
+
+ # law: load word into AC
+ my $indirect = ( $instruction >> 13 ) & 1;
+ if ($indirect) {
+ dprintf( "law %06o into AC\n", $instruction );
+ $AC = $instruction;
+ $PC++;
+ return;
+ }
+
+ # List of skip opcode names for the next section
+ my @skipop = (
+ '', 'sma', 'sza', 'sza sma',
+ 'snl', 'snl sma', 'snl sza', 'snl sza sma',
+ 'skp', 'spa', 'sna', 'sna spa',
+ 'szl', 'szl spa', 'szl sna', 'szl sna spa'
+ );
+
+ # This logic shamelessly borrowed from SimH
+ # https://github.com/simh/simh/blob/master/PDP18B/pdp18b_cpu.c
+ my $skip = 0;
+ my $i = ( $instruction >> 6 ) & 017; # decode IR<8:11>
+ dprintf( "%s", $skipop[$i] );
+
+ $skip = 1 if ( ( $i == 1 ) && ( $AC & SIGN ) != 0 ); # sma
+ $skip = 1 if ( ( $i == 2 ) && ( $AC & MAXINT ) == 0 ); # sza
+ $skip = 1
+ if ( ( $i == 3 )
+ && ( ( ( $AC & MAXINT ) == 0 ) || ( ( $AC & SIGN ) != 0 ) ) )
+ ; # sza | sma
+ $skip = 1 if ( ( $i == 4 ) && ($LINK) ); # snl
+ $skip = 1 if ( ( $i == 5 ) && ( $LINK || ( $AC >= SIGN ) ) ); # snl | sma
+ $skip = 1 if ( ( $i == 6 ) && ( $LINK || ( $AC == 0 ) ) ); # snl | sza
+ $skip = 1
+ if ( ( $i == 7 )
+ && ( $LINK || ( $AC >= SIGN ) || ( $AC == 0 ) ) ); # snl | sza | sma
+ $skip = 1 if ( $i == 010 ); # skp
+ $skip = 1 if ( ( $i == 011 ) && ( ( $AC & SIGN ) == 0 ) ); # spa
+ $skip = 1 if ( ( $i == 012 ) && ( ( $AC & MAXINT ) != 0 ) ); # sna
+ $skip = 1
+ if ( ( $i == 013 )
+ && ( ( $AC & MAXINT ) != 0 )
+ && ( ( $AC & SIGN ) == 0 ) ); # sna & spa
+ $skip = 1 if ( ( $i == 014 ) && ( $LINK == 0 ) ); # szl
+ $skip = 1
+ if ( ( $i == 015 ) && ( $LINK == 0 ) && ( $AC < SIGN ) ); # szl & spa
+ $skip = 1
+ if ( ( $i == 016 ) && ( $LINK == 0 ) && ( $AC != 0 ) ); # szl & sna
+ $skip = 1
+ if ( ( $i == 017 )
+ && ( $LINK == 0 )
+ && ( $AC < SIGN )
+ && ( $AC != 0 ) ); # szl & sna & spa
+
+ # Clear operations
+ if ( $instruction & 010000 ) { # cla
+ dprintf(" cla");
+ $AC = 0;
+ }
+ if ( $instruction & 004000 ) { # cll
+ dprintf(" cll");
+ $LINK = 0;
+ }
+ if ( $instruction & 000002 ) { # cml
+ dprintf(" cml");
+ $LINK = ($LINK) ? 0 : LINKMASK;
+ }
+ if ( $instruction & 000001 ) { # cma
+ dprintf(" cma");
+ $AC = ( $AC ^ MAXINT ) & MAXINT;
+ }
+
+ # Rotate instructions
+ $i = $instruction & 02030;
+
+ # Single rotate right
+ if ( $i == 020 ) {
+ dprintf(" rar");
+ my $newlink = ( $AC & 1 ) ? LINKMASK : 0;
+ $AC = ( $LINK | $AC ) >> 1;
+ $LINK = $newlink;
+ }
+
+ # Double rotate right
+ if ( $i == 02020 ) {
+ dprintf(" rtr");
+ my $msb = ( $AC & 1 ) << 17;
+ my $newlink = ( $AC & 2 ) ? LINKMASK : 0;
+ $AC = ( ( $LINK | $AC ) >> 2 ) | $msb;
+ $LINK = $newlink;
+ }
+
+ # Single rotate left
+ if ( $i == 010 ) {
+ dprintf(" ral");
+ my $newlink = ( $AC & SIGN ) ? LINKMASK : 0;
+ my $lsb = $LINK ? 1 : 0;
+ $AC = ( ( $AC << 1 ) | $lsb ) & MAXINT;
+ $LINK = $newlink;
+ }
+
+ # Double rotate left
+ if ( $i == 02010 ) {
+ dprintf(" rtl");
+ my $newlink = ( $AC & 0200000 ) ? LINKMASK : 0;
+ my $lsb = ( $AC & SIGN ) ? 1 : 0;
+ my $twolsb = $LINK ? 2 : 0;
+ $AC = ( ( $AC << 2 ) | $twolsb | $lsb ) & MAXINT;
+ $LINK = $newlink;
+ }
+
+ # Impossible left and right rotates: 02030 or 00030. Do nothing!
+
+ # Note: We didn't do the oas instruction above.
+ $PC += 1 + $skip;
+ dprintf("\n");
+ return;
+}
+
+# Extended arithmetic element instructions
+sub eae {
+ my ( $instruction, $addr, $indaddr ) = @_;
+ my $step = $instruction & EAESTEP;
+ my $maskedinstr = $instruction & EAEIMASK;
+
+ if ( $instruction == 0653323 ) { # idiv: integer division
+ my $divisor= $Mem[ $PC+1 ];
+ dprintf( "idiv %06o by %06o (decimal %d by %d)\n",
+ $AC, $divisor, $AC, $divisor );
+ # Prevent division by zero :-)
+ my $quotient = ($divisor) ? int($AC / $divisor) : 0;
+ my $remainder = ($divisor) ? $AC % $divisor : 0;
+ $MQ= $quotient;
+ $AC= $remainder;
+ $PC+=2;
+ return;
+ }
+ if ( $instruction == 0640323 ) { # div: 36-bit unsigned integer division
+ my $divisor= $Mem[ $PC+1 ];
+ dprintf( "div MQ.AC %06o.%06o by %06o (decimal %d)\n",
+ $MQ, $AC, $divisor, $divisor );
+ # http://www.perlmonks.org/?node_id=718414 says that we won't
+ # lose accuracy before 2^53
+ my $dividend= ($MQ << 18) | $AC;
+ # Prevent division by zero :-)
+ my $quotient = ($divisor) ? $dividend / $divisor : 0;
+ my $remainder = ($divisor) ? $dividend % $divisor : 0;
+ $MQ= $quotient;
+ $AC= $remainder;
+ $PC+=2;
+ return;
+ }
+ if ( $maskedinstr == 0660500 ) { # lrss: long right shift, signed
+ # We ignore the MQ as it's not
+ # used by any user-mode programs
+ dprintf( "lrss %06o AC step %d\n", $AC, $step );
+
+ # Save the AC's sign into LINK
+ my $newlink = ( $AC << 1 ) & LINKMASK;
+# $AC = ( ( $LINK | $AC ) >> $step ) & MAXINT;
+ $AC = ( ( ($newlink * -1) | $AC ) >> $step ) & MAXINT; # XXX Not sure if this is correct!?!?!
+ $LINK = $newlink;
+ $PC++;
+ return;
+ }
+ if ( $maskedinstr == 0660700 ) { # alss: AC left shift, signed
+ dprintf( "alss step %d\n", $step );
+ $AC = ( $AC << $step ) & MAXINT;
+ $LINK = ( $AC << 1 ) & LINKMASK;
+ $PC++;
+ return;
+ }
+ if ( ($maskedinstr == 0660600) ||
+ ($maskedinstr == 0661600) ) { # llss: long left shift, signed
+ # Set the link to be the AC sign bit
+ $LINK= ($AC & SIGN) ? LINKMASK : 0;
+ $AC = 0 if ($maskedinstr & 01000); # PLB: ecla llss seen in adm,apr,bc,ds,sh
+ dprintf( "llss step %d\n", $step );
+ foreach my $i ( 1 .. $step ) {
+ my $MQmsb = ( $MQ & SIGN ) ? 1 : 0;
+ $AC = ( ( $AC << 1 ) | $MQmsb ) & MAXINT;
+ $MQ = ( ( $MQ << 1 ) | ( ($LINK) ? 1 : 0 ) ) & MAXINT;
+ }
+ $PC++;
+ return;
+ }
+ # lls: long left shift
+ if ( ($maskedinstr == 0640600) || ($maskedinstr == 0641600) ) {
+ dprintf( "lls step %d\n", $step );
+ # Clear AC if the 01000 bit is set
+ $AC=0 if ($maskedinstr == 0641600);
+ foreach my $i ( 1 .. $step ) {
+ my $MQmsb = ( $MQ & SIGN ) ? 1 : 0;
+ $AC = ( ( $AC << 1 ) | $MQmsb ) & MAXINT;
+ $MQ = ( ( $MQ << 1 ) | ( ($LINK) ? 1 : 0 ) ) & MAXINT;
+ }
+ $PC++;
+ return;
+ }
+ # lrs: long right shift
+ if (($maskedinstr & 0766777) == 0640500) {
+ dprintf( "lrs step %d\n", $step );
+ # Clear AC if the 01000 bit is set
+ $AC=0 if ($maskedinstr & 01000);
+ # Clear MQ if the 010000 bit is set
+ $MQ=0 if ($maskedinstr & 010000);
+ foreach my $i ( 1 .. $step ) {
+ my $MQmsb = ( $AC & 1 ) ? 0400000 : 0;
+ $AC = ( ( $AC >> 1 ) | ( ($LINK) ? 0400000 : 0 ) ) & MAXINT;
+ $MQ = ( ( $MQ >> 1 ) | $MQmsb ) & MAXINT;
+ }
+ $PC++;
+ return;
+ }
+ if ( $maskedinstr == 0640700 ) { # als: AC left shift
+ dprintf( "als AC step %d\n", $step );
+ $AC = ( $AC << $step ) & MAXINT;
+ $PC++;
+ return;
+ }
+ if ( $instruction == 0652000 ) { # lmq: load MC from AC
+ dprintf( "lmq AC %06o into MQ\n", $AC );
+ $MQ = $AC;
+ $PC++;
+ return;
+ }
+ if ( $instruction == 0641002 ) { # lacq: load AC from MQ
+ dprintf( "lacq MQ %06o into AC\n", $MQ );
+ $AC = $MQ;
+ $PC++;
+ return;
+ }
+ if ( $instruction == 0640002 ) { # lacq: OR AC with MQ
+ dprintf( "omq MQ %06o and AC %06o\n", $MQ, $AC );
+ $AC |= $MQ;
+ $PC++;
+ return;
+ }
+ if ( $instruction == 0653122 ) { # mul: unsigned multiply
+ # This logic shamelessly borrowed from SimH
+ # https://github.com/simh/simh/blob/master/PDP18B/pdp18b_cpu.c
+ my $MB= $Mem[ $PC+1 ];
+ my $eae_ac_sign;
+ dprintf("mul AC %06o by %06o (decimal %d by %d)\n", $AC, $MB, $AC, $MB);
+
+ if (($instruction & 0004000) && ($AC & SIGN)) { # IR<6> and minus?
+ $eae_ac_sign = $LINK; # set eae_ac_sign
+ } else {
+ $eae_ac_sign = 0; # if not, unsigned
+ }
+ $MQ = $MQ ^ MAXINT if ($eae_ac_sign); # EAE AC sign? ~MQ
+ my $oldlink= $LINK;
+ $LINK = 0; # Clear link
+
+ my $result= $AC * $MB;
+ $AC= ($result >> 18) & MAXINT;
+ $MQ= $result & MAXINT;
+
+## foreach my $SC (1 .. $instruction & 077) { # Loop for SC times
+## $AC = $AC + $MB
+## if ($MQ & 1); # MQ<17>? add
+## $MQ = ($MQ >> 1) | (($AC & 1) << 17);
+## $AC = $AC >> 1; # Shift AC'MQ right
+## }
+ if ($eae_ac_sign ^ $oldlink) { # Result negative?
+ $AC = $AC ^ MAXINT;
+ $MQ = $MQ ^ MAXINT;
+ }
+
+ $PC+=2;
+ return;
+ }
+ printf( STDERR "PC %s: Unknown eae instruction %06o\n",
+ addr($PC), $instruction );
+ exit(1);
+}
+
+# cal: used for system calls
+sub cal {
+ my ( $instruction, $addr, $indaddr ) = @_;
+
+ # Syscalls that we can simulate
+ my %Syscallist = (
+
+ # 1: save
+ 2 => \&sys_getuid,
+ 3 => \&sys_open,
+ 4 => \&sys_read,
+ 5 => \&sys_write,
+ 6 => \&sys_creat,
+ 7 => \&sys_seek,
+ # 8 tell
+ 9 => \&sys_close,
+ 10 => \&sys_link,
+ 11 => \&sys_unlink,
+ 12 => \&sys_setuid,
+ 13 => \&sys_rename,
+ 14 => \&sys_exit,
+ 15 => \&sys_time,
+ 16 => \&sys_intrp,
+ 17 => \&sys_chdir,
+ 18 => \&sys_chmod,
+ 19 => \&sys_chown,
+ # 20 badcal
+ # 21 syslog
+ # 22 badcal
+ # 23 capt
+ # 24 rele
+ 25 => \&sys_status,
+ # 26 badcal
+ 27 => \&sys_smes,
+ 28 => \&sys_rmes,
+ 29 => \&sys_fork,
+ );
+
+ # Simulate the syscall. Each syscall updates the $PC
+ if ( defined( $Syscallist{$addr} ) ) {
+ $Syscallist{$addr}->();
+ }
+ else {
+ printf( STDERR "PC %s: Unknown syscall %d\n", addr($PC), $addr );
+ exit(1);
+ }
+}
+
+# Exit system call
+sub sys_exit {
+ dprintf( "exit system call, pid %06o\n", $$ );
+ print_coverage() if ($coverage);
+ exit(0);
+}
+
+# Getuid system call
+sub sys_getuid {
+ $AC = $< & MAXINT;
+ # On PDP-7 Unix, the root user is user-id -1
+ $AC= MAXINT if ($AC==0);
+ dprintf( "getuid system call, uid %06o\n", $AC );
+ $PC += 1;
+ return;
+}
+
+# Setuid system call
+sub sys_setuid {
+
+ # For now, do nothing
+ dprintf("setuid system call\n");
+ $PC += 1;
+ return;
+}
+
+# Intrp system call
+sub sys_intrp {
+
+ # For now, do nothing
+ dprintf("intrp system call\n");
+ $PC += 1;
+ return;
+}
+
+# Fork system call
+sub sys_fork {
+
+ # Fork and get the child's process-id back, or zero if we are the child
+ my $pid = fork();
+ $AC = $pid & MAXINT;
+ dprintf( "fork, got id %06o\n", $AC );
+
+ # The parent returns back to PC+1, the child returns to PC+2
+ $PC += ($pid) ? 1 : 2;
+ return;
+}
+
+# shell depends on smes hanging while child process exists
+# https://www.bell-labs.com/usr/dmr/www/hist.html
+# The message facility was used as follows: the parent shell, after
+# creating a process to execute a command, sent a message to the new
+# process by smes; when the command terminated (assuming it did not
+# try to read any messages) the shell's blocked smes call returned an
+# error indication that the target process did not exist. Thus the
+# shell's smes became, in effect, the equivalent of wait.
+sub sys_smes {
+ waitpid($AC,0);
+ dprintf("smes returning error\n");
+ $AC = -1;
+ $PC += 1;
+}
+
+# Rmes system call. We simply call wait and
+# return the process-id in AC
+sub sys_rmes {
+ my $pid = wait();
+ dprintf("rmes system call, got pid $pid\n");
+ $AC = $pid & MAXINT;
+ $PC += 1;
+ return;
+}
+
+# Close system call
+sub sys_close {
+
+ # AC is the file descriptor
+ my $fd = $AC;
+ dprintf( "close: closing fd %d\n", $fd );
+
+ # Bump up the PC
+ $PC += 1;
+
+ # That filehandle is not open, set an error -1 in octal
+ if ( !defined( $FD[$fd] ) ) {
+ dprintf("close: fd $fd is not open\n");
+ $AC = MAXINT;
+ return;
+ }
+ close( $FD[$fd] );
+ $FD[$fd] = undef;
+ $ISBINARY[$fd] = 0; # For next time
+ $AC = 0;
+ return;
+}
+
+# Open something which could be a file or a directory
+# Convert directories into files. Return the file handle and
+# if the file is ASCII or binary.
+sub opensomething {
+ my ( $readorwrite, $filename ) = @_;
+ my $tempfile = "/tmp/a7out.$$";
+ my $FH;
+
+ # If this is not a directory, open it and return the FH
+ if ( !-d $filename ) {
+ open( $FH, $readorwrite, $filename ) || return (undef);
+
+ # Opened for writing, so for now this is not binary
+ return ( $FH, 0) if ($readorwrite eq ">");
+
+ # Determine if the file is pure ASCII or contains 18-bit
+ # words encoded in 24-bit groups. We test the msb of the
+ # first character in the file. If it's on then it's a
+ # binary file and not ASCII.
+ # XXX: This means that we have to seek back to the beginning,
+ # which may be a problem on things like stdin.
+ my $ch = getc($FH);
+ my $isbinary = ( defined($ch) && ( ord($ch) & 0x80 ) ) ? 1 : 0;
+ binmode($FH) if ($isbinary);
+ seek( $FH, 0, SEEK_SET );
+ return ( $FH, $isbinary );
+ }
+
+ # It's a directory. The on-disk format for this was:
+ # d.i: .=.+1 " inode number
+ # d.name: .=.+4 " name (space padded)
+ # d.uniq: .=.+1 " unique number from directory inode
+ # followed by two unused words
+ # The code creates a temporary file and fills in the i-node numbers
+ # and space padded filenames from the directory. The file is closed
+ # opened read-only and unlinked, and the open filehandle is returned.
+ opendir( my $dh, $filename ) || return (undef);
+ open( $FH, ">", $tempfile ) || return (undef);
+ dprintf("Converting directory $filename\n");
+
+ my @list = sort( readdir($dh) );
+ foreach my $name (@list) {
+
+ # Get the file's i-node number and write it
+ my ( undef, $inode ) = stat($name);
+ print( $FH word2three($inode) );
+
+ # Convert the name into 8 characters, space padded
+ my $spaceword = sprintf( "%-8s", substr( $name, 0, 8 ) );
+
+ # Convert to four words and write each as three bytes
+ foreach my $word ( ascii2words($spaceword) ) {
+ print( $FH word2three($word) );
+ }
+
+ # Now write three zero words to pad to eight in total
+ print( $FH word2three(0) );
+ print( $FH word2three(0) );
+ print( $FH word2three(0) );
+ }
+ closedir($dh);
+ close($FH);
+ open( $FH, "<", $tempfile ) || return (undef);
+ binmode($FH);
+ #exit(0);
+ unlink($tempfile);
+ return ( $FH, 1 );
+}
+
+# Common code for creat and open
+sub creatopen {
+ my ( $filename, $readorwrite ) = @_;
+
+ # Open the file
+ my ( $FH, $isbinary ) = opensomething( $readorwrite, $filename );
+ if ($FH) {
+
+ # Find a place in the @FD array to store this filehandle.
+ # 99 is arbitrary
+ foreach my $fd ( 0 .. 99 ) {
+ if ( !defined( $FD[$fd] ) ) {
+ $FD[$fd] = $FH;
+ $ISBINARY[$fd] = $isbinary;
+ $AC = $fd;
+ last;
+ }
+ }
+ }
+ else {
+ # No filehandle, so it's an error
+ dprintf("open failed: $!\n");
+ $AC = MAXINT;
+ }
+}
+
+# Open system call
+sub sys_open {
+
+ # Open seems to have 2 arguments: PC+1 is a pointer to the filename.
+ # PC+2 seems to be 1 for write, 0 for read.
+ # Some programs seem to have a third argument always set to 0.
+ # AC is the opened fd on success, or -1 on error
+
+ # Get the start address of the string
+ # Convert this to a sensible ASCII filename
+ my $start = $Mem[ $PC + 1 ];
+ my $filename = mem2arg($start);
+
+ # Choose to open read-only or write-only
+ my $readorwrite = ( $Mem[ $PC + 2 ] ) ? ">" : "<";
+ dprintf( "open: base %06o, %s file %s\n", $start, $readorwrite, $filename );
+
+ # Bump up the PC
+ $PC += 3;
+
+ # Now open the file and return
+ creatopen( $filename, $readorwrite );
+}
+
+# Creat system call
+sub sys_creat {
+
+ # Creat seems to have 1 argument: PC+1 is a pointer to the filename.
+ # Some programs seem to have a second argument always set to 0.
+ # AC is the opened fd on success, or -1 on error
+
+ # Get the start address of the string
+ my $start = $Mem[ $PC + 1 ];
+
+ # Convert this to a sensible ASCII filename
+ my $filename = mem2arg($start);
+
+ # Choose to open write-only
+ my $readorwrite = ">";
+ dprintf( "creat: base %06o, file %s\n", $start, $filename );
+
+ # Bump up the PC
+ $PC += 2;
+
+ # Now open the file and return
+ creatopen( $filename, $readorwrite );
+}
+
+# Read system call
+sub sys_read {
+
+ # Read seems to have arguments: AC is the file descriptor, PC+1 is
+ # the pointer to the buffer and PC+2 is the number of words to read.
+ # Return the number of words read in AC on success, or -1 on error.
+
+ # Get the file descriptor, start address and end address
+ my $fd = $AC;
+ my $start = $Mem[ $PC + 1 ];
+ my $count = $Mem[ $PC + 2 ];
+ my $end = ( $start + $count - 1 ) & MAXADDR;
+ die("sys_read: bad start/end addresses $start $end\n") if ( $end < $start );
+ printf( "read: %d words into %s from fd %d\n", $count, addr($start), $fd )
+ if ( ($debug) || ($singlestep) );
+
+ # Bump up the PC
+ $PC += 3;
+
+ # That filehandle is not open, set an error -1 in octal
+ if ( !defined( $FD[$fd] ) ) {
+ dprintf("read: fd $fd is not open\n");
+ $AC = MAXINT;
+ return;
+ }
+
+ # Read each word in
+ my $FH = $FD[$fd];
+ $count = 0;
+ if (-t $FH) { # TTY?
+ my $char = getc($FH); # use Term::ReadKey for 'cbreak' mode??
+ if (defined($char)) {
+ $Mem[$start] = ord($char) << 9; # only ever returns one char
+ $AC = 1;
+ }
+ else {
+ $AC = 0; # EOF
+ }
+ return;
+ }
+ foreach my $addr ( $start .. $end ) {
+
+ if ( $ISBINARY[$fd] ) {
+ # Convert three bytes into one 18-bit word
+ my $result = read_word($FH);
+ last if ($result == -1);
+ $Mem[$addr] = $result;
+ $count++;
+ }
+ else {
+ # Convert two ASCII characters into one 18-bit word
+ my $c1 = getc($FH);
+ last if ( !defined($c1) ); # No character, leave the loop
+ my $word = ord($c1) << 9;
+ my $c2 = getc($FH);
+ $word |= ord($c2) if (defined($c2));
+ $Mem[$addr] = $word;
+ $count++;
+ } # ascii
+ }
+
+ # No error
+ $AC = $count;
+ return;
+}
+
+# Write system call
+sub sys_write {
+
+ # Write seems to have arguments: AC is the file descriptor, PC+1 is
+ # the pointer to the buffer and PC+2 is the number of words to write
+
+ # Get the file descriptor, start address and end address
+ my $fd = $AC;
+ my $start = $Mem[ $PC + 1 ];
+ my $count = $Mem[ $PC + 2 ];
+ my $end = ( $start + $count - 1 ) & MAXADDR;
+ die("sys_write: bad start/end addresses $start $end\n")
+ if ( $count != 0 && $end < $start );
+ printf( "write: %d words from %s to fd %d\n", $count, addr($start), $fd )
+ if ( ($debug) || ($singlestep) );
+
+ # Bump up the PC
+ $PC += 3;
+
+ # That filehandle is not open, set an error -1 in octal
+ if ( !defined( $FD[$fd] ) ) {
+ dprintf("write: fd $fd is not open\n");
+ $AC = MAXINT;
+ return;
+ }
+
+ # Write each word out either in binary or in ASCII
+ my $FH = $FD[$fd];
+ foreach my $addr ( $start .. $end ) {
+ # First see if any "non-ASCII" bits are set in the word.
+ # If so, then this is a binary file
+ my $word= $Mem[$addr];
+ $ISBINARY[$fd]=1 if ($word & 0600600);
+
+ if ($ISBINARY[$fd]) {
+ print( $FH word2three($word) );
+ } else {
+ print( $FH word2ascii($word) );
+ }
+ }
+
+ # No error
+ $AC = 0;
+ return;
+}
+
+# Chmod system call
+sub sys_chmod {
+
+ # Chmod gets the permission bits in AC and a pointer
+ # to the file's name in PC+1. s2.s has these instruction for chmod:
+ # lac u.ac; and o17 so only the lowest 4
+ # bits are the permission bits that can be set.
+ # I'm going to guess these (from v1 chmod manual):
+ # 01 write for non-owner
+ # 02 read for non-owner
+ # 04 write for owner
+ # 10 read for owner
+ my $mode = 0;
+ $mode |= 0002 if ( $AC & 01 );
+ $mode |= 0004 if ( $AC & 02 );
+ $mode |= 0220 if ( $AC & 04 );
+ $mode |= 0440 if ( $AC & 010 );
+
+ my $start = $Mem[ $PC + 1 ];
+ my $filename = mem2arg($start);
+ dprintf( "chmod %06o file %s\n", $mode, $filename );
+
+ # Do the chmod on the file
+ my $result = chmod( $mode, $filename );
+
+ # Set AC to -1 if no files were changed, else 0
+ $AC = ( $result == 0 ) ? MAXINT : 0;
+ $PC += 2;
+ return;
+}
+
+# Chown system call
+sub sys_chown {
+
+ # Chown gets the numeric user-id in AC and a pointer
+ # to the file's name in PC+1.
+ # Get the start address of the string
+ # Convert this to a sensible ASCII filename
+ my $start = $Mem[ $PC + 1 ];
+ my $filename = mem2arg($start);
+ dprintf( "chown file %s to uid %06o\n", $filename, $AC );
+
+ # Do the chown, leave group-id untouched. Get number of files changed
+ my $result = chown( $AC, -1, $filename );
+
+ # Set AC to -1 if no files were changed, else 0
+ $AC = ( $result == 0 ) ? MAXINT : 0;
+ $PC += 2;
+ return;
+}
+
+# Chdir system call
+sub sys_chdir {
+
+ # Chdir gets the directory name in PC+1
+ # Return 0 on success, -1 on error
+ # Convert this to a sensible ASCII filename
+ my $start = $Mem[ $PC + 1 ];
+ my $filename = mem2arg($start);
+ dprintf( "chdir %s\n", $filename );
+
+ # Bump up the PC
+ $PC += 2;
+
+ # Do nothing on chdir to "dd"
+ return (0) if ( $filename eq "dd" );
+
+ # Do the chdir
+ return ( chdir($filename) ? 0 : MAXINT );
+}
+
+# Unlink system call
+sub sys_unlink {
+
+ # Unlink gets the file name in PC+1
+ # Return 0 on success, -1 on error
+ # Convert this to a sensible ASCII filename
+ my $start = $Mem[ $PC + 1 ];
+ my $filename = mem2arg($start);
+ dprintf( "unlink %s\n", $filename );
+
+ # Bump up the PC and do the unlink
+ $PC += 2;
+ return ( unlink($filename) ? 0 : MAXINT );
+}
+
+# Time system call
+sub sys_time {
+
+ # Dennis' draft says: The call sys time returns in
+ # the AC and MQ registers the number of sixtieths of
+ # a second since the start of the current year.
+
+ # Get two Datetime objects set to now
+ my $dt = DateTime->now;
+ my $yearstart = DateTime->now;
+
+ # Set one object back to the beginning of the year
+ $yearstart->set( month => 1 );
+ $yearstart->set( day => 1 );
+ $yearstart->set( hour => 0 );
+ $yearstart->set( minute => 0 );
+ $yearstart->set( second => 0 );
+
+ # Get the duration in sixtieths of a second
+ my $duration = $dt->subtract_datetime_absolute($yearstart);
+ my $sixtieths = $duration->seconds() * 60;
+
+ # Set MQ to the high 18 bits and AC to the low 18 bits
+ $MQ = $sixtieths >> 18;
+ $AC = $sixtieths & 0777777;
+ dprintf( "time %06o %06o, %d sixtieths\n", $MQ, $AC, $sixtieths );
+ $PC += 1;
+ return;
+}
+
+# Status system call
+sub sys_status {
+
+ # AC holds the pointer to the stat buffer
+ # PC+1 is the directory holding the entry
+ # PC+2 is the directory entry we want to stat.
+ # The statbuf is:
+ # word 0: permission bits
+ # words 1-7: disk block pointers
+ # word 8: user-id
+ # word 9: number of links
+ # word 10: size in words
+ # word 11: uniq, I have no idea what this is.
+ # word 12: i-number.
+ # The permission bits are:
+ # 200000 large file, bigger than 4096 words
+ # 000020 directory
+ # 000010 owner read
+ # 000004 owner write
+ # 000002 user write
+ # 000001 user write
+
+ # Get the directory and file names
+ # Convert this to a sensible ASCII filename
+ my $dirname = mem2arg($Mem[ $PC + 1 ]);
+ my $filename = mem2arg($Mem[ $PC + 2 ]);
+ dprintf( "status file %s/%s statbuf %06o\n", $dirname, $filename, $AC );
+
+ # Get the file's details
+ my ( undef, $ino, $mode, $nlink, $uid, undef, undef, $size ) =
+ stat("$dirname/$filename");
+
+ # Set up the statbuf if we got a result
+ if ($nlink) {
+ $Mem[ $AC + 8 ] = $uid & MAXINT;
+ $Mem[ $AC + 9 ] = (-$nlink) & MAXINT;
+ $Mem[ $AC + 10 ] = $size & MAXINT; # Yes, I know, not words
+ $Mem[ $AC + 12 ] = $ino & MAXINT;
+
+ my $perms = 0;
+ $perms = 01 if ( $mode & 02 ); # World writable
+ $perms |= 02 if ( $mode & 04 ); # World readable
+ $perms |= 04 if ( $mode & 0200 ); # Owner writable
+ $perms |= 010 if ( $mode & 0400 ); # Owner readable
+ $perms |= 020 if ( -d $filename ); # Directory
+ $perms |= 0200000 if ( $size > 4096 ); # Large file
+ $Mem[$AC] = $perms;
+
+ # Set AC to zero as we got something, else return -1
+ $AC = 0;
+ }
+ else {
+ $AC = MAXINT;
+ }
+
+ $PC += 3;
+ return;
+}
+
+# Seek syscall
+sub sys_seek {
+ # Seek takes three arguments: AC is the fd, PC+1 is a signed count
+ # and PC+2 is how to seek: 0=from start, 1=from curptr, 2=from end
+ # of file. Return AC=0 if OK, -1 on error.
+ my $fd= $AC;
+ my $FH= $FD[$fd];
+ my $offset= $Mem[ $PC + 1 ];
+ # XXX For now, we always do SEEK_SET.
+
+ # If it's a binary file, we have to seek 3 bytes for every word,
+ # but for an ASCII file that's 2 bytes per word.
+ $offset *= ($ISBINARY[$fd]) ? 3 : 2;
+ my $result= seek($FH, $offset, SEEK_SET);
+
+ # Set the AC result
+ $AC= ($result)? 0: MAXINT;
+ $PC += 3;
+ return;
+}
+
+# Rename syscall
+sub sys_rename {
+ # Rename takes two arguments: PC+1 is the current filename and
+ # PC+2 is the new filename. Returns AC=0 on success, AC=-1 on error.
+ #
+ my $oldname = mem2arg($Mem[$PC+1]);
+ my $newname = mem2arg($Mem[$PC+2]);
+ dprintf( "rename file %s to %s\n", $oldname, $newname );
+ my $result= rename($oldname, $newname);
+
+ # Set the AC result
+ $AC= ($result)? 0: MAXINT;
+ $PC += 3;
+ return;
+}
+
+# Link syscall
+sub sys_link {
+ # Link takes two arguments: PC+1 is the current filename and
+ # PC+2 is the new filename. Returns AC=0 on success, AC=-1 on error.
+ # Yes, this is not strictly what PDP-7 Unix would have done.
+ #
+ my $oldname = mem2arg($Mem[$PC+1]);
+ my $newname = mem2arg($Mem[$PC+2]);
+ dprintf( "link file %s to %s\n", $oldname, $newname );
+ my $result= link($oldname, $newname);
+
+ # Set the AC result
+ $AC= ($result)? 0: MAXINT;
+ $PC += 3;
+ return;
+}
+
+# Convert an 18-bit word into a scalar which has three sixbit
+# values in three bytes. Set the msb in the first byte
+sub word2three {
+ my $val = shift;
+
+ my $b1 = ( ( $val >> 12 ) & 077 ) | 0x80;
+ my $b2 = ( $val >> 6 ) & 077;
+ my $b3 = $val & 077;
+ return ( pack( "CCC", $b1, $b2, $b3 ) );
+}
+
+# Convert an ASCII string into an array of 18-bit word values
+# where two characters are packed into each word. Put NUL in
+# if the string has an odd number of characters. Return the array
+sub ascii2words {
+ my $str = shift;
+ my @words;
+ for ( my $i = 0 ; $i < length($str) ; $i += 2 ) {
+ my $c1 = substr( $str, $i, 1 ) || "\0";
+ my $c2 = substr( $str, $i + 1, 1 ) || "\0";
+
+ push( @words, ( ord($c1) << 9 ) | ord($c2) );
+ }
+ return (@words);
+}
+
+# Convert an 18-bit word into two ASCII characters and return them.
+# Don't return NUL characters
+sub word2ascii {
+ my $word = shift;
+ my $c1 = ( $word >> 9 ) & 0177;
+ my $c2 = $word & 0177;
+ my $result = "";
+ if (($c1 >= 1) && ($c1 <= 126)) { $result .= chr($c1); }
+ if (($c2 >= 1) && ($c2 <= 126)) { $result .= chr($c2); }
+ return ($result);
+}
+
+# Given the address of a four word argument string in
+# memory, return a copy of the string in ASCII format.
+# Lose any trailing spaces as well.
+sub mem2arg {
+ my $addr = shift;
+ my $result = "";
+
+ $addr &= MAXADDR;
+ foreach ( 1 .. 4 ) {
+
+ # Stop if the address leave the 8K word address space
+ last if ( $addr > MAXADDR );
+ my $word = $Mem[ $addr++ ];
+ my $c1 = ( $word >> 9 ) & 0177;
+ my $c2 = $word & 0177;
+ $result .= chr($c1) . chr($c2);
+ }
+ $result =~ s{ *$}{};
+ return ($result);
+}
+
+# Print out debug messages
+sub dprintf {
+ printf( STDERR @_ ) if ( ($debug) || ($singlestep) );
+}
+
+# Get one or more commands from the user and execute them
+sub get_user_command {
+ my %Cmdlist = (
+ 'b' => \&cmd_setbreak,
+ 'break' => \&cmd_setbreak,
+ 'd' => \&cmd_dump,
+ 'dump' => \&cmd_dump,
+ 'db' => \&cmd_delbreak,
+ 'del' => \&cmd_delbreak,
+ 'delete' => \&cmd_delbreak,
+ '?' => \&cmd_help,
+ 'h' => \&cmd_help,
+ 'help' => \&cmd_help,
+ 's' => \&cmd_step,
+ 'l' => \&cmd_listbreak,
+ 'list' => \&cmd_listbreak,
+ 'step' => \&cmd_step,
+ 'q' => \&cmd_exit,
+ 'x' => \&cmd_exit,
+ 'quit' => \&cmd_exit,
+ 'exit' => \&cmd_exit,
+ 'c' => \&cmd_continue,
+ 'continue' => \&cmd_continue,
+ 'r' => \&cmd_showregs,
+ 'regs' => \&cmd_showregs,
+ );
+
+ # Loop until we get a leave result
+ while (1) {
+
+ # Get a command from the user
+ # and split into command, start and end addresses.
+ # Convert addresses from octal
+ print("a7out> ");
+ chomp( my $line = <STDIN> );
+ my ( $cmd, $addr, $endaddr ) = split( /\s+/, $line );
+
+ $addr = lookup($addr) if ( defined($addr) );
+ $endaddr = lookup($endaddr) if ( defined($endaddr) );
+
+ # Run the command
+ my $leave;
+ if ( defined($cmd) && defined( $Cmdlist{$cmd} ) ) {
+ $leave = $Cmdlist{$cmd}->( $addr, $endaddr );
+ }
+ else {
+ printf( "%s: unknown command\n", $cmd || "" );
+ cmd_help();
+ }
+ return if ($leave);
+ }
+}
+
+# Exit the program
+sub cmd_exit {
+ exit(0);
+}
+
+# Continue by disabling single-step
+# and break out of the command loop
+sub cmd_continue {
+ $singlestep = 0;
+ return (1);
+}
+
+# Step by staying in single-step
+# but break out of the command loop
+sub cmd_step {
+ return (1);
+}
+
+# Set a breakpoint
+sub cmd_setbreak {
+ my $addr = shift;
+ $Breakpoint{$addr} = 1;
+ return (0);
+}
+
+# Delete a breakpoint
+sub cmd_delbreak {
+ my $addr = shift;
+ delete( $Breakpoint{$addr} );
+ printf( "Delete breakpoint %06o\n", $addr );
+ return (0);
+}
+
+sub cmd_help {
+ print(" [b]reak <octal> set a breakpoint\n");
+ print(" [c]ontinue leave single-step and continue\n");
+ print(" [d]ump [<octal>] [<octal>] dump addresses in range\n");
+ print(" db <octal> delete a breakpoint\n");
+ print(" [del]ete <octal> delete a breakpoint\n");
+ print(" [l]ist list breakpoints\n");
+ print(" [r]egs print PC, LINK, AC and MQ regs\n");
+ print(" [s]tep single-step next instruction\n");
+ print(" ?, h, help print this help list\n");
+ print(" e[x]it, [q]uit exit the program\n");
+ return (0);
+}
+
+sub cmd_showregs {
+ my $link = ($LINK) ? 1 : 0;
+ printf( "PC: %s, L.AC %d.%06o, MQ: %06o\n", addr($PC), $link, $AC, $MQ );
+ return (0);
+}
+
+sub cmd_dump {
+ my ( $start, $end ) = @_;
+
+ # No arguments, so dump everything but not empty locations
+ if ( !defined($start) ) {
+ dump_memory( 0, MAXADDR, 0 );
+ return (0);
+ }
+
+ # Dump a limited range
+ $end = $start if ( !defined($end) );
+ dump_memory( $start, $end, 1 );
+ return (0);
+}
+
+sub cmd_listbreak {
+ print("Breakpoints:\n");
+ foreach my $addr ( sort( keys(%Breakpoint) ) ) {
+ printf( " %06o\n", $addr );
+ }
+ return (0);
+}
--- /dev/null
+#!/usr/bin/env perl
+#
+# Read in files of PDP-7 assembly code in Ken Thompson's as format
+# and convert them into PDP-7 machine code
+#
+# (c) 2016 Warren Toomey, GPL3
+# Tweaked by Phil Budne (line, expression parsing, output formats)
+#
+use strict;
+use warnings;
+use Data::Dumper;
+use Getopt::Long qw(GetOptions);
+
+Getopt::Long::Configure qw(gnu_getopt);
+
+### Global variables ###
+my %Var; # Variables such as ., .., t
+my %Glabel; # Global labels that are defined once
+my %Llabel; # Local labels that are defined once
+my %Islocal; # True if the label is a local label
+my %Rlabel; # Relative labels, e.g. 1:, 2:
+ # with an array of locations for each label
+
+my @Mem; # Actual PDP-7 memory locations
+my @Mline; # Source lines associated with mem locations
+my $origline; # The original current input line of code
+my $line; # line being parsed
+my $stage = 1; # Pass one or pass two
+my $errors = 0; # set to non-zero on error
+my $line_error = ' ';
+my $file; # current file name
+my $lineno; # current line number
+my $OUTPUT; # output file
+my $RELATIVE = 01000000; # set on non-absolute symbol values
+my $BASE = 0|$RELATIVE; # starting value for "."
+### Main program ###
+
+## command line options
+my $debug = 0; # Run in debug mode
+my $format = 'a7out'; # output format
+my $namelist = 0; # output n.out file
+my $output = 'a.out'; # output file
+my $no_label_warnings = 0; # suppress multiply defined label warnings
+
+# keep this near the GetOptions call to make it easy to add documentation!
+sub usage {
+ die("Usage: $0 [--debug] [--format=a7out|list|ptr|rim ]\n" .
+ "\t[-n] [--out file] file1.s [file2.s ...]\n");
+}
+
+GetOptions(
+ 'debug|d' => \$debug,
+ 'format|f=s' => \$format,
+ 'namelist|n' => \$namelist,
+ 'output|o=s' => \$output,
+ 'no-label-warnings' => \$no_label_warnings,
+) or usage();
+
+usage() if ( @ARGV < 1 );
+
+# http://minnie.tuhs.org/cgi-bin/utree.pl?file=V3/man/manx/as.1
+# ".." is the relocation constant and is added to each relocatable
+# reference. On a PDP-11 with relocation hardware, its value is 0; on
+# most systems without protection, its value is 40000(8).
+
+# PLB: "relocatable" values are flagged with $RELATIVE
+
+# start with the location counter at zero
+# predefine syscall and opcodes as variables
+%Var = (
+ '.' => $BASE,
+ '..' => 4096, # output base addr?
+
+ # as.s does not have an initial symbol table
+ # (except for the above), so there must have been a
+ # user "ops" file
+
+ save => 1, # saves core dump & user area!
+ getuid => 2,
+ open => 3,
+ read => 4,
+ write => 5,
+ creat => 6,
+ seek => 7,
+ tell => 8,
+ close => 9,
+ link => 10,
+ unlink => 11,
+ setuid => 12,
+ rename => 13,
+ exit => 14,
+ time => 15,
+ intrp => 16,
+ chdir => 17,
+ chmod => 18,
+ chown => 19,
+ # 20 removed
+ sysloc => 21, # return system addresses
+ # 22 removed
+ capt => 23, # capture display?
+ rele => 24, # release display?
+ status => 25, # "stat"
+ smes => 27,
+ rmes => 28,
+ fork => 29,
+
+ # List of instruction names and machine code values
+ # These come from https://raw.githubusercontent.com/simh/
+
+ sys => 0020000, # "cal i" instruction (trap indirect thru 020)
+ i => 0020000, # indirect bit
+
+ # memory reference instructions
+ dac => 0040000, # deposit AC
+ jms => 0100000, # jump to subroutine
+ dzm => 0140000, # deposit zero in memory
+ lac => 0200000, # load AC
+ xor => 0240000, # exclusive or
+ add => 0300000, # one's complement add
+ tad => 0340000, # two's complement add
+ xct => 0400000, # execute
+ isz => 0440000, # increment and skip if zero
+ and => 0500000, # AND with contents of Y
+ sad => 0540000, # skip if AC different from content of Y
+ jmp => 0600000, # jump to Y
+
+ # Type 177 Extended Arithmetic Element (EAE)
+ eae => 0640000, # base instruction (nop)
+ osc => 0640001, # OR SC into AC
+ omq => 0640002, # OR MQ into AC
+ cmq => 0640004, # Complement MQ
+ div => 0640323, # divide
+ norm => 0640444, # normalize, unsigned
+ lls => 0640600, # long left shift
+ clls => 0641600, # lls but clear AC first
+ als => 0640700, # AC shift
+ lrs => 0640500, # long right shift
+ ecla => 0641000, # clear AC
+ lacs => 0641001, # load AC with SC
+ lacq => 0641002, # load AC with MQ
+ abs => 0644000, # absolute value
+ divs => 0644323, # divide, signed
+
+ clq => 0650000, # clear MQ
+ frdiv => 0650323, # fractional divide
+ lmq => 0652000, # load MQ from AC
+ mul => 0653122, # multiply
+ idiv => 0653323, # integer divide
+ idivs => 0657323, # integer divide, signed
+ frdivs => 0654323, # fractional divide, signed
+ muls => 0657122, # multiply, signed
+
+ norms => 0660444, # normalize, signed
+ gsm => 0664000, # get sign and magnitude
+ lrss => 0660500, # long right shift, signed
+ llss => 0660600, # long left shift, signed
+ alss => 0660700, # AC left shift, signed
+
+ # PLB: removed I/OT instructions: kernel uses sop.s
+
+ # Operate Instructions
+
+ # Group 1 (OPR 1) instructions
+ opr => 0740000, # base operate instruction (nop)
+ nop => 0740000,
+ cma => 0740001, # complement accumulator
+ cml => 0740002, # complement link
+ oas => 0740004, # inclusive or accumulator switches
+ ral => 0740010, # rotate (ac, link) left
+ rar => 0740020, # rotate (ac, link) right
+ hlt => 0740040, # HALT
+ xx => 0740040,
+ sma => 0740100, # skip on minus accumulator
+ sza => 0740200, # skip on zero accumulator
+ snl => 0740400, # skip on non-zero link
+
+ skp => 0741000, # unconditional skip
+ spa => 0741100, # skip on positive accumulator
+ sna => 0741200, # skip on negative accumulator
+ szl => 0741400, # skip on zero link
+
+ rtl => 0742010, # rotate two left (ral*2)
+ rtr => 0742020, # rotate two right (rar*2)
+
+ cll => 0744000, # clear link
+ stl => 0744002, # set link
+ rcl => 0744010, # clear link, rotate left
+ rcr => 0744020, # clear link, rotate right
+
+ cla => 0750000, # clear accumulator
+ clc => 0750001, # clear and complement acc
+ las => 0750004, # load acc from switches
+ glk => 0750010, # get link
+
+ # Group 2 operate
+ law => 0760000, # load accumulator with (instruction)
+# lam => 0777777, # (load accumulator minus)
+);
+
+
+# Parse all the files
+print STDERR "I\n"; # like the real as
+foreach my $file (@ARGV) {
+ parse_file($file);
+}
+
+# Now do it all again, pass two
+$Var{'.'} = $BASE;
+$stage = 2;
+open(my $OUT, ">$output") || die "$output";
+
+print STDERR "II\n"; # like the real as
+foreach my $file (@ARGV) {
+ print STDERR "$file\n"; # like the real as
+ parse_file($file);
+}
+
+if ($format eq 'a7out') {
+ # print out the contents of memory
+ for my $i ( 0 .. $#Mem ) {
+ if ( defined( $Mem[$i] ) ) {
+ printf $OUT "%06o: %06o\t%s\n", $i, $Mem[$i], ($Mline[$i] || "");
+ }
+ }
+}
+elsif ($format eq 'list') {
+ print $OUT "\n";
+ print $OUT "Labels:\n";
+ dump_labels($OUT);
+}
+elsif ($format eq 'ptr') { # dump absolute memory in PTR binary
+ for my $loc ( $Var{'..'} .. $#Mem ) {
+ punch($Mem[$loc] || 0);
+ }
+}
+elsif ($format eq 'rim') { # "Hardware Read In" tape
+ # only handles continguous memory, but no overhead
+ my $base = $Var{'..'};
+ for my $loc ( $base .. $#Mem ) {
+ punch($Mem[$loc] || 0);
+ }
+ # final word: command; has 0100 lit on last frame
+ punch(0600000 | $base, 0100 );
+}
+else {
+ die("unknown format $format");
+}
+close($OUT);
+
+if ($namelist) {
+ # as.s writes a binary file named n.out, ours is ascii
+ open (my $NOUT, ">", "n.out") || die "n.out";
+ dump_labels($NOUT);
+ close($NOUT);
+}
+
+exit($errors);
+
+# report an assmebly error:
+# sets error flag
+# reports filename:lineno for emacs m-x compile
+sub err {
+ $line_error = shift;
+ my $msg = shift;
+
+ $errors = 1; # exit status
+ if ($stage == 2) {
+ print STDERR "$file:$lineno: $msg\n";
+ print $OUT "$file:$lineno: $msg\n" if ($format eq 'list');
+ }
+ return 0; # expression value
+}
+
+# Set a label, either global or local
+sub set_label
+{
+ my ($label,$loc)= @_;
+
+ # PLB: truncate to eight: moo.s declares "standing"
+ # but references it as "standings"
+ $label = substr($label, 0, 8);
+
+ # It is a local label if we're told it is, or if it starts with "L"
+ if ($Islocal{$file}{$label} || $label=~ m{^L}) {
+ # An error to have different values
+ if ( defined( $Llabel{$file}{$label} ) && $Llabel{$file}{$label} != $loc ) {
+ # non-fatal: as.s doesn't even warn!!!!
+ print STDERR "$file:$lineno: Local label $label multiply defined\n"
+ if ($stage == 2 && !$no_label_warnings);
+ }
+ else {
+ $Llabel{$file}{$label} = $loc;
+ printf( "Set local label %s to %#o\n", $label, $loc ) if ($debug);
+ }
+ } else {
+ # original as doesn't complain about multiple definitions of labels
+ # (Space Travel depends on this). Now a warning (on by default)
+ if ( defined( $Glabel{$label} ) && $Glabel{$label} != $loc ) {
+ print STDERR "$file:$lineno: Warning: Global label $label multiply defined\n"
+ if ($stage == 2 && !$no_label_warnings);
+ }
+ $Glabel{$label} = $loc;
+ printf( "Set global label %s to %#o\n", $label, $loc ) if ($debug);
+ }
+}
+
+# Get the value of a global or local label
+sub get_label
+{
+ my $label= shift;
+ # PLB: truncate to eight: moo.s declares "standing"
+ # but references it as "standings"
+ $label = substr($label, 0, 8);
+ return($Llabel{$file}{$label}) if (defined($Llabel{$file}{$label}));
+ return($Glabel{$label});
+}
+
+# Open and parse the given file
+sub parse_file {
+ $file = shift;
+
+ open( my $IN, "<", $file ) || die("Cannot open $file: $!\n");
+ $lineno = 0;
+ while ( $line = <$IN> ) {
+ $lineno++;
+ chomp($line); # Lose the end of line
+ $origline = $line;
+ print $OUT "\t\t$line\n"
+ if ($stage == 2 && $line ne '' && $format eq 'list');
+ parse_line();
+ }
+ close($IN);
+}
+
+# process a label and set its value to the location counter
+# OK for symbolic label to be entered twice, so long as it's the same value
+# (ie; both passes)
+sub process_label {
+ my $label = shift;
+ my $loc = $Var{'.'};
+
+ print "process_label $label\n" if ($debug);
+
+ if ( $label =~ m{^\d+$} ) { # numeric (relative) label?
+ if ($stage == 1) {
+ push( @{ $Rlabel{$label} }, $loc );
+ printf( "Pushing %#o for label %s\n", $loc, $label ) if ($debug);
+ }
+ } # numeric label
+ else { # symbolic label
+ set_label($label, $loc);
+ }
+}
+
+# Parse assembler directives. These were not in the original
+# PDP-7 Unix source, but we need them so that we can write
+# compilers that target this assembler.
+sub parse_directive
+{
+ my $directive= shift;
+ print("Got directive $directive\n") if ($debug);
+
+ # Set this as a local label
+ if ($directive=~ m{^\@local\s+(\S+)}) {
+ $Islocal{$file}{$1}=1;
+ }
+}
+
+sub eol {
+ return $line eq '' || $line =~ m{^"}; # empty or comment
+}
+
+# Blame Phil for this....
+# parses global $line based on prefixes, nibbling of a bit at a time
+# (: and ; can appear in char literals)
+# handles multiple ';' separated words per line
+# allows " in character literals (tho none appear in listings)
+sub parse_line {
+ while (1) {
+ $line_error = ' '; # clear listing error indicator
+
+ return if (eol());
+
+ print "parse_line: '$line'\n" if ($debug);
+
+ # Lose any leading whitespace
+ $line =~ s{^\s*}{};
+
+ # Assembler directives start with an @
+ if ($line =~ m{^\@}) {
+ parse_directive($line);
+ return;
+ }
+
+ while ($line =~ s{^([A-Za-z0-9_\.]+):\s*}{}) { # labels
+ process_label($1);
+ }
+
+ return if (eol());
+
+ if ( $line =~ s{^([^;= \t]+)\s*=}{}) { # assignment
+ my $lhs = $1;
+ my $word = parse_expression();
+ printf( "Setting variable %s to 0%o\n", $lhs, $word ) if ($debug);
+ $Var{$lhs} = $word;
+ printf $OUT "\t%06o %s\n", $word, $line_error
+ if ($stage == 2 && $format eq 'list');
+ }
+ else { # bare expression (not assignment)
+ # Get its value on pass two and save to memory
+ # Also save the input line that altered memory
+ my $word = parse_expression();
+ if ( $stage == 2 ) {
+ my $location = $Var{'.'};
+ if ($location & $RELATIVE) { # non-absolute location?
+ $location &= 0777777;
+ $location += $Var{'..'} & 0777777; # relocate
+ # XXX check for overflow?
+ }
+ if ($word & $RELATIVE) { # word created from relative addresses?
+ $word &= 0777777;
+ $word += $Var{'..'} & 0777777; # relocate
+ # XXX check for overflow?
+ }
+ if ($location < 0) {
+ err('.', 'below base');
+ }
+ else {
+ $Mem[$location] = $word;
+ }
+ $Mline[$location] = $origline;
+ $origline = '';
+ if ($format eq 'list' and defined($word)) {
+ # show flags??
+ printf $OUT "%06o: %06o %s\n",
+ $location, $word, $line_error;
+ }
+ }
+ # Move up to the next location in both passes
+ $Var{'.'}++;
+ } # expr
+
+ # eat trailing whitespace and ";", if any
+ $line =~ s{^\s*;?}{};
+ } # while
+}
+
+# Blame Phil for this bit too...
+# Parse an expression off $line and return a PDP-7 word
+# as a series of whitespace separated "syllables"
+# ORed, added, or subtracted
+sub parse_expression {
+ my $word = 0;
+ my $flags = 0;
+
+ print "expression: '$line'\n" if ($debug);
+
+ while (1) {
+ my $syllable = 0;
+ my $op = '|';
+
+ $line =~ s{^\s+}{}; # as.s accepts ",' as whitespace too!
+
+ if ($line eq '' || $line =~ m{^[";]}) { # EOL ; and " terminate expr
+ $word |= $flags;
+ printf("\tparse_expression => %#o\n", $word) if ($debug);
+ return $word;
+ }
+
+ print " '$line'\n" if ($debug);
+
+ if ($line =~ s{^-}{}) {
+ print "\tfound -\n" if ($debug);
+ $op = '-';
+ }
+ elsif ($line =~ s{^\+}{}) {
+ print "\tfound +\n" if ($debug);
+ $op = '+';
+ }
+
+ if ($line =~ s{^<(.)}{}) { # <char
+ print "\tfound <x\n" if ($debug);
+ $syllable = ord($1) << 9; # absolute
+ }
+ elsif ($line =~ s{^(.)>}{}) { # char>
+ print "\tfound x>\n" if ($debug);
+ $syllable = ord($1) # absolute
+ }
+ elsif ($line =~ s{^>(.)}{}) { # >char !!
+ print "\tfound >x\n" if ($debug);
+ $syllable = ord($1) # absolute
+ }
+ elsif ($line =~ s{^([A-Za-z_\.][A-Za-z0-9_\.]*)}{}) {
+ my $sym = $1;
+ print "\tsym: $sym\n" if ($debug);
+
+ if (defined($Var{$sym})) {
+ $syllable = $Var{$sym};
+ printf("\tvar: %s: %#o\n", $sym, $syllable) if ($debug);
+ }
+ elsif (defined(get_label($sym))) {
+ $syllable = get_label($sym);
+ printf("\tlbl: %s: %#o\n", $sym, $syllable) if ($debug);
+ }
+ elsif ($stage == 2) {
+ err('U', "$sym not defined")
+ } # pass 2
+ } # symbol
+ elsif ( $line =~ s{^(\d+)([fb])}{} ) { # relative label
+ printf "\tfound relative: $1$2\n" if ($debug);
+ $syllable = find_relative_label( $1, $2 ) if ($stage == 2);
+ }
+ elsif ( $line =~ s{^(\d+)}{} ) { # constant
+ my $value = $1;
+ printf "\tfound constant: $value\n" if ($debug);
+ if ( $value =~ m{^0} ) {
+ # PLB 2020-10-05: behave like as.s
+ $syllable = 0;
+ for my $digit (split(//, $value)) {
+ $syllable = $syllable * 010 + ord($digit) - ord('0');
+ }
+ }
+ else {
+ $syllable = $value + 0;
+ }
+ $syllable &= 0777777; # absolute
+ }
+ else {
+ # From the BSD fortune file:
+ # Ken Thompson has an automobile which he helped design.
+ # Unlike most automobiles, it has neither speedometer,
+ # nor gas gauge, nor any of the numerous idiot lights
+ # which plague the modern driver. Rather, if the driver
+ # makes any mistake, a giant "?" lights up in the center
+ # of the dashboard. "The experienced driver",
+ # he says, "will usually know what's wrong.
+ err('?', "huh? '$line'");
+ $line = ''; # abort processing
+ return undef;
+ }
+
+ my $sylflags = $syllable & $RELATIVE;
+ $syllable &= 0777777;
+
+ if ($op eq '+') {
+ $word += $syllable;
+ $flags |= $sylflags;
+ }
+ elsif ($op eq '-') {
+ $word -= $syllable;
+ if ($flags & $RELATIVE) {
+ # relative-relative => absolute!
+ if ($sylflags & $RELATIVE) {
+ $flags &= ~$RELATIVE;
+ }
+ # else: relative-abs => relative (no change)
+ }
+ else { # word is absolute
+ if ($sylflags & $RELATIVE) {
+ err('A', 'absolute value minus relative??');
+ }
+ # else: absolute-absolute => absolute (no change)
+ }
+ }
+ else {
+ $word |= $syllable;
+ $flags |= $sylflags;
+ }
+ $word &= 0777777;
+ printf("\tsyllable: %#o word: %#o\n", $syllable, $word) if ($debug);
+ }
+}
+
+# Given a relative label number and a direction,
+# return the location of this relative label or
+# die if we don't have one
+sub find_relative_label {
+ my ( $label, $direction ) = @_;
+ my $curlocation = $Var{'.'};
+
+ # Error check: no labels at all
+ if ( !defined( $Rlabel{$label} ) ) {
+ return err('U', "relative label $label never defined");
+ }
+
+ # Get the list of possible locations for this label
+ my $locarray = $Rlabel{$label};
+
+ # Error check: no locations
+ return err('U', "No relative labels") if ( @{$locarray} == 0 );
+
+ if ( $direction eq 'f' ) {
+ # Search forward for first location larger then the current one
+ foreach my $reflocation ( @{$locarray} ) {
+ printf("forward %#o %#o\n", $reflocation, $curlocation) if ($debug);
+ return ($reflocation) if ( $reflocation > $curlocation );
+ }
+ }
+ else {
+ # Search backwards for first location smaller than the current one
+ foreach my $reflocation ( sort( { $b <=> $a } @{$locarray} ) ) {
+ printf("backward %#o %#o\n", $reflocation, $curlocation) if ($debug);
+ return ($reflocation) if ( $reflocation < $curlocation );
+ }
+ }
+ return err('U', "undefined relative reference $label$direction");
+}
+
+sub punch { # output a word in paper tape binary format
+ my $word = shift;
+ my $final = shift || 0;
+
+ printf $OUT "%c%c%c",
+ (($word >> 12) & 077) | 0200,
+ (($word >> 6) & 077) | 0200,
+ ($word & 077) | 0200 | $final;
+}
+
+sub dump_labels { # for 'list' and --namelist
+ my $file = shift;
+
+ foreach my $key (sort keys %Glabel) {
+ my $addr = $Glabel{$key};
+ my $flags = ($addr & $RELATIVE) ? "r" : "";
+ if ($addr & $RELATIVE) {
+ $addr &= 0777777;
+ $addr += $Var{'..'};
+ }
+ printf $file "%-8.8s %#06o %s\n", $key, $addr & 0777777, $flags;
+ }
+}
--- /dev/null
+#!/usr/bin/env perl
+#
+# Load a code coverage report from SimH and a kernel assembly listing
+# from as7, and show which lines in the kernel were not executed.
+#
+# To capture the list of executed locations in SimH, run SimH but stop
+# before executing any code, e.g. dep pc 0100 but don't go.
+#
+# Run this command to log execution of locations 21-4545:
+# set br 21-4545[200000000]
+#
+# Eventually, ctrl-E to stop execution. Now dump the results:
+# show @brk.list break all
+#
+# which will output a BRK.LIST Then run this command:
+# ccov7 BRK.LIST a.lst | less
+#
+#
+# (c) 2016 Warren Toomey, GPL3
+#
+use strict;
+use warnings;
+use Data::Dumper;
+
+die("Usage: $0 breaklist_file a.lst\n") if (@ARGV !=2);
+
+# Read in the breaklist file and work out which lines were not
+# used. We assume that [200000000] was used in SimH
+my @Unused;
+open(my $IN, "<", $ARGV[0]) || die("Can't open $ARGV[0]: $!\n");
+while (<$IN>) {
+ if (m{^(\d+):.*\[(\d+)\]}) {
+ $Unused[$1]=1 if ($2 == 200000000);
+ }
+}
+close($IN);
+
+# Now open the kernel listing file. Decorate those lines which
+# were not executed
+my $decoration= "\t NOT EXECUTED";
+
+open($IN, "<", $ARGV[1]) || die("Can't open $ARGV[1]: $!\n");
+while (<$IN>) {
+ chomp;
+ if (m{^(\d+):}) { # Find a line starting with digits, trim
+ my $location= $1; # leading zeroes, append $decoration
+ $location=~ s{^0+}{}; # if this is an unused location
+ $_ .= $decoration if (defined($Unused[$location]));
+ }
+ print("$_\n");
+}
+close($IN);
+exit(0);
--- /dev/null
+#!/usr/bin/env perl
+#
+# fsck7: Check a PDP-7 filesystem for consistency
+#
+# (c) 2016 Warren Toomey, GPL3
+#
+use strict;
+use warnings;
+use Fcntl qw(:flock SEEK_SET);
+use Data::Dumper;
+use Getopt::Long qw(GetOptions);
+
+Getopt::Long::Configure qw(gnu_getopt);
+
+# Constants
+use constant NUMBLOCKS => 8000; # Number of blocks on a surface
+use constant WORDSPERBLK => 64; # 64 words per block
+use constant LASTFREEBLOCK => 6399; # That's what s9.s uses
+use constant NUMINODEBLKS => 710; # Number of i-node blocks
+use constant FIRSTINODEBLK => 2; # First i-node block number
+use constant INODESIZE => 12; # Size of an i-node
+use constant INODESPERBLK => int( WORDSPERBLK / INODESIZE );
+use constant DIRENTSIZE => 8; # Size of an directory entry
+use constant DIRENTSPERBLK => WORDSPERBLK / DIRENTSIZE;
+
+use constant MAXINT => 0777777; # Biggest unsigned integer
+use constant SIGN => 0400000; # Sign bit
+use constant BYTESPERWORD => 4; # We encode each word into 4 bytes
+
+# i-node field offsets
+use constant I_FLAGS => 0;
+use constant I_DISKPS => 1;
+use constant I_UID => 8;
+use constant I_NLKS => 9;
+use constant I_SIZE => 10;
+use constant I_UNIQ => 11;
+
+use constant I_NUMBLKS => 7; # Seven block pointers in i-node
+
+# i-node flag masks
+use constant I_USED => 0400000;
+use constant I_LARGE => 0200000;
+use constant I_SPECIAL => 0000040;
+use constant I_DIRECTORY => 0000020;
+use constant I_FILE => 0000000;
+use constant I_OWNERREAD => 0000010;
+use constant I_OWNERWRITE => 0000004;
+use constant I_WORLDREAD => 0000002;
+use constant I_WORLDWRITE => 0000001;
+
+use constant I_LINK => 0000001; # Never used in an i-node: just internal use
+
+# Directory field offsets
+use constant D_INUM => 0;
+use constant D_NAME => 1;
+use constant D_UNIQ => 5;
+use constant D_NUMWORDS => 8; # Eight words in a direntry
+
+# Globals
+my ($debug, $no_dd) = (0,0);
+my @Block; # Array of blocks and words in each block
+my @Freelist; # List of free block numbers
+my @Usedlist; # List of in-use block numbers
+my @Usedinode; # List of i-nodes in use
+my @Dirdone; # List of directory i-nodes already processed
+
+# Debug printing
+sub dprint {
+ print(@_) if ($debug);
+}
+
+sub dprintf {
+ printf(@_) if ($debug);
+}
+
+### read a word from a file in SimH format
+### return -1 on EOF
+sub read_word {
+ my $F = shift;
+
+ # Convert four bytes into one 18-bit word
+ return -1 if ( read( $F, my $four, 4 ) != 4 ); # Not enough bytes read
+ my ( $b1, $b2, $b3, $b4 ) = unpack( "CCCC", $four );
+ return (
+ ( $b1 & 0xff ) | ( ( $b2 & 0xff ) << 8 ) | ( ( $b3 & 0xff ) << 16 ) |
+ ( ( $b4 & 0xff ) << 24 ) );
+}
+
+# Return blocknumber and offset for a specific i-node
+sub get_inode_block_offset {
+ my $inum = shift;
+ my $blocknum = FIRSTINODEBLK + int( $inum / INODESPERBLK );
+ my $offset = INODESIZE * ( $inum % INODESPERBLK );
+ return ( $blocknum, $offset );
+}
+
+# Mark a block as being in-use
+sub mark_block_inuse {
+ my $usedblk = shift;
+ die("bad usedblk $usedblk\n") if ($usedblk >= NUMBLOCKS);
+
+ dprint("Block $usedblk is in-use\n");
+ print("Free block $usedblk is being used\n")
+ if ( $Freelist[$usedblk] );
+ print("In-use block $usedblk is being re-used\n")
+ if ( $Usedlist[$usedblk] );
+ $Usedlist[$usedblk] = 1;
+}
+
+# Given an i-node number and a flag mask, return true
+# if the flags contains that mask, 0 otherwise
+sub is_inode {
+ my ( $inode, $mask ) = @_;
+ my ( $blocknum, $offset ) = get_inode_block_offset($inode);
+ my $flags = $Block[$blocknum][ $offset + I_FLAGS ];
+ return ( $flags & $mask );
+}
+
+# Given an i-node number, return the flags, uid, # link,
+# file size, uniq number and list of disk blocks for
+# the i-node (if $wantblocks is true).
+# Return undef if the i-node is not used.
+sub get_inode {
+ my ( $inode, $wantblocks ) = @_;
+ my ( $blocknum, $offset ) = get_inode_block_offset($inode);
+ my $flags = $Block[$blocknum][ $offset + I_FLAGS ];
+ my $uid = $Block[$blocknum][ $offset + I_UID ];
+ my $links = $Block[$blocknum][ $offset + I_NLKS ];
+ my $size = $Block[$blocknum][ $offset + I_SIZE ];
+ my $uniq = $Block[$blocknum][ $offset + I_UNIQ ];
+
+ # Skip unused i-nodes
+ return (undef) if ( ( $flags & I_USED ) == 0 );
+
+ # Return now if they don't want the blocks
+ return ( $flags, $uid, $links, $size, $uniq ) if ( !$wantblocks );
+
+ # Build a list of in-use blocks
+ my @used;
+ if ( $flags & I_LARGE ) {
+
+ # Large file
+ foreach
+ my $o ( $offset + I_DISKPS .. $offset + I_DISKPS + I_NUMBLKS - 1 )
+ {
+ my $usedptr = $Block[$blocknum][$o];
+ next if ( $usedptr == 0 );
+ die("bad usedptr $usedptr in i-node $inode\n") if ($usedptr >= NUMBLOCKS);
+
+ mark_block_inuse($usedptr);
+ foreach my $indo ( 0 .. WORDSPERBLK - 1 ) {
+
+ my $usedblk = $Block[$usedptr][$indo];
+ next if ( $usedblk == 0 );
+ push( @used, $usedblk );
+ }
+ }
+ }
+ else {
+ # Small file
+ foreach
+ my $o ( $offset + I_DISKPS .. $offset + I_DISKPS + I_NUMBLKS - 1 )
+ {
+ my $usedblk = $Block[$blocknum][$o];
+ next if ( $usedblk == 0 );
+ push( @used, $usedblk );
+ }
+ }
+ return ( $flags, $uid, $links, $size, $uniq, @used );
+}
+
+# Given the address of a four word argument string in
+# a block, return a copy of the string in ASCII format.
+# Lose any trailing spaces as well.
+sub word2filename {
+ my ( $block, $offset ) = @_;
+ my $result = "";
+
+ foreach ( 1 .. 4 ) {
+
+ my $word = $Block[$block][ $offset++ ];
+ my $c1 = ( $word >> 9 ) & 0177;
+ my $c2 = $word & 0177;
+ $result .= chr($c1) . chr($c2);
+ }
+ $result =~ s{ *$}{};
+ return ($result);
+}
+
+# Print out a directory entry
+sub print_direntry {
+ my ( $inum, $name ) = @_;
+ my ( $flags, $uid, $links, $size, $uniq ) = get_inode( $inum, 0 );
+ if ( !defined($flags) ) {
+ printf( "%4d unallocated i-node in this dir named %s\n", $inum, $name );
+ return;
+ }
+
+ # Get the text perm characters
+ my ( $p1, $p2, $p3, $p4, $p5 ) = ( 's', '-', '-', '-', '-' );
+ $p1 = 'l' if ( $flags & I_LARGE );
+ $p1 = 'i' if ( $flags & I_SPECIAL );
+ $p1 = 'd' if ( $flags & I_DIRECTORY );
+ $p2 = 'r' if ( $flags & I_OWNERREAD );
+ $p3 = 'w' if ( $flags & I_OWNERWRITE );
+ $p4 = 'r' if ( $flags & I_WORLDREAD );
+ $p5 = 'w' if ( $flags & I_WORLDWRITE );
+
+ # Convert links and uid
+ $links = MAXINT - $links + 1;
+ $uid = -1 if ( $uid == MAXINT );
+
+ # Warn about empty filename
+ $name= "EMPTY FILENAME" if ($name=~ m{/$});
+
+ printf( "%4d %s%s%s%s%s %2d %3o %5d %s\n",
+ $inum, $p1, $p2, $p3, $p4, $p5, $links, $uid & 0777, $size, $name );
+}
+
+# Given a directory's i-num and name, check it
+sub check_directory {
+ my ( $inode, $name ) = @_;
+ my @dirtocheck; # List of dirs to check
+
+ print("Directory $name, i-node $inode\n");
+
+ my ( $flags, $uid, $links, $size, $uniq, @used ) = get_inode( $inode, 1 );
+ if ( !defined($flags) ) {
+ print("Directory $name has empty i-node $inode\n");
+ return;
+ }
+
+ if ( ( $flags & I_DIRECTORY ) == 0 ) {
+ print("Directory $name i-node $inode not a directory\n");
+ return;
+ }
+ $Dirdone[$inode] = 1;
+
+ # Read the contents of the data blocks
+ foreach my $block (@used) {
+ for (
+ my $direntoff = 0 ;
+ $direntoff < WORDSPERBLK ;
+ $direntoff += DIRENTSIZE
+ )
+ {
+ my $inum = $Block[$block][ $direntoff + D_INUM ];
+ my $direntname = word2filename( $block, $direntoff + D_NAME );
+ next if ( $inum == 0 );
+ print_direntry( $inum, "$name/$direntname" );
+
+ # Check sub-directories
+ if ( is_inode( $inum, I_DIRECTORY ) && ( !$Dirdone[$inum] ) ) {
+ push( @dirtocheck, [ $inum, "$name/$direntname" ] );
+ }
+ }
+ }
+ print("\n");
+
+ # Now check the subdirs
+ foreach my $d (@dirtocheck) {
+ check_directory( $d->[0], $d->[1] );
+ }
+
+}
+
+# Keep this near the GetOptions call to make it easy to add documentation!
+sub usage {
+ die("Usage: $0 [--debug] imagefile\n");
+}
+
+### MAIN PROGRAM
+
+GetOptions(
+ 'debug|d' => \$debug,
+ 'no_dd|3' => \$no_dd,
+)
+ or usage();
+
+usage() if ( @ARGV < 1 );
+
+# Open the image and skip the first surface
+open( my $IN, "<", $ARGV[0] ) || die("Can't open $ARGV[0]: $!\n");
+seek($IN, NUMBLOCKS*WORDSPERBLK*BYTESPERWORD, SEEK_SET) ||
+ die("Cannot seek: $!\n");
+
+# Now read the filesystem into the Block array
+foreach my $block ( 0 .. NUMBLOCKS - 1 ) {
+ foreach my $posn ( 0 .. WORDSPERBLK - 1 ) {
+ my $word = read_word($IN);
+ last if ( $word == -1 );
+ $Block[$block][$posn] = $word;
+ }
+}
+
+# Build and check the free list
+my $freeptr = $Block[0][0];
+while ( $freeptr != 0 ) {
+
+ # Add nine blocks to the free list
+ foreach my $posn ( 1 .. 9 ) {
+ my $freeblock = $Block[$freeptr][$posn];
+ if ( $freeblock != 0 ) {
+ print("Block $freeblock multiply free\n")
+ if ( $Freelist[$freeblock] );
+ $Freelist[$freeblock] = 1;
+ }
+ }
+
+ # Move the pointer up
+ $freeptr = $Block[$freeptr][0];
+}
+
+# Check the list of i-nodes
+foreach my $inode ( 0 .. NUMINODEBLKS * INODESPERBLK - 1 ) {
+
+ my ( $flags, $uid, $links, $size, $uniq, @used ) = get_inode( $inode, 1 );
+ next if ( !defined($flags) );
+ $Usedinode[$inode] = 1;
+ dprint("I-node $inode in use\n");
+
+ # Check number of links is not zero
+ print("I-node $inode link count 0\n") if ( $links == 0 );
+
+ # Mark all the file's blocks in-use
+ foreach my $b (@used) {
+ mark_block_inuse($b);
+ }
+ dprint("\n");
+}
+
+# Now check the directories. We start with dd at i-num 4.
+if ($no_dd) {
+ check_directory( 2, "" );
+} else {
+ check_directory( 4, "dd" );
+}
+
+exit(0);
--- /dev/null
+#!/usr/bin/env perl
+#
+# mkfs7: Make a PDP-7 filesystem image for SimH
+#
+# (c) 2016 Warren Toomey, GPL3
+#
+use strict;
+use warnings;
+use Data::Dumper;
+use Getopt::Long qw(GetOptions);
+
+Getopt::Long::Configure qw(gnu_getopt);
+
+# Constants
+use constant NUMBLOCKS => 8000; # Number of blocks on a surface
+use constant WORDSPERBLK => 64; # 64 words per block
+use constant LASTFREEBLOCK => 6399; # That's what s9.s uses
+use constant NUMINODEBLKS => 710; # Number of i-node blocks
+use constant FIRSTINODEBLK => 2; # First i-node block number
+use constant INODESIZE => 12; # Size of an i-node
+use constant INODESPERBLK => int(WORDSPERBLK / INODESIZE);
+use constant DIRENTSIZE => 8; # Size of an directory entry
+use constant DIRENTSPERBLK => WORDSPERBLK / DIRENTSIZE;
+
+use constant DD_INUM => 2; # I-number of the dd directory
+use constant MAXINT => 0777777; # Biggest unsigned integer
+
+# i-node field offsets
+use constant I_FLAGS => 0;
+use constant I_DISKPS => 1;
+use constant I_UID => 8;
+use constant I_NLKS => 9;
+use constant I_SIZE => 10;
+use constant I_UNIQ => 11;
+
+use constant I_NUMBLKS => 7; # Seven block pointers in i-node
+
+# i-node flag masks
+use constant I_USED => 0400000;
+use constant I_LARGE => 0200000;
+use constant I_SPECIAL => 0000040;
+use constant I_DIRECTORY => 0000020;
+use constant I_FILE => 0000000;
+use constant I_OWNERREAD => 0000010;
+use constant I_OWNERWRITE => 0000004;
+use constant I_WORLDREAD => 0000002;
+use constant I_WORLDWRITE => 0000001;
+
+use constant I_LINK => 0000001; # Never used in an i-node: just internal use
+
+# Directory field offsets
+use constant D_INUM => 0;
+use constant D_NAME => 1;
+use constant D_UNIQ => 5;
+use constant D_NUMWORDS => 8; # Eight words in a direntry
+
+# Globals
+my ($debug,$wantdot,$wantdotdot, $no_dd)=(0,0,0,0);
+my @Block; # Array of blocks and words in each block
+my @Freelist; # List of free block numbers
+my $nextinum = 1; # i-num 0 is never used
+my @Dirstack; # Stack of directories. Each value is a ref
+ # to a [ blocknum, offset, inum ] array which
+ # is the next free position in the directory
+my $lastinum = -1; # last inum assigned, for link to i-num -1
+
+# Debug printing
+sub dprint {
+ print(@_) if ($debug);
+}
+
+sub dprintf {
+ printf(@_) if ($debug);
+}
+
+# Initialise the free block list
+# s9.s sets up blocks 710 to 6399 as free
+sub init_freelist {
+ foreach my $blk (FIRSTINODEBLK+NUMINODEBLKS-1 .. LASTFREEBLOCK) {
+ push(@Freelist, $blk);
+ }
+}
+
+# Recursively write the free list of blocks to disk.
+# Set up a block with nine free block numbers in it,
+# plus a pointer to the next block in the free list.
+# Return the block number of this block with nine free block numbers
+# or 0 if we did not set up a block.
+# The argument is only used to make the debug output pleasing
+sub write_freelist {
+ no warnings 'recursion';
+ my $i= shift;
+
+ # Get a block to store nine free block numbers
+ # Return if there are no free blocks
+ my $thisblock= shift(@Freelist);
+ return(0) if (!defined($thisblock));
+ dprint("$thisblock ");
+ dprint("\n") if (($i % 14) == 0);
+
+ # Try to grab nine of them and store in this block
+ foreach my $count (1 .. 9) {
+ $Block[$thisblock][$count]= shift(@Freelist) || 0;
+ }
+
+ # Now we need the pointer to the next block in the chain
+ $Block[$thisblock][0]= write_freelist($i+1);
+
+ # and return our own block number
+ return($thisblock);
+}
+
+# Fill block zero, the sysdata block, with whatever it needs.
+# As far as we can tell, all it needs is the pointer to the
+# beginning of the free list.
+sub fill_sysdata {
+ $Block[0][0]= write_freelist(6);
+}
+
+# Given a size in words, allocate and return a set of block numbers
+# for the entity
+sub allocate_blocks {
+ my $numwords = shift;
+ my @blklist;
+
+ my $numblocks = int( ( $numwords + WORDSPERBLK - 1 ) / WORDSPERBLK );
+ foreach my $cnt ( 1 .. $numblocks ) {
+ my $blk= shift(@Freelist);
+ die("Not enough blocks\n") if (!defined($blk));
+ push( @blklist, $blk );
+ }
+ dprintf(
+ "Allocated blocks for size %d: %d .. %d (%06o .. %06o)\n",
+ $numwords, $blklist[0], $blklist[-1], $blklist[0], $blklist[-1])
+ if ($blklist[0]);
+ return (@blklist);
+}
+
+# Allocate and return either the specified i-node or the next
+# available one if there is no argument
+sub allocate_inode {
+ my $inum = shift;
+ return ( $nextinum++ ) if ( !defined($inum) );
+ if ( $inum < $nextinum ) {
+ print("i-num $inum already allocated, ignoring this\n")
+ } else {
+ $nextinum = $inum + 1;
+ }
+ return ($inum);
+}
+
+# Given a list of block numbers, allocate a set of indirect blocks
+# and install block pointers into the indirect blocks. Return the
+# list of indirect block numbers.
+sub build_indirect_blocks {
+ my @blklist = @_;
+ my $blkcount = @blklist;
+
+ # Divide the number of data blocks by WORDSPERBLK and round up, so
+ # we know how many indirect blocks to allocate.
+ my $indcount = int( ( $blkcount + WORDSPERBLK - 1 ) / WORDSPERBLK );
+ dprint("Allocating $indcount indirect blks for $blkcount direct blks\n");
+
+ # Get enough indirect blocks
+ my @indlist = allocate_blocks(WORDSPERBLK * $indcount);
+
+ # Now fill in the pointers
+ my $indblock = $indlist[0];
+ my $offset = 0;
+ foreach my $datablock (@blklist) {
+ # dprint("$indblock $offset -> $datablock\n");
+ $Block[$indblock][ $offset++ ] = $datablock;
+ if ( $offset == WORDSPERBLK ) {
+ $offset = 0;
+ $indblock++;
+ }
+ }
+
+ # Return the indirect block numbers
+ dprint("Built indirect blocks $indlist[0] .. $indlist[-1]\n");
+ return (@indlist);
+}
+
+# Return blocknumber and offset for a specific i-node
+sub get_inode_block_offset {
+ my $inum = shift;
+ my $blocknum = FIRSTINODEBLK + int( $inum / INODESPERBLK );
+ my $offset = INODESIZE * ( $inum % INODESPERBLK );
+ dprint("inum $inum => block $blocknum offset $offset\n");
+ return ( $blocknum, $offset );
+}
+
+# Given an i-node number (possibly undef), permission, filetype, uid, size
+# and up to seven direct or indirect block numbers, fill in the given i-node
+# with the data. If the i-node number is undef, allocate an i-node number.
+# Return the i-node number used.
+sub fill_inode {
+ my ( $inum, $perms, $filetype, $uid, $size, @blklist ) = @_;
+ die("Too many blocks\n") if ( @blklist > 7 );
+
+ $uid &= MAXINT; # truncate negative UID to 18 bits
+
+ # Calculate the block number and word offset for this
+ $inum = allocate_inode() if ( !defined($inum) );
+ my ( $blocknum, $offset ) = get_inode_block_offset($inum);
+
+ # Fill in the easy fields. Link count is negative
+ $Block[$blocknum][ $offset + I_UID ] = $uid;
+ $Block[$blocknum][ $offset + I_SIZE ] = $size;
+ $Block[$blocknum][ $offset + I_NLKS ] = 0;
+
+ my $i = $offset;
+ foreach my $datablocknum (@blklist) {
+ $Block[$blocknum][ $i + I_DISKPS ] = $datablocknum;
+ $i++;
+ }
+
+ # Deal with the flags and see if it's a large file
+ my $flags = $perms | $filetype | I_USED;
+ $flags |= I_LARGE if ( $size > WORDSPERBLK * I_NUMBLKS );
+ $Block[$blocknum][ $offset + I_FLAGS ] = $flags;
+
+ dprintf( "Fill inum %d: flags %06o uid %06o size %d (%06o)=> blk %d off %d\n",
+ $inum, $flags, $uid, $size, $size, $blocknum, $offset );
+ return ($inum);
+}
+
+# Increase the file size of an i-node
+sub increment_file_length {
+ my ( $inum, $incr) = @_;
+ my ( $blocknum, $offset ) = get_inode_block_offset($inum);
+ $Block[$blocknum][ $offset + I_SIZE ] += $incr;
+}
+
+# Increase the link count of an i-node
+sub increment_link_count {
+ my $inum = shift;
+ my ( $blocknum, $offset ) = get_inode_block_offset($inum);
+ $Block[$blocknum][ $offset + I_NLKS ] --;
+ $Block[$blocknum][ $offset + I_NLKS ] &= MAXINT;
+}
+
+# Convert an ASCII string into an array of 18-bit word values
+# where two characters are packed into each word. Put NUL in
+# if the string has an odd number of characters. Return the array
+sub ascii2words {
+ my $str = shift;
+ my @words;
+ # Pad the string to eight characters
+ $str = sprintf( "%-8s", substr( $str, 0, 8 ) );
+ for ( my $i = 0 ; $i < length($str) ; $i += 2 ) {
+ my $c1 = substr( $str, $i, 1 ) || "\0";
+ my $c2 = substr( $str, $i + 1, 1 ) || "\0";
+
+ push( @words, ( ord($c1) << 9 ) | ord($c2) );
+ }
+ return (@words);
+}
+
+# Add an extra block to an i-node. NOTE: for now, we don't change the size
+# in the i-node.
+sub add_block_to_inode {
+ my ( $blknum, $inum ) = @_;
+
+ my ( $iblock, $offset ) = get_inode_block_offset($inum);
+
+ foreach my $i ( 1 .. I_NUMBLKS ) {
+ next if ( $Block[$iblock][ $offset + $i ] ); # Skip in-use blocks
+ $Block[$iblock][ $offset + $i ] = $blknum;
+ return;
+ }
+ die("Unable to add extra block to i-node $inum\n");
+ dprint("Added block $blknum to i-node $inum\n");
+}
+
+# Add a name and an i-node number to the current directory in the
+# directory stack.
+sub add_direntry {
+ my ( $name, $inum ) = @_;
+
+ $inum = $lastinum if ($inum == -1);
+
+ # Get the block and offset to the next empty slot in the directory
+ my $dirref = $Dirstack[-1];
+
+ if ( !defined($dirref) ) {
+ dprint("Adding $name inode $inum to current directory\n");
+ dprint("Empty dirstack, we must be building the root dir\n");
+ return;
+ }
+
+ my $blocknum = $dirref->[0];
+ my $offset = $dirref->[1];
+ dprint("Adding $name inode $inum to curdir inum $dirref->[2]" .
+ " blk $blocknum off $offset\n");
+
+ # Convert the name into four words
+ my @wlist = ascii2words($name);
+
+ # Fill in the directory entry
+ $Block[$blocknum][ $offset + D_INUM ] = $inum;
+ $Block[$blocknum][ $offset + D_NAME ] = shift(@wlist);
+ $Block[$blocknum][ $offset + D_NAME + 1 ] = shift(@wlist);
+ $Block[$blocknum][ $offset + D_NAME + 2 ] = shift(@wlist);
+ $Block[$blocknum][ $offset + D_NAME + 3 ] = shift(@wlist);
+
+ # Move up to the next position in the directory.
+ $dirref->[1] += D_NUMWORDS;
+
+ # Update the directory inode's i.size, another 8 words
+ increment_file_length( $dirref->[2], D_NUMWORDS );
+
+ # If we have filled the directory up, allocate another block to it
+ if ( $dirref->[1] == WORDSPERBLK ) {
+ my ($nextblock) = allocate_blocks(WORDSPERBLK);
+ dprint("Extra block $nextblock for this directory\n");
+ $dirref->[0] = $nextblock;
+ $dirref->[1] = 0;
+
+ # And add this new block to the directory's i-node
+ add_block_to_inode( $nextblock, $dirref->[2] );
+ }
+
+ # Finally, increment the link count
+ increment_link_count($inum);
+ $lastinum = $inum;
+}
+
+# Given a name, perms, a user-id and an optional i-node number, make a
+# directory. Link it to the previous directory in the directory stack.
+# Allocate blocks and i-nodes for it. Add a "dd" entry as well.
+sub make_dir {
+ my ( $dirname, $perms, $uid, $inum ) = @_;
+
+ # Get an i-node number or validate the one we got
+ $inum = allocate_inode($inum);
+
+ # Get a block for this directory
+ my ($dirblock) = allocate_blocks(WORDSPERBLK);
+
+ # Add this to the previous directory
+ # and fill the i-node with the details
+ fill_inode( $inum, $perms, I_DIRECTORY, $uid, 0, $dirblock );
+ add_direntry( $dirname, $inum );
+
+ # Make this the top directory on the dirstack
+ dprint("Pushing dir block $dirblock inum $inum to dirstack\n");
+ push( @Dirstack, [ $dirblock, 0, $inum ] );
+
+ # Add a "." entry to this directory if requested
+ if ($wantdot) {
+ add_direntry( ".", $inum );
+ dprint("Added a . entry to ourselves\n");
+ }
+
+ # and a ".." directory to the previous one on the stack
+ if ($wantdotdot && defined($Dirstack[-2])) {
+ add_direntry( "..", $Dirstack[-2]->[2] );
+ dprintf("Added a .. entry to i-num %d\n", $Dirstack[-2]->[2] );
+ }
+
+ # Finally, add a "dd" entry to this directory. We get the
+ # i-num from the first entry in the Dirstack. Sorry for the dbl negative.
+ if (!$no_dd) {
+ add_direntry( "dd", $Dirstack[0]->[2] );
+ dprintf("Added a dd entry to i-num %d\n", $Dirstack[0]->[2] );
+ if (!$wantdotdot && !$wantdot) { # PLB 2019
+ add_direntry( "..", $inum );
+ dprint("Added a .. entry to ourselves\n");
+ }
+ }
+ dprintf( "Made directory %s perms %06o uid %d in inum %d\n\n",
+ $dirname, $perms, $uid, $inum );
+}
+
+# Read a word from a file in paper tape binary format.
+# Return -1 on EOF
+sub read_word {
+ my $FH = shift;
+
+ # Convert three bytes into one 18-bit word
+ return (-1) if ( read( $FH, my $three, 3 ) != 3 ); # Not enough bytes read
+ my ( $b1, $b2, $b3 ) = unpack( "CCC", $three );
+ return ( ( ( $b1 & 077 ) << 12 ) | ( ( $b2 & 077 ) << 6 ) | ( $b3 & 077 ) );
+}
+
+# Given a filename, read that file in and return an array of
+# words containing that file, or die otherwise
+sub read_file {
+ my $extfile= shift;
+ my @buf;
+
+ # Open the external file
+ open( my $IN, "<", $extfile ) || die("Can't open $extfile: $!\n");
+
+ # Determine if this is ASCII or binary
+ my $isbinary = 0;
+ my $c = getc($IN);
+ seek( $IN, 0, 0 );
+ $isbinary = 1 if ($c && (( ord($c) & 0300 ) == 0200 ));
+
+ # Read the file into a buffer, converting from ASCII or sixbit encoding
+ while (1) {
+ if ($isbinary) {
+
+ # Convert three bytes into one 18-bit word
+ my $result = read_word($IN);
+ last if ( $result == -1 );
+ push(@buf, $result);
+ } else {
+ # Convert two ASCII characters into one 18-bit word
+ my $c1 = getc($IN);
+ last if ( !defined($c1) ); # No character, leave the loop
+ my $word = ord($c1) << 9;
+ my $c2 = getc($IN);
+ $word |= ord($c2) if ( defined($c2) );
+ push(@buf, $word);
+ }
+ }
+ return(@buf);
+}
+
+# Write a file which is stored in a buffer into the in-memory
+# disk image. Takes the base block number and the buffer of words
+sub write_file {
+ my ($blocknum, @buf)= @_;
+ my $size= @buf;
+ my $offset=0;
+
+ foreach my $i (0 .. $size-1) {
+ $Block[$blocknum][$offset++]= $buf[$i];
+ if ( $offset == WORDSPERBLK ) {
+ $offset = 0;
+ $blocknum++;
+ dprint("Filling block $blocknum\n");
+ }
+ }
+}
+
+# Given a filename, perms, user-id and an external file, add a file to the
+# filesystem. Add an entry to this file in the current directory on
+# the dirstack.
+sub add_file {
+ my ( $name, $perms, $uid, $extfile, $inum ) = @_;
+ dprintf( "Adding file %s perms %06o uid %d extfile %s\n",
+ $name, $perms, $uid, $extfile );
+
+ # Read the file into a buffer
+ my @buf= read_file($extfile);
+ my $size= @buf;
+
+ # Allocate enough blocks for the file
+ my @blklist = allocate_blocks($size);
+
+ # Put the contents of the file into the blocks
+ if ($blklist[0]) {
+ dprint("Filling block $blklist[0] with content from $extfile\n");
+ write_file($blklist[0], @buf);
+ }
+
+ # If it's too big, allocate indirect blocks
+ my $large = 0;
+ my @indblocks;
+ if ( @blklist > I_NUMBLKS ) {
+ $large = 1;
+ @indblocks = build_indirect_blocks(@blklist);
+ }
+
+ # Allocate and fill in the i-node
+ $inum = allocate_inode($inum);
+ if ($large) {
+ fill_inode( $inum, $perms, I_FILE, $uid, $size, @indblocks );
+ } else {
+ fill_inode( $inum, $perms, I_FILE, $uid, $size, @blklist );
+ }
+
+ # and add the entry in the directory
+ add_direntry( $name, $inum );
+ dprint("Done adding file $name as inum $inum\n\n");
+}
+
+# Given a name, perms, uid and i-number
+# add a special file to the filesystem
+sub add_special {
+ my ( $name, $perms, $uid, $inum ) = @_;
+
+ # Allocate and fill in the i-node
+ $inum = allocate_inode($inum);
+ fill_inode( $inum, $perms, I_SPECIAL, $uid, 0 );
+
+ # Add the entry in the directory
+ add_direntry( $name, $inum );
+ dprint("Done adding special file $name inum $inum\n\n");
+}
+
+# Parse the perms word from the proto file.
+# Return filetype and perms as a number.
+sub parse_perms {
+ my $permstring = shift;
+ my ( $filetype, $perms ) = ( I_FILE, 0 );
+
+ die("perms word $permstring is not 5 characters long\n")
+ if ( length($permstring) != 5 );
+
+ $filetype = I_DIRECTORY if ( $permstring =~ m{^d} );
+ $filetype = I_SPECIAL if ( $permstring =~ m{^i} );
+ $filetype = I_LINK if ( $permstring =~ m{^l} );
+
+ $perms |= I_OWNERREAD if ( $permstring =~ m{^.r} );
+ $perms |= I_OWNERWRITE if ( $permstring =~ m{^..w} );
+ $perms |= I_WORLDREAD if ( $permstring =~ m{^...r} );
+ $perms |= I_WORLDWRITE if ( $permstring =~ m{^....w} );
+ return ( $filetype, $perms );
+}
+
+sub uid {
+ my $uid = shift;
+ return -1 if ($uid eq '-1');
+ return oct($uid);
+}
+
+# Open the named proto file and parse it
+sub parse_proto_file {
+ my $file = shift;
+ open( my $IN, "<", $file ) || die("Can't one $file: $!\n");
+ while (<$IN>) {
+ chomp;
+
+ # Skip comments
+ s{#.*}{};
+
+ # Get the words on the line;
+ my @words = split( /\s+/, $_ );
+
+ # Skip if no words on this line
+ # but lose any empty word
+ next if ( @words == 0 );
+ shift(@words) if ( $words[0] eq '' );
+
+ # If the first word is a $, then pop a directory from the stack
+ if ( $words[0] eq '$' ) {
+ pop(@Dirstack);
+ dprint("Popping back a directory in the dirstack\n\n");
+ next;
+ }
+
+ # Get the filetype and permissions
+ my ( $type, $perms ) = parse_perms( $words[1] );
+
+ if ( $type eq I_DIRECTORY ) {
+ my ( $name, $permstr, $uid, $inum ) = @words;
+ make_dir( $name, $perms, uid($uid), $inum );
+ next;
+ }
+ if ( $type eq I_FILE ) {
+ my ( $name, $permstr, $uid, $extfile, $inum ) = @words;
+ add_file( $name, $perms, uid($uid), $extfile, $inum );
+ next;
+ }
+ if ( $type eq I_SPECIAL ) {
+ my ( $name, $permstr, $uid, $inum ) = @words;
+ add_special( $name, $perms, uid($uid), $inum );
+ next;
+ }
+ if ( $type eq I_LINK ) {
+ my ( $name, $permstr, $inum ) = @words;
+ dprint("Adding link in curdir to $name inum $inum\n");
+ add_direntry( $name, $inum );
+ next;
+ }
+ }
+ close($IN);
+}
+
+# Convert an 18-bit word into two ASCII characters and return them.
+# Don't return NUL characters
+sub word2ascii {
+ my $word = shift;
+ my $c1 = ( $word >> 9 ) & 0177;
+ my $c2 = $word & 0177;
+ my $result = "";
+ $result .= (($c1 >= 32) && ($c1 <= 126)) ? chr($c1) : ' ';
+ $result .= (($c2 >= 32) && ($c2 <= 126)) ? chr($c2) : ' ';
+ return ($result);
+}
+
+# Convert an 18-bit word into a scalar which has three sixbit
+# values in three bytes. Set the msb in the first byte
+sub word2three {
+ my $val = shift;
+
+ my $b1 = ( ( $val >> 12 ) & 077 ) | 0x80;
+ my $b2 = ( $val >> 6 ) & 077;
+ my $b3 = $val & 077;
+ return ( pack( "CCC", $b1, $b2, $b3 ) );
+}
+
+# Dump the image to the output file
+sub dump_image {
+ my ( $format, $output ) = @_;
+ open( my $OUT, ">", $output ) || die("Can't write to $output: $!\n");
+
+ # list: Octal output with block comments. We don't dump the first 8K blocks
+ if ( $format eq "list" ) {
+ foreach my $blocknum ( 0 .. NUMBLOCKS - 1 ) {
+ printf( $OUT "Block %d (%06o)\n", $blocknum, $blocknum );
+ foreach my $line ( 0 .. 7 ) {
+
+ # Print out the words in octal
+ foreach my $offset ( 0 .. 7 ) {
+ printf( $OUT "%06o ",
+ $Block[$blocknum][ 8 * $line + $offset ] || 0
+ );
+ }
+
+ # Now print out the ASCII characters in the word
+ foreach my $offset ( 0 .. 7 ) {
+ print( $OUT word2ascii(
+ $Block[$blocknum][ 8 * $line + $offset ] || 0));
+ }
+ print( $OUT "\n" );
+ }
+ print( $OUT "\n" );
+ }
+ }
+
+ # ptr: Each word into three bytes, a sixbit in each one
+ if ( $format eq "ptr" ) {
+ # Dump 8000 empty blocks first
+ foreach my $blocknum ( 0 .. NUMBLOCKS - 1 ) {
+ foreach my $offset ( 0 .. WORDSPERBLK-1 ) {
+ print( $OUT word2three( 0 ) );
+ }
+ }
+
+ # Now the real blocks
+ foreach my $blocknum ( 0 .. NUMBLOCKS - 1 ) {
+ foreach my $offset ( 0 .. WORDSPERBLK-1 ) {
+ print( $OUT word2three( $Block[$blocknum][$offset] || 0 ) );
+ }
+ }
+ }
+
+ # simh: Each word into four bytes, little endian
+ if ( $format eq "simh" ) {
+ # Dump 8000 empty blocks first
+ foreach my $blocknum ( 0 .. NUMBLOCKS - 1 ) {
+ foreach my $offset ( 0 .. WORDSPERBLK-1 ) {
+ print( $OUT pack( "CCCC", 0,0,0,0));
+ }
+ }
+
+ # Now the real blocks
+ foreach my $blocknum ( 0 .. NUMBLOCKS - 1 ) {
+ foreach my $offset ( 0 .. WORDSPERBLK-1 ) {
+ my $word = $Block[$blocknum][$offset] || 0;
+ # SIMH format packs word in a little-endian 32-bit int
+ my $packedword = pack( "CCCC",
+ $word & 0xff,
+ ( $word >> 8 ) & 0xff,
+ ( $word >> 16 ) & 0xff,
+ ( $word >> 24 ) & 0xff);
+ print( $OUT $packedword );
+ }
+ }
+ }
+
+ close($OUT);
+}
+
+# Keep this near the GetOptions call to make it easy to add documentation!
+sub usage {
+ die("Usage: $0 [--debug] [--format=list|ptr|simh] [--out file] protofile\n");
+}
+
+### MAIN PROGRAM
+
+my ( $format, $output, $kernelfile, $chartable ) = ( "simh", "image.fs" );
+
+GetOptions(
+ 'debug|d' => \$debug,
+ 'dot|1' => \$wantdot,
+ 'dotdot|2' => \$wantdotdot,
+ 'no_dd|3' => \$no_dd,
+ 'format|f=s' => \$format,
+ 'output|o=s' => \$output,
+ 'kernel|k=s' => \$kernelfile,
+ 'chars|c=s' => \$chartable,
+) or usage();
+
+usage() if ( @ARGV < 1 );
+init_freelist();
+parse_proto_file( $ARGV[0] );
+dprint("Storing free list in blocks ");
+fill_sysdata();
+dprint("\n");
+
+# If we were given a kernel image, write that to track 80
+# which is block number 6400.
+# (maksys.s can write to tracks 80-89)
+my $bootblock = 6400;
+if ($kernelfile) {
+ dprint("Adding kernel $kernelfile to track 80\n");
+ my @buf= read_file($kernelfile);
+ write_file($bootblock, @buf);
+}
+# If we were given a character table, write that
+# so it gets loaded at the 3K mark
+# maksys.s writes the contents of memory at 3K to the boot track!
+if ($chartable) {
+ dprint("Adding character table $chartable to track 80\n");
+ my @buf= read_file($chartable);
+ # XXX truncate to 1K, or at least complain??
+ write_file($bootblock + 3072/WORDSPERBLK, @buf);
+}
+dump_image( $format, $output );
+exit(0);
--- /dev/null
+#!/usr/bin/env perl
+#
+# sdump: Dump the contents of a filesystem in SimH format
+#
+# (c) 2016 Warren Toomey, GPL3
+#
+use strict;
+use warnings;
+use Fcntl qw(:flock SEEK_SET);
+
+### read a word from a file in SimH format
+### return -1 on EOF
+sub read_word {
+ my $F = shift;
+
+ # Convert four bytes into one 18-bit word
+ return -1 if ( read( $F, my $four, 4 ) != 4 ); # Not enough bytes read
+ my ( $b1, $b2, $b3, $b4 ) = unpack( "CCCC", $four );
+ return (
+ ( $b1 & 0xff ) | ( ( $b2 & 0xff ) << 8 ) | ( ( $b3 & 0xff ) << 16 ) |
+ ( ( $b4 & 0xff ) << 24 ) );
+}
+
+### Main program
+die("Usage: $0 imagefile\n") if ( @ARGV != 1 );
+
+open( my $IN, "<", $ARGV[0] ) || die("Couldn't open $ARGV[0]: $!\n");
+
+use constant NUMBLOCKS => 8000; # Number of blocks on a surface
+use constant WORDSPERBLK => 64; # 64 words per block
+use constant BYTESPERWORD => 4; # We encode each word into 4 bytes
+
+# Skip the first surface
+seek( $IN, NUMBLOCKS * WORDSPERBLK * BYTESPERWORD, SEEK_SET )
+ || die("Cannot seek: $!\n");
+
+foreach my $blocknum ( 0 .. NUMBLOCKS * 2 - 1 ) {
+ printf( "Block %d (%06o)\n", $blocknum, $blocknum );
+ foreach my $line ( 0 .. 7 ) {
+
+ # Print out the words in octal
+ my @buf;
+ foreach my $offset ( 0 .. 7 ) {
+
+ # Get a word
+ my $word = read_word($IN);
+ exit(0) if ( $word == -1 );
+ $buf[$offset] = $word;
+ }
+ foreach my $offset ( 0 .. 7 ) {
+ printf( "%06o ", $buf[$offset] );
+ }
+ print(" ");
+ foreach my $offset ( 0 .. 7 ) {
+ my $c1 = ( $buf[$offset] >> 9 ) & 0777;
+ $c1 = ( ( $c1 >= 32 ) && ( $c1 <= 126 ) ) ? chr($c1) : ' ';
+ my $c2 = $buf[$offset] & 0777;
+ $c2 = ( ( $c2 >= 32 ) && ( $c2 <= 126 ) ) ? chr($c2) : ' ';
+ print("$c1$c2");
+ }
+ print("\n");
+ }
+ print("\n");
+}
+exit(0);
--- /dev/null
+#!/usr/bin/env perl
+#
+# Read in files of PDP-7 assembly code in Ken Thompson's as format
+# and output cross-reference and other details on the files.
+# It's very rough and ready.
+#
+# (c) 2016 Warren Toomey, GPL3
+use strict;
+use warnings;
+
+#use Data::Dumper;
+
+my %Label; # Hash of labels found
+
+# Instructions that use the MQ register but don't modify it
+my %UseMQ = ( omq => 1, lacq => 1 );
+
+# Instructions that use and modify the MQ register
+my %ModMQ = (
+ lrs => 1,
+ lrss => 1,
+ lls => 1,
+ llss => 1,
+ norm => 1,
+ norms => 1,
+ mul => 1,
+ muls => 1,
+ div => 1,
+ divs => 1,
+ idiv => 1,
+ frdiv => 1,
+ frdivs => 1,
+ clq => 1,
+ cmq => 1
+);
+
+# Instructions that use memory locations
+my %UseMem = (
+ lac => 1,
+ xor => 1,
+ add => 1,
+ tad => 1,
+ xct => 1,
+ and => 1,
+ law => 1
+);
+
+# Instructions that modify memory
+my %ModMem = ( dac => 1, dzm => 1, isz => 1 );
+
+# Kernel-mode instructions
+my %Kmode = (
+ dscs => 'Uses disk: yes',
+ dslw => 'Uses disk: yes',
+ dslm => 'Uses disk: yes',
+ dsld => 'Uses disk: yes',
+ dsls => 'Uses disk: yes',
+ dssf => 'Uses disk: yes',
+ dsrs => 'Uses disk: yes',
+ iof => 'Uses interrupts: yes',
+ ion => 'Uses interrupts: yes',
+ caf => 'Uses CPU: yes',
+ clon => 'Uses clock: yes',
+ clsf => 'Uses clock: yes',
+ clof => 'Uses clock: yes',
+ ksf => 'Uses keyboard: yes',
+ krb => 'Uses keyboard: yes',
+ tsf => 'Uses tty: yes',
+ tcf => 'Uses tty: yes',
+ tls => 'Uses tty: yes',
+ sck => 'Uses G2: yes',
+ cck => 'Uses G2: yes',
+ lck => 'Uses G2: yes',
+ rsf => 'Uses ptr: yes',
+ rsa => 'Uses ptr: yes',
+ rrb => 'Uses ptr: yes',
+ psf => 'Uses ptr: yes',
+ pcf => 'Uses ptr: yes',
+ psa => 'Uses ptr: yes',
+ lds => 'Uses G2: yes',
+ lda => 'Uses G2: yes',
+ wcga => 'Uses G2: yes',
+ raef => 'Uses G2: yes',
+ rlpd => 'Uses G2: yes',
+ beg => 'Uses G2: yes',
+ spb => 'Uses G2: yes',
+ cpb => 'Uses G2: yes',
+ lpb => 'Uses G2: yes',
+ wbl => 'Uses G2: yes',
+ dprs => 'Uses dataphone: yes',
+ dpsf => 'Uses dataphone: yes',
+ dpcf => 'Uses dataphone: yes',
+ dprc => 'Uses dataphone: yes',
+ crsf => 'Uses cdr: yes',
+ crrb => 'Uses cdr: yes',
+);
+
+# Parse all the files for labels only
+my $stage = 1;
+my $curlabel = ""; # Last defined label
+foreach my $file (@ARGV) {
+ parse_file($file);
+}
+
+# Now go back and find the details about things
+$stage = 2;
+$curlabel = ""; # Last defined label
+foreach my $file (@ARGV) {
+ parse_file($file);
+}
+
+#print Dumper(\%Label);
+print_output();
+print_callgraph();
+exit(0);
+
+sub parse_file {
+ my $file = shift;
+ open( my $IN, "<", $file ) || die("Cannot read $file: $!\n");
+ while ( my $line = <$IN> ) {
+ chomp($line); # Lose the end of line
+ parse_line( $file, $line );
+ }
+ close($IN);
+}
+
+sub parse_line {
+ my ( $file, $line ) = @_;
+ $file =~ s{.*/}{};
+
+ # Lose leading whitespace and comments
+ $line =~ s{^\s+}{};
+ $line =~ s{\s*".*}{};
+ return if ( $line =~ m{^$} ); # Ignore empty lines
+ return if ( $line =~ m{=} ); # Ignore assignments
+ #print("$line\n") if ($stage==2);
+
+ # Capture and define useful labels
+ if ( $line =~ s{^([a-z0-9\.]+):\s*}{} ) {
+ my $label = $1;
+
+ # Only do non-numeric labels
+ if ( !( $label =~ m{^\d+$} ) ) {
+
+ # Define the label in stage 1
+ if ( $stage == 1 ) {
+ $Label{$label}{def} = 1;
+ $Label{$label}{file} = $file;
+ }
+ $curlabel = $label;
+ }
+ }
+ return if ( $stage == 1 ); # Only labels in stage 1
+
+ # Stage 2: break the remainder up into statements
+ foreach my $statement ( split( /\s*;\s*/, $line ) ) {
+ my @expr = split( /\s+/, $statement );
+
+ # Does it use the MQ?
+ $Label{$curlabel}{usemq} = 1 if ( $UseMQ{ $expr[0] } );
+
+ # Does it modify the MQ?
+ if ( $ModMQ{ $expr[0] } ) {
+ $Label{$curlabel}{usemq} = 1;
+ $Label{$curlabel}{modmq} = 1;
+ }
+
+ # Does it modify memory
+ if ( $ModMem{ $expr[0] } ) {
+ die("ModMem but no argument\n") if ( !defined( $expr[1] ) );
+ $Label{$curlabel}{modmem}{ $expr[1] } = 1;
+ }
+
+ # Does it use memory
+ if ( $UseMem{ $expr[0] } ) {
+
+ # We should die if no expr[1], but there's one use of
+ # law in the kernel that stops us doing this
+ $Label{$curlabel}{usemem}{ $expr[1] } = 1
+ if ( defined( $expr[1] ) );
+ }
+
+ # Routine calls
+ $Label{$curlabel}{calls}{ $expr[1] } = 1
+ if ( ( $expr[0] eq "jms" ) && defined( $expr[1] ) );
+
+ # Any kernel mode instructions?
+ $Label{$curlabel}{kmode}{ $Kmode{ $expr[0] } } = 1
+ if ( $Kmode{ $expr[0] } );
+ }
+}
+
+sub print_output {
+ foreach $curlabel ( sort( keys(%Label) ) ) {
+
+ # Does it have anything useful?
+ my $count = keys( %{ $Label{$curlabel} } );
+ next if ( $count == 2 ); # Nope
+
+ print("Function $curlabel\n");
+ print("==============\n");
+ print("File: $Label{$curlabel}{file}\n");
+ print("Purpose:\n");
+ print("Arguments:\n");
+ print("Returns:\n");
+
+ print("Uses MQ: yes\n")
+ if ( defined( $Label{$curlabel}{usemq} )
+ && !defined( $Label{$curlabel}{usemq} ) );
+ print("Modifies MQ: yes\n")
+ if ( defined( $Label{$curlabel}{usemq} ) );
+
+ my $usemem =
+ join( ', ', sort( keys( %{ $Label{$curlabel}{usemem} } ) ) );
+ print("Uses memory: $usemem\n") if ( $usemem ne '' );
+ my $modmem =
+ join( ', ', sort( keys( %{ $Label{$curlabel}{modmem} } ) ) );
+ print("Modifies memory: $modmem\n") if ( $modmem ne '' );
+ my $calls = join( ', ', sort( keys( %{ $Label{$curlabel}{calls} } ) ) );
+ print("Calls: $calls\n") if ( $calls ne '' );
+
+ foreach my $kmode ( sort( keys( %{ $Label{$curlabel}{kmode} } ) ) ) {
+ print("$kmode\n");
+ }
+
+ print("Comments:\n");
+ print("\n\n");
+ }
+}
+
+# Print a graphview call graph file
+sub print_callgraph {
+ open(my $OUT, ">", "kernel_calls.gv")
+ || die("Can't write kernel_calls.gv: $!\n");
+ print $OUT <<EOF;
+digraph callgraph {
+ratio=compress; size="16.53,11.69";
+{rank=same; ".capt" ".chdir" ".chmod" ".chown" ".close" ".creat" ".exit"
+ ".fork" ".halt" ".link" ".open" ".read" ".rele" ".rename" ".rmes"
+ ".save" ".seek" ".setuid" ".smes" ".status" ".sysloc" ".tell"
+ ".unlink" ".write"}
+EOF
+ foreach $curlabel ( sort( keys(%Label) ) ) {
+ my $count = keys( %{ $Label{$curlabel} } );
+ next if ( $count == 2 );
+
+ my $calls = join( '"; "', sort( keys( %{ $Label{$curlabel}{calls} } ) ) );
+ if ( $calls ne '' ) {
+ print($OUT "\"$curlabel\" -> { \"$calls\" ; }\n");
+ }
+ }
+ print($OUT "}\n");
+ close($OUT);
+}
public / perl-5.20.0.git / commitdiff