mirror of
https://github.com/DoctorWkt/pdp7-unix.git
synced 2026-01-13 15:27:39 +00:00
I've added code to detect binary PDP-7 files to a7out. This is needed
for doing the seek() and tell() syscalls which are next to do.
This commit is contained in:
Warren Toomey
parent
51ad7db306
commit
451a58fc58
26
tools/3dump
Executable file
26
tools/3dump
Executable 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);
|
||||
389
tools/a7out
389
tools/a7out
@ -6,6 +6,7 @@
|
||||
#
|
||||
use strict;
|
||||
use warnings;
|
||||
use Fcntl qw(:seek);
|
||||
use DateTime;
|
||||
use Data::Dumper;
|
||||
|
||||
@ -15,6 +16,7 @@ my $singlestep = 0; # Are we running in single-step mode?
|
||||
my %Breakpoint; # Hash of defined breakpoints
|
||||
my @Mem; # 8K 18-bit words of main memory
|
||||
my @FD; # Array of open filehandles
|
||||
my @ISBINARY; # Array of filehandle flags: ASCII or binary files?
|
||||
|
||||
# Registers
|
||||
my $PC = 010000; # Program counter
|
||||
@ -141,6 +143,7 @@ sub set_arguments {
|
||||
# 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 ) || "";
|
||||
@ -176,9 +179,9 @@ sub simulate {
|
||||
# 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
|
||||
oct("000") => 1, # cal
|
||||
oct("064") => 1, # eae
|
||||
oct("074") => 1 # opr
|
||||
);
|
||||
|
||||
# Loop indefinitely
|
||||
@ -190,13 +193,16 @@ sub simulate {
|
||||
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;
|
||||
}
|
||||
# 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;
|
||||
@ -215,7 +221,8 @@ sub simulate {
|
||||
# Simulate the instruction. Each subroutine updates the $PC
|
||||
if ( defined( $Oplist{$opcode} ) ) {
|
||||
$Oplist{$opcode}->( $instruction, $addr, $indaddr );
|
||||
} else {
|
||||
}
|
||||
else {
|
||||
printf( STDERR "Unknown instruction 0%06o at location 0%06o\n",
|
||||
$instruction, $PC );
|
||||
exit(1);
|
||||
@ -229,12 +236,13 @@ sub simulate {
|
||||
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)
|
||||
|
||||
# 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 );
|
||||
}
|
||||
}
|
||||
@ -261,7 +269,7 @@ sub tad {
|
||||
dprintf( "tad AC (value %06o) with addr %06o (%06o)\n",
|
||||
$AC, $indaddr, $Mem[$indaddr] );
|
||||
$AC = $AC + $Mem[$indaddr];
|
||||
$LINK = ($LINK ^ $AC) & LINKMASK;
|
||||
$LINK = ( $LINK ^ $AC ) & LINKMASK;
|
||||
$AC = $AC & MAXINT;
|
||||
$PC++;
|
||||
}
|
||||
@ -380,18 +388,21 @@ sub opr {
|
||||
|
||||
$skip = 1 if ( ( $i == 1 ) && ( $AC & SIGN ) != 0 ); # sma
|
||||
$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 ) ) )
|
||||
; # 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 )
|
||||
$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 )
|
||||
$skip = 1
|
||||
if ( ( $i == 013 )
|
||||
&& ( ( $AC & MAXINT ) != 0 )
|
||||
&& ( ( $AC & SIGN ) == 0 ) ); # sna & spa
|
||||
$skip = 1 if ( ( $i == 014 ) && ( $LINK == 0 ) ); # szl
|
||||
@ -399,17 +410,20 @@ sub opr {
|
||||
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 )
|
||||
$skip = 1
|
||||
if ( ( $i == 017 )
|
||||
&& ( $LINK == 0 )
|
||||
&& ( $AC != 0 )
|
||||
&& ( $AC != 0 ) ); # szl & sna & spa
|
||||
|
||||
# Clear operations
|
||||
if ( $instruction & 010000 ) { # cla
|
||||
dprintf(" cla"); $AC = 0;
|
||||
dprintf(" cla");
|
||||
$AC = 0;
|
||||
}
|
||||
if ( $instruction & 004000 ) { # cli
|
||||
dprintf(" cli"); $LINK = 0;
|
||||
dprintf(" cli");
|
||||
$LINK = 0;
|
||||
}
|
||||
if ( $instruction & 000002 ) { # cmi
|
||||
dprintf(" cmi");
|
||||
@ -470,8 +484,8 @@ sub opr {
|
||||
# Extended arithmetic element instructions
|
||||
sub eae {
|
||||
my ( $instruction, $addr, $indaddr ) = @_;
|
||||
my $step = $instruction & EAESTEP;
|
||||
my $maskedinstr= $instruction & EAEIMASK;
|
||||
my $step = $instruction & EAESTEP;
|
||||
my $maskedinstr = $instruction & EAEIMASK;
|
||||
|
||||
if ( $maskedinstr == 0660500 ) { # lrss: long right shift, signed
|
||||
# We ignore the MQ as it's not
|
||||
@ -487,18 +501,18 @@ sub eae {
|
||||
}
|
||||
if ( $maskedinstr == 0660700 ) { # alss: AC left shift, signed
|
||||
dprintf( "alss AC %06o step %d\n", $AC, $step );
|
||||
$AC = ( $AC << $step ) & MAXINT;
|
||||
$AC = ( $AC << $step ) & MAXINT;
|
||||
$LINK = ( $AC << 1 ) & LINKMASK;
|
||||
$PC++;
|
||||
return;
|
||||
}
|
||||
if ( $maskedinstr == 0660600 ) { # llss: long left shift, signed
|
||||
dprintf( "llss AC %06o step %d\n", $AC, $step );
|
||||
foreach my $i (1 .. $step) {
|
||||
my $MQmsb= ($MQ & SIGN) ? 1 : 0;
|
||||
$AC= (($AC << 1) | $MQmsb) & MAXINT;
|
||||
$MQ= (($MQ << 1) | (($LINK) ? 1 : 0)) & MAXINT;
|
||||
}
|
||||
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;
|
||||
}
|
||||
@ -509,20 +523,20 @@ sub eae {
|
||||
return;
|
||||
}
|
||||
if ( $instruction == 0652000 ) { # lmq: load MC from AC
|
||||
dprintf( "lmq AC %06o into MQ\n", $AC);
|
||||
$MQ= $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;
|
||||
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;
|
||||
dprintf( "omq MQ %06o and AC %06o\n", $MQ, $AC );
|
||||
$AC |= $MQ;
|
||||
$PC++;
|
||||
return;
|
||||
}
|
||||
@ -537,32 +551,38 @@ sub cal {
|
||||
|
||||
# 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 seek
|
||||
# 8 tell
|
||||
9 => \&sys_close,
|
||||
# 10 link
|
||||
|
||||
# 1: save
|
||||
2 => \&sys_getuid,
|
||||
3 => \&sys_open,
|
||||
4 => \&sys_read,
|
||||
5 => \&sys_write,
|
||||
6 => \&sys_creat,
|
||||
|
||||
# 7 seek
|
||||
# 8 tell
|
||||
9 => \&sys_close,
|
||||
|
||||
# 10 link
|
||||
11 => \&sys_unlink,
|
||||
12 => \&sys_setuid,
|
||||
# 13 rename
|
||||
|
||||
# 13 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
|
||||
|
||||
# 20 badcal
|
||||
# 21 syslog
|
||||
# 22 badcal
|
||||
# 23 capt
|
||||
# 24 rele
|
||||
25 => \&sys_status,
|
||||
# 26 badcal
|
||||
|
||||
# 26 badcal
|
||||
27 => \&sys_smes,
|
||||
28 => \&sys_rmes,
|
||||
29 => \&sys_fork,
|
||||
@ -571,7 +591,8 @@ sub cal {
|
||||
# Simulate the syscall. Each syscall updates the $PC
|
||||
if ( defined( $Syscallist{$addr} ) ) {
|
||||
$Syscallist{$addr}->();
|
||||
} else {
|
||||
}
|
||||
else {
|
||||
printf( STDERR "PC %06o: Unknown syscall %d\n", $PC, $addr );
|
||||
exit(1);
|
||||
}
|
||||
@ -579,20 +600,21 @@ sub cal {
|
||||
|
||||
# Exit system call
|
||||
sub sys_exit {
|
||||
dprintf("exit system call, pid %06o\n", $$);
|
||||
dprintf( "exit system call, pid %06o\n", $$ );
|
||||
exit(0);
|
||||
}
|
||||
|
||||
# Getuid system call
|
||||
sub sys_getuid {
|
||||
$AC= $< & MAXINT;
|
||||
dprintf("getuid system call, uid %06o\n", $AC);
|
||||
$AC = $< & MAXINT;
|
||||
dprintf( "getuid system call, uid %06o\n", $AC );
|
||||
$PC += 1;
|
||||
return;
|
||||
}
|
||||
|
||||
# Setuid system call
|
||||
sub sys_setuid {
|
||||
|
||||
# For now, do nothing
|
||||
dprint("setuid system call\n");
|
||||
$PC += 1;
|
||||
@ -601,6 +623,7 @@ sub sys_setuid {
|
||||
|
||||
# Intrp system call
|
||||
sub sys_intrp {
|
||||
|
||||
# For now, do nothing
|
||||
dprint("intrp system call\n");
|
||||
$PC += 1;
|
||||
@ -611,9 +634,9 @@ sub sys_intrp {
|
||||
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);
|
||||
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;
|
||||
@ -625,6 +648,7 @@ sub sys_fork {
|
||||
# sys exit, that's going to wake wait() up and do the
|
||||
# rmes anyway.
|
||||
sub sys_smes {
|
||||
|
||||
# For now, do nothing
|
||||
dprintf("smes system call\n");
|
||||
$PC += 1;
|
||||
@ -634,9 +658,9 @@ sub sys_smes {
|
||||
# Rmes system call. We simply call wait and
|
||||
# return the process-id in AC
|
||||
sub sys_rmes {
|
||||
my $pid= wait();
|
||||
my $pid = wait();
|
||||
dprintf("rmes system call, got pid $pid\n");
|
||||
$AC= $pid & MAXINT;
|
||||
$AC = $pid & MAXINT;
|
||||
$PC += 1;
|
||||
return;
|
||||
}
|
||||
@ -658,22 +682,35 @@ sub sys_close {
|
||||
return;
|
||||
}
|
||||
close( $FD[$fd] );
|
||||
$FD[$fd] = undef;
|
||||
$AC = 0;
|
||||
$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.
|
||||
# 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 ( $readorwrite, $filename ) = @_;
|
||||
my $tempfile = "/tmp/a7out.$$";
|
||||
my $FH;
|
||||
|
||||
# If this is not a directory, simply open and return the FH
|
||||
if (! -d $filename) {
|
||||
open( $FH, $readorwrite, $filename ) || return(undef);
|
||||
return($FH);
|
||||
# If this is not a directory, open it and return the FH
|
||||
if ( !-d $filename ) {
|
||||
open( $FH, $readorwrite, $filename ) || return (undef);
|
||||
|
||||
# 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:
|
||||
@ -684,45 +721,58 @@ sub opensomething {
|
||||
# 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);
|
||||
opendir( my $dh, $filename ) || return (undef);
|
||||
open( $FH, ">", $tempfile ) || return (undef);
|
||||
dprintf("Converting directory $filename\n");
|
||||
|
||||
my @list= sort(readdir($dh));
|
||||
my @list = sort( readdir($dh) );
|
||||
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
|
||||
# no way to represent a proper 18-bit value. For now I'll pad
|
||||
# with spaces to create the record
|
||||
printf( $FH " %-8s ", substr( $name, 0, 8 ) );
|
||||
# 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);
|
||||
open( $FH, "<", $tempfile ) || return (undef);
|
||||
binmode($FH);
|
||||
unlink($tempfile);
|
||||
return($FH);
|
||||
return ( $FH, 1 );
|
||||
}
|
||||
|
||||
# Common code for creat and open
|
||||
sub creatopen {
|
||||
my ($filename, $readorwrite)= @_;
|
||||
my ( $filename, $readorwrite ) = @_;
|
||||
|
||||
# Open the file
|
||||
my $FH= opensomething($readorwrite, $filename );
|
||||
if ( $FH ) {
|
||||
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;
|
||||
$AC = $fd;
|
||||
$FD[$fd] = $FH;
|
||||
$ISBINARY[$fd] = $isbinary;
|
||||
$AC = $fd;
|
||||
last;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
}
|
||||
else {
|
||||
# No filehandle, so it's an error
|
||||
dprintf("open failed: $!\n");
|
||||
$AC = MAXINT;
|
||||
@ -739,7 +789,7 @@ sub sys_open {
|
||||
|
||||
# Get the start address of the string
|
||||
# Convert this to a sensible ASCII filename
|
||||
my $start = $Mem[ $PC + 1 ];
|
||||
my $start = $Mem[ $PC + 1 ];
|
||||
my $filename = mem2arg($start);
|
||||
|
||||
# Choose to open read-only or write-only
|
||||
@ -750,11 +800,12 @@ sub sys_open {
|
||||
$PC += 3;
|
||||
|
||||
# Now open the file and return
|
||||
creatopen($filename, $readorwrite);
|
||||
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
|
||||
@ -773,7 +824,7 @@ sub sys_creat {
|
||||
$PC += 2;
|
||||
|
||||
# Now open the file and return
|
||||
creatopen($filename, $readorwrite);
|
||||
creatopen( $filename, $readorwrite );
|
||||
}
|
||||
|
||||
# Read system call
|
||||
@ -806,12 +857,23 @@ sub sys_read {
|
||||
$count = 0;
|
||||
foreach my $addr ( $start .. $end ) {
|
||||
|
||||
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
|
||||
if ( $ISBINARY[$fd] ) {
|
||||
|
||||
# Convert three bytes into one 18-bit word
|
||||
my $result = read( $FH, my $three, 3 );
|
||||
last if ( $result != 3 ); # Not enough bytes read
|
||||
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++;
|
||||
}
|
||||
|
||||
@ -822,6 +884,7 @@ sub sys_read {
|
||||
|
||||
# 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
|
||||
|
||||
@ -858,6 +921,7 @@ sub sys_write {
|
||||
|
||||
# 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
|
||||
@ -867,108 +931,113 @@ sub sys_chmod {
|
||||
# 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 $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);
|
||||
dprintf( "chmod %06o file %s\n", $mode, $filename );
|
||||
|
||||
# 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
|
||||
$AC= ($result == 0) ? MAXINT : 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 $start = $Mem[ $PC + 1 ];
|
||||
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
|
||||
my $result= chown($AC, -1, $filename);
|
||||
my $result = chown( $AC, -1, $filename );
|
||||
|
||||
# Set AC to -1 if no files were changed, else 0
|
||||
$AC= ($result == 0) ? MAXINT : 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 $start = $Mem[ $PC + 1 ];
|
||||
my $filename = mem2arg($start);
|
||||
dprintf( "chdir %s\n", $filename);
|
||||
dprintf( "chdir %s\n", $filename );
|
||||
|
||||
# Bump up the PC
|
||||
$PC += 2;
|
||||
|
||||
# Do nothing on chdir to "dd"
|
||||
return(0) if ($filename eq "dd");
|
||||
return (0) if ( $filename eq "dd" );
|
||||
|
||||
# Do the chdir
|
||||
return( chdir($filename) ? 0 : MAXINT);
|
||||
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 $start = $Mem[ $PC + 1 ];
|
||||
my $filename = mem2arg($start);
|
||||
dprintf( "unlink %s\n", $filename);
|
||||
dprintf( "unlink %s\n", $filename );
|
||||
|
||||
# Bump up the PC and do the unlink
|
||||
$PC += 2;
|
||||
return( unlink($filename) ? 0 : MAXINT);
|
||||
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 $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);
|
||||
$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 $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\n", $MQ, $AC);
|
||||
dprintf( "time %06o %06o\n", $MQ, $AC );
|
||||
$PC += 1;
|
||||
return;
|
||||
}
|
||||
|
||||
# Status system call
|
||||
sub sys_status {
|
||||
|
||||
# This seems to called as follows:
|
||||
# law statbuf
|
||||
# sys status; scrname; dd
|
||||
@ -991,37 +1060,66 @@ sub sys_status {
|
||||
|
||||
# Get the start address of the string
|
||||
# Convert this to a sensible ASCII filename
|
||||
my $start = $Mem[ $PC + 1 ];
|
||||
my $start = $Mem[ $PC + 1 ];
|
||||
my $filename = mem2arg($start);
|
||||
dprintf( "status file %s statbuf %06o\n", $filename, $AC );
|
||||
|
||||
# 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
|
||||
if ($nlink) {
|
||||
$Mem[ $AC+8 ]= $uid & MAXINT;
|
||||
$Mem[ $AC+9 ]= $nlink & MAXINT;
|
||||
$Mem[ $AC+10 ]= $size & MAXINT; # Yes, I know, not words
|
||||
$Mem[ $AC + 8 ] = $uid & MAXINT;
|
||||
$Mem[ $AC + 9 ] = $nlink & MAXINT;
|
||||
$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
|
||||
$AC= 0;
|
||||
} else {
|
||||
$AC= MAXINT;
|
||||
$AC = 0;
|
||||
}
|
||||
else {
|
||||
$AC = 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 {
|
||||
@ -1102,7 +1200,8 @@ sub get_user_command {
|
||||
my $leave;
|
||||
if ( defined($cmd) && defined( $Cmdlist{$cmd} ) ) {
|
||||
$leave = $Cmdlist{$cmd}->( $addr, $endaddr );
|
||||
} else {
|
||||
}
|
||||
else {
|
||||
printf( "%s: unknown command\n", $cmd || "" );
|
||||
cmd_help();
|
||||
}
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user