glm94/pdp7-unix
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

I've added code to detect binary PDP-7 files to a7out. This is needed

Browse Source 
for doing the seek() and tell() syscalls which are next to do.
This commit is contained in:
Warren Toomey
2016-03-04 13:03:42 +10:00
parent 51ad7db306
commit 451a58fc58
2 changed files with 270 additions and 145 deletions
Download Patch File Download Diff File Expand all files Collapse all files
tools/3dump
Executable
+26
View File
@@ -0,0 +1,26 @@
#!/usr/bin/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 << 6) | $b3;
my $c1= ($word >> 9) & 0777;
$c1= ($c1 < 0200) ? chr($c1) : " ";
my $c2= $word & 0777;
$c2= ($c2 < 0200) ? chr($c2) : " ";
printf("%06o %s%s\n", $word, $c1, $c2)
}
close($IN);
exit(0);
tools/a7out
+244 -145
View File
@@ -6,6 +6,7 @@
# #
use strict; use strict;
use warnings; use warnings;
use Fcntl qw(:seek);
use DateTime; use DateTime;
use Data::Dumper; use Data::Dumper;
@@ -15,6 +16,7 @@ my $singlestep = 0; # Are we running in single-step mode?
my %Breakpoint; # Hash of defined breakpoints my %Breakpoint; # Hash of defined breakpoints
my @Mem; # 8K 18-bit words of main memory my @Mem; # 8K 18-bit words of main memory
my @FD; # Array of open filehandles my @FD; # Array of open filehandles
my @ISBINARY; # Array of filehandle flags: ASCII or binary files?
# Registers # Registers
my $PC = 010000; # Program counter my $PC = 010000; # Program counter
@@ -141,6 +143,7 @@ sub set_arguments {
# Truncate and/or space pad the argument # Truncate and/or space pad the argument
my $str = sprintf( "%-8s", substr( $_, 0, 8 ) ); my $str = sprintf( "%-8s", substr( $_, 0, 8 ) );
# XXX: use ascii2words
# Store pairs of characters into memory # Store pairs of characters into memory
for ( my $i = 0 ; $i < length($str) ; $i += 2 ) { for ( my $i = 0 ; $i < length($str) ; $i += 2 ) {
my $c1 = substr( $str, $i, 1 ) || ""; my $c1 = substr( $str, $i, 1 ) || "";
@@ -176,9 +179,9 @@ sub simulate {
# List of opcodes that DON'T auto-increment # List of opcodes that DON'T auto-increment
# locations 10-17 when we have the indirect bit # locations 10-17 when we have the indirect bit
my %NoIncr = ( my %NoIncr = (
oct("000") => 1, # cal oct("000") => 1, # cal
oct("064") => 1, # eae oct("064") => 1, # eae
oct("074") => 1 # opr oct("074") => 1 # opr
); );
# Loop indefinitely # Loop indefinitely
@@ -190,13 +193,16 @@ sub simulate {
my $indirect = ( $instruction >> 13 ) & 1; my $indirect = ( $instruction >> 13 ) & 1;
my $addr = $instruction & MAXADDR; my $addr = $instruction & MAXADDR;
# Auto-increment locations 010 to 017 if $indirect # Auto-increment locations 010 to 017 if $indirect
# and this is an instruction that does increment # and this is an instruction that does increment
if ($indirect && ($addr >= 010) && ($addr <= 017) && if ( $indirect
!defined($NoIncr{$opcode})) { && ( $addr >= 010 )
$Mem[$addr]++; && ( $addr <= 017 )
$Mem[$addr] &= MAXINT; && !defined( $NoIncr{$opcode} ) )
} {
$Mem[$addr]++;
$Mem[$addr] &= MAXINT;
}
# Work out what any indirect address would be # Work out what any indirect address would be
my $indaddr = ($indirect) ? $Mem[$addr] & MAXADDR : $addr; my $indaddr = ($indirect) ? $Mem[$addr] & MAXADDR : $addr;
@@ -215,7 +221,8 @@ sub simulate {
# Simulate the instruction. Each subroutine updates the $PC # Simulate the instruction. Each subroutine updates the $PC
if ( defined( $Oplist{$opcode} ) ) { if ( defined( $Oplist{$opcode} ) ) {
$Oplist{$opcode}->( $instruction, $addr, $indaddr ); $Oplist{$opcode}->( $instruction, $addr, $indaddr );
} else { }
else {
printf( STDERR "Unknown instruction 0%06o at location 0%06o\n", printf( STDERR "Unknown instruction 0%06o at location 0%06o\n",
$instruction, $PC ); $instruction, $PC );
exit(1); exit(1);
@@ -229,12 +236,13 @@ sub simulate {
sub dump_memory { sub dump_memory {
my ( $start, $end, $yeszero ) = @_; my ( $start, $end, $yeszero ) = @_;
foreach my $i ( $start .. $end ) { foreach my $i ( $start .. $end ) {
# Convert the word into possibly two ASCII characters
my $c1= ($Mem[$i] >> 9) & 0777; # Convert the word into possibly two ASCII characters
$c1= ($c1 < 0200) ? chr($c1) : " "; my $c1 = ( $Mem[$i] >> 9 ) & 0777;
my $c2= $Mem[$i] & 0777; $c1 = ( $c1 < 0200 ) ? chr($c1) : " ";
$c2= ($c2 < 0200) ? chr($c2) : " "; my $c2 = $Mem[$i] & 0777;
printf( STDERR "%06o: %06o %s%s\n", $i, $Mem[$i], $c1, $c2) $c2 = ( $c2 < 0200 ) ? chr($c2) : " ";
printf( STDERR "%06o: %06o %s%s\n", $i, $Mem[$i], $c1, $c2 )
if ( $yeszero || $Mem[$i] != 0 ); if ( $yeszero || $Mem[$i] != 0 );
} }
} }
@@ -261,7 +269,7 @@ sub tad {
dprintf( "tad AC (value %06o) with addr %06o (%06o)\n", dprintf( "tad AC (value %06o) with addr %06o (%06o)\n",
$AC, $indaddr, $Mem[$indaddr] ); $AC, $indaddr, $Mem[$indaddr] );
$AC = $AC + $Mem[$indaddr]; $AC = $AC + $Mem[$indaddr];
$LINK = ($LINK ^ $AC) & LINKMASK; $LINK = ( $LINK ^ $AC ) & LINKMASK;
$AC = $AC & MAXINT; $AC = $AC & MAXINT;
$PC++; $PC++;
} }
@@ -380,18 +388,21 @@ sub opr {
$skip = 1 if ( ( $i == 1 ) && ( $AC & SIGN ) != 0 ); # sma $skip = 1 if ( ( $i == 1 ) && ( $AC & SIGN ) != 0 ); # sma
$skip = 1 if ( ( $i == 2 ) && ( $AC & MAXINT ) == 0 ); # sza $skip = 1 if ( ( $i == 2 ) && ( $AC & MAXINT ) == 0 ); # sza
$skip = 1 if ( ( $i == 3 ) $skip = 1
if ( ( $i == 3 )
&& ( ( ( $AC & MAXINT ) == 0 ) || ( ( $AC & SIGN ) != 0 ) ) ) && ( ( ( $AC & MAXINT ) == 0 ) || ( ( $AC & SIGN ) != 0 ) ) )
; # sza | sma ; # sza | sma
$skip = 1 if ( ( $i == 4 ) && ($LINK) ); # snl $skip = 1 if ( ( $i == 4 ) && ($LINK) ); # snl
$skip = 1 if ( ( $i == 5 ) && ( $LINK || ( $AC >= SIGN ) ) ); # snl | sma $skip = 1 if ( ( $i == 5 ) && ( $LINK || ( $AC >= SIGN ) ) ); # snl | sma
$skip = 1 if ( ( $i == 6 ) && ( $LINK || ( $AC == 0 ) ) ); # snl | sza $skip = 1 if ( ( $i == 6 ) && ( $LINK || ( $AC == 0 ) ) ); # snl | sza
$skip = 1 if ( ( $i == 7 ) $skip = 1
if ( ( $i == 7 )
&& ( $LINK || ( $AC >= SIGN ) || ( $AC == 0 ) ) ); # snl | sza | sma && ( $LINK || ( $AC >= SIGN ) || ( $AC == 0 ) ) ); # snl | sza | sma
$skip = 1 if ( $i == 010 ); # skp $skip = 1 if ( $i == 010 ); # skp
$skip = 1 if ( ( $i == 011 ) && ( ( $AC & SIGN ) == 0 ) ); # spa $skip = 1 if ( ( $i == 011 ) && ( ( $AC & SIGN ) == 0 ) ); # spa
$skip = 1 if ( ( $i == 012 ) && ( ( $AC & MAXINT ) != 0 ) ); # sna $skip = 1 if ( ( $i == 012 ) && ( ( $AC & MAXINT ) != 0 ) ); # sna
$skip = 1 if ( ( $i == 013 ) $skip = 1
if ( ( $i == 013 )
&& ( ( $AC & MAXINT ) != 0 ) && ( ( $AC & MAXINT ) != 0 )
&& ( ( $AC & SIGN ) == 0 ) ); # sna & spa && ( ( $AC & SIGN ) == 0 ) ); # sna & spa
$skip = 1 if ( ( $i == 014 ) && ( $LINK == 0 ) ); # szl $skip = 1 if ( ( $i == 014 ) && ( $LINK == 0 ) ); # szl
@@ -399,17 +410,20 @@ sub opr {
if ( ( $i == 015 ) && ( $LINK == 0 ) && ( $AC < SIGN ) ); # szl & spa if ( ( $i == 015 ) && ( $LINK == 0 ) && ( $AC < SIGN ) ); # szl & spa
$skip = 1 $skip = 1
if ( ( $i == 016 ) && ( $LINK == 0 ) && ( $AC != 0 ) ); # szl & sna if ( ( $i == 016 ) && ( $LINK == 0 ) && ( $AC != 0 ) ); # szl & sna
$skip = 1 if ( ( $i == 017 ) $skip = 1
if ( ( $i == 017 )
&& ( $LINK == 0 ) && ( $LINK == 0 )
&& ( $AC != 0 ) && ( $AC != 0 )
&& ( $AC != 0 ) ); # szl & sna & spa && ( $AC != 0 ) ); # szl & sna & spa
# Clear operations # Clear operations
if ( $instruction & 010000 ) { # cla if ( $instruction & 010000 ) { # cla
dprintf(" cla"); $AC = 0; dprintf(" cla");
$AC = 0;
} }
if ( $instruction & 004000 ) { # cli if ( $instruction & 004000 ) { # cli
dprintf(" cli"); $LINK = 0; dprintf(" cli");
$LINK = 0;
} }
if ( $instruction & 000002 ) { # cmi if ( $instruction & 000002 ) { # cmi
dprintf(" cmi"); dprintf(" cmi");
@@ -470,8 +484,8 @@ sub opr {
# Extended arithmetic element instructions # Extended arithmetic element instructions
sub eae { sub eae {
my ( $instruction, $addr, $indaddr ) = @_; my ( $instruction, $addr, $indaddr ) = @_;
my $step = $instruction & EAESTEP; my $step = $instruction & EAESTEP;
my $maskedinstr= $instruction & EAEIMASK; my $maskedinstr = $instruction & EAEIMASK;
if ( $maskedinstr == 0660500 ) { # lrss: long right shift, signed if ( $maskedinstr == 0660500 ) { # lrss: long right shift, signed
# We ignore the MQ as it's not # We ignore the MQ as it's not
@@ -487,18 +501,18 @@ sub eae {
} }
if ( $maskedinstr == 0660700 ) { # alss: AC left shift, signed if ( $maskedinstr == 0660700 ) { # alss: AC left shift, signed
dprintf( "alss AC %06o step %d\n", $AC, $step ); dprintf( "alss AC %06o step %d\n", $AC, $step );
$AC = ( $AC << $step ) & MAXINT; $AC = ( $AC << $step ) & MAXINT;
$LINK = ( $AC << 1 ) & LINKMASK; $LINK = ( $AC << 1 ) & LINKMASK;
$PC++; $PC++;
return; return;
} }
if ( $maskedinstr == 0660600 ) { # llss: long left shift, signed if ( $maskedinstr == 0660600 ) { # llss: long left shift, signed
dprintf( "llss AC %06o step %d\n", $AC, $step ); dprintf( "llss AC %06o step %d\n", $AC, $step );
foreach my $i (1 .. $step) { foreach my $i ( 1 .. $step ) {
my $MQmsb= ($MQ & SIGN) ? 1 : 0; my $MQmsb = ( $MQ & SIGN ) ? 1 : 0;
$AC= (($AC << 1) | $MQmsb) & MAXINT; $AC = ( ( $AC << 1 ) | $MQmsb ) & MAXINT;
$MQ= (($MQ << 1) | (($LINK) ? 1 : 0)) & MAXINT; $MQ = ( ( $MQ << 1 ) | ( ($LINK) ? 1 : 0 ) ) & MAXINT;
} }
$PC++; $PC++;
return; return;
} }
@@ -509,20 +523,20 @@ sub eae {
return; return;
} }
if ( $instruction == 0652000 ) { # lmq: load MC from AC if ( $instruction == 0652000 ) { # lmq: load MC from AC
dprintf( "lmq AC %06o into MQ\n", $AC); dprintf( "lmq AC %06o into MQ\n", $AC );
$MQ= $AC; $MQ = $AC;
$PC++; $PC++;
return; return;
} }
if ( $instruction == 0641002 ) { # lacq: load AC from MQ if ( $instruction == 0641002 ) { # lacq: load AC from MQ
dprintf( "lacq MQ %06o into AC\n", $MQ); dprintf( "lacq MQ %06o into AC\n", $MQ );
$AC= $MQ; $AC = $MQ;
$PC++; $PC++;
return; return;
} }
if ( $instruction == 0640002 ) { # lacq: OR AC with MQ if ( $instruction == 0640002 ) { # lacq: OR AC with MQ
dprintf( "omq MQ %06o and AC %06o\n", $MQ, $AC); dprintf( "omq MQ %06o and AC %06o\n", $MQ, $AC );
$AC |= $MQ; $AC |= $MQ;
$PC++; $PC++;
return; return;
} }
@@ -537,32 +551,38 @@ sub cal {
# Syscalls that we can simulate # Syscalls that we can simulate
my %Syscallist = ( my %Syscallist = (
# 1: save
2 => \&sys_getuid, # 1: save
3 => \&sys_open, 2 => \&sys_getuid,
4 => \&sys_read, 3 => \&sys_open,
5 => \&sys_write, 4 => \&sys_read,
6 => \&sys_creat, 5 => \&sys_write,
# 7 seek 6 => \&sys_creat,
# 8 tell
9 => \&sys_close, # 7 seek
# 10 link # 8 tell
9 => \&sys_close,
# 10 link
11 => \&sys_unlink, 11 => \&sys_unlink,
12 => \&sys_setuid, 12 => \&sys_setuid,
# 13 rename
# 13 rename
14 => \&sys_exit, 14 => \&sys_exit,
15 => \&sys_time, 15 => \&sys_time,
16 => \&sys_intrp, 16 => \&sys_intrp,
17 => \&sys_chdir, 17 => \&sys_chdir,
18 => \&sys_chmod, 18 => \&sys_chmod,
19 => \&sys_chown, 19 => \&sys_chown,
# 20 badcal
# 21 syslog # 20 badcal
# 22 badcal # 21 syslog
# 23 capt # 22 badcal
# 24 rele # 23 capt
# 24 rele
25 => \&sys_status, 25 => \&sys_status,
# 26 badcal
# 26 badcal
27 => \&sys_smes, 27 => \&sys_smes,
28 => \&sys_rmes, 28 => \&sys_rmes,
29 => \&sys_fork, 29 => \&sys_fork,
@@ -571,7 +591,8 @@ sub cal {
# Simulate the syscall. Each syscall updates the $PC # Simulate the syscall. Each syscall updates the $PC
if ( defined( $Syscallist{$addr} ) ) { if ( defined( $Syscallist{$addr} ) ) {
$Syscallist{$addr}->(); $Syscallist{$addr}->();
} else { }
else {
printf( STDERR "PC %06o: Unknown syscall %d\n", $PC, $addr ); printf( STDERR "PC %06o: Unknown syscall %d\n", $PC, $addr );
exit(1); exit(1);
} }
@@ -579,20 +600,21 @@ sub cal {
# Exit system call # Exit system call
sub sys_exit { sub sys_exit {
dprintf("exit system call, pid %06o\n", $$); dprintf( "exit system call, pid %06o\n", $$ );
exit(0); exit(0);
} }
# Getuid system call # Getuid system call
sub sys_getuid { sub sys_getuid {
$AC= $< & MAXINT; $AC = $< & MAXINT;
dprintf("getuid system call, uid %06o\n", $AC); dprintf( "getuid system call, uid %06o\n", $AC );
$PC += 1; $PC += 1;
return; return;
} }
# Setuid system call # Setuid system call
sub sys_setuid { sub sys_setuid {
# For now, do nothing # For now, do nothing
dprint("setuid system call\n"); dprint("setuid system call\n");
$PC += 1; $PC += 1;
@@ -601,6 +623,7 @@ sub sys_setuid {
# Intrp system call # Intrp system call
sub sys_intrp { sub sys_intrp {
# For now, do nothing # For now, do nothing
dprint("intrp system call\n"); dprint("intrp system call\n");
$PC += 1; $PC += 1;
@@ -611,9 +634,9 @@ sub sys_intrp {
sub sys_fork { sub sys_fork {
# Fork and get the child's process-id back, or zero if we are the child # Fork and get the child's process-id back, or zero if we are the child
my $pid= fork(); my $pid = fork();
$AC= $pid & MAXINT; $AC = $pid & MAXINT;
dprintf( "fork, got id %06o\n", $AC); dprintf( "fork, got id %06o\n", $AC );
# The parent returns back to PC+1, the child returns to PC+2 # The parent returns back to PC+1, the child returns to PC+2
$PC += ($pid) ? 1 : 2; $PC += ($pid) ? 1 : 2;
@@ -625,6 +648,7 @@ sub sys_fork {
# sys exit, that's going to wake wait() up and do the # sys exit, that's going to wake wait() up and do the
# rmes anyway. # rmes anyway.
sub sys_smes { sub sys_smes {
# For now, do nothing # For now, do nothing
dprintf("smes system call\n"); dprintf("smes system call\n");
$PC += 1; $PC += 1;
@@ -634,9 +658,9 @@ sub sys_smes {
# Rmes system call. We simply call wait and # Rmes system call. We simply call wait and
# return the process-id in AC # return the process-id in AC
sub sys_rmes { sub sys_rmes {
my $pid= wait(); my $pid = wait();
dprintf("rmes system call, got pid $pid\n"); dprintf("rmes system call, got pid $pid\n");
$AC= $pid & MAXINT; $AC = $pid & MAXINT;
$PC += 1; $PC += 1;
return; return;
} }
@@ -658,22 +682,35 @@ sub sys_close {
return; return;
} }
close( $FD[$fd] ); close( $FD[$fd] );
$FD[$fd] = undef; $FD[$fd] = undef;
$AC = 0; $ISBINARY[$fd] = 0; # For next time
$AC = 0;
return; return;
} }
# Open something which could be a file or a directory # Open something which could be a file or a directory
# Convert directories into files. Return the file handle. # Convert directories into files. Return the file handle and
# if the file is ASCII or binary.
sub opensomething { sub opensomething {
my ($readorwrite, $filename )= @_; my ( $readorwrite, $filename ) = @_;
my $tempfile= "/tmp/a7out.$$"; my $tempfile = "/tmp/a7out.$$";
my $FH; my $FH;
# If this is not a directory, simply open and return the FH # If this is not a directory, open it and return the FH
if (! -d $filename) { if ( !-d $filename ) {
open( $FH, $readorwrite, $filename ) || return(undef); open( $FH, $readorwrite, $filename ) || return (undef);
return($FH);
# 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: # It's a directory. The on-disk format for this was:
@@ -684,45 +721,58 @@ sub opensomething {
# The code creates a temporary file and fills in the i-node numbers # The code creates a temporary file and fills in the i-node numbers
# and space padded filenames from the directory. The file is closed # and space padded filenames from the directory. The file is closed
# opened read-only and unlinked, and the open filehandle is returned. # opened read-only and unlinked, and the open filehandle is returned.
opendir(my $dh, $filename) || return(undef); opendir( my $dh, $filename ) || return (undef);
open( $FH, ">", $tempfile) || return(undef); open( $FH, ">", $tempfile ) || return (undef);
dprintf("Converting directory $filename\n"); dprintf("Converting directory $filename\n");
my @list= sort(readdir($dh)); my @list = sort( readdir($dh) );
foreach my $name (@list) { foreach my $name (@list) {
# Get the file's i-node number
my (undef,$inode)= stat($name);
# ARGH! For now we are still read/writing ASCII files, so there's # Get the file's i-node number and write it
# no way to represent a proper 18-bit value. For now I'll pad my ( undef, $inode ) = stat($name);
# with spaces to create the record print( $FH word2three($inode) );
printf( $FH " %-8s ", substr( $name, 0, 8 ) );
# 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); closedir($dh);
close($FH); close($FH);
open( $FH, "<", $tempfile) || return(undef); open( $FH, "<", $tempfile ) || return (undef);
binmode($FH);
unlink($tempfile); unlink($tempfile);
return($FH); return ( $FH, 1 );
} }
# Common code for creat and open # Common code for creat and open
sub creatopen { sub creatopen {
my ($filename, $readorwrite)= @_; my ( $filename, $readorwrite ) = @_;
# Open the file # Open the file
my $FH= opensomething($readorwrite, $filename ); my ( $FH, $isbinary ) = opensomething( $readorwrite, $filename );
if ( $FH ) { if ($FH) {
# Find a place in the @FD array to store this filehandle. # Find a place in the @FD array to store this filehandle.
# 99 is arbitrary # 99 is arbitrary
foreach my $fd ( 0 .. 99 ) { foreach my $fd ( 0 .. 99 ) {
if ( !defined( $FD[$fd] ) ) { if ( !defined( $FD[$fd] ) ) {
$FD[$fd] = $FH; $FD[$fd] = $FH;
$AC = $fd; $ISBINARY[$fd] = $isbinary;
$AC = $fd;
last; last;
} }
} }
} else { }
else {
# No filehandle, so it's an error # No filehandle, so it's an error
dprintf("open failed: $!\n"); dprintf("open failed: $!\n");
$AC = MAXINT; $AC = MAXINT;
@@ -739,7 +789,7 @@ sub sys_open {
# Get the start address of the string # Get the start address of the string
# Convert this to a sensible ASCII filename # Convert this to a sensible ASCII filename
my $start = $Mem[ $PC + 1 ]; my $start = $Mem[ $PC + 1 ];
my $filename = mem2arg($start); my $filename = mem2arg($start);
# Choose to open read-only or write-only # Choose to open read-only or write-only
@@ -750,11 +800,12 @@ sub sys_open {
$PC += 3; $PC += 3;
# Now open the file and return # Now open the file and return
creatopen($filename, $readorwrite); creatopen( $filename, $readorwrite );
} }
# Creat system call # Creat system call
sub sys_creat { sub sys_creat {
# Creat seems to have 1 argument: PC+1 is a pointer to the filename. # 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. # Some programs seem to have a second argument always set to 0.
# AC is the opened fd on success, or -1 on error # AC is the opened fd on success, or -1 on error
@@ -773,7 +824,7 @@ sub sys_creat {
$PC += 2; $PC += 2;
# Now open the file and return # Now open the file and return
creatopen($filename, $readorwrite); creatopen( $filename, $readorwrite );
} }
# Read system call # Read system call
@@ -806,12 +857,23 @@ sub sys_read {
$count = 0; $count = 0;
foreach my $addr ( $start .. $end ) { foreach my $addr ( $start .. $end ) {
my $c1 = getc($FH); if ( $ISBINARY[$fd] ) {
last if ( !defined($c1) ); # No character, leave the loop
my $c2 = getc($FH); # No character, make it a NUL # Convert three bytes into one 18-bit word
$c2= "" if (!defined($c2)); my $result = read( $FH, my $three, 3 );
$Mem[$addr] = last if ( $result != 3 ); # Not enough bytes read
( ord($c1) << 9 ) | ord($c2); # Pack both into one word my ( $b1, $b2, $b3 ) = unpack( "CCC", $three );
$Mem[$addr] = ( ( $b1 & 077 ) << 12 ) | ( $b2 << 6 ) | $b3;
}
else {
# Convert two ASCII characters into one 18-bit word
my $c1 = getc($FH);
last if ( !defined($c1) ); # No character, leave the loop
my $c2 = getc($FH); # No character, make it a NUL
$c2 = "" if ( !defined($c2) );
$Mem[$addr] =
( ord($c1) << 9 ) | ord($c2); # Pack both into one word
}
$count++; $count++;
} }
@@ -822,6 +884,7 @@ sub sys_read {
# Write system call # Write system call
sub sys_write { sub sys_write {
# Write seems to have arguments: AC is the file descriptor, PC+1 is # 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 # the pointer to the buffer and PC+2 is the number of words to write
@@ -858,6 +921,7 @@ sub sys_write {
# Chmod system call # Chmod system call
sub sys_chmod { sub sys_chmod {
# Chmod gets the permission bits in AC and a pointer # 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: # 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 # lac u.ac; and o17 so only the lowest 4
@@ -867,108 +931,113 @@ sub sys_chmod {
# 02 read for non-owner # 02 read for non-owner
# 04 write for owner # 04 write for owner
# 10 read for owner # 10 read for owner
my $mode=0; my $mode = 0;
$mode|= 0002 if ($AC & 01); $mode |= 0002 if ( $AC & 01 );
$mode|= 0004 if ($AC & 02); $mode |= 0004 if ( $AC & 02 );
$mode|= 0220 if ($AC & 04); $mode |= 0220 if ( $AC & 04 );
$mode|= 0440 if ($AC & 010); $mode |= 0440 if ( $AC & 010 );
my $start = $Mem[ $PC + 1 ]; my $start = $Mem[ $PC + 1 ];
my $filename = mem2arg($start); my $filename = mem2arg($start);
dprintf( "chmod %06o file %s\n", $mode, $filename); dprintf( "chmod %06o file %s\n", $mode, $filename );
# Do the chmod on the file # Do the chmod on the file
my $result= chmod($mode, $filename); my $result = chmod( $mode, $filename );
# Set AC to -1 if no files were changed, else 0 # Set AC to -1 if no files were changed, else 0
$AC= ($result == 0) ? MAXINT : 0; $AC = ( $result == 0 ) ? MAXINT : 0;
$PC += 2; $PC += 2;
return; return;
} }
# Chown system call # Chown system call
sub sys_chown { sub sys_chown {
# Chown gets the numeric user-id in AC and a pointer # Chown gets the numeric user-id in AC and a pointer
# to the file's name in PC+1. # to the file's name in PC+1.
# Get the start address of the string # Get the start address of the string
# Convert this to a sensible ASCII filename # Convert this to a sensible ASCII filename
my $start = $Mem[ $PC + 1 ]; my $start = $Mem[ $PC + 1 ];
my $filename = mem2arg($start); my $filename = mem2arg($start);
dprintf( "chown file %s to uid %06o\n", $filename, $AC); dprintf( "chown file %s to uid %06o\n", $filename, $AC );
# Do the chown, leave group-id untouched. Get number of files changed # Do the chown, leave group-id untouched. Get number of files changed
my $result= chown($AC, -1, $filename); my $result = chown( $AC, -1, $filename );
# Set AC to -1 if no files were changed, else 0 # Set AC to -1 if no files were changed, else 0
$AC= ($result == 0) ? MAXINT : 0; $AC = ( $result == 0 ) ? MAXINT : 0;
$PC += 2; $PC += 2;
return; return;
} }
# Chdir system call # Chdir system call
sub sys_chdir { sub sys_chdir {
# Chdir gets the directory name in PC+1 # Chdir gets the directory name in PC+1
# Return 0 on success, -1 on error # Return 0 on success, -1 on error
# Convert this to a sensible ASCII filename # Convert this to a sensible ASCII filename
my $start = $Mem[ $PC + 1 ]; my $start = $Mem[ $PC + 1 ];
my $filename = mem2arg($start); my $filename = mem2arg($start);
dprintf( "chdir %s\n", $filename); dprintf( "chdir %s\n", $filename );
# Bump up the PC # Bump up the PC
$PC += 2; $PC += 2;
# Do nothing on chdir to "dd" # Do nothing on chdir to "dd"
return(0) if ($filename eq "dd"); return (0) if ( $filename eq "dd" );
# Do the chdir # Do the chdir
return( chdir($filename) ? 0 : MAXINT); return ( chdir($filename) ? 0 : MAXINT );
} }
# Unlink system call # Unlink system call
sub sys_unlink { sub sys_unlink {
# Unlink gets the file name in PC+1 # Unlink gets the file name in PC+1
# Return 0 on success, -1 on error # Return 0 on success, -1 on error
# Convert this to a sensible ASCII filename # Convert this to a sensible ASCII filename
my $start = $Mem[ $PC + 1 ]; my $start = $Mem[ $PC + 1 ];
my $filename = mem2arg($start); my $filename = mem2arg($start);
dprintf( "unlink %s\n", $filename); dprintf( "unlink %s\n", $filename );
# Bump up the PC and do the unlink # Bump up the PC and do the unlink
$PC += 2; $PC += 2;
return( unlink($filename) ? 0 : MAXINT); return ( unlink($filename) ? 0 : MAXINT );
} }
# Time system call # Time system call
sub sys_time { sub sys_time {
# Dennis' draft says: The call sys time returns in # Dennis' draft says: The call sys time returns in
# the AC and MQ registers the number of sixtieths of # the AC and MQ registers the number of sixtieths of
# a second since the start of the current year. # a second since the start of the current year.
# Get two Datetime objects set to now # Get two Datetime objects set to now
my $dt = DateTime->now; my $dt = DateTime->now;
my $yearstart = DateTime->now; my $yearstart = DateTime->now;
# Set one object back to the beginning of the year # Set one object back to the beginning of the year
$yearstart->set( month => 1); $yearstart->set( month => 1 );
$yearstart->set( day => 1); $yearstart->set( day => 1 );
$yearstart->set( hour => 0); $yearstart->set( hour => 0 );
$yearstart->set( minute => 0); $yearstart->set( minute => 0 );
$yearstart->set( second => 0); $yearstart->set( second => 0 );
# Get the duration in sixtieths of a second # Get the duration in sixtieths of a second
my $duration = $dt->subtract_datetime_absolute($yearstart); my $duration = $dt->subtract_datetime_absolute($yearstart);
my $sixtieths = $duration->seconds() * 60; my $sixtieths = $duration->seconds() * 60;
# Set MQ to the high 18 bits and AC to the low 18 bits # Set MQ to the high 18 bits and AC to the low 18 bits
$MQ = $sixtieths >> 18; $MQ = $sixtieths >> 18;
$AC = $sixtieths & 0777777; $AC = $sixtieths & 0777777;
dprintf( "time %06o %06o\n", $MQ, $AC); dprintf( "time %06o %06o\n", $MQ, $AC );
$PC += 1; $PC += 1;
return; return;
} }
# Status system call # Status system call
sub sys_status { sub sys_status {
# This seems to called as follows: # This seems to called as follows:
# law statbuf # law statbuf
# sys status; scrname; dd # sys status; scrname; dd
@@ -991,37 +1060,66 @@ sub sys_status {
# Get the start address of the string # Get the start address of the string
# Convert this to a sensible ASCII filename # Convert this to a sensible ASCII filename
my $start = $Mem[ $PC + 1 ]; my $start = $Mem[ $PC + 1 ];
my $filename = mem2arg($start); my $filename = mem2arg($start);
dprintf( "status file %s statbuf %06o\n", $filename, $AC ); dprintf( "status file %s statbuf %06o\n", $filename, $AC );
# Get the file's details # Get the file's details
my (undef,undef,$mode,$nlink,$uid,undef,undef,$size)= stat($filename); my ( undef, undef, $mode, $nlink, $uid, undef, undef, $size ) =
stat($filename);
# Set up the statbuf if we got a result # Set up the statbuf if we got a result
if ($nlink) { if ($nlink) {
$Mem[ $AC+8 ]= $uid & MAXINT; $Mem[ $AC + 8 ] = $uid & MAXINT;
$Mem[ $AC+9 ]= $nlink & MAXINT; $Mem[ $AC + 9 ] = $nlink & MAXINT;
$Mem[ $AC+10 ]= $size & MAXINT; # Yes, I know, not words $Mem[ $AC + 10 ] = $size & MAXINT; # Yes, I know, not words
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;
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 # Set AC to zero as we got something, else return -1
$AC= 0; $AC = 0;
} else { }
$AC= MAXINT; else {
$AC = MAXINT;
} }
$PC += 3; $PC += 3;
return; 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. # Convert an 18-bit word into two ASCII characters and return them.
# Don't return NUL characters # Don't return NUL characters
sub word2ascii { sub word2ascii {
@@ -1102,7 +1200,8 @@ sub get_user_command {
my $leave; my $leave;
if ( defined($cmd) && defined( $Cmdlist{$cmd} ) ) { if ( defined($cmd) && defined( $Cmdlist{$cmd} ) ) {
$leave = $Cmdlist{$cmd}->( $addr, $endaddr ); $leave = $Cmdlist{$cmd}->( $addr, $endaddr );
} else { }
else {
printf( "%s: unknown command\n", $cmd || "" ); printf( "%s: unknown command\n", $cmd || "" );
cmd_help(); cmd_help();
} }