github.com/wfjm.w11
1
0
Fork 0
mirror of https://github.com/wfjm/w11.git synced 2026-04-25 11:51:51 +00:00
Code Issues Releases Wiki Activity
Files
a20f49fcd5517f09f6b48cc6a8d3c19162a19c6e
wfjm.w11/tools/bin/pi_rri
Walter F.J. Mueller a20f49fcd5 - add sources for C++/Tcl based backend, add directories 
- tools/src/...
  - tools/tcl/...
  - tools/dox
  - tools/make
- add rlink test system
  - rtl/sys_gen/tst_rlink/nexys2/...
2011-04-02 11:08:56 +00:00

7199 lines
220 KiB
Perl
Executable File
Raw Blame History

#!/usr/bin/perl -w
# $Id: pi_rri 374 2011-03-27 17:02:47Z mueller $
#
# Copyright 2007-2010 by Walter F.J. Mueller <W.F.J.Mueller@gsi.de>
#
# This program is free software; you may redistribute and/or modify it under
# the terms of the GNU General Public License as published by the Free
# Software Foundation, either version 2, or at your option any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY, without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for complete details.
#
# Revision History:
# Date Rev Version Comment
# 2010-12-29 351 1.6.3 rename rriext->cext and cpmon->rlmon
# 2010-06-27 310 1.6.2 fix autoflush for fh_log; duplicate exec err to log
# 2010-06-18 306 1.6.1 PDPCP_ADDR_IBRB now 020, PDPCP_ADDR_IBR now 0200;
# ibrbase now just drops the 6 lsb's; pdpcp mode:
# rename librb -> wibrb; finished cp/rri overhaul
# 2010-06-13 305 1.6 change PDPCP_ADDR_ assignments, add PDPCP_FUNC_
# constants; adapt pdpcp mode to changed rri addr and
# stim file format; emulate old 'sta' behaviour with
# new 'stapc' command; rename lal,lah -> wal,wah and
# implement locally; adapt serv11 mode to new rri
# 2010-06-11 303 1.5.1 add cmd_inter; flush{"line"} after interactive cmd
# added readline support.
# 2010-06-07 302 1.5 use sop/eop framing instead of soc+chaining
# 2010-06-06 301 1.4.18 rename .rpmon->.rbmon; NCOMM=4 (new eop,nak commas)
# 2010-06-03 299 1.4.17 adapt .reset to new rbus init decode
# 2010-05-05 288 1.4.16 first preliminary implementation of eval based
# perl macro's via @@pmac; add ^C signal handler;
# added optional min/max check for cget_gdat() and
# cget_tagval_gdat().
# 2010-05-02 287 1.4.15 enable hardware flow control in termios
# 2010-05-01 286 1.4.14 add .sinit command for rri and pdpcp modes;
# add 500k,1M,2M,3M baudrates, check value now
# 2010-04-26 284 1.4.13 add error check for GetOptions
# 2010-04-25 283 1.4.12 raw_rcv9_to: handle undef as return value correctly
# 2009-10-11 244 1.4.11 support > 115kbaud speed; new stat output in log;
# use nxbuf_max=8 as default;
# 2009-09-27 242 1.4.10 add "ERR --" messages in log file; fix usage of
# uninitialized vars in serv11_exec_probe();
# 2009-09-25 241 1.4.9 BUGFIX: serv11_server_attn_get() now or's attn bits
# 2009-09-20 240 1.4.8 serv11_rri_uset cache under $ctl, not in unittbl
# 2009-09-13 238 1.4.7 add ctlname for DL11 log entries; only TTA output
# written to stdout when no terminal attached.
# 2009-07-26 236 1.4.6 fix cpraw mode and .mode error handling;
# 2009-07-12 233 1.4.5 add attach/detach support for term; telnet support;
# 2009-07-05 232 1.4.4 add cchk_number(), cget_regrange(); rename _atdt_ to
# _attdet_; serv11: add exa/dep command; removed
# rr[0-7], wr[0-7], rmem, and wmem commands; new probe
# handling, use {probe_[ir]val} and {probemask};
# serv11: command parser supports abbeviations;
# serv11: add set/sho command, reorganize ls* cmds;
# serv11: add {trace} parameter; rri_sideband() flush;
# 2009-07-04 231 1.4.3 first reglist definitions; add CPU in _ctltbl;
# add serv11_probe_cpu();
# 2009-06-28 230 1.4.2 use serv11_atdt_pc11(), remove atdt via ucb hack;
# add serv11_rri_uset(); pc11 now fully supported;
# attn log message now gives device; use -e as file
# test; add ptape boot mode support; lsconf output
# sorted by ibus address;
# 2009-06-21 228 1.4.1 BUGFIX: correct typo in RK6 ucb; reorganize init
# handling, introduce usethdl; reorganize attach;
# add atdthdl at ctl or ucb level; add det command;
# 2009-06-20 227 1.4 nxbuf_min,max,inc now a ctl property;
# 2009-06-14 226 1.3.31 add very preliminary lp11 device handling
# 2009-06-11 225 1.3.30 quick hack to add dl11 log files.
# 2009-05-30 220 1.3.29 add papertape boot code;
# 2009-05-24 219 1.3.28 add papertape hook as dev "PC" units "PTR" and "PTP"
# 2009-05-21 217 1.3.27 rk11: now error message when init not done
# 2009-05-17 216 1.3.26 BUGFIX:rk11: fix read/write logic for short sectors;
# BUGFIX:rk11: re-work the seek complete handling
# add read/write check support; add PGE error support;
# 2009-05-13 215 1.3.25 dl11: drop parity bit in transmit path;
# rk11: add read/write format; set SOK at init time;
# 2009-05-10 214 1.3.24 BUGFIX: in serv11_attn_rk11() RKER was written
# instead of RKMR for RKCS_DRESET, _WLOCK, _SEEK
# 2009-04-11 206 1.3.23 add --int to force interactive mode
# fix handling of odd length records in lsabs
# 2008-12-14 177 1.3.22 correct DL11_BASE_B to 176500 (was RL address)
# 2008-11-28 173 1.3.21 serv11_rri_lalh(): allow now mode =0,1,2 and 3;
# serv11_rdma_rk11(): use mode=3 in rri_lalh, thus
# enable 22bit and ubmap simultaneously.
# add proper MEX update for RKCS in rdma_rk11.
# add proper DRSEL propagation for RKDA in rdma_rk11.
# 2008-05-30 151 1.3.20 BUGFIX: corrected @que_rcv logic in serv11 input
# loop, TT0 output will not longer hang sometimes;
# disable the attn+ioto(16 or 63 ms) hack;
# 2008-05-23 150 1.3.19 tio[89b] messages: to $fh_log now, add delta-time;
# fixes in disk extend logic and messages; add the
# (^c form of ( command; add adaptive read vector
# in serv11_attn_dl11;
# 2008-05-22 149 1.3.18 add term_tios_print, fixes for --term under cygwin;
# 2008-05-22 148 1.3.17 add (,< short-cut commands
# 2008-05-18 147 1.3.16 ATTN comma drop now warning, -W (was -I);
# 2008-05-12 145 1.3.15 rename ldpta -> ldabs
# 2008-05-09 144 1.3.14 disable call in attn_dispatch(1) (needs busy logic)
# 2008-05-01 142 1.3.13 serv11: add stop,cont,reset; add $force for attn
# handlers; use attn+ioto(16ms) to avoid TTO hangs
# 2008-05-01 141 1.3.12 write TTO char-by-char now to STDOUT
# 2008-04-25 138 1.3.11 show ccc/scc for code 000257/000277 in disassembler
# 2008-04-19 137 1.3.10 minor fix disassembler: use f reg prefix for f4,f5
# 2008-04-18 136 1.3.9 hack in a poor man's output to console...
# 2008-04-13 135 1.3.8 substitute environment variables in cmd file names
# 2008-04-11 134 1.3.7 allow line comments starting with ";" (for simh)
# 2008-04-06 133 1.3.6 fix file check in serv11_cexec_ldpta; fix wrong
# opcode for mfps; fixed bug in disassembling mode=77
# add -a for lsmem;
# 2008-04-04 132 1.3.5 add in disassembler non-11/70 and fpp codes;
# add (>|>>)file option for lsmem (redirect to file)
# 2008-03-39 131 1.3.4 lsmem -m: use now wide (3 word) symbolic dump format
# add ldpta command (load paper tape abs format)
# add start and step command
# 2008-03-24 129 1.3.3 allow comments when in serv11 server mode.
# check attach file size; zero-fill after partial
# block write; reorganize dsk file and rdma handling
# leading blanks now ignored in commands
# 2008-03-22 128 1.3.2 fully functional server mode (todo: TT <-> telnet)
# 2008-03-19 127 1.3.1 very preliminary server mode now working
# 2008-03-09 124 1.3 add serv11 mode; add PDP11 disamssebler
# 2008-03-02 121 1.2.5 the default .sdef now checks for hard errors.
# the _open handlers for rri and pdpcp setup default
# Add .cerr, .merr as ignored directives for pdpcp
# 2008-02-24 119 1.2.4 added lah,rps,wps command in .pdpcp mode
# 2008-02-16 116 1.2.3 add librb,[rw]ibr,and wtlam to pdpcp command set
# 2007-12-25 105 1.2.2 for rri mode add .dbas[io] (set base for data vals)
# add ${par}, ${par:=val}, ${par:-val} substitution
# allow parameter definition via par=val lines
# add $[..perl code..] escape to embed perl code
# allow @file(arg1,arg2,arg3,...); print .wtlam wait
# 2007-11-24 98 1.2.1 adapt to new rri internal init handling
# 2007-11-18 96 1.2 add 'read before write' logic to avoid deadlocks
# under cygwin broken fifo (size=1 !) implementation
# 2007-10-12 88 1.1.4 fix some -w issues
# 2007-09-23 84 1.1.3 .reset command in pdpcp mode; keep-alive in --fifo
# 2007-09-16 83 1.1.2 add --cmax; full --term implemented
# 2007-09-09 80 1.1.1 add --run; modularize I/O handling; initial --term
# proper return code / retry loop for sysread/write
# 2007-09-09 80 1.1 new non-blocking/blocking handling; ignore IDLE's
# and unexpected ATTN commas; add <mode>_flush; add
# data check handling, command chaining, 'pdpcp' mode.
# 2007-09-02 79 1.0.1 implement 'rri' mode
# 2007-09-01 78 1.0 Initial version
use 5.005; # require Perl 5.005 or higher
use strict; # require strict checking
use FileHandle;
use POSIX qw(mkfifo isatty :termios_h);
use Fcntl qw(O_WRONLY O_RDONLY O_NOCTTY);
use Errno qw(EINTR);
use Time::HiRes qw(gettimeofday);
use Socket;
use Term::ReadLine;
use constant CPREF => 0x80;
use constant NCOMM => 4;
use constant CESC => CPREF|0x0f ;
use constant CEN1 => (~CPREF)&0xf0;
use constant D9IDLE => 0x100;
use constant D9SOP => 0x101;
use constant D9EOP => 0x102;
use constant D9NAK => 0x103;
use constant D9ATTN => 0x104;
use constant PDPCP_ADDR_CONF => 000;
use constant PDPCP_ADDR_CNTL => 001;
use constant PDPCP_ADDR_STAT => 002;
use constant PDPCP_ADDR_PSW => 003;
use constant PDPCP_ADDR_AL => 004;
use constant PDPCP_ADDR_AH => 005;
use constant PDPCP_ADDR_MEM => 006;
use constant PDPCP_ADDR_MEMI => 007;
use constant PDPCP_ADDR_R0 => 010;
use constant PDPCP_ADDR_PC => 017;
use constant PDPCP_ADDR_IBRB => 020;
use constant PDPCP_ADDR_IBR => 0200;
use constant PDPCP_FUNC_NOOP => 000;
use constant PDPCP_FUNC_STA => 001;
use constant PDPCP_FUNC_STO => 002;
use constant PDPCP_FUNC_CONT => 003;
use constant PDPCP_FUNC_STEP => 004;
use constant PDPCP_FUNC_RST => 017;
use constant LINUX_B57600 => 0010001; # B57600 not part of POSIX package !
use constant LINUX_B115200 => 0010002; # in linux these values are in
use constant LINUX_B230400 => 0010003; # termios.h, specifically in
use constant LINUX_B460800 => 0010004; # /usr/include/bits/termios.h
use constant LINUX_B500000 => 0010005;
use constant LINUX_B576000 => 0010006;
use constant LINUX_B921600 => 0010007;
use constant LINUX_B1000000 => 0010010;
use constant LINUX_B2000000 => 0010013;
use constant LINUX_B3000000 => 0010015;
use constant LINUX_CRTSCTS => 020000000000; # ! Not part of POSIX !!
use Getopt::Long;
my %opts = ();
GetOptions(\%opts, "help", "int", "trace",
"tio8", "tio9", "tiob",
"dserv", "tserv", "log:s",
"fifo:s", "term:s",
"timeout=f", "cmax=i",
"run=s",
)
or die "bad options";
sub init_regtbl; # initialize regtbl from reglist
sub get_command;
sub do_command;
sub read_command;
sub setpar_command;
sub nomode_open;
sub nomode_flush;
sub nomode_close;
sub nomode_cexec;
sub cpraw_open;
sub cpraw_flush;
sub cpraw_close;
sub cpraw_cexec;
sub do_cprx;
sub do_cptx;
sub cpraw_tx_match_now;
sub cpraw_tx_match;
sub rri_open;
sub rri_flush;
sub rri_close;
sub rri_cexec;
sub rri_cget_stat;
sub rri_cget_addr;
sub rri_cget_nblk;
sub rri_sideband;
sub rri_cmdlist_do;
sub rri_cmdlist_dump;
sub rri_cmdlist_exec;
sub rri_cmdlist_check_stat;
sub rri_cmdlist_get_rval;
sub rri_cmdlist_conv_rval;
sub rri_ref_check; # check reference data (1=err)
sub pdpcp_open;
sub pdpcp_flush;
sub pdpcp_close;
sub pdpcp_cexec;
sub pdpcp_cmd_rreg;
sub pdpcp_cmd_wreg;
sub serv11_open;
sub serv11_flush;
sub serv11_close;
sub serv11_cexec;
sub serv11_cexec_shoreg;
sub serv11_cexec_shommu_ssrx;
sub serv11_cexec_shommu_sadr;
sub serv11_cexec_ldabs;
sub serv11_cexec_shoconf;
sub serv11_cexec_shoatt;
sub serv11_cexec_attdet;
sub serv11_cexec_boot;
sub serv11_cexec_exa;
sub serv11_cexec_dep;
sub serv11_config;
sub serv11_init_dispatch;
sub serv11_server;
sub serv11_server_attn_get;
sub serv11_server_attn_dispatch;
sub serv11_probe_gen; # generic probe handler
sub serv11_init_gen; # generic controller init handler
sub serv11_detach_gen; # generic detach handler
sub serv11_attdet_disk; # generic disk att/det handler
sub serv11_attdet_ronly; # generic in only att/det handler
sub serv11_attdet_wonly; # generic out only att/det handler
sub serv11_attdet_term; # generic term att/det handler
sub serv11_probe_cpu; # cpu: probe handler
sub serv11_attn_cpu; # cpu: attention handler
sub serv11_exadep_cpu; # cpu: exa/dep handler
sub serv11_ichr_dl11;
sub serv11_attn_dl11;
sub serv11_uset_lp11;
sub serv11_attn_lp11;
sub serv11_uset_pc11;
sub serv11_attdet_pc11;
sub serv11_attn_pc11;
sub serv11_uset_rk11;
sub serv11_attn_rk11;
sub serv11_attn_rk11_logerr;
sub serv11_rdma_rk11;
sub serv11_icb_disk_read; # read one dsk file block
sub serv11_icb_disk_write; # write one dsk file block
sub serv11_rri_init; # issue rri init command
sub serv11_rri_attn; # issue rri attn command
sub serv11_rri_stat; # issue rri stat command
sub serv11_rri_rreg; # issue rri rreg command
sub serv11_rri_wreg; # issue rri wreg command
sub serv11_rri_rblk; # issue rri rblk command
sub serv11_rri_wblk; # issue rri wblk command
sub serv11_rri_lalh; # issue pdpcp lal and lah commands
sub serv11_rri_ibrb; # issue rbus set base address
sub serv11_rri_ribr; # issue rbus read
sub serv11_rri_wibr; # issue rbus write
sub serv11_rri_clear;
sub serv11_rri_exec;
sub serv11_rri_uset; # issue rbus uset writes
sub serv11_exec_rblk;
sub serv11_exec_wblk;
sub serv11_exec_probe;
sub next_nxbuf; # calculate next nxbuf value
sub telnet_readhdl; # telnet: socket read handler
sub telnet_writehdl; # telnet: write handler
sub pdp11_disassemble; # simple PDP11 disassembler
sub pdp11_disassemble_regmod; # helper
sub file_seek; # fseek wrapper
sub file_read; # fread wrapper
sub file_seek_read; # fseek+fread wrapper
sub file_write; # fwrite wrapper
sub file_seek_write; # fseek+fwrite wrapper
sub raw_get9_crc_16bit; # read 16 bit value
sub raw_get9_crc_8bit; # read 8bit value
sub raw_get9_crc_check; # get 9bit, block, crc, ref value
sub raw_get9_check; # get 9bit, block, expect ref value
sub raw_get9_checksop; # get 9bit, block, expect 'sop'
sub raw_get9_checkeop; # get 9bit, block, expect 'eop'
sub raw_get9_crc; # get 9bit, block, update crc
sub raw_get9; # get 9bit, block
sub raw_snd9_crc; # put 9bit to RX, update crc
sub raw_snd9; # put 9bit to RX
sub raw_snd8; # put 8bit to RX
sub raw_rcv9; # get 9bit from TX, non-blocking
sub raw_rcv8; # get 8bit from TX, non-blocking
sub raw_rcv9_to; # get 9bit from TX, expl. time-out
sub raw_rcv8_to; # get 8bit from TX, expl. time-out
sub wait_sel_filercv; # poll/wait for RCV to be ready
sub fifo_open; # chan fifo: open handler
sub fifo_close; # chan fifo: close handler
sub term_open; # chan term: open handler
sub term_close; # chan term: close handler
sub term_tios_print; # chan term: print termios state
sub genio_read; # generic io: read handler
sub genio_write; # generic io: write handler
sub cget_chkblank; # check for unused chars in cmd line
sub cget_tagval2_gdat; # get tag=v1[,v2], generic base
sub cget_tagval_gdat; # get tag=val, generic base
sub cget_gdat; # get generic base value
sub cget_name; # get name \w+
sub cget_bool; # get boolean [01]
sub cget_file; # get filename [\w\/.]+
sub cget_ucb; # get ucb (read name, return ucb)
sub cget_opt; # get option
sub cget_optset; # get option set
sub cget_regrange; # get register/memory range
sub cchk_number; # check for number. any gdat value
sub sget_bdat; # convert 01 string -> binary value
sub conv_etime; # generate timestamp string
sub conv_dat9;
sub conv_dat8;
sub conv_str2bytes; # string to bytelist; handle \n
sub conv_buf2wlist; # string buffer -> word list
sub conv_wlist2buf; # word list -> string buffer
sub conv_byte2ascii2; # byte -> 2 charcter ASCII display
sub gconv_dat16;
sub hdl_sigint; # SIGINT handler
sub get_time;
sub get_timestamp;
sub filename_expand; # expand $nnn in name
sub print_fatal;
sub print_help;
my %stat_tab = ( obyte => 0.,
oesc => 0.,
osop => 0.,
ibyte => 0.,
iesc => 0.,
att => 0.,
xreg => 0.,
xblk => 0.,
rdisk => 0.,
wdisk => 0.);
my %stat_tab_last = %stat_tab;
my %mode_tab = (nomode => {open => \&nomode_open,
flush => \&nomode_flush,
close => \&nomode_close,
cmd => \&nomode_cexec},
cpraw => {open => \&cpraw_open,
flush => \&cpraw_flush,
close => \&cpraw_close,
cmd => \&cpraw_cexec},
rri => {open => \&rri_open,
flush => \&rri_flush,
close => \&rri_close,
cmd => \&rri_cexec},
pdpcp => {open => \&pdpcp_open,
flush => \&pdpcp_flush,
close => \&pdpcp_close,
cmd => \&pdpcp_cexec},
serv11 => {open => \&serv11_open,
flush => \&serv11_flush,
close => \&serv11_close,
cmd => \&serv11_cexec}
);
my %chan_tab = (fifo => {open => \&fifo_open,
close => \&fifo_close,
read => \&genio_read,
write => \&genio_write},
term => {open => \&term_open,
close => \&term_close,
read => \&genio_read,
write => \&genio_write}
);
my $curmode = "nomode";
my $curcmd = \&nomode_cexec;
my $curchan = undef;
my @cmdfh;
my @cmdfn;
my @cmdargs;
my $time0 = -1;
my $tlast_tio8 = 0;
my $tlast_tio9 = 0;
my $tlast_tiob = 0;
my @que_rcv;
my @que_snd;
my @cpraw_tx_read;
my @cpraw_tx_expt;
my $fh_log = *STDOUT;
my $fh_snd;
my $fh_rcv;
my $fdset_filercv;
my $fifo_keep;
my $term_oldtios;
my $raw_rcv_esc = 0;
my $raw_timeout = 1.;
my $cmax = 16;
my $cmd_line;
my $cmd_rest;
my $cmd_bad;
my $cmd_inter; # interactive cmd flag
my $term;
if (-t STDIN) {
$term = new Term::ReadLine 'pi_rri';
}
my %par; # params for command line substitution
my $sigint_count = 0; # SIGINT counter
use constant TELNET_CODE_NULL => 0;
use constant TELNET_CODE_LF => 10;
use constant TELNET_CODE_CR => 13;
use constant TELNET_CODE_ESC => 27;
use constant TELNET_CODE_SE => 240;
use constant TELNET_CODE_NOP => 241;
use constant TELNET_CODE_IP => 244;
use constant TELNET_CODE_GA => 249;
use constant TELNET_CODE_SB => 250;
use constant TELNET_CODE_WILL => 251;
use constant TELNET_CODE_WONT => 252;
use constant TELNET_CODE_DO => 253;
use constant TELNET_CODE_DONT => 254;
use constant TELNET_CODE_IAC => 255;
use constant TELNET_OPT_BIN => 0;
use constant TELNET_OPT_ECHO => 1;
use constant TELNET_OPT_SGA => 3;
use constant TELNET_OPT_TTYP => 24;
use constant TELNET_OPT_LINE => 34;
use constant TELNET_STATE_LISTEN => -1;
use constant TELNET_STATE_STREAM => 0;
use constant TELNET_STATE_IAC => 1;
use constant TELNET_STATE_CMD => 2;
use constant TELNET_STATE_SUBNEG => 3;
use constant TELNET_STATE_SUBIAC => 4;
#
# %telnettbl->{snum} --> telnet session table, hash of hashes, key'ed by port
# -> {port} port number (int)
# -> {state} state: (_LISTEN|_STREAM|_IAC|_CMD|_SUBNEG|_SUBIAC)
# -> {fh_port} file handle of port socket (for listen)
# -> {fh_data} file handle of data socket
# -> {ucb} ucb the port is attached to
#
my %telnettbl;
my $rri_ref_sdef = 0x00; # by default check for 'hard' errors
my $rri_msk_sdef = 0xf0; # ignore the status bits + attn flag
my %rri_amtbl;
my @rri_cmdlist;
my $rri_rvalcnt = 0;
my $rri_ncmdmax = undef;
my $rri_dbasi = 2; # default input base
my $rri_dbaso = 8; # default output base
my $rri_nodfill = " " x 5; # filler string for "d=-" stanzas
my %rri_cname2cmd = (rreg => 0, # c_rri_cmd_rreg : slv3 := "000";
rblk => 1, # c_rri_cmd_rblk : slv3 := "001";
wreg => 2, # c_rri_cmd_wreg : slv3 := "010";
wblk => 3, # c_rri_cmd_wblk : slv3 := "011";
stat => 4, # c_rri_cmd_stat : slv3 := "100";
attn => 5, # c_rri_cmd_attn : slv3 := "101";
init => 6); # c_rri_cmd_init : slv3 := "110";
my @crc8_tbl = ( 0, 29, 58, 39, 116, 105, 78, 83, # from gen_crc8_tbl
232, 245, 210, 207, 156, 129, 166, 187,
205, 208, 247, 234, 185, 164, 131, 158,
37, 56, 31, 2, 81, 76, 107, 118,
135, 154, 189, 160, 243, 238, 201, 212,
111, 114, 85, 72, 27, 6, 33, 60,
74, 87, 112, 109, 62, 35, 4, 25,
162, 191, 152, 133, 214, 203, 236, 241,
19, 14, 41, 52, 103, 122, 93, 64,
251, 230, 193, 220, 143, 146, 181, 168,
222, 195, 228, 249, 170, 183, 144, 141,
54, 43, 12, 17, 66, 95, 120, 101,
148, 137, 174, 179, 224, 253, 218, 199,
124, 97, 70, 91, 8, 21, 50, 47,
89, 68, 99, 126, 45, 48, 23, 10,
177, 172, 139, 150, 197, 216, 255, 226,
38, 59, 28, 1, 82, 79, 104, 117,
206, 211, 244, 233, 186, 167, 128, 157,
235, 246, 209, 204, 159, 130, 165, 184,
3, 30, 57, 36, 119, 106, 77, 80,
161, 188, 155, 134, 213, 200, 239, 242,
73, 84, 115, 110, 61, 32, 7, 26,
108, 113, 86, 75, 24, 5, 34, 63,
132, 153, 190, 163, 240, 237, 202, 215,
53, 40, 15, 18, 65, 92, 123, 102,
221, 192, 231, 250, 169, 180, 147, 142,
248, 229, 194, 223, 140, 145, 182, 171,
16, 13, 42, 55, 100, 121, 94, 67,
178, 175, 136, 149, 198, 219, 252, 225,
90, 71, 96, 125, 46, 51, 20, 9,
127, 98, 69, 88, 11, 22, 49, 44,
151, 138, 173, 176, 227, 254, 217, 196);
my $ocrc = 0;
my $icrc = 0;
my $kpid = -1;
my @pdp11_opcode_tbl = (
{code=>0000000, mask=>0000000, name=>"halt", type=>"0arg"},
{code=>0000001, mask=>0000000, name=>"wait", type=>"0arg"},
{code=>0000002, mask=>0000000, name=>"rti ", type=>"0arg"},
{code=>0000003, mask=>0000000, name=>"bpt ", type=>"0arg"},
{code=>0000004, mask=>0000000, name=>"iot ", type=>"0arg"},
{code=>0000005, mask=>0000000, name=>"reset",type=>"0arg"},
{code=>0000006, mask=>0000000, name=>"rtt ", type=>"0arg"},
{code=>0000007, mask=>0000000, name=>"!!mfpt", type=>"0arg"},
{code=>0000100, mask=>0000077, name=>"jmp ", type=>"1arg"},
{code=>0000200, mask=>0000007, name=>"rts ", type=>"1reg"},
{code=>0000230, mask=>0000007, name=>"spl ", type=>"spl"},
{code=>0000240, mask=>0000017, name=>"cl", type=>"ccop"},
{code=>0000260, mask=>0000017, name=>"se", type=>"ccop"},
{code=>0000300, mask=>0000077, name=>"swap", type=>"1arg"},
{code=>0000400, mask=>0000377, name=>"br ", type=>"br"},
{code=>0001000, mask=>0000377, name=>"bne ", type=>"br"},
{code=>0001400, mask=>0000377, name=>"beq ", type=>"br"},
{code=>0002000, mask=>0000377, name=>"bge ", type=>"br"},
{code=>0002400, mask=>0000377, name=>"blt ", type=>"br"},
{code=>0003000, mask=>0000377, name=>"bgt ", type=>"br"},
{code=>0003400, mask=>0000377, name=>"ble ", type=>"br"},
{code=>0004000, mask=>0000777, name=>"jsr ", type=>"jsr"},
{code=>0005000, mask=>0000077, name=>"clr ", type=>"1arg"},
{code=>0005100, mask=>0000077, name=>"com ", type=>"1arg"},
{code=>0005200, mask=>0000077, name=>"inc ", type=>"1arg"},
{code=>0005300, mask=>0000077, name=>"dec ", type=>"1arg"},
{code=>0005400, mask=>0000077, name=>"neg ", type=>"1arg"},
{code=>0005500, mask=>0000077, name=>"adc ", type=>"1arg"},
{code=>0005600, mask=>0000077, name=>"sbc ", type=>"1arg"},
{code=>0005700, mask=>0000077, name=>"tst ", type=>"1arg"},
{code=>0006000, mask=>0000077, name=>"ror ", type=>"1arg"},
{code=>0006100, mask=>0000077, name=>"rol ", type=>"1arg"},
{code=>0006200, mask=>0000077, name=>"asr ", type=>"1arg"},
{code=>0006300, mask=>0000077, name=>"asl ", type=>"1arg"},
{code=>0006400, mask=>0000077, name=>"mark", type=>"mark"},
{code=>0006500, mask=>0000077, name=>"mfpi", type=>"1arg"},
{code=>0006600, mask=>0000077, name=>"mtpi", type=>"1arg"},
{code=>0006700, mask=>0000077, name=>"sxt ", type=>"1arg"},
{code=>0007000, mask=>0000077, name=>"!!csm", type=>"1arg"},
{code=>0007200, mask=>0000077, name=>"!!tstset",type=>"1arg"},
{code=>0007300, mask=>0000077, name=>"!!wrtlck",type=>"1arg"},
{code=>0010000, mask=>0007777, name=>"mov ", type=>"2arg"},
{code=>0020000, mask=>0007777, name=>"cmp ", type=>"2arg"},
{code=>0030000, mask=>0007777, name=>"bit ", type=>"2arg"},
{code=>0040000, mask=>0007777, name=>"bic ", type=>"2arg"},
{code=>0050000, mask=>0007777, name=>"bis ", type=>"2arg"},
{code=>0060000, mask=>0007777, name=>"add ", type=>"2arg"},
{code=>0070000, mask=>0000777, name=>"mul ", type=>"rdst"},
{code=>0071000, mask=>0000777, name=>"div ", type=>"rdst"},
{code=>0072000, mask=>0000777, name=>"ash ", type=>"rdst"},
{code=>0073000, mask=>0000777, name=>"ashc", type=>"rdst"},
{code=>0074000, mask=>0000777, name=>"xor ", type=>"rdst"},
{code=>0077000, mask=>0000777, name=>"sob ", type=>"sob"},
{code=>0100000, mask=>0000377, name=>"bpl ", type=>"br"},
{code=>0100400, mask=>0000377, name=>"bmi ", type=>"br"},
{code=>0101000, mask=>0000377, name=>"bhi ", type=>"br"},
{code=>0101400, mask=>0000377, name=>"blos", type=>"br"},
{code=>0102000, mask=>0000377, name=>"bvc ", type=>"br"},
{code=>0102400, mask=>0000377, name=>"bvs ", type=>"br"},
{code=>0103000, mask=>0000377, name=>"bcc ", type=>"br"},
{code=>0103400, mask=>0000377, name=>"bcs ", type=>"br"},
{code=>0104000, mask=>0000377, name=>"emt ", type=>"trap"},
{code=>0104400, mask=>0000377, name=>"trap", type=>"trap"},
{code=>0105000, mask=>0000077, name=>"clrb", type=>"1arg"},
{code=>0105100, mask=>0000077, name=>"comb", type=>"1arg"},
{code=>0105200, mask=>0000077, name=>"incb", type=>"1arg"},
{code=>0105300, mask=>0000077, name=>"decb", type=>"1arg"},
{code=>0105400, mask=>0000077, name=>"negb", type=>"1arg"},
{code=>0105500, mask=>0000077, name=>"adcb", type=>"1arg"},
{code=>0105600, mask=>0000077, name=>"sbcb", type=>"1arg"},
{code=>0105700, mask=>0000077, name=>"tstb", type=>"1arg"},
{code=>0106000, mask=>0000077, name=>"rorb", type=>"1arg"},
{code=>0106100, mask=>0000077, name=>"rolb", type=>"1arg"},
{code=>0106200, mask=>0000077, name=>"asrb", type=>"1arg"},
{code=>0106300, mask=>0000077, name=>"aslb", type=>"1arg"},
{code=>0106400, mask=>0000077, name=>"!!mtps", type=>"1arg"},
{code=>0106500, mask=>0000077, name=>"mfpd", type=>"1arg"},
{code=>0106600, mask=>0000077, name=>"mtpd", type=>"1arg"},
{code=>0106700, mask=>0000077, name=>"!!mfps", type=>"1arg"},
{code=>0110000, mask=>0007777, name=>"movb", type=>"2arg"},
{code=>0120000, mask=>0007777, name=>"cmpb", type=>"2arg"},
{code=>0130000, mask=>0007777, name=>"bitb", type=>"2arg"},
{code=>0140000, mask=>0007777, name=>"bicb", type=>"2arg"},
{code=>0150000, mask=>0007777, name=>"bisb", type=>"2arg"},
{code=>0160000, mask=>0007777, name=>"sub ", type=>"2arg"},
{code=>0170000, mask=>0000000, name=>"!!cfcc", type=>"0arg"},
{code=>0170001, mask=>0000000, name=>"!!setf", type=>"0arg"},
{code=>0170011, mask=>0000000, name=>"!!setd", type=>"0arg"},
{code=>0170002, mask=>0000000, name=>"!!seti", type=>"0arg"},
{code=>0170012, mask=>0000000, name=>"!!setl", type=>"0arg"},
{code=>0170100, mask=>0000077, name=>"!!ldfps",type=>"1fpp"},
{code=>0170200, mask=>0000077, name=>"!!stfps",type=>"1fpp"},
{code=>0170300, mask=>0000077, name=>"!!stst", type=>"1fpp"},
{code=>0170400, mask=>0000077, name=>"!!clrf", type=>"1fpp"},
{code=>0170500, mask=>0000077, name=>"!!tstf", type=>"1fpp"},
{code=>0170600, mask=>0000077, name=>"!!absf", type=>"1fpp"},
{code=>0170700, mask=>0000077, name=>"!!negf", type=>"1fpp"},
{code=>0171000, mask=>0000377, name=>"!!mulf", type=>"rfpp"},
{code=>0171400, mask=>0000377, name=>"!!modf", type=>"rfpp"},
{code=>0172000, mask=>0000377, name=>"!!addf", type=>"rfpp"},
{code=>0172400, mask=>0000377, name=>"!!ldf", type=>"rfpp"},
{code=>0173000, mask=>0000377, name=>"!!subf", type=>"rfpp"},
{code=>0173400, mask=>0000377, name=>"!!cmpf", type=>"rfpp"},
{code=>0174000, mask=>0000377, name=>"!!stf", type=>"rfpp"},
{code=>0174400, mask=>0000377, name=>"!!divf", type=>"rfpp"},
{code=>0175000, mask=>0000377, name=>"!!stexp",type=>"rfpp"},
{code=>0175400, mask=>0000377, name=>"!!stcif",type=>"rfpp"},
{code=>0176000, mask=>0000377, name=>"!!stcfd",type=>"rfpp"},
{code=>0176400, mask=>0000377, name=>"!!ldexp",type=>"rfpp"},
{code=>0177000, mask=>0000377, name=>"!!ldcif",type=>"rfpp"},
{code=>0177400, mask=>0000377, name=>"!!ldcdf",type=>"rfpp"}
);
use constant BIT00 => 0000001;
use constant BIT01 => 0000002;
use constant BIT02 => 0000004;
use constant BIT03 => 0000010;
use constant BIT04 => 0000020;
use constant BIT05 => 0000040;
use constant BIT06 => 0000100;
use constant BIT07 => 0000200;
use constant BIT08 => 0000400;
use constant BIT09 => 0001000;
use constant BIT10 => 0002000;
use constant BIT11 => 0004000;
use constant BIT12 => 0010000;
use constant BIT13 => 0020000;
use constant BIT14 => 0040000;
use constant BIT15 => 0100000;
use constant REGATTR_RBMBOX => 0000001; # rbus is mailbox, skip on exa loop
use constant REGATTR_RBRD => 0000002; # by default read on rbus
use constant REGATTR_RBWR => 0000004; # by default write on rbus
use constant REGATTR_IBMBOX => 0000010; # ibus is mailbox, skip on exa loop
# some common defs
my @partbl_nxbuf = ( nxbuf_min => { type => "hval:d" },
nxbuf_inc => { type => "hval:d" },
nxbuf_max => { type => "hval:d" },
nxbuf => { type => "hval:d" } );
# CPU general defs
use constant CPU_MMR3 => 0172516;
use constant CPU_SDREG => 0177570;
use constant CPU_MMR0 => 0177572;
use constant CPU_MMR1 => 0177574;
use constant CPU_MMR2 => 0177576;
use constant CPU_LOSIZE => 0177760;
use constant CPU_HISIZE => 0177762;
use constant CPU_SYSID => 0177764;
use constant CPU_CPUERR => 0177766;
use constant CPU_MBRK => 0177770;
use constant CPU_PIRQ => 0177772;
use constant CPU_STKLIM => 0177774;
use constant CPU_PSW => 0177776;
# DL11 general defs
use constant DL11_BASE_A => 0177560;
use constant DL11_BASE_B => 0176500;
# DL11 address offsets
use constant DL11_RCSR => 00;
use constant DL11_RBUF => 02;
use constant DL11_XCSR => 04;
use constant DL11_XBUF => 06;
# DL11 register defs
use constant DL11_RCSR_M_RDONE => BIT07;
use constant DL11_XCSR_M_XRDY => BIT07;
use constant DL11_XBUF_M_RRDY => BIT09;
use constant DL11_XBUF_M_XVAL => BIT08;
use constant DL11_XBUF_M_XBUF => 0377;
my @reglist_dl11 = ({name => "rcsr",
offset => DL11_RCSR},
{name => "rbuf",
offset => DL11_RBUF,
attr => REGATTR_IBMBOX},
{name => "xcsr",
offset => DL11_XCSR},
{name => "xbuf",
offset => DL11_XBUF,
attr => REGATTR_RBMBOX});
my %partbl_dl11 = ( trace => { type => "hval:b" },
@partbl_nxbuf );
# LP11 general defs
use constant LP11_BASE => 0177514;
# LP11 address offsets
use constant LP11_CSR => 00;
use constant LP11_BUF => 02;
# LP11 register defs
use constant LP11_CSR_M_ERR => BIT15;
use constant LP11_BUF_M_VAL => BIT08;
use constant LP11_BUF_M_BUF => 0177;
my @reglist_lp11 = ({name => "csr",
offset => LP11_CSR},
{name => "buf",
offset => LP11_BUF,
attr => REGATTR_RBMBOX});
my %partbl_lp11 = ( trace => { type => "hval:b" },
@partbl_nxbuf );
# PC11 address offsets
use constant PC11_RCSR => 00;
use constant PC11_RBUF => 02;
use constant PC11_PCSR => 04;
use constant PC11_PBUF => 06;
# PC11 register defs
use constant PC11_RCSR_M_ERR => BIT15;
use constant PC11_PCSR_M_ERR => BIT15;
use constant PC11_PBUF_M_RBUSY => BIT09;
use constant PC11_PBUF_M_PVAL => BIT08;
use constant PC11_PBUF_M_PBUF => 0377;
my @reglist_pc11 = ({name => "rcsr",
offset => PC11_RCSR},
{name => "rbuf",
offset => PC11_RBUF,
attr => REGATTR_IBMBOX},
{name => "pcsr",
offset => PC11_PCSR},
{name => "pbuf",
offset => PC11_PBUF,
attr => REGATTR_RBMBOX});
my %partbl_pc11 = ( trace => { type => "hval:b" },
@partbl_nxbuf );
# RK11 general defs
use constant RK11_BASE => 0177400;
use constant RK11_NUMSE => 12; # number of sectors
use constant RK11_NUMHD => 2; # number of heads
use constant RK11_NUMCY => 203; # number of cylinders
use constant RK11_NUMDR => 8; # number of drives
use constant RK11_NUMBL => RK11_NUMSE * RK11_NUMHD * RK11_NUMCY;
use constant RK11_BLKSIZE => 512; # disk block size
use constant RK11_VOLSIZE => RK11_BLKSIZE * RK11_NUMBL; # disk volume size
# RK11 address offsets
use constant RK11_RKDS => 00;
use constant RK11_RKER => 02;
use constant RK11_RKCS => 04;
use constant RK11_RKWC => 06;
use constant RK11_RKBA => 010;
use constant RK11_RKDA => 012;
use constant RK11_RKMR => 014;
# RK11 register defs
use constant RKDS_M_ID => 0160000; # ID: drive number
use constant RKDS_V_ID => 13;
use constant RKDS_B_ID => 0007;
use constant RKDS_M_HDEN => BIT11; # HDEN: high density drive (rk05)
use constant RKDS_M_DRU => BIT10; # DRU: drive unsafe
use constant RKDS_M_SIN => BIT09; # SIN: seek incomplete
use constant RKDS_M_SOK => BIT08; # SOK: sector counter OK
use constant RKDS_M_DRY => BIT07; # DRY: drive ready
use constant RKDS_M_ADRY => BIT06; # ADRY: access ready
use constant RKDS_M_WPS => BIT05; # WPS: write protect
use constant RKDS_B_SC => 0017; # SC: sector counter
use constant RKER_M_DRE => BIT15; # DRE: drive error
use constant RKER_M_OVR => BIT14; # OVR: overrun
use constant RKER_M_WLO => BIT13; # WLO: write lock violation
use constant RKER_M_PGE => BIT11; # PGE: programming error
use constant RKER_M_NXM => BIT10; # NXM: non existent memory
use constant RKER_M_NXD => BIT07; # NXD: non existent drive
use constant RKER_M_NXC => BIT06; # NXC: non existent cylinder
use constant RKER_M_NXS => BIT05; # NXS: non existent sector
use constant RKER_M_CSE => BIT01; # CSE: check sum error
use constant RKER_M_WCE => BIT00; # WCE: write check error
use constant RKCS_M_MAINT => BIT12; # MAINT: maintenance mode
use constant RKCS_M_IBA => BIT11; # IBA: inhibit increment RKBA
use constant RKCS_M_FMT => BIT10; # FMT: format
use constant RKCS_M_RWA => BIT09; # RWA: read-write all
use constant RKCS_M_SSE => BIT08; # SSE: stop on soft errors
use constant RKCS_M_MEX => 0000060; # MEX: memory extension
use constant RKCS_V_MEX => 4;
use constant RKCS_B_MEX => 0003;
use constant RKCS_V_FUNC => 1; # FUNC: function
use constant RKCS_B_FUNC => 0007;
use constant RKCS_CRESET => 0;
use constant RKCS_WRITE => 1;
use constant RKCS_READ => 2;
use constant RKCS_WCHK => 3;
use constant RKCS_SEEK => 4;
use constant RKCS_RCHK => 5;
use constant RKCS_DRESET => 6;
use constant RKCS_WLOCK => 7;
use constant RKCS_M_GO => BIT00; # GO: go bit
use constant RKDA_M_DRSEL => 0160000; # DRSEL: drive number
use constant RKDA_V_DRSEL => 13;
use constant RKDA_B_DRSEL => 0007;
use constant RKDA_M_CYL => 0017740; # CYL: cyclinder address
use constant RKDA_V_CYL => 5;
use constant RKDA_B_CYL => 0377;
use constant RKDA_M_SUR => 0000020; # SUR: surface
use constant RKDA_V_SUR => 4;
use constant RKDA_B_SUR => 0001;
use constant RKDA_B_SC => 0017; # SC: sector address
use constant RKMR_M_RID => 0160000; # RID: drive id for RKDS RB read
use constant RKMR_V_RID => 13;
use constant RKMR_V_CRDONE => 11; # CRDONE: control reset done
use constant RKMR_V_SBCLR => 10; # SBCLR: clear SBUSY's with SDONE
use constant RKMR_V_CRESET => 9; # CRESET: initiate control reset
use constant RKMR_V_FDONE => 8; # FDONE: initiate function done
my @reglist_rk11 = ({name => "rkds",
offset => RK11_RKDS},
{name => "rker",
offset => RK11_RKER},
{name => "rkcs",
offset => RK11_RKCS},
{name => "rkwc",
offset => RK11_RKWC},
{name => "rkba",
offset => RK11_RKBA},
{name => "rkda",
offset => RK11_RKDA},
{name => "rkmr",
offset => RK11_RKMR});
my %partbl_rk11 = ( trace => { type => "hval:b" } );
# KWP general defs
my @reglist_kwp = ({name => "csr",
offset => 0},
{name => "csb",
offset => 2},
{name => "ctr",
offset => 4});
# KWL general defs
my @reglist_kwl = ({name => "csr",
offset => 0});
# IIST general defs
my @reglist_iist = ({name => "acr",
offset => 0},
{name => "adr",
offset => 2});
use constant BOOT_START => 02000;
my $serv11_fds_update = 1;
my $serv11_config_done = 0;
my $serv11_init_pending = 1;
my $serv11_rdma_chunk = 256;
my $serv11_init_anena = 0x8000; # enable attn
#my $serv11_init_anena = 0xC03f; # enable attn+ioto(63ms)
#
# %serv11_ctltbl->{dev} --> controller table; is hash of hashes
# -> {ctlname} controller name
# -> {ctltype} controller type (e.g. DL11)
# -> {devname} device name
# -> {type} device type: term, lpr, ptap, disk, tape, eth
# -> {units} array of unit names
# -> {base} controller base address
# -> {ibrb} controller base mapping for remote ib access
# -> {csroff} csr offset from base (for probing)
# -> {lam} lam number used by controller
# -> {nxbuf_min} nxbuf: minimal vector size
# -> {nxbuf_inc} nxbuf: vector size increment
# -> {nxbuf_max} nxbuf: maximal vector size
# -> {probehdl} address of probe handler
# -> {probemask} sides to be tested (set to "ir" if missing)
# -> {ichrhdl} address of input character handler
# -> {inithdl} address of controler init handler
# -> {usethdl} address of unit setup handler
# -> {attdethdl} address of attach/detach handler
# -> {attnhdl} address og attention handler
# -> {reglist} register list (array of regdsc's)
# -> {regtbl} register table (by name, created by ...)
# -> {partbl} parameter table (array of pardsc's)
# -> {blksize} block size (in bytes) {for disk}
# -> {volsize} volume size (in bytes) {for disk}
# -> {boot_mode} boot mode: "ptape" undef
# -> {boot_base} base address for boot code if not BOOT_START {for ptap}
# -> {boot_mode} boot mode: "ptape" undef
# -> {boot_entry} boot code entry point, relative to BOOT_START
# -> {boot_unit} offset from BOOT_START where unit number is stored
# -> {boot_code} array with boot loader code
#
# -> {memsize} memory size {for cpu}
#
# -> {nxbuf} nxbuf: current value
# -> {probe_ival} defined if cpu side probing ok
# -> {probe_rval} defined if rem side probing ok
# -> {probe_ok} true if required sides available (see probe_mask)
# -> {probe_text} text for "sho conf" generated during probe
my %serv11_ctltbl = (
CPU =>
{ ctlname => "CPU",
ctltype => "W11A",
type => "cpu",
base => CPU_PSW, # use psw to get it to top of list
lam => 0,
probehdl => \&serv11_probe_cpu,
probemask => "i",
attnhdl => \&serv11_attn_cpu,
reglist => [ ],
partbl => { }
},
TTA =>
{ ctlname => "TTA",
ctltype => "DL11",
devname => "TT",
type => "term",
units => ["TT0"],
base => DL11_BASE_A,
ibrb => DL11_BASE_A & ~(077),
csroff => 0,
lam => 1,
nxbuf_min => 2, # to disable nxbuf mechanism use
nxbuf_inc => 2, # min=1, inc=0, max=1
nxbuf_max => 8, # otherwise: min=2,inc=2,max=8
trace => 1,
probehdl => \&serv11_probe_gen,
ichrhdl => \&serv11_ichr_dl11,
attdethdl => \&serv11_attdet_term,
attnhdl => \&serv11_attn_dl11,
reglist => [ @reglist_dl11 ],
partbl => { %partbl_dl11 }
},
TTB =>
{ ctlname => "TTB",
ctltype => "DL11",
devname => "TT",
type => "term",
units => ["TT1"],
base => DL11_BASE_B,
ibrb => DL11_BASE_B & ~(077),
csroff => 0,
lam => 2,
nxbuf_min => 2,
nxbuf_inc => 2,
nxbuf_max => 8,
trace => 1,
probehdl => \&serv11_probe_gen,
ichrhdl => \&serv11_ichr_dl11,
attdethdl => \&serv11_attdet_term,
attnhdl => \&serv11_attn_dl11,
reglist => [ @reglist_dl11 ],
partbl => { %partbl_dl11 }
},
DZ =>
{ ctlname => "DZ",
ctltype => "DZ11",
devname => "DZ",
type => "term",
units => ["DZ0","DZ1","DZ2","DZ3","DZ4","DZ5","DZ6","DZ7"],
base => 0160100,
ibrb => 0160100 & ~(077),
csroff => 0,
lam => 3,
probehdl => \&serv11_probe_gen
},
LP =>
{ ctlname => "LP",
ctltype => "LP11",
devname => "LP",
type => "lpr",
units => ["LP0"],
base => 0177514,
ibrb => 0177514 & ~(077),
csroff => 0,
lam => 8,
nxbuf_min => 2, # to disable nxbuf mechanism use
nxbuf_inc => 2, # min=1, inc=0, max=1
nxbuf_max => 8, # otherwise: min=2,inc=2,max=8
trace => 1,
probehdl => \&serv11_probe_gen,
inithdl => \&serv11_init_gen,
usethdl => \&serv11_uset_lp11,
attdethdl => \&serv11_attdet_wonly,
attnhdl => \&serv11_attn_lp11,
reglist => [ @reglist_lp11 ],
partbl => { %partbl_lp11 }
},
PC =>
{ ctlname => "PC",
ctltype => "PC11",
devname => "PC",
type => "ptap",
units => ["PTR","PTP"],
base => 0177550,
ibrb => 0177550 & ~(077),
csroff => 0,
lam => 10,
nxbuf_min => 2,
nxbuf_inc => 2,
nxbuf_max => 8,
trace => 1,
probehdl => \&serv11_probe_gen,
usethdl => \&serv11_uset_pc11,
attdethdl => \&serv11_attdet_pc11,
attnhdl => \&serv11_attn_pc11,
reglist => [ @reglist_pc11 ],
partbl => { %partbl_pc11 },
boot_mode => "ptape",
boot_base => 0017476,
boot_entry=> 0017500,
boot_code => [ # papertape lda loader, from dec-11-l2pc-po
0000000, # C000: halt
0010706, # astart: mov pc,sp
0024646, # cmp -(sp),-(sp)
0010705, # mov pc,r5
0062705, 0000112, # add #000112,r5
0005001, # clr r1
0013716, 0177570, # B000: mov @#cp.dsr,(sp)
0006016, # ror (sp)
0103402, # bcs B001
0005016, # clr (sp)
0000403, # br B002
0006316, # B001: asl (sp)
0001001, # bne B002
0010116, # mov r1,(sp)
0005000, # B002: clr r0
0004715, # jsr pc,(r5)
0105303, # decb r3
0001374, # bne B002
0004715, # jsr pc,(r5)
0004767, 0000074, # jsr pc,R000
0010402, # mov r4,r2
0162702, 0000004, # sub #000004,r2
0022702, 0000002, # cmp #000002,r2
0001441, # beq B007
0004767, 0000054, # jsr pc,R000
0061604, # add (sp),r4
0010401, # mov r4,r1
0004715, # B003: jsr pc,(r5)
0002004, # bge B005
0105700, # tstb r0
0001753, # beq B002
0000000, # B004: halt
0000751, # br B002
0110321, # B005: movb r3,(r1)+
0000770, # br B003
0016703, 0000152, # ldchr: mov p.prcs,r3
0105213, # incb (r3)
0105713, # B006: tstb (r3)
0100376, # bpl B006
0116303, 0000002, # movb 000002(r3),r3
0060300, # add r3,r0
0042703, 0177400, # bic #177400,r3
0005302, # dec r2
0000207, # rts pc
0012667, 0000046, # R000: mov (sp)+,D000
0004715, # jsr pc,(r5)
0010304, # mov r3,r4
0004715, # jsr pc,(r5)
0000303, # swap r3
0050304, # bis r3,r4
0016707, 0000030, # mov D000,pc
0004767, 0177752, # B007: jsr pc,R000
0004715, # jsr pc,(r5)
0105700, # tstb r0
0001342, # bne B004
0006204, # asr r4
0103002, # bcc B008
0000000, # halt
0000700, # br B000
0006304, # B008: asl r4
0061604, # add (sp),r4
0000114, # jmp (r4)
0000000, # D000: .word 000000
0012767, 0000352, 0000020, # L000: mov #000352,B009+2
0012767, 0000765, 0000034, # mov #000765,D001
0000167, 0177532, # jmp C000
0016701, 0000026, # bstart: mov p.prcs,r1
0012702, 0000352, # B009: mov #000352,r2
0005211, # inc (r1)
0105711, # B010: tstb (r1)
0100376, # bpl B010
0116162, 0000002, 0157400, # movb 000002(r1),157400(r2)
0005267, 0177756, # inc B009+2
0000765, # D001: br B009
0177550 # p.prcs: .word 177550
]
},
RK =>
{ ctlname => "RK",
ctltype => "RK11/RK05",
devname => "RK",
type => "disk",
units => ["RK0","RK1","RK2","RK3","RK4","RK5","RK6","RK7"],
base => RK11_BASE,
ibrb => RK11_BASE & ~(077),
csroff => 4,
lam => 4,
trace => 1,
probehdl => \&serv11_probe_gen,
inithdl => \&serv11_init_gen,
usethdl => \&serv11_uset_rk11,
attdethdl => \&serv11_attdet_disk,
attnhdl => \&serv11_attn_rk11,
reglist => [ @reglist_rk11 ],
partbl => { %partbl_rk11 },
blksize => RK11_BLKSIZE,
volsize => RK11_VOLSIZE,
boot_entry=> BOOT_START + 002,
boot_unit => BOOT_START + 010,
boot_code => [ # rk05 boot loader - from simh pdp11_rk.c
0042113, # "KD"
0012706, BOOT_START, # MOV #boot_start, SP
0012700, 0000000, # MOV #unit, R0 ; unit number
0010003, # MOV R0, R3
0000303, # SWAB R3
0006303, # ASL R3
0006303, # ASL R3
0006303, # ASL R3
0006303, # ASL R3
0006303, # ASL R3
0012701, 0177412, # MOV #RKDA, R1 ; rkda
0010311, # MOV R3, (R1) ; load da
0005041, # CLR -(R1) ; clear ba
0012741, 0177000, # MOV #-256.*2, -(R1) ; load wc
0012741, 0000005, # MOV #READ+GO, -(R1) ; read & go
0005002, # CLR R2
0005003, # CLR R3
0012704, BOOT_START+020, # MOV #START+20, R4
0005005, # CLR R5
0105711, # TSTB (R1)
0100376, # BPL .-2
0105011, # CLRB (R1)
0005007 # CLR PC (5007)
]
},
RL =>
{ ctlname => "RL",
ctltype => "RL11/RL02",
devname => "RL",
type => "disk",
units => ["RL0","RL1","RL2","RL3"],
base => 0174400,
ibrb => 0174400 & ~(077),
csroff => 0, # ???CHECK-ME???
lam => 5,
probehdl => \&serv11_probe_gen,
boot_entry=> BOOT_START + 002,
boot_unit => BOOT_START + 010,
boot_code => [ # rl02 boot loader - from simh pdp11_rl.c
0042114, # "LD"
0012706, BOOT_START, # MOV #boot_start, SP
0012700, 0000000, # MOV #unit, R0
0010003, # MOV R0, R3
0000303, # SWAB R3
0012701, 0174400, # MOV #RLCS, R1 ; csr
0012761, 0000013, 0000004, # MOV #13, 4(R1) ; clr err
0052703, 0000004, # BIS #4, R3 ; unit+gstat
0010311, # MOV R3, (R1) ; issue cmd
0105711, # TSTB (R1) ; wait
0100376, # BPL .-2
0105003, # CLRB R3
0052703, 0000010, # BIS #10, R3 ; unit+rdhdr
0010311, # MOV R3, (R1) ; issue cmd
0105711, # TSTB (R1) ; wait
0100376, # BPL .-2
0016102, 0000006, # MOV 6(R1), R2 ; get hdr
0042702, 0000077, # BIC #77, R2 ; clr sector
0005202, # INC R2 ; magic bit
0010261, 0000004, # MOV R2, 4(R1) ; seek to 0
0105003, # CLRB R3
0052703, 0000006, # BIS #6, R3 ; unit+seek
0010311, # MOV R3, (R1) ; issue cmd
0105711, # TSTB (R1) ; wait
0100376, # BPL .-2
0005061, 0000002, # CLR 2(R1) ; clr ba
0005061, 0000004, # CLR 4(R1) ; clr da
0012761, 0177000, 0000006, # MOV #-512., 6(R1) ; set wc
0105003, # CLRB R3
0052703, 0000014, # BIS #14, R3 ; unit+read
0010311, # MOV R3, (R1) ; issue cmd
0105711, # TSTB (R1) ; wait
0100376, # BPL .-2
0042711, 0000377, # BIC #377, (R1)
0005002, # CLR R2
0005003, # CLR R3
0012704, BOOT_START+020, # MOV #START+20, R4
0005005, # CLR R5
0005007 # CLR PC
]
},
RP =>
{ ctlname => "RP",
ctltype => "RH70/RP06",
devname => "RP",
type => "disk",
units => ["RP0","RP1","RP2","RP3"],
base => 0176700,
ibrb => 0176700 & ~(077),
csroff => 0, # ???CHECK-ME???
lam => 6,
probehdl => \&serv11_probe_gen,
boot_entry=> BOOT_START + 002,
boot_unit => BOOT_START + 010,
boot_code => [ # rp/rm boot loader - from simh pdp11_rp.c
0042102, # "BD"
0012706, BOOT_START, # mov #boot_start, sp
0012700, 0000000, # mov #unit, r0
0012701, 0176700, # mov #RPCS1, r1
0012761, 0000040, 0000010, # mov #CS2_CLR, 10(r1) ; reset
0010061, 0000010, # mov r0, 10(r1) ; set unit
0012711, 0000021, # mov #RIP+GO, (r1) ; pack ack
0012761, 0010000, 0000032, # mov #FMT16B, 32(r1) ; 16b mode
0012761, 0177000, 0000002, # mov #-512., 2(r1) ; set wc
0005061, 0000004, # clr 4(r1) ; clr ba
0005061, 0000006, # clr 6(r1) ; clr da
0005061, 0000034, # clr 34(r1) ; clr cyl
0012711, 0000071, # mov #READ+GO, (r1) ; read
0105711, # tstb (r1) ; wait
0100376, # bpl .-2
0005002, # clr R2
0005003, # clr R3
0012704, BOOT_START+020, # mov #start+020, r4
0005005, # clr R5
0105011, # clrb (r1)
0005007 # clr PC
]
},
TM =>
{ ctlname => "TM",
ctltype => "TM11",
devname => "TM",
type => "tape",
units => ["TM0","TM1","TM2","TM3","TM4","TM5","TM6","TM7"],
base => 0172520,
ibrb => 0172520 & ~(077),
csroff => 2,
lam => 7,
probehdl => \&serv11_probe_gen,
boot_entry=> BOOT_START + 002,
boot_unit => BOOT_START + 010,
boot_code => [ # tm11 boot2 (skip 1st record) - from simh pdp11_tm.c
0046524, # boot_start: "TM"
0012706, BOOT_START, # mov #boot_start, sp
0012700, 0000000, # mov #unit_num, r0
0012701, 0172526, # mov #172526, r1 ; mtcma
0005011, # clr (r1)
0012741, 0177777, # mov #-1, -(r1) ; mtbrc
0010002, # mov r0,r2
0000302, # swab r2
0062702, 0060011, # add #60011, r2
0010241, # mov r2, -(r1) ; space + go
0105711, # tstb (r1) ; mtc
0100376, # bpl .-2
0010002, # mov r0,r2
0000302, # swab r2
0062702, 0060003, # add #60003, r2
0010211, # mov r2, (r1) ; read + go
0105711, # tstb (r1) ; mtc
0100376, # bpl .-2
0005002, # clr r2
0005003, # clr r3
0012704, BOOT_START+020, # mov #boot_start+20, r4
0005005, # clr r5
0005007 # clr r7
]
},
XU =>
{ ctlname => "XU",
ctltype => "DENUA",
devname => "XU",
type => "eth",
units => ["XU0"],
base => 0174510,
ibrb => 0174510 & ~(077),
csroff => 0,
lam => 9,
probehdl => \&serv11_probe_gen
},
KWP =>
{ ctlname => "KWP",
ctltype => "KW11-P",
devname => "--",
type => "misc",
base => 0172540,
probehdl => \&serv11_probe_gen,
probemask => "i",
reglist => [ @reglist_kwp ]
},
KWL =>
{ ctlname => "KWL",
ctltype => "KW11-L",
devname => "--",
type => "misc",
base => 0177546,
probehdl => \&serv11_probe_gen,
probemask => "i",
reglist => [ @reglist_kwl ]
},
IIS =>
{ ctlname => "IIS",
ctltype => "IIST",
devname => "--",
type => "misc",
base => 0177500,
probehdl => \&serv11_probe_gen,
probemask => "i",
reglist => [ @reglist_iist ]
}
);
#
# %serv11_unittbl->{unit} --> unit table; is hash of hashes
# -> {unitname} unit name
# -> {ctlname} controller name
# -> {ctlunit} unit number of controller {ctlname}
# -> {devunit} device number for device $ucb->{ctlname}->{devname}
# -> {rcvque} receive queue {for term}
# -> {sndque} send queue {for term}
# -> {rcv7bit} use only 7 bits in receive {for term}
# -> {logfile} name of logfile
# -> {logfh} file handle for logfile
#
my %serv11_unittbl = (
TT0 => { unitname => "TT0",
ctlname => "TTA",
ctlunit => 0,
devunit => 0,
rcvque => [],
sndque => [],
rcv7bit => 1,
logfile => "pi_tt0.log",
logfh => undef
},
TT1 => { unitname => "TT1",
ctlname => "TTB",
ctlunit => 0,
devunit => 1,
rcvque => [],
sndque => [],
rcv7bit => 1,
logfile => "pi_tt1.log",
logfh => undef
},
DZ0 => { unitname => "DZ0",
ctlname => "DZ",
ctlunit => 0,
devunit => 0,
rcvque => [],
sndque => []
},
DZ1 => { unitname => "DZ1",
ctlname => "DZ",
ctlunit => 1,
devunit => 1,
rcvque => [],
sndque => []
},
DZ2 => { unitname => "DZ2",
ctlname => "DZ",
ctlunit => 2,
devunit => 2,
rcvque => [],
sndque => []
},
DZ3 => { unitname => "DZ3",
ctlname => "DZ",
ctlunit => 3,
devunit => 3,
rcvque => [],
sndque => []
},
DZ4 => { unitname => "DZ4",
ctlname => "DZ",
ctlunit => 4,
devunit => 4,
rcvque => [],
sndque => []
},
DZ5 => { unitname => "DZ5",
ctlname => "DZ",
ctlunit => 5,
devunit => 5,
rcvque => [],
sndque => []
},
DZ6 => { unitname => "DZ6",
ctlname => "DZ",
ctlunit => 6,
devunit => 6,
rcvque => [],
sndque => []
},
DZ7 => { unitname => "DZ7",
ctlname => "DZ",
ctlunit => 7,
devunit => 7,
rcvque => [],
sndque => []
},
LP0 => { unitname => "LP0",
ctlname => "LP",
ctlunit => 0,
devunit => 0,
logfile => "pi_lp0.log",
logfh => undef
},
PTR => { unitname => "PTR",
ctlname => "PC",
ctlunit => 0,
devunit => 0
},
PTP => { unitname => "PTP",
ctlname => "PC",
ctlunit => 1,
devunit => 1
},
RK0 => { unitname => "RK0",
ctlname => "RK",
ctlunit => 0,
devunit => 0
},
RK1 => { unitname => "RK1",
ctlname => "RK",
ctlunit => 1,
devunit => 1
},
RK2 => { unitname => "RK2",
ctlname => "RK",
ctlunit => 2,
devunit => 2
},
RK3 => { unitname => "RK3",
ctlname => "RK",
ctlunit => 3,
devunit => 3
},
RK4 => { unitname => "RK4",
ctlname => "RK",
ctlunit => 4,
devunit => 4
},
RK5 => { unitname => "RK5",
ctlname => "RK",
ctlunit => 5,
devunit => 5
},
RK6 => { unitname => "RK6",
ctlname => "RK",
ctlunit => 6,
devunit => 6
},
RK7 => { unitname => "RK7",
ctlname => "RK",
ctlunit => 7,
devunit => 7
},
RL0 => { unitname => "RL0",
ctlname => "RL",
ctlunit => 0,
devunit => 0
},
RL1 => { unitname => "RL1",
ctlname => "RL",
ctlunit => 1,
devunit => 1
},
RL2 => { unitname => "RL2",
ctlname => "RL",
ctlunit => 2,
devunit => 2
},
RL3 => { unitname => "RL3",
ctlname => "RL",
ctlunit => 3,
devunit => 3
},
RP0 => { unitname => "RP0",
ctlname => "RP",
ctlunit => 0,
devunit => 0
},
RP1 => { unitname => "RP1",
ctlname => "RP",
ctlunit => 1,
devunit => 1
},
RP2 => { unitname => "RP2",
ctlname => "RP",
ctlunit => 2,
devunit => 2
},
RP3 => { unitname => "RP3",
ctlname => "RP",
ctlunit => 3,
devunit => 3
},
TM0 => { unitname => "TM0",
ctlname => "TM",
ctlunit => 0,
devunit => 0
},
TM1 => { unitname => "TM1",
ctlname => "TM",
ctlunit => 1,
devunit => 1
},
TM2 => { unitname => "TM2",
ctlname => "TM",
ctlunit => 2,
devunit => 2
},
TM3 => { unitname => "TM3",
ctlname => "TM",
ctlunit => 3,
devunit => 3
},
TM4 => { unitname => "TM4",
ctlname => "TM",
ctlunit => 4,
devunit => 4
},
TM5 => { unitname => "TM5",
ctlname => "TM",
ctlunit => 5,
devunit => 5
},
TM6 => { unitname => "TM6",
ctlname => "TM",
ctlunit => 6,
devunit => 6
},
TM7 => { unitname => "TM7",
ctlname => "TM",
ctlunit => 7,
devunit => 7
},
XU0 => { unitname => "XU0",
ctlname => "XU",
ctlunit => 0,
devunit => 0
}
);
my @serv11_attntbl;
my $serv11_active = 0;
my $serv11_attn_mask = 0;
my $serv11_attn_seen = 0;
my @serv11_icbque = ();
my $only_argv = 0;
$only_argv = 1 if scalar(@ARGV) > 0;
$only_argv = 0 if exists $opts{int};
#
# -- Main program starts here ------------------------------------------------
#
autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
autoflush STDOUT 1 if (-t STDOUT); # autoflush if output into term
if (exists $opts{help}) {
print_help();
exit 0;
}
$SIG{INT} = 'hdl_sigint'; # install ^C (SIGINT) handler
if (exists $opts{log} && $opts{log} ne "") {
my $fh = new FileHandle;
my $filename = $opts{log};
$fh->open(">$filename") or die "couldn't open log file";
$fh_log = $fh;
autoflush $fh_log if (-t $fh);
printf $fh_log "==== opened log file on %s\n", get_timestamp();
}
$raw_timeout = $opts{timeout} if exists $opts{timeout};
$cmax = $opts{cmax} if exists $opts{cmax};
if (exists $opts{run}) {
if (not defined ($kpid=fork())) {
die "cannot fork: $!";
} elsif ($kpid == 0) { # in child
exec "/bin/sh", "-c", $opts{run};
die "failed to exec /bin/sh -c $opts{run}: $!";
} else { # in parent
}
}
fifo_open($opts{fifo}) if (exists $opts{fifo});
$time0 = get_time(); # do T0 after fifo open
term_open($opts{term}) if (exists $opts{term});
while(1) {
my $cmd = get_command();
if (defined $cmd) {
do_command($cmd);
} else {
do_command(".mode nomode");
last;
}
}
if ($curchan) {
&{$chan_tab{$curchan}{write}}(); # flush write queue before close
&{$chan_tab{$curchan}{close}}();
}
if (exists $opts{run}) {
waitpid($kpid, 0);
print "pi_rri($curmode)-I: exit status: $?\n" if $?;
}
0;
#-------------------------------------------------------------------------------
sub init_regtbl { # initialize regtbl from reglist
foreach my $ctlname (sort keys %serv11_ctltbl) {
my $ctl = $serv11_ctltbl{$ctlname};
next unless defined $ctl->{reglist};
$ctl->{regtbl} = {};
my $nregs = scalar (@{$ctl->{reglist}});
for (my $i = 0; $i<$nregs; $i++) {
my $name = $ctl->{reglist}->[$i]->{name};
$ctl->{regtbl}->{$name} = $i;
$ctl->{reglist}->[$i]->{rank} = $i;
##print "+++ 1a $ctl->{ctlname} $name $i\n";
}
}
}
#-------------------------------------------------------------------------------
sub get_command {
my $cmd;
while (1) {
$cmd = read_command;
return $cmd if (not defined $cmd); # quit if EOF
print "$cmd\n" if exists $opts{trace};
if ($cmd =~ m/^C/) { # ignore, but print "C ..." lines
&{$mode_tab{$curmode}{flush}}("comm");
print "$cmd\n" unless exists $opts{trace};
next;
}
$cmd =~ s{^\s*}{}; # remove leading blanks
next if $cmd =~ m/^#/; # ignore "# ...." lines
next if $cmd =~ m/^;/; # ignore "; ...." lines
$cmd =~ s{--.*}{}; # remove comments after --
$cmd =~ s{\s*$}{}; # remove trailing blanks
next if $cmd eq ""; # ignore empty lines
return $cmd;
}
}
#-------------------------------------------------------------------------------
sub do_command {
my ($cmd) = @_;
if ($cmd =~ /^\.mode\s*(\w*)/) { # .mode command
if (exists $mode_tab{$1}) {
&{$mode_tab{$curmode}{flush}}("mode");
&{$mode_tab{$curmode}{close}}();
print "pi_rri($curmode)-I: closed mode\n" unless $curmode eq "nomode";
$curmode = $1;
$curcmd = $mode_tab{$curmode}{cmd};
print "pi_rri($curmode)-I: open mode\n" unless $curmode eq "nomode";
&{$mode_tab{$curmode}{open}}();
} else {
printf "pi_rri($curmode)-E: mode '%s' doesn't exist\n", $1;
printf "pi_rri($curmode)-E: use %s\n", join ",", (sort keys %mode_tab);
}
} else { # any other command
$sigint_count = 0; # clear pending ^C's
&$curcmd($cmd);
&{$mode_tab{$curmode}{flush}}("line") if $cmd_inter;
}
}
#-------------------------------------------------------------------------------
sub read_command {
my $cmd;
$cmd_inter = 0;
while (1) {
# read command line
if (scalar(@cmdfh)==0 && scalar(@ARGV)>0) {
$cmd = shift @ARGV;
} else {
if (scalar(@cmdfh)) {
my $fh = $cmdfh[$#cmdfh];
$cmd = <$fh>;
chomp $cmd if defined $cmd;
if (defined $cmd && $cmd =~ /\\$/) { # continuation line ?
$cmd = $`;
my $cline = <$fh>;
chomp $cline;
$cmd .= $cline if defined $cline;
}
unless (defined $cmd) {
$fh->close();
pop @cmdfh;
print "pi_rri($curmode)-I: close " . pop(@cmdfn) . "\n";
&{$mode_tab{$curmode}{flush}}("file");
pop @cmdargs;
setpar_command($cmdargs[-1]) if scalar(@cmdargs);
next;
}
} else {
return undef if $only_argv;
if (defined $term) {
$cmd = $term->readline('>');
} else {
$cmd = <STDIN>;
}
if (-t STDIN && -t STDOUT) {
$cmd_inter = 1; # signal that cmd interactive
}
chomp $cmd if defined $cmd;
return undef if not defined $cmd;
if (defined $cmd && $cmd =~ /\\$/) { # continuation line ?
$cmd = $`;
my $cline = <STDIN>;
chomp $cline;
$cmd .= $cline if defined $cline;
}
}
}
# preprocess command line
# handle substitutions
while ($cmd =~ /\$\{(\w*):([-=])(.*?)\}/) { # ${name:[-=]val} seen
my $name = $1;
my $typ = $2;
my $val = $3;
if (exists $par{$name}) {
$cmd = $` . $par{$name} . $';
} else {
$cmd = $` . $val . $';
$par{$name} = $val if ($typ eq "=");
}
}
while ($cmd =~ /\$\{(\w*)\}/) { # ${name} seen
my $name = $1;
if (exists $par{$name}) {
$cmd = $` . $par{$name} . $';
} else {
print "pi_rri($curmode)-E: variable \"$name\" not defined\n";
$cmd = $` . "\$?$name?" . $';
}
}
while ($cmd =~ /\$\[(.*)\]/) { # $[name] seen
my $evalstr = $1;
my $evalval = eval $evalstr;
if ($@) {
print "pi_rri($curmode)-E: eval error for \"$evalstr\"\n";
print "pi_rri($curmode)-E: $@\n";
$cmd = $` . "\$?$evalstr?" . $';
} else {
$evalval = "" unless defined $evalval;
$cmd = $` . $evalval . $';
}
}
# handle asignments
if ($cmd =~ /^(\w*)=/) {
my $name = $1;
my $val = $';
$val =~ s/--.*$//;
$val =~ s/\s*$//;
$par{$name} = $val;
next;
}
# handle @@xxx lines (pmac perl macros)
if ($cmd =~ /^\s*\@\@(\S*)\s*(.*)$/) { # is it a "@@xxx" macro call ?
my $file = $1;
my $args = $2;
my $fileexp = filename_expand($file);
print_fatal "pmac file $fileexp not found" unless -r $fileexp;
open (PMACFILE, "<$fileexp") or die "failed to open $fileexp: $!";
my @code = <PMACFILE>;
close PMACFILE;
my $code = join "", @code;
##printf "+++1 code to execute from $fileexp:\n$code---\n";
$cmd_line = $cmd;
$cmd_rest = $args;
$cmd_bad = 0;
$sigint_count = 0; # clear pending ^C's
{ eval $code; }
if ($@) {
print STDERR "pi_rri-E: compile error in $fileexp:\n";
print STDERR $@;
}
next;
}
# handle @xxx lines (pcmd command lists)
if ($cmd =~ /^\s*\@(.*)$/) { # is it a "@xxx" command ?
my $file = $1;
my $args = "";
if ($file =~ /\((.*)\)$/) { # is it a "@xxx(args)" command ?
$file = $`;
$args = $1;
}
my $fileexp = filename_expand($file);
print_fatal "pcmd file $fileexp not found" unless -r $fileexp;
my $fh = new FileHandle;
$fh->open("<$fileexp") or die "failed to open $fileexp: $!";
print "pi_rri($curmode)-I: open $fileexp\n";
push @cmdfh, $fh;
push @cmdfn, $fileexp;
push @cmdargs, $args;
setpar_command($args);
} else {
return $cmd;
}
}
}
#-------------------------------------------------------------------------------
sub setpar_command {
my ($args) = @_;
my @arglist = split /,/,$args;
for (my $i=scalar(@arglist); $i<8; $i++) {
$arglist[$i] = "";
}
for (my $i=0; $i<scalar(@arglist); $i++) {
my $name = $i+1;
$par{"$name"} = $arglist[$i];
}
}
#-------------------------------------------------------------------------------
sub nomode_open {
}
#-------------------------------------------------------------------------------
sub nomode_flush {
my ($case) = @_;
}
#-------------------------------------------------------------------------------
sub nomode_close {
}
#-------------------------------------------------------------------------------
sub nomode_cexec {
my ($cmd) = @_;
print "pi_rri($curmode)-E: unknown command \"$cmd\"\n";
}
#-------------------------------------------------------------------------------
sub cpraw_open {
}
#-------------------------------------------------------------------------------
sub cpraw_flush {
my ($case) = @_;
cpraw_tx_match_now unless $case eq "line";
}
#-------------------------------------------------------------------------------
sub cpraw_close {
}
#-------------------------------------------------------------------------------
# cprx 0 11110000
# cptx 0 11110000
sub cpraw_cexec {
my ($cmd) = @_;
my $dat;
if ($cmd =~ /^(cp[rt]x)\s+([01])\s+([01]{8})\s*/) {
print "pi_rri($curmode)-E: extra data ignored: \"$'\"\n" if $';
} else {
print "pi_rri($curmode)-E: unknown cpraw command: \"$cmd\"\n";
return;
}
$dat = vec(pack("B8",$3), 0,8);
$dat += 0x100 if $2 eq "1";
if ($1 eq "cprx") {
do_cprx($dat);
} else {
do_cptx($dat);
}
}
#-------------------------------------------------------------------------------
sub do_cprx {
my ($dat) = @_;
raw_snd9($dat);
cpraw_tx_match;
}
#-------------------------------------------------------------------------------
sub do_cptx {
my ($dat) = @_;
push @cpraw_tx_expt, $dat;
if ($dat == D9ATTN) { # attn comma ?
print conv_etime(), ".wtlam\n";
cpraw_tx_match_now; # if yes, force match now
} else {
cpraw_tx_match; # otherwise just queue
}
}
#-------------------------------------------------------------------------------
sub cpraw_tx_match_now {
my $nexpt = scalar(@cpraw_tx_expt);
while (scalar(@cpraw_tx_expt)) {
if (wait_sel_filercv(1.)) {
cpraw_tx_match;
} else {
print "pi_rri($curmode)-I: time out waiting for cptx response\n";
last;
}
}
}
#-------------------------------------------------------------------------------
sub cpraw_tx_match {
while (1) {
my $dat = raw_rcv9();
last unless defined $dat;
push @cpraw_tx_read, $dat;
}
while (scalar(@cpraw_tx_expt)>0 &&
scalar(@cpraw_tx_read)>0) {
my $dat_e = shift @cpraw_tx_expt;
my $dat_r = shift @cpraw_tx_read;
print conv_etime(), "cptx ", conv_dat9($dat_r), " CHECK ";
if ($dat_e == $dat_r) {
print "OK";
} else {
print "FAIL exp=", conv_dat9($dat_e);
}
print "\n";
}
}
#-------------------------------------------------------------------------------
sub rri_open {
$rri_ref_sdef = 0x00; # by default check for 'hard' errors
$rri_msk_sdef = 0xf0; # ignore the status bits + attn flag
}
#-------------------------------------------------------------------------------
sub rri_flush {
my ($case) = @_;
rri_cmdlist_do();
}
#-------------------------------------------------------------------------------
sub rri_close {
}
#-------------------------------------------------------------------------------
# .rlmon 0|1
# .rbmon 0|1
# .scntl n 0|1
# .sinit g8 g16
# .sdef [s=g8]
# .amclr
# .amdef name g8
# .reset
# .wait n
# .wtlam n
# .cclst
# rreg <addr> [d=g16] [s=g8]
# rblk <addr> n [s=g8]
# followed by n d=g16 data check values
# wreg <addr> g16 [s=g8]
# wblk <addr> n [s=g8]
# followed by n g16 data values
# stat [d=g16] [s=d8]
# attn [d=g16] [s=d8]
# init <addr> g16 [s=g8]
sub rri_cexec {
my ($cmd) = @_;
$cmd_line = $cmd;
$cmd_rest = "";
$cmd_bad = 0;
if ($cmd =~ /^(\.rlmon|\.rbmon)\s+([01])/) { # .rlmon, .rbmon -------------
my $ind = ($1 eq ".rlmon") ? 15 : 14;
$cmd_rest = $';
rri_sideband(0x00, ($ind<<8) + $2);
} elsif ($cmd =~ /^\.scntl\s+(\d+)\s([01])/) { # .scntl ------------------
$cmd_rest = $';
rri_sideband(0x00, ($1<<8) + $2);
} elsif ($cmd =~ /^\.sinit/) { # .sinit ------------------
$cmd_rest = $';
my $addr = cget_gdat(8,$rri_dbasi);
my $data = cget_gdat(16,$rri_dbasi);
rri_sideband($addr, $data) if (not $cmd_bad);
} elsif ($cmd =~ /^\.sdef/) { # .sdef -------------------------
$cmd_rest = $';
($rri_ref_sdef,$rri_msk_sdef) = cget_tagval2_gdat("s",8,2);
} elsif ($cmd =~ /^\.amclr/) { # .amclr ------------------------
$cmd_rest = $';
%rri_amtbl = ();
} elsif ($cmd =~ /^\.amdef\s+([a-zA-Z][a-zA-Z0-9]*)/) {# .amdef ------------
$cmd_rest = $';
my $name = $1;
my $addr = cget_gdat(8,2);
if (defined $addr) {
$rri_amtbl{$name} = $addr;
} else {
$cmd_bad = 1;
}
} elsif ($cmd =~ /^\.dbasi\s+(\d+)/) { # .dbasi -----------------------
$cmd_rest = $';
my $dbase = int $1;
$rri_dbasi = $dbase;
} elsif ($cmd =~ /^\.dbaso\s+(\d+)/) { # .dbaso -----------------------
$cmd_rest = $';
my $dbase = int $1;
$rri_dbaso = $dbase;
if ($rri_dbaso == 2) {
$rri_nodfill = " " x 15;
} elsif ($rri_dbaso == 8) {
$rri_nodfill = " " x 5;
} elsif ($rri_dbaso == 16) {
$rri_nodfill = " " x 3;
} else {
$rri_nodfill = "???";
}
} elsif ($cmd =~ /^\.reset/) { # .reset ------------------------
$cmd_rest = $';
print "pi_rri($curmode)-I: $cmd currently ignored\n";
} elsif ($cmd =~ /^\.wait\s+(\d+)/) { # .wait ------------------------
$cmd_rest = $';
my $delay = int $1;
rri_cmdlist_do(); # flush before waiting
for (my $i = 0; $i < $delay; $i++) {
raw_snd9(D9IDLE);
}
} elsif ($cmd =~ /^\.wtlam\s+(\d+)/) { # .wtlam ------------------------
$cmd_rest = $';
rri_cmdlist_do(); # flush before wait for ATTN
my $tstart = get_time();
raw_get9_check(D9ATTN, "wtlam"); # ???FIXME this is a hack...
printf "-- .wtlam # wait for %7.3f sec\n", get_time()-$tstart;
} elsif ($cmd =~ /^\.cclst/) { # .cclst ------------------------
$cmd_rest = $';
$rri_ncmdmax = scalar(@rri_cmdlist) + 1; # force exec after next cmd
} elsif ($cmd =~ /^rreg/) { # rreg --------------------------
$cmd_rest = $';
my $addr = rri_cget_addr;
my ($ref_data, $msk_data) = cget_tagval2_gdat("d",16,$rri_dbasi);
my ($ref_stat, $msk_stat) = rri_cget_stat;
if (not $cmd_bad) {
push @rri_cmdlist, {cname => "rreg",
addr => $addr,
ref_data => $ref_data,
msk_data => $msk_data,
ref_stat => $ref_stat,
msk_stat => $msk_stat};
}
} elsif ($cmd =~ /^rblk/) { # rblk --------------------------
$cmd_rest = $';
my $addr = rri_cget_addr;
my $nblk = rri_cget_nblk;
my ($ref_stat, $msk_stat) = rri_cget_stat;
my @ref_rblk;
my @msk_rblk;
my $i;
cget_chkblank();
for ($i = 0; $i < $nblk; $i++) {
$cmd_rest = get_command() if ($cmd_rest eq "");
$cmd_rest =~ s/^\s*//;
my ($ref,$msk) = cget_tagval2_gdat("d",16,$rri_dbasi);
push @ref_rblk, $ref;
push @msk_rblk, $msk;
}
cget_chkblank();
if (not $cmd_bad) {
push @rri_cmdlist, {cname => "rblk",
addr => $addr,
nblk => $nblk,
ref_rblk => [@ref_rblk],
msk_rblk => [@msk_rblk],
ref_stat => $ref_stat,
msk_stat => $msk_stat};
}
} elsif ($cmd =~ /^wreg/) { # wreg --------------------------
$cmd_rest = $';
my $addr = rri_cget_addr;
my $data = cget_gdat(16,$rri_dbasi);
my ($ref_stat, $msk_stat) = rri_cget_stat;
if (not $cmd_bad) {
push @rri_cmdlist, {cname => "wreg",
addr => $addr,
data => $data,
ref_stat => $ref_stat,
msk_stat => $msk_stat};
}
} elsif ($cmd =~ /^wblk/) { # wblk --------------------------
$cmd_rest = $';
my $addr = rri_cget_addr;
my $nblk = rri_cget_nblk;
my ($ref_stat, $msk_stat) = rri_cget_stat;
my @dat_wblk;
my $i;
cget_chkblank();
for ($i = 0; $i < $nblk; $i++) {
$cmd_rest = get_command() if ($cmd_rest eq "");
$cmd_rest =~ s/^\s*//;
push @dat_wblk, cget_gdat(16,$rri_dbasi);
}
cget_chkblank();
if (not $cmd_bad) {
push @rri_cmdlist, {cname => "wblk",
addr => $addr,
nblk => $nblk,
dat_wblk => [@dat_wblk],
ref_stat => $ref_stat,
msk_stat => $msk_stat};
}
} elsif ($cmd =~ /^stat/) { # stat --------------------------
$cmd_rest = $';
my ($ref_data, $msk_data) = cget_tagval_gdat("d",16,2);
my ($ref_stat, $msk_stat) = rri_cget_stat;
if (not $cmd_bad) {
push @rri_cmdlist, {cname => "stat",
ref_data => $ref_data,
msk_data => $msk_data,
ref_stat => $ref_stat,
msk_stat => $msk_stat};
}
} elsif ($cmd =~ /^attn/) { # attn --------------------------
$cmd_rest = $';
my ($ref_data, $msk_data) = cget_tagval_gdat("d",16,$rri_dbasi);
my ($ref_stat, $msk_stat) = rri_cget_stat;
if (not $cmd_bad) {
push @rri_cmdlist, {cname => "attn",
ref_data => $ref_data,
msk_data => $msk_data,
ref_stat => $ref_stat,
msk_stat => $msk_stat};
}
} elsif ($cmd =~ /^init/) { # init --------------------------
$cmd_rest = $';
my $addr = rri_cget_addr;
my $data = cget_gdat(16,$rri_dbasi);
my ($ref_stat, $msk_stat) = rri_cget_stat;
if (not $cmd_bad) {
push @rri_cmdlist, {cname => "init",
addr => $addr,
data => $data,
ref_stat => $ref_stat,
msk_stat => $msk_stat};
}
} else {
print "pi_rri($curmode)-E: unknown command: \"$cmd_line\"\n";
}
cget_chkblank() unless $cmd_bad;
if ($cmd_bad) {
print "pi_rri($curmode)-E: parse error, command ignored: \"$cmd_line\"\n";
} else {
if (scalar(@rri_cmdlist) >= $cmax ||
($rri_ncmdmax && scalar(@rri_cmdlist) >= $rri_ncmdmax)) {
$rri_ncmdmax = undef;
rri_cmdlist_do();
}
}
}
#-------------------------------------------------------------------------------
sub rri_cget_stat {
my ($dat, $msk) = cget_tagval2_gdat("s",8,2);
if (defined $dat) {
return ($dat, $msk);
} else {
return ($rri_ref_sdef, $rri_msk_sdef);
}
}
#-------------------------------------------------------------------------------
sub rri_cget_addr {
my $odat;
$cmd_rest =~ s/^\s*//;
if ($cmd_rest =~ /^\.([a-zA-Z][a-zA-Z0-9]*)/) {
$cmd_rest = $';
if (exists $rri_amtbl{$1}) {
$odat = $rri_amtbl{$1};
if ($cmd_rest =~ /^\|/) {
$cmd_rest = $';
$odat |= cget_gdat(8,2);
}
} else {
print "pi_rri($curmode)-E: undefined address mnemo: \"$1\"\n";
$cmd_bad = 1;
}
} else {
$odat = cget_gdat(8,2);
}
return $odat;
}
#-------------------------------------------------------------------------------
sub rri_cget_nblk {
my $odat;
$cmd_rest =~ s/^\s*//;
if ($cmd_rest =~ /^(\d*)/) {
$cmd_rest = $';
$odat = int $1;
if ($odat <= 0 || $odat > 256) {
print "pi_rri($curmode)-E: block length <0 or >256\n";
$cmd_bad = 1;
}
} else {
$cmd_bad = 1;
}
return $odat;
}
#-------------------------------------------------------------------------------
sub rri_cmdlist_dump {
my ($href,$dblk,$fh) = @_;
my $fh_old;
$fh_old = select($fh) if defined $fh;
foreach my $ele (@$href) {
printf "-- %-4s",$ele->{cname};
printf " %-7s","[$ele->{aname}]" if exists $ele->{aname};
printf " c=%1.1x%1d%1d", $ele->{cmd}>>4, ($ele->{cmd}>>3)&0x1,
$ele->{cmd}&0x7 if exists $ele->{cmd};
printf " a=%s",conv_dat8($ele->{addr}) if exists $ele->{addr};
printf " n=%d", $ele->{nblk} if exists $ele->{nblk};
printf " d=%s", gconv_dat16($ele->{data},$rri_dbaso) if exists $ele->{data};
if (exists $ele->{ref_data}) {
if ((defined $ele->{msk_data} && $ele->{msk_data} == 0xffff)
|| not defined $ele->{ref_data}) {
printf " d=-%s", $rri_nodfill;
} else {
printf " d=%s", gconv_dat16($ele->{ref_data},$rri_dbaso);
printf ",%s", gconv_dat16($ele->{msk_data},$rri_dbaso) if $ele->{msk_data};
}
}
if (defined $ele->{rcv_data}) {
printf " D=%s%s", gconv_dat16($ele->{rcv_data},$rri_dbaso),
($ele->{err_data} ? "(#)" : " ");
}
if (exists $ele->{ref_stat}) {
if ((defined $ele->{msk_stat} && $ele->{msk_stat} == 0xffff)
|| not defined $ele->{ref_stat}) {
printf " s=-";
} else {
printf " s=%s", conv_dat8($ele->{ref_stat});
printf ",%s", conv_dat8($ele->{msk_stat}) if $ele->{msk_stat};
}
}
if (defined $ele->{rcv_stat}) {
printf " S=%s%s", conv_dat8($ele->{rcv_stat}),
($ele->{err_stat} ? "(#)" : " ");
}
if (exists $ele->{ok}) {
print ($ele->{ok} ? " OK" : "FAIL");
} else {
print " PEND";
}
if (exists $ele->{dat_wblk} && $dblk) {
my $i = 0;
foreach ( @{$ele->{dat_wblk}} ) {
printf "\n-- " if ($i % 8 == 0);
printf " %s", gconv_dat16($_,$rri_dbaso);
$i += 1;
}
}
if (exists $ele->{ref_rblk} && $dblk && scalar(@{$ele->{ref_rblk}}) ) {
my $i;
my $nblk = $ele->{nblk};
for ($i = 0; $i < $nblk; $i++) {
printf "\n-- " if ($i % 4 == 0);
if ((defined $ele->{msk_rblk}[$i] && $ele->{msk_rblk}[$i] == 0xffff)
|| not defined $ele->{ref_rblk}[$i]){
printf " d=-%s %s", $rri_nodfill, $rri_nodfill;
} else {
printf " d=%s", gconv_dat16($ele->{ref_rblk}[$i],$rri_dbaso);
if ($ele->{msk_rblk}[$i]) {
printf ",%s", gconv_dat16($ele->{msk_rblk}[$i],$rri_dbaso);
} else {
print " ";
}
}
}
}
if (exists $ele->{rcv_rblk} && $dblk) {
my $i;
my $nblk = $ele->{nblk};
for ($i = 0; $i < $nblk; $i++) {
printf "\n-- " if ($i % 4 == 0);
printf " D=%s%s ", gconv_dat16($ele->{rcv_rblk}[$i],$rri_dbaso),
($ele->{err_rblk}[$i] ? "(#)" : " ");
}
}
printf "\n";
}
select($fh_old) if defined $fh_old;
}
#-------------------------------------------------------------------------------
sub rri_sideband {
my ($addr,$data) = @_;
my $dl = $data & 0xff;
my $dh = ($data>>8) & 0xff;
rri_cmdlist_do();
raw_snd8(CESC);
raw_snd8(CESC);
raw_snd8($addr); # ADDR
raw_snd8($dl); # DL
raw_snd8($dh); # DH
&{$chan_tab{$curchan}{write}}(); # flush write queue
}
#-------------------------------------------------------------------------------
sub rri_cmdlist_do {
if (scalar(@rri_cmdlist)) {
rri_cmdlist_exec(\@rri_cmdlist);
rri_cmdlist_dump(\@rri_cmdlist, 1);
@rri_cmdlist = ();
}
}
#-------------------------------------------------------------------------------
sub rri_cmdlist_exec {
my ($href) = @_;
my $seq = 0;
my $nele = scalar(@$href);
return unless $nele;
$ocrc = 0;
$icrc = 0;
raw_snd9(D9SOP);
foreach my $ele (@$href) {
my $cname = $ele->{cname};
my $cmd;
$cmd = $rri_cname2cmd{$cname};
$cmd |= 0x08 if $seq < $nele-1; # set chain bit
$cmd |= ($seq & 0xf) << 4; # set sequence number field
$ele->{cmd} = $cmd;
raw_snd9_crc($cmd);
$seq += 1;
if ($cname eq "rreg") {
$stat_tab{xreg} += 1;
raw_snd9_crc($ele->{addr});
raw_snd9($ocrc);
} elsif ($cname eq "rblk") {
$stat_tab{xblk} += 1;
raw_snd9_crc($ele->{addr});
raw_snd9_crc($ele->{nblk}-1);
raw_snd9($ocrc);
} elsif ($cname eq "wreg") {
$stat_tab{xreg} += 1;
raw_snd9_crc($ele->{addr});
raw_snd9_crc( $ele->{data} & 0xff);
raw_snd9_crc(($ele->{data}>>8) & 0xff);
raw_snd9($ocrc);
} elsif ($cname eq "wblk") {
$stat_tab{xblk} += 1;
raw_snd9_crc($ele->{addr});
raw_snd9_crc($ele->{nblk}-1);
raw_snd9($ocrc);
foreach ( @{$ele->{dat_wblk}} ) {
raw_snd9_crc( $_ & 0xff);
raw_snd9_crc(($_>>8) & 0xff);
}
raw_snd9($ocrc);
} elsif ($cname eq "stat") {
raw_snd9($ocrc);
} elsif ($cname eq "attn") {
raw_snd9($ocrc);
} elsif ($cname eq "init") {
raw_snd9_crc($ele->{addr});
raw_snd9_crc( $ele->{data} & 0xff);
raw_snd9_crc(($ele->{data}>>8) & 0xff);
raw_snd9($ocrc);
}
}
raw_snd9(D9EOP);
raw_get9_checksop() or return 0;
foreach my $ele (@$href) {
my $cname = $ele->{cname};
my $idat;
my $ok = 1;
raw_get9_crc_check($ele->{cmd}, "cmd") or return 0;
if ($cname eq "rreg") {
raw_get9_crc_16bit(\$ele->{rcv_data}) or return 0;
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
raw_get9_check($icrc, "crc") or return 0;
} elsif ($cname eq "rblk") {
raw_get9_crc_check($ele->{nblk}-1, "nblk") or return 0;
for (my $i=0; $i<$ele->{nblk}; $i++) {
my $data;
my $err;
raw_get9_crc_16bit(\$data) or return 0;
push @{$ele->{rcv_rblk}}, $data;
$err = rri_ref_check($data, $ele->{ref_rblk}[$i], $ele->{msk_rblk}[$i]);
push @{$ele->{err_rblk}}, $err;
$ok = 0 if $err;
}
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
raw_get9_check($icrc, "crc") or return 0;
} elsif ($cname eq "wreg") {
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
raw_get9_check($icrc, "crc") or return 0;
} elsif ($cname eq "wblk") {
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
raw_get9_check($icrc, "crc") or return 0;
} elsif ($cname eq "stat") {
raw_get9_crc_8bit(\$ele->{rcv_ccmd}) or return 0;
raw_get9_crc_16bit(\$ele->{rcv_data}) or return 0;
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
raw_get9_check($icrc, "crc") or return 0;
} elsif ($cname eq "attn") {
raw_get9_crc_16bit(\$ele->{rcv_data}) or return 0;
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
raw_get9_check($icrc, "crc") or return 0;
} elsif ($cname eq "init") {
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
raw_get9_check($icrc, "crc") or return 0;
}
if (defined $ele->{rcv_data}) {
$ele->{err_data} = rri_ref_check($ele->{rcv_data},
$ele->{ref_data}, $ele->{msk_data});
$ok = 0 if $ele->{err_data};
}
if (defined $ele->{rcv_stat}) {
$ele->{err_stat} = rri_ref_check($ele->{rcv_stat},
$ele->{ref_stat}, $ele->{msk_stat});
$ok = 0 if $ele->{err_stat};
}
$ele->{ok} = $ok;
}
raw_get9_checkeop() or return 0;
return 1;
}
#-------------------------------------------------------------------------------
sub rri_cmdlist_check_stat {
my ($href) = @_;
foreach my $ele (@$href) {
return 1 if not exists $ele->{rcv_stat};
return 1 if $ele->{err_stat};
}
return 0;
}
#-------------------------------------------------------------------------------
sub rri_cmdlist_get_rval {
my ($href,$ind) = @_;
my $nele = scalar(@$href);
return (undef, "#ind?#") if ($ind >= $nele);
return (undef, "#sta?#") if not exists $$href[$ind]->{rcv_stat};
return (undef, sprintf "#s=%2.2x#",$$href[$ind]->{rcv_stat})
if $$href[$ind]->{err_stat};
return (undef, "#dat?#") if (not exists $$href[$ind]->{rcv_data});
return ($$href[$ind]->{rcv_data}, sprintf "%6.6o",$$href[$ind]->{rcv_data});
}
#-------------------------------------------------------------------------------
sub rri_cmdlist_conv_rval {
my ($href,$ind) = @_;
my ($val,$str) = rri_cmdlist_get_rval($href, $ind);
return $str;
}
#-------------------------------------------------------------------------------
sub rri_ref_check { # check reference data (1=err)
my ($rcv,$ref,$msk) = @_;
if (defined $ref) {
my $mask = (defined $msk) ? $msk : 0;
my $mrcv = $rcv | $mask;
my $mref = $ref | $mask;
return 1 if $mrcv != $mref;
}
return 0;
}
#-------------------------------------------------------------------------------
sub pdpcp_open {
$rri_ref_sdef = 0x00; # by default check for 'hard' errors
$rri_msk_sdef = 0x70; # ignore cpuhalt,cpugo and attn
}
#-------------------------------------------------------------------------------
sub pdpcp_flush {
my ($case) = @_;
rri_cmdlist_do();
}
#-------------------------------------------------------------------------------
sub pdpcp_close {
}
#-------------------------------------------------------------------------------
# .tocmd n
# .tostp n
# .togo n
# .anena 0|1
# .rlmon 0|1
# .rbmon 0|1
# .scntl n 0|1
# .sinit g8 g16
# .sdef [s=g8]
# .cerr 0|1
# .merr 0|1
# .reset
# .wait n
# .cclst
# rr* [d=g16] [s=g8]
# wr* g16 [s=g8]
# brm n [s=g8]
# followed by n d=g16 data check values
# bwm n [s=g8]
# followed by n g16 data values
# wal g16 [s=g8]
# wah g16 [s=g8]
# rps [d=g16] [s=g8]
# wps g16 [s=g8]
# rm [d=g16] [s=g8]
# rmi [d=g16] [s=g8]
# wm g16 [s=g8]
# wmi g16 [s=g8]
# stapc g16 [s=g8]
# sta [s=g8]
# sto [s=g8]
# cont [s=g8]
# step [s=g8]
# rst [s=g8]
# wibrb g16
# ribr g6 [d=g16] [s=g8]
# wibr g6 g16
# wtgo
# wtlam [d=g16]
#
sub pdpcp_cexec {
my ($cmd) = @_;
my $cclast;
my $aname;
if ($cmd =~ /^([a-z0-9]*)/) {
$aname = $1;
}
$cmd =~ s/^rsp/rr6/; # rsp -> rr6
$cmd =~ s/^rpc/rr7/; # rsp -> rr7
$cmd =~ s/^wsp/wr6/; # wsp -> wr6
$cmd =~ s/^wpc/wr7/; # wsp -> wr7
$cmd_line = $cmd;
$cmd_rest = "";
$cmd_bad = 0;
if ($cmd =~ /^\.to(cmd|stp|go)\s+(\d*)/) {# .tocmd, .tostp, .togo
$cmd_rest = $';
print "pi_rri($curmode)-I: $cmd currently ignored\n";
} elsif ($cmd =~ /^\.anena\s+([01])/) { # .anena ------------------------
$cmd_rest = $';
my $ena = int $1;
my $ena_data = ($ena==0) ? 0x0000 : 0x8000;
rri_cmdlist_do();
push @rri_cmdlist, {cname => "init",
aname => ".anena",
addr => 0xff,
data => $ena_data};
rri_cmdlist_do();
} elsif ($cmd =~ /^(\.rlmon|\.rbmon)\s+([01])/) { # .rlmon, .rbmon ---------
$cmd_rest = $';
my $ind = ($1 eq ".rlmon") ? 15 : 14;
$cmd_rest = $';
rri_sideband(0x00, ($ind<<8) + $2);
} elsif ($cmd =~ /^\.scntl\s+(\d+)\s([01])/) { # .scntl ------------------
$cmd_rest = $';
rri_sideband(0x00, ($1<<8) + $2);
} elsif ($cmd =~ /^\.sinit/) { # .sinit ------------------
$cmd_rest = $';
my $addr = cget_gdat(8,$rri_dbasi);
my $data = cget_gdat(16,$rri_dbasi);
rri_sideband($addr, $data) if (not $cmd_bad);
} elsif ($cmd =~ /^\.sdef/) { # .sdef -------------------------
$cmd_rest = $';
($rri_ref_sdef,$rri_msk_sdef) = cget_tagval2_gdat("s",8,2);
} elsif ($cmd =~ /^\.[cm]err\s*[01]/) { # .[cm]err
# ignore, no action
} elsif ($cmd =~ /^\.reset/) { # .reset ------------------------
$cmd_rest = $';
rri_cmdlist_do(); # flush before reset
push @rri_cmdlist, {cname => "init",
aname => ".reset",
addr => 0x00,
data => 0x01};
rri_cmdlist_do(); # flush after reset
} elsif ($cmd =~ /^\.wait\s+(\d+)/) { # .wait ------------------------
$cmd_rest = $';
my $delay = int $1;
rri_cmdlist_do(); # flush before waiting
for (my $i = 0; $i < $delay; $i++) {
raw_snd9(D9IDLE);
}
} elsif ($cmd =~ /^\.cclst/) { # .cclst ------------------------
$cmd_rest = $';
$rri_ncmdmax = scalar(@rri_cmdlist) + 1; # force exec after next cmd
} elsif ($cmd =~ /^rr([0-7])/) { # rr* ---------------------------
$cmd_rest = $';
my $rnum = int $1;
pdpcp_cmd_rreg($aname, PDPCP_ADDR_R0+$rnum);
} elsif ($cmd =~ /^wr([0-7])/) { # wr* ---------------------------
$cmd_rest = $';
my $rnum = int $1;
pdpcp_cmd_wreg($aname, PDPCP_ADDR_R0+$rnum);
} elsif ($cmd =~ /^brm/) { # brm ---------------------------
$cmd_rest = $';
my $addr = PDPCP_ADDR_MEMI;
my $nblk = rri_cget_nblk;
my ($ref_stat, $msk_stat) = rri_cget_stat;
my @ref_rblk;
my @msk_rblk;
my $i;
cget_chkblank();
for ($i = 0; $i < $nblk; $i++) {
$cmd_rest = get_command() if ($cmd_rest eq "");
$cmd_rest =~ s/^\s*//;
my ($ref,$msk) = cget_tagval2_gdat("d",16,8);
push @ref_rblk, $ref;
push @msk_rblk, $msk;
}
cget_chkblank();
if (not $cmd_bad) {
push @rri_cmdlist, {cname => "rblk",
aname => $aname,
addr => $addr,
nblk => $nblk,
ref_rblk => [@ref_rblk],
msk_rblk => [@msk_rblk],
ref_stat => $ref_stat,
msk_stat => $msk_stat};
}
} elsif ($cmd =~ /^bwm/) { # bwm ---------------------------
$cmd_rest = $';
my $addr = PDPCP_ADDR_MEMI;
my $nblk = rri_cget_nblk;
my ($ref_stat, $msk_stat) = rri_cget_stat;
my @dat_wblk;
my $i;
cget_chkblank();
for ($i = 0; $i < $nblk; $i++) {
$cmd_rest = get_command() if ($cmd_rest eq "");
$cmd_rest =~ s/^\s*//;
push @dat_wblk, cget_gdat(16,8);
}
cget_chkblank();
if (not $cmd_bad) {
push @rri_cmdlist, {cname => "wblk",
aname => $aname,
addr => $addr,
nblk => $nblk,
dat_wblk => [@dat_wblk],
ref_stat => $ref_stat,
msk_stat => $msk_stat};
}
} elsif ($cmd =~ /^wal/) { # wal ---------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_AL);
} elsif ($cmd =~ /^wah/) { # wah ---------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_AH);
} elsif ($cmd =~ /^rps/) { # rps ---------------------------
$cmd_rest = $';
pdpcp_cmd_rreg($aname, PDPCP_ADDR_PSW);
} elsif ($cmd =~ /^wps/) { # wps ---------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_PSW);
} elsif ($cmd =~ /^rmi/) { # rmi ---------------------------
$cmd_rest = $';
pdpcp_cmd_rreg($aname, PDPCP_ADDR_MEMI);
} elsif ($cmd =~ /^rm/) { # rm ----------------------------
$cmd_rest = $';
pdpcp_cmd_rreg($aname, PDPCP_ADDR_MEM);
} elsif ($cmd =~ /^wmi/) { # wmi ---------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_MEMI);
} elsif ($cmd =~ /^wm/) { # wm ----------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_MEM);
} elsif ($cmd =~ /^stapc/) { # stapc -------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_PC);
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_STA);
} elsif ($cmd =~ /^sta/) { # sta ---------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_STA);
} elsif ($cmd =~ /^sto/) { # sto ---------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_STO);
} elsif ($cmd =~ /^cont/) { # cont --------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_CONT);
} elsif ($cmd =~ /^step/) { # step --------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_STEP);
} elsif ($cmd =~ /^rst/) { # rst ---------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_RST);
} elsif ($cmd =~ /^wibrb/) { # wibrb -------------------------
$cmd_rest = $';
pdpcp_cmd_wreg($aname, PDPCP_ADDR_IBRB);
} elsif ($cmd =~ /^ribr/) { # ribr --------------------------
$cmd_rest = $';
my $off = cget_gdat(6,8);
pdpcp_cmd_rreg($aname, PDPCP_ADDR_IBR+int($off/2));
} elsif ($cmd =~ /^wibr/) { # wibr --------------------------
$cmd_rest = $';
my $off = cget_gdat(6,8);
pdpcp_cmd_wreg($aname, PDPCP_ADDR_IBR+int($off/2));
} elsif ($cmd =~ /^wtgo/) { # wtgo --------------------------
$cmd_rest = $';
rri_cmdlist_do();
my $tstart = get_time();
raw_get9_check(D9ATTN, "wtgo"); # ???FIXME this is a hack...
printf "-- wtgo # wait for %7.3f sec\n", get_time()-$tstart;
push @rri_cmdlist, {cname => "attn",
aname => ".wtgo"};
} elsif ($cmd =~ /^wtlam/) { # wtlam -------------------------
$cmd_rest = $';
my ($ref_data, $msk_data) = cget_tagval2_gdat("d",16,8);
rri_cmdlist_do();
my $tstart = get_time();
raw_get9_check(D9ATTN, "wtgo"); # ???FIXME this is a hack...
printf "-- wtlam # wait for %7.3f sec\n", get_time()-$tstart;
push @rri_cmdlist, {cname => "attn",
aname => ".wtlam",
ref_data => $ref_data,
msk_data => $msk_data};
} else {
print "pi_rri($curmode)-E: unknown command: \"$cmd_line\"\n";
}
cget_chkblank() unless $cmd_bad;
if ($cmd_bad) {
print "pi_rri($curmode)-E: parse error, command ignored: \"$cmd_line\"\n";
} else {
if (scalar(@rri_cmdlist) >= $cmax || $cclast ||
($rri_ncmdmax && scalar(@rri_cmdlist) >= $rri_ncmdmax)) {
$rri_ncmdmax = undef;
rri_cmdlist_do();
}
}
}
#-------------------------------------------------------------------------------
sub pdpcp_cmd_rreg {
my ($aname,$addr) = @_;
my ($ref_data,$msk_data) = cget_tagval2_gdat("d",16,8);
my ($ref_stat,$msk_stat) = rri_cget_stat;
if (not $cmd_bad) {
push @rri_cmdlist, {cname => "rreg",
aname => $aname,
addr => $addr,
ref_data => $ref_data,
msk_data => $msk_data,
ref_stat => $ref_stat,
msk_stat => $msk_stat};
}
}
#-------------------------------------------------------------------------------
sub pdpcp_cmd_wreg {
my ($aname,$addr,$data) = @_;
my $ldata = (defined $data) ? $data : cget_gdat(16,8);
my ($ref_stat,$msk_stat) = rri_cget_stat;
if (not $cmd_bad) {
push @rri_cmdlist, {cname => "wreg",
aname => $aname,
addr => $addr,
data => $ldata,
ref_stat => $ref_stat,
msk_stat => $msk_stat};
}
}
#-------------------------------------------------------------------------------
sub serv11_open {
$rri_ref_sdef = 0x00; # by default check for 'hard' errors
$rri_msk_sdef = 0x70; # ignore cpuhalt,cpugo and attn
serv11_config() unless $serv11_config_done;
}
#-------------------------------------------------------------------------------
sub serv11_flush {
my ($case) = @_;
}
#-------------------------------------------------------------------------------
sub serv11_close {
}
#-------------------------------------------------------------------------------
# <string
# (string
# lspc
# lsmem {-m|-a} g16{(:g16|nddd)} {(>|>>)file}
# ldabs {-s} file
# exa <rrange>
# dep <rrange> g16
# set ...
# sho conf
# sho att
# sho regs
# sho mmu
# sho ubm[ap]
# wtt <unit> "string"
# attn
# att <unit> file
# det <unit>|all
# init
# boot <unit>
# start g16
# step
# stop
# cont
# reset
# server
#
sub serv11_cexec {
my ($cmd) = @_;
$cmd_line = $cmd;
$cmd_rest = "";
$cmd_bad = 0;
#
# First handle 'special syntax commands: ( and <
#
if ($cmd =~ /^([<(])/) { # < and ( short hands -----------
my $str = $';
my $ucb = cget_ucb("term", "tt0");
return if $cmd_bad or cget_chkblank();
my @bytes;
if ($1 eq "<") { # < command
conv_str2bytes($str, \@bytes);
push @bytes, 0015;
} else { # ( command
if ($str =~ /^\\([0-7]{3})$/) { # (\ooo escape
push @bytes, oct $1;
} elsif ($str =~ /^\\\^(.)$/) { # (^c escape
my $byt = ord($1); # to byte value
$byt -= 040 if ($byt >= 040); # map to control char
$byt -= 040 if ($byt >= 040);
$byt -= 040 if ($byt >= 040);
push @bytes, $byt;
} else {
conv_str2bytes($str, \@bytes, 1);
}
}
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
&{$ctl->{ichrhdl}}($ucb, \@bytes);
return;
}
#
# Now prepare normal syntax commands
#
if ($cmd =~ /^(\w+)\b/) { # get command name
$cmd = $1;
$cmd_rest = $';
$cmd_rest =~ s/^\s*//;
}
if ($cmd =~ /^lspc/) { # dump pc/ps -----------------
return if cget_chkblank();
serv11_cexec_shoreg(0);
} elsif ($cmd =~ /^lsmem/) { # dump memory --------------------
my $opt_m = cget_opt("-m");
my $opt_a = cget_opt("-a");
my $abeg = cget_gdat(22, 8);
return if $cmd_bad;
my $aend = $abeg+64;
my $fh = *STDOUT;
my $redi = 0;
if ($cmd_rest =~ /^:n(\d*)/) {
$cmd_rest = $';
$aend = $abeg + 2*(int $1);
} elsif ($cmd_rest =~ /^:/) {
$cmd_rest = $';
$aend = cget_gdat(22, 8);
return if $cmd_bad;
}
if ($cmd_rest =~ /^\s*(>{1,2})([\w\/.-]+)/) {
$cmd_rest = $';
my $oper = $1;
my $file = $2;
my $fh_new = new FileHandle;
if ($fh_new->open("$oper$file")) {
$fh = $fh_new;
$redi = 1;
} else {
print "pi_rri($curmode)-E: failed to open output file $file\n";
}
}
$abeg &= 0xfffffffe;
$aend &= 0xfffffffe;
my $nword = int (($aend - $abeg)/2);
$nword = 1 if $nword <= 1;
return if cget_chkblank();
my @data;
my $rc = serv11_exec_rblk($abeg, 1, \@data, $nword);
my $inst_nw = 0;
my $inst_str = "";
printf $fh "Memory %8.8o:%8.8o:\n", $abeg, $aend;
for (my $i=0; $i<$nword; $i++) {
if ($opt_m) {
($inst_str, $inst_nw) =
pdp11_disassemble($abeg+2*$i, $data[$i],$data[$i+1],$data[$i+2]);
printf $fh " %6.6o :", $abeg+2*$i;
for (my $j=0; $j<3; $j++) {
if ($j < $inst_nw) {
printf $fh " %6.6o", (defined $data[$i+$j]) ? $data[$i+$j] : 0;
} else {
print $fh " ";
}
}
printf $fh " # %s\n", $inst_str;
$i += $inst_nw-1;
} elsif ($opt_a) {
my $nline = $nword - $i;
my $ascbuf;
$nline = 4 if $nline > 4;
printf $fh " %6.6o :", $abeg+2*$i;
for (my $j=0; $j<$nline; $j++) {
my $word = $data[$i+$j];
my $bl = $word & 0377;
my $bh = ($word>>8) & 0377;
printf $fh " %3.3o %3.3o", $bl, $bh;
$ascbuf .= " " . conv_byte2ascii2($bl);
$ascbuf .= " " . conv_byte2ascii2($bh);
}
print $fh " " x (8*(4-$nline)+4);
print $fh $ascbuf;
print $fh "\n";
$i += $nline-1;
} else {
printf $fh " %6.6o : %6.6o\n", $abeg+2*$i, $data[$i];
}
}
$fh->close() if $redi;
} elsif ($cmd =~ /^ldabs/) { # load absolute loader format ----
my $opt_s = cget_opt("-s");
my $file = cget_file();
return if cget_chkblank();
serv11_cexec_ldabs($file, $opt_s);
} elsif ($cmd =~ /^exa/) { # examine register or memory -----
my $optset = cget_optset("ir");
my ($ctl, $beg, $end) = cget_regrange();
return if cget_chkblank();
serv11_cexec_exa($optset, $ctl, $beg, $end);
} elsif ($cmd =~ /^dep/) { # deposit register or memory -----
my $optset = cget_optset("ir");
my ($ctl, $beg, $end) = cget_regrange();
my $data = cget_gdat(16, 8);
return if cget_chkblank();
serv11_cexec_dep($optset, $ctl, $beg, $end, $data);
} elsif ($cmd =~ /^set/) { # set parameter ------------------
my $what = cget_name();
return if $cmd_bad;
if ($what =~ /^sim/) { # set sim[ulator] ------
my $pnam = cget_name();
my $val = cget_bool();
return if $cmd_bad or cget_chkblank();
my $ind;
$ind = 15 if $pnam eq "rlmon";
$ind = 14 if $pnam eq "rbmon";
$ind = 13 if $pnam eq "tmu";
if (defined $ind) {
rri_sideband(0x00, ($ind<<8) + $val);
} else {
printf "pi_rri($curmode)-E: Invalid parameter '$pnam' for set sim\n";
}
} else { # set <device> ---------
my $ctl = $serv11_ctltbl{uc($what)};
if (defined $ctl) {
my $partbl = $ctl->{partbl};
if (defined $partbl) {
my $pnam = cget_name();
return if $cmd_bad;
my $pdsc = $partbl->{$pnam};
if (defined $pdsc) {
my $type = $pdsc->{type};
if ($type =~ /^hval:([bdos])$/) {
my $cnv = $1;
my $val;
if ($cnv eq "b") {
$val = cget_bool();
} elsif ($cnv eq "d") {
$val = cget_gdat(32, 10);
} elsif ($cnv eq "o") {
$val = cget_gdat(32, 8);
} elsif ($cnv eq "s") {
$val = $cmd_rest;
$val =~ s/^\s*//;
$val =~ s/\s*$//;
$cmd_rest = "";
}
return if $cmd_bad or cget_chkblank();
$ctl->{$pnam} = $val;
} else {
print "pi_rri($curmode)-E: unexpected type $type in partbl\n";
}
} else {
print "pi_rri($curmode)-E: '$pnam' not valid for 'set $what'\n";
}
} else {
print "pi_rri($curmode)-I: nothing to set for '$what'\n";
}
} else {
print "pi_rri($curmode)-E: unknown entity for 'set': \"$what\"\n";
}
}
} elsif ($cmd =~ /^sho/) { # show parameters ----------------
my $what = cget_name();
return if $cmd_bad;
if ($what =~ /^conf/) { # sho conf[iguration] --
return if cget_chkblank();
serv11_cexec_shoconf();
} elsif ($what =~ /^att/) { # sho att --------------
return if cget_chkblank();
serv11_cexec_shoatt();
} elsif ($what =~ /^regs/) { # sho regs -------------
return if cget_chkblank();
serv11_cexec_shoreg(1);
} elsif ($what =~ /^mmu/) { # sho mmu --------------
return if cget_chkblank();
serv11_cexec_shommu_ssrx;
serv11_cexec_shommu_sadr(0172300, "KM");
serv11_cexec_shommu_sadr(0172200, "SM");
serv11_cexec_shommu_sadr(0177600, "UM");
} elsif ($what =~ /^ubm/) { # sho ubmap ------------
return if cget_chkblank();
my @data;
my $rc = serv11_exec_rblk(0170200, 0, \@data, 64);
print "UNIBUS mapping registers:\n";
for (my $i=0; $i<32; $i++) {
printf " [%2d]: %2.2o,%6.6o\n", $i, $data[2*$i+1], $data[2*$i];
}
} else { # sho <device> ---------
my $ctl = $serv11_ctltbl{uc($what)};
if (defined $ctl) {
my $partbl = $ctl->{partbl};
if (defined $partbl) {
foreach my $pnam (sort keys %{$partbl}) {
my $pdsc = $partbl->{$pnam};
my $type = $pdsc->{type};
if ($type =~ /^hval:([bdos])$/) {
my $cnv = $1;
my $val = $ctl->{$pnam};
my $val_str = $val;
if (defined $val) {
$val_str = ($val) ? "1 (yes)" : "0 (no)" if $cnv eq "b";
$val_str = sprintf("%6d.", $val) if $cnv eq "d";
$val_str = sprintf("%6.6o", $val) if $cnv eq "o";
} else {
$val_str = "<undef>";
}
printf "%4s %10s : %s\n", uc($what), $pnam, $val_str;
} else {
print "pi_rri($curmode)-E: unexpected type $type in partbl\n";
}
}
} else {
print "pi_rri($curmode)-I: nothing to show for '$what'\n";
}
} else {
print "pi_rri($curmode)-E: unknown entity for 'sho': \"$what\"\n";
}
}
} elsif ($cmd =~ /^wtt/) { # write to TT decives -------------
my $ucb = cget_ucb("term");
my $str = "\\n";
if ($cmd_rest =~ /^\s*"(.*)"\s*/) {
$cmd_rest = $';
$str = $1;
}
return if $cmd_bad or cget_chkblank();
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
my @bytes;
conv_str2bytes($str, \@bytes, 1);
&{$ctl->{ichrhdl}}($ucb, \@bytes)
} elsif ($cmd =~ /^attn/) { # attn --------------------------
return if cget_chkblank();
serv11_server_attn_get();
} elsif ($cmd =~ /^att/) { # attach ------------------------
my $ucb = cget_ucb();
return if $cmd_bad;
serv11_cexec_attdet(0,$ucb);
} elsif ($cmd =~ /^det/) { # detach ------------------------
my $ucb = cget_ucb();
return if cget_chkblank();
serv11_cexec_attdet(1,$ucb);
} elsif ($cmd =~ /^init/) { # init --------------------------
return if cget_chkblank();
serv11_init_dispatch() if $serv11_init_pending;
} elsif ($cmd =~ /^boot/) { # boot --------------------------
my $ucb = cget_ucb();
return if $cmd_bad or cget_chkblank();
serv11_cexec_boot($ucb);
} elsif ($cmd =~ /^start/) { # start --------------------------
my $addr = cget_gdat(16, 8);
return if cget_chkblank();
my @rval;
my $rc;
serv11_rri_init(".anena", 0xff, $serv11_init_anena);# enable attn+ioto
serv11_rri_attn("attn"); # discard old attn's
serv11_rri_wreg("wpc", PDPCP_ADDR_PC, $addr);
serv11_rri_wreg("sta", PDPCP_ADDR_CNTL, PDPCP_FUNC_STA);
$rc = serv11_rri_exec(\@rval);
} elsif ($cmd =~ /^step/) { # step --------------------------
my @rval;
my $rc;
serv11_rri_wreg("sta", PDPCP_ADDR_CNTL, PDPCP_FUNC_STEP);
$rc = serv11_rri_exec(\@rval);
serv11_cexec_shoreg(1);
} elsif ($cmd =~ /^stop/) { # stop --------------------------
my @rval;
my $rc;
serv11_rri_wreg("sto", PDPCP_ADDR_CNTL, PDPCP_FUNC_STO);
$rc = serv11_rri_exec(\@rval);
serv11_cexec_shoreg(1);
} elsif ($cmd =~ /^cont/) { # cont --------------------------
my @rval;
my $rc;
serv11_rri_wreg("sto", PDPCP_ADDR_CNTL, PDPCP_FUNC_CONT);
$rc = serv11_rri_exec(\@rval);
} elsif ($cmd =~ /^reset/) { # reset -------------------------
my @rval;
my $rc;
serv11_rri_wreg("rst", PDPCP_ADDR_CNTL, PDPCP_FUNC_RST);
$rc = serv11_rri_exec(\@rval);
} elsif ($cmd =~ /^server/) { # enter server mode --------------
return if cget_chkblank();
serv11_server();
} else {
print "pi_rri($curmode)-E: unknown command: \"$cmd_line\"\n";
}
}
#-------------------------------------------------------------------------------
sub serv11_cexec_shoreg {
my ($mode) = @_;
my $ipc;
my $ips;
my @rval;
if ($mode > 0) {
serv11_rri_rreg("rr0", PDPCP_ADDR_R0+0);
serv11_rri_rreg("rr1", PDPCP_ADDR_R0+1);
serv11_rri_rreg("rr2", PDPCP_ADDR_R0+2);
serv11_rri_rreg("rr3", PDPCP_ADDR_R0+3);
serv11_rri_rreg("rr4", PDPCP_ADDR_R0+4);
serv11_rri_rreg("rr5", PDPCP_ADDR_R0+5);
serv11_rri_rreg("rr6", PDPCP_ADDR_R0+6);
}
$ipc = serv11_rri_rreg("rr7", PDPCP_ADDR_R0+7);
$ips = serv11_rri_rreg("rps", PDPCP_ADDR_PSW);
my $rc = serv11_rri_exec(\@rval);
print "Processor registers and status:\n" if ($mode > 0);
my $ps_bin = gconv_dat16($rval[$ips],2);
printf " PC: %6.6o ", $rval[$ipc] if ($mode == 0);
printf " PS: %6.6o", $rval[$ips];
printf " cmo=%s",substr($ps_bin,0,2); # bit 15:14 -> 0,2
printf " pmo=%s",substr($ps_bin,2,2); # bit 13:12 -> 2,2
printf " set=%s",substr($ps_bin,4,1); # bit 11 -> 4
printf " pri=%d",($rval[$ips]>>5)&0x7; # bit 07:05
printf " t=%s", substr($ps_bin,11,1); # bit 04 -> 11,1
printf " NZVC=%s", substr($ps_bin,12,4); # bit 03:00 -> 12,4
print "\n";
if ($mode > 0) {
printf " R0: %6.6o", $rval[0];
printf " R1: %6.6o", $rval[1];
printf " R2: %6.6o", $rval[2];
printf " R3: %6.6o\n", $rval[3];
printf " R4: %6.6o", $rval[4];
printf " R5: %6.6o", $rval[5];
printf " SP: %6.6o", $rval[6];
printf " PC: %6.6o\n", $rval[$ipc];
}
}
#-------------------------------------------------------------------------------
# ssr0 177572
# ssr1 177574
# ssr2 177576
# ssr3 172516
sub serv11_cexec_shommu_ssrx {
my @rval;
serv11_rri_wreg("wal", PDPCP_ADDR_AL, 0177572);
my $issr0 = serv11_rri_rreg("rmi", PDPCP_ADDR_MEMI);
my $issr1 = serv11_rri_rreg("rmi", PDPCP_ADDR_MEMI);
my $issr2 = serv11_rri_rreg("rmi", PDPCP_ADDR_MEMI);
serv11_rri_wreg("lal", PDPCP_ADDR_AL, 0172516);
my $issr3 = serv11_rri_rreg("rmi", PDPCP_ADDR_MEMI);
my $rc = serv11_rri_exec(\@rval);
print "MMU registers:\n";
printf " SSR0: %6.6o\n", $rval[$issr0];
printf " SSR1: %6.6o\n", $rval[$issr1];
printf " SSR2: %6.6o\n", $rval[$issr2];
printf " SSR3: %6.6o\n", $rval[$issr3];
}
#-------------------------------------------------------------------------------
#
# Note: The ptape maindec's have even size records, except possibly for the
# last one, and always start at an even address.
# The lda's extracted with UPD2 PIP from the xxdp22 disk have often
# records with 503 byte payload, starting at even and odd addresses.
# Since blkw only handles even sized transfers on even addresses some
# magic with the %oddbyt hash is needed to handle this correctly.
#
sub serv11_cexec_ldabs {
my ($file,$opt_s) = @_;
if (not -r $file) {
print "pi_rri($curmode)-E: file $file not found or readable\n";
return;
}
my $fh = new FileHandle;
$fh->open("<$file") or die "unexpected open failure";
my $chrnum = 0; # char number in block
my $blknum = 0; # block number
my $bytcnt = 0; # byte count
my $ldaddr = 0; # load address
my $chksum = 0; # check sum
my $addr = 0; # current address
my @data; # data array for transfer
my %oddbyt; # odd byte cache
my $word;
while (1) {
my $buf;
my $rc = $fh->read($buf,1);
if ($rc == 0) {
print "pi_rri($curmode)-E: unexpected EOF in $file\n" unless $chrnum == 0;
return;
}
return if $rc != 1;
my $byt = ord($buf);
$chksum = ($chksum + $byt) & 0377;
if ($chrnum == 0) { # in blank tape
if ($byt == 0) {
next;
} elsif ($byt == 1) {
$chrnum += 1;
} else {
printf "pi_rri($curmode)-E: unexpected start-of-block %3.3o in $file\n",
$byt;
return;
}
} elsif ($chrnum == 1) { # 001 frame seen
if ($byt == 0) {
$chrnum += 1;
} else {
printf "pi_rri($curmode)-E: unexpected 2nd char %3.3o in $file\n",
$byt;
return;
}
} elsif ($chrnum == 2) { # byte count low
$bytcnt = $byt & 0377;
$chrnum += 1;
} elsif ($chrnum == 3) { # byte count high
$bytcnt |= ($byt & 0377)<<8;
$chrnum += 1;
} elsif ($chrnum == 4) { # load address low
$ldaddr = $byt & 0377;
$chrnum += 1;
} elsif ($chrnum == 5) { # load address high
$ldaddr |= ($byt & 0377)<<8;
$chrnum += 1;
printf "pi_rri($curmode)-I: block %3d, length %5d byte,".
" address %6.6o:%6.6o\n",
$blknum, ($bytcnt-6), $ldaddr, $ldaddr+($bytcnt-6)-1;
$addr = $ldaddr; # setup current address
$word = 0;
if (($addr & 01) == 1 && $bytcnt > 6) { # setup even byte if known...
$word = $oddbyt{sprintf("%6.6o",$addr)};
if (not defined $word) {
printf "pi_rri($curmode)-W: no low byte data for %6.6o\n", $addr;
$word = 0;
}
}
} elsif ($chrnum == $bytcnt) { # check sum byte
if ($chksum != 0) {
printf "pi_rri($curmode)-E: check sum error %3.3o in $file\n",
$chksum;
return;
}
if ($chrnum == 6) {
printf "pi_rri($curmode)-I: start address %6.6o\n", $ldaddr;
return;
} else {
if (($addr & 01) == 1) { # high byte not yet seen
push @data, $word; # zero fill high byte
$oddbyt{sprintf("%6.6o",$addr)} = $word; # store even byte for later
# note that address is odd here
}
serv11_exec_wblk($ldaddr, 0, \@data);
@data = ();
}
$chrnum = 0;
$blknum += 1;
} else { # in data
if (($addr & 01) == 0) { # low byte
$word = $byt & 0377;
$addr += 1;
} else { # high byte
$word |= ($byt & 0377)<<8;
push @data, $word;
$addr += 1;
}
$chrnum += 1;
}
}
$fh->close();
}
#-------------------------------------------------------------------------------
# sadr format:
# offset 0: DR[0] I space
# offset 20: DR[0] D space
# offset 40: AR[0] I space
# offset 60: AR[0] D space
#
sub serv11_cexec_shommu_sadr {
my ($base,$mode) = @_;
my @data;
my $rc = serv11_exec_rblk($base, 0, \@data, 32);
for (my $i=0; $i<16; $i++) {
my $space = ($i<8) ? "I" : "D";
my $ind = $i%8;
my $dr = $data[$i];
my $ar = $data[$i+16];
my $dr_bin = gconv_dat16($dr,2);
my $dr_acf = $dr&0xf; # bit 3:0
printf " %s-%s[%d]: %6.6o,%6.6o", $mode,$space,$ind, $dr, $ar;
printf " slf=%3d", ($dr>>8)&0xff;
printf " aib=%s", substr($dr_bin,8,2); # bit 7:6 -> 8,2
printf " acf=%d", $dr_acf;
print "\n";
}
}
#-------------------------------------------------------------------------------
sub serv11_cexec_shoconf {
foreach my $ctlname (sort { $serv11_ctltbl{$b}->{base} <=>
$serv11_ctltbl{$a}->{base} }
keys %serv11_ctltbl) {
my $ctl = $serv11_ctltbl{$ctlname};
my $mask = $ctl->{probemask};
my $ival = $ctl->{probe_ival};
my $rval = $ctl->{probe_rval};
my $ib_str = ($mask =~ /i/) ? ( (defined $ival) ? "y" : "n" ) : "-";
my $rb_str = ($mask =~ /r/) ? ( (defined $rval) ? "y" : "n" ) : "-";
printf "%-3s %-9s %4s: %s ib=%s rb=%s lam=%s boot=%s", $ctlname,
$ctl->{ctltype}, $ctl->{type},
($ctl->{base} ? sprintf("%6.6o", $ctl->{base}) : "......"),
$ib_str, $rb_str,
(exists $ctl->{lam} ? sprintf("%2d",$ctl->{lam}) : " -"),
(exists $ctl->{boot_code} ? "y" : "n");
printf " %s",$ctl->{probe_text} if $ctl->{probe_text};
print "\n";
}
}
#-------------------------------------------------------------------------------
sub serv11_cexec_shoatt {
foreach my $unitname (sort keys %serv11_unittbl) {
my $ucb = $serv11_unittbl{$unitname};
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
next unless $ctl->{probe_ok};
next unless $ucb->{att_ok};
printf "%-3s : ", $unitname;
if ($ctl->{type} eq "disk") {
printf "nblk=%6d wp=%s file=%s",
$ucb->{att_nblk},
($ucb->{att_wpro} ? "y" : "n"),
$ucb->{att_file};
} elsif ($ctl->{type} eq "tape") {
printf "wp=%s file=%s",
($ucb->{att_wpro} ? "y" : "n"),
$ucb->{att_file};
} elsif ($ctl->{type} eq "term") {
printf "port=%s",
$ucb->{att_port};
}
print "\n";
}
}
#-------------------------------------------------------------------------------
sub serv11_cexec_attdet {
my ($det,$ucb) = @_;
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
my $attdethdl = $ctl->{attdethdl};
if (not defined $attdethdl) {
printf "pi_rri($curmode)-E: attach/detach not supported for %s\n",
$ucb->{unitname};
return;
}
&{$attdethdl}($det, $ucb); # call handler
}
#-------------------------------------------------------------------------------
sub serv11_cexec_boot {
my ($ucb) = @_;
my @rval;
my $rc;
my $unitname = $ucb->{unitname};
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
if (not exists $ctl->{boot_code}) {
print "pi_rri($curmode)-E: device $unitname not bootable\n";
return;
}
serv11_init_dispatch() if $serv11_init_pending;
my @boot_code = @{$ctl->{boot_code}};
my $boot_length = scalar(@boot_code);
my $boot_mode = $ctl->{boot_mode};
my $boot_entry = $ctl->{boot_entry};
$boot_mode = "disk" unless defined $boot_mode;
if ($boot_mode eq "disk") {
my $boot_unit = $ctl->{boot_unit};
$boot_code[int (($boot_unit-(BOOT_START))/2)] =
$ucb->{ctlunit}; # patch in unit num
$rc = serv11_exec_wblk(BOOT_START, 0, \@boot_code, $boot_length);
} elsif ($boot_mode eq "ptape") {
my $boot_base = $ctl->{boot_base};
my $memsize = 56 * 1024; # FIXME: check memtop !!!
$memsize = 56*1024 if ($memsize > 56*1024);
my $nblk8k = $memsize/020000;
my $offset = ($nblk8k-1) * 020000;
$boot_base += $offset;
$boot_entry += $offset;
$rc = serv11_exec_wblk($boot_base, 0, \@boot_code, $boot_length);
} else {
print_fatal("unsupported boot mode '$boot_mode' in serv11_cexec_boot");
}
serv11_rri_init(".anena", 0xff, $serv11_init_anena); # enable attn+ioto
serv11_rri_attn("attn"); # discard old attn's
serv11_rri_wreg("wpc", PDPCP_ADDR_PC, $boot_entry);
serv11_rri_wreg("sta", PDPCP_ADDR_CNTL, PDPCP_FUNC_STA);
$rc = serv11_rri_exec(\@rval);
}
#-------------------------------------------------------------------------------
sub serv11_cexec_exa {
my ($optset,$ctl,$beg,$end) = @_;
if (not defined $ctl) { # numerical address
for (my $addr=$beg; $addr<=$end; $addr+=2) {
my @rval;
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr);
serv11_rri_rreg("rm", PDPCP_ADDR_MEM);
my $rc = serv11_rri_exec(\@rval);
printf "mem %6.6o : %6.6o\n", $addr, $rval[0];
}
} else {
my $reglist = $ctl->{reglist};
for (my $i=$beg; $i<=$end; $i++) {
my $dsc = $reglist->[$i];
last if not defined $reglist->[$i];
my $name = $dsc->{name};
my $addr = $dsc->{addr};
my $offset = $dsc->{offset};
my $attr = $dsc->{attr};
my $val;
my $addr_str = "......";
my $acs_str = "ib";
my $val_str = "......";
my $com_str = "";
$addr = $ctl->{base} + $offset if defined $offset;
$attr = 0 unless defined $attr;
$acs_str = "rb" if ($attr & REGATTR_RBRD);
$acs_str = "ib" if $optset =~ /i/;
$acs_str = "rb" if $optset =~ /r/;
if ($end > $beg &&
( ( ($attr & REGATTR_IBMBOX) && $acs_str eq "ib" ) ||
( ($attr & REGATTR_RBMBOX) && $acs_str eq "rb" )
) ) {
$com_str = "mailbox skipped";
} else {
my $exadethdl = $dsc->{hdl};
if (defined $dsc->{hdl}) {
$acs_str = " ";
$val = &{$dsc->{hdl}}(0, $dsc);
} else {
if ($acs_str eq "rb") {
my $ibrbase = $addr & ~(077);
my $ibroff = $addr - $ibrbase;
serv11_rri_wreg("wibrb", PDPCP_ADDR_IBRB, $ibrbase);
serv11_rri_rreg("ribr", PDPCP_ADDR_IBR + int($ibroff/2));
$acs_str = "rb";
} else {
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr);
serv11_rri_rreg("rm", PDPCP_ADDR_MEM);
$acs_str = "ib";
}
my @rval;
my $rc = serv11_rri_exec(\@rval);
$val = $rval[0];
}
}
$addr_str = sprintf("%6.6o", $addr) if defined $addr;
$val_str = sprintf("%6.6o", $val) if defined $val;
printf "%4s %6s %2s %6s : %6s", $ctl->{ctlname}, $name,
$acs_str, $addr_str, $val_str;
print " $com_str" if defined $com_str;
print "\n";
}
}
}
#-------------------------------------------------------------------------------
sub serv11_cexec_dep {
my ($optset,$ctl,$beg,$end,$data) = @_;
if (not defined $ctl) { # numerical address
for (my $addr=$beg; $addr<=$end; $addr+=2) {
my @rval;
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr);
serv11_rri_wreg("wm", PDPCP_ADDR_MEM, $data);
my $rc = serv11_rri_exec(\@rval);
}
} else {
my $reglist = $ctl->{reglist};
for (my $i=$beg; $i<=$end; $i++) {
my $dsc = $reglist->[$i];
last if not defined $reglist->[$i];
my $name = $dsc->{name};
my $addr = $dsc->{addr};
my $offset = $dsc->{offset};
my $attr = $dsc->{attr};
my $acs_str = "ib";
$addr = $ctl->{base} + $offset if defined $offset;
$attr = 0 unless defined $attr;
$acs_str = "rb" if ($attr & REGATTR_RBWR);
$acs_str = "ib" if $optset =~ /i/;
$acs_str = "rb" if $optset =~ /r/;
my $exadethdl = $dsc->{hdl};
if (defined $dsc->{hdl}) {
$acs_str = " ";
&{$dsc->{hdl}}(1, $dsc, $data);
} else {
if ($acs_str eq "rb") {
my $ibrbase = $addr & ~(077);
my $ibroff = $addr - $ibrbase;
serv11_rri_wreg("wibrb", PDPCP_ADDR_IBRB, $ibrbase);
serv11_rri_wreg("wibr", PDPCP_ADDR_IBR + int($ibroff/2), $data);
$acs_str = "rb";
} else {
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr);
serv11_rri_wreg("wm", PDPCP_ADDR_MEM, $data);
$acs_str = "ib";
}
my @rval;
my $rc = serv11_rri_exec(\@rval);
}
}
}
}
#-------------------------------------------------------------------------------
# config is called once on the first entering of serv11 mode
#
sub serv11_config {
$serv11_config_done = 1;
foreach my $ctlname (sort keys %serv11_ctltbl) {
my $ctl = $serv11_ctltbl{$ctlname};
$ctl->{probemask} = "ir" unless defined $ctl->{probemask};
&{$ctl->{probehdl}}($ctl) if exists $ctl->{probehdl};
}
if (not $serv11_ctltbl{CPU}->{probe_ok}) {
print_fatal("probe of CPU failed in serv11_open()");
}
init_regtbl();
serv11_cexec_shoconf();
}
#-------------------------------------------------------------------------------
sub serv11_init_dispatch {
foreach my $ctlname (sort keys %serv11_ctltbl) {
my $ctl = $serv11_ctltbl{$ctlname};
&{$ctl->{inithdl}}($ctl) if (exists $ctl->{inithdl} && $ctl->{probe_ok});
}
$serv11_init_pending = 0;
}
#-------------------------------------------------------------------------------
sub serv11_server {
my $old_timeout = $raw_timeout;
my $nfound;
my $fds_rd_act = "";
my $fds_rd;
my $stat_delta = 10.;
my $stat_count = 0;
my $fno_rcv = fileno($fh_rcv);
my $fno_stdin = fileno(STDIN);
my @telfno2dsc;
@serv11_attntbl = ();
foreach my $ctlname (sort keys %serv11_ctltbl) {
my $ctl = $serv11_ctltbl{$ctlname};
if ($ctl->{probe_ok} && exists $ctl->{lam} && exists $ctl->{attnhdl}) {
push @serv11_attntbl, [1<<($ctl->{lam}), $ctl->{attnhdl}, $ctl];
}
}
$raw_timeout = 30.;
$serv11_active = 1;
print "pi_rri($curmode)-I: entering server mode\n";
my $time_stat = get_time() + $stat_delta;
while ($serv11_active) {
my $time_now = get_time();
if ($time_now >= $time_stat) {
##serv11_server_attn_dispatch(1);
if ($stat_count % 20 == 0) {
printf $fh_log "stat -- ";
printf $fh_log " obyte oesc osop ibyte iesc att";
printf $fh_log " xreg xblk rdisk wdisk";
printf $fh_log "\n";
}
$stat_count += 1;
my $dt = $stat_delta;
printf $fh_log "stat -- %s", get_timestamp();
printf $fh_log " %6.0f", ($stat_tab{obyte} - $stat_tab_last{obyte})/$dt;
printf $fh_log " %4.0f", ($stat_tab{oesc} - $stat_tab_last{oesc})/$dt;
printf $fh_log " %4.0f", ($stat_tab{osop} - $stat_tab_last{osop})/$dt;
printf $fh_log " %6.0f", ($stat_tab{ibyte} - $stat_tab_last{ibyte})/$dt;
printf $fh_log " %4.0f", ($stat_tab{iesc} - $stat_tab_last{iesc})/$dt;
printf $fh_log " %3.0f", ($stat_tab{att} - $stat_tab_last{att})/$dt;
printf $fh_log " %5.0f", ($stat_tab{xreg} - $stat_tab_last{xreg})/$dt;
printf $fh_log " %4.0f", ($stat_tab{xblk} - $stat_tab_last{xblk})/$dt;
printf $fh_log " %6.0f", ($stat_tab{rdisk} - $stat_tab_last{rdisk})/$dt;
printf $fh_log " %6.0f", ($stat_tab{wdisk} - $stat_tab_last{wdisk})/$dt;
printf $fh_log "\n";
%stat_tab_last = %stat_tab;
while ($time_stat < $time_now) {
$time_stat += $stat_delta;
}
}
my $timeout = $time_stat - $time_now;
# set timeout=0 if some unfinished business is still pending
$timeout = 0. if $serv11_attn_mask != 0; # attn mask not yet worked down
$timeout = 0. if scalar(@serv11_icbque); # icb queue non empty
$timeout = 0. if scalar(@que_rcv); # still input chars in buffer
if ($serv11_fds_update) {
$fds_rd_act = "";
vec($fds_rd_act, $fno_rcv, 1) = 1;
vec($fds_rd_act, $fno_stdin, 1) = 1;
@telfno2dsc = ();
foreach my $port_str (keys %telnettbl) {
my $teldsc = $telnettbl{$port_str};
my $fno;
if ($teldsc->{state} == TELNET_STATE_LISTEN) {
$fno = fileno($teldsc->{fh_port});
} else {
$fno = fileno($teldsc->{fh_data});
}
vec($fds_rd_act, $fno, 1) = 1;
push @telfno2dsc, [$fno, $teldsc];
}
$serv11_fds_update = 0;
}
##printf $fh_log "+++1 select $timeout, rcvq=%d\n", scalar(@que_rcv);
$nfound = select($fds_rd=$fds_rd_act, undef, undef, $timeout);
##printf $fh_log "+++2 select $nfound\n";
if (vec($fds_rd, $fno_stdin, 1)) {
my $cmd = <STDIN>;
if (defined $cmd) {
chomp $cmd;
$cmd = "lspc" unless $cmd ne "";
$cmd =~ s{^\s*}{}; # remove leading blanks
$cmd =~ s{--.*}{}; # remove comments after --
$cmd =~ s{\s*$}{}; # remove trailing blanks
if ($cmd eq "quit") {
$serv11_active = 0;
} else {
if ($cmd =~ m/^C/) { # ignore, but log "C ..." lines
print $fh_log "$cmd\n";
} elsif ($cmd =~ m/^#/) { # ignore "# ...." lines
} elsif ($cmd =~ m/^;/) { # ignore "; ...." lines
} else { # otherwise execute
serv11_cexec($cmd);
}
}
} else { # handle ^D
$serv11_active = 0;
}
}
# process next input char if read will not block (either fd ready for
# input, or still chars in queue).
if (vec($fds_rd, $fno_rcv, 1) || scalar(@que_rcv)) {
my $dat = raw_rcv9_to(0.);
if (not defined $dat) {
print "pi_rri($curmode)-I: spurious select on rcv channel\n";
next;
} elsif ($dat == D9IDLE) {
next;
} elsif ($dat == D9ATTN) {
serv11_server_attn_get();
} else {
printf "pi_rri($curmode)-I: spurious char on server wait: %3.3x\n",
$dat;
next;
}
}
# process telnet sessions
foreach (@telfno2dsc) {
my $fno = $_->[0];
if (vec($fds_rd, $fno, 1)) {
my $teldsc = $_->[1];
telnet_readhdl($teldsc);
}
}
if ($serv11_attn_mask != 0) {
serv11_server_attn_dispatch(0);
}
if (scalar(@serv11_icbque)) {
my $icb = shift @serv11_icbque;
&{$icb->{rdmahdl}}($icb);
}
if ($serv11_attn_mask == 0 && $serv11_attn_seen) {
$serv11_attn_seen = 0;
serv11_server_attn_get();
}
}
$raw_timeout = $old_timeout;
$serv11_active = 0;
print "pi_rri($curmode)-I: leaving server mode\n";
}
#-------------------------------------------------------------------------------
sub serv11_server_attn_get {
my @rval;
my $rc;
serv11_rri_attn("attn");
$rc = serv11_rri_exec(\@rval);
my $mask_old = $serv11_attn_mask;
$serv11_attn_mask |= $rval[0]; # or-in new attn flags
if (exists $opts{tserv}) {
printf $fh_log "serv -- attn %s :", gconv_dat16($serv11_attn_mask, 2);
foreach my $adsc (@serv11_attntbl) {
my $msk = $adsc->[0];
my $ctl = $adsc->[2];
if ($serv11_attn_mask & $msk) {
my $pref = "";
my $suff = "";
if ($mask_old & $msk) { # old flags are in ()
$pref = "(";
$suff = ")";
}
printf $fh_log " %s%s%s", $pref, $ctl->{ctlname}, $suff;
}
}
printf $fh_log "\n";
}
}
#-------------------------------------------------------------------------------
sub serv11_server_attn_dispatch {
my ($force) = @_;
foreach my $adsc (@serv11_attntbl) {
my $msk = $adsc->[0];
my $hdl = $adsc->[1];
my $ctl = $adsc->[2];
if (($serv11_attn_mask & $msk) || $force) {
$serv11_attn_mask &= ~$msk;
&{$hdl}($ctl,$force);
}
}
}
#-------------------------------------------------------------------------------
sub serv11_probe_gen { # generic probe handler
my ($ctl) = @_;
my $mask = $ctl->{probemask};
my $addr = $ctl->{base};
$addr += $ctl->{csroff} if defined $ctl->{csroff};
my ($ival,$rval) = serv11_exec_probe($addr, $mask);
$ctl->{probe_ival} = $ival;
$ctl->{probe_rval} = $rval;
$ctl->{probe_ok} = 1;
$ctl->{probe_ok} = 0 if ($mask =~ /i/ && ! defined $ival);
$ctl->{probe_ok} = 0 if ($mask =~ /r/ && ! defined $rval);
}
#-------------------------------------------------------------------------------
sub serv11_init_gen { # generic controller init handler
my ($ctl) = @_;
if (exists $ctl->{usethdl}) {
foreach my $unitname (@{$ctl->{units}}) {
my $ucb = $serv11_unittbl{$unitname};
&{$ctl->{usethdl}}($ucb);
}
} else {
printf "pi_rri($curmode)-E: usethdl not defined for %s\n", $ctl->{ctlname};
}
}
#-------------------------------------------------------------------------------
sub serv11_detach_gen { # generic detach handler
my ($ucb) = @_;
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
if ($ucb->{att_ok}) {
my $fh = $ucb->{att_fh};
$fh->close() or die "Unexpected close error";
$ucb->{att_ok} = 0;
delete $ucb->{att_file};
delete $ucb->{att_nbyt};
delete $ucb->{att_nblk};
delete $ucb->{att_wpro};
delete $ucb->{att_fh};
delete $ucb->{att_eof};
&{$ctl->{usethdl}}($ucb); # setup unit registers
} else {
printf "pi_rri($curmode)-E: no file attached for %s\n", $ucb->{unitname};
}
}
#-------------------------------------------------------------------------------
sub serv11_attdet_disk { # generic disk att/det handler
my ($det,$ucb) = @_;
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
if ($det) { # detach handling
serv11_detach_gen($ucb);
} else { # attach handling
if (cget_opt("-w")) { # -w remount
return if $cmd_bad or cget_chkblank();
my $fh = $ucb->{att_fh};
if ($fh) { # mounted and open ?
if (-w $fh) { # file writable ?
$ucb->{att_wpro} = 0; # remove write protect
&{$ctl->{usethdl}}($ucb); # setup unit registers
} else {
printf "pi_rri($curmode)-E: file %s (for %s) is write protected\n",
$ucb->{att_file}, $ucb->{unitname};
return;
}
} else {
printf "pi_rri($curmode)-E: no file attached for %s\n",
$ucb->{unitname};
return;
}
} else { # normal (non -w) handling
my $opt_r = cget_opt("-r");
my $filename = cget_file();
return if $cmd_bad or cget_chkblank();
if (not -e $filename) {
print "pi_rri($curmode)-E: file $filename not found\n";
return;
}
if (not -r $filename) {
print "pi_rri($curmode)-E: file $filename is not readable\n";
return;
}
my $wpro = $opt_r;
if (! $wpro && ! -w $filename) {
print "pi_rri($curmode)-I: file $filename is write protected\n";
$wpro = 1;
}
my $filesize = -s $filename;
if (defined $ctl->{volsize}) {
if ($filesize < $ctl->{volsize}) {
printf "pi_rri($curmode)-W: dsk file too small, %s requires %d".
" file $filename has %d bytes\n",
$ucb->{unitname}, $ctl->{volsize}, $filesize;
}
}
my $fh = new FileHandle;
sysopen ($fh, $filename, $wpro ? O_RDONLY : O_RDWR)
or die "Unexpected sysopen error";
$ucb->{att_ok} = 1;
$ucb->{att_file} = $filename;
$ucb->{att_nbyt} = $filesize;
$ucb->{att_wpro} = $wpro;
$ucb->{att_fh} = $fh;
$ucb->{att_nblk} = int ($ucb->{att_nbyt}/512);
if ($ucb->{att_nbyt}%512 != 0) {
print "pi_rri($curmode)-I: size $filename not multiple of 512\n";
}
&{$ctl->{usethdl}}($ucb); # setup unit registers
}
}
}
#-------------------------------------------------------------------------------
sub serv11_attdet_ronly { # generic in only att/det handler
my ($det,$ucb) = @_;
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
if ($det) { # detach handling
serv11_detach_gen($ucb);
} else { # attach handling
my $filename = cget_file();
return if $cmd_bad or cget_chkblank();
if (not -e $filename) {
print "pi_rri($curmode)-E: file $filename not found\n";
return;
}
if (not -r $filename) {
print "pi_rri($curmode)-E: file $filename is not readable\n";
return;
}
my $fh = new FileHandle;
my $rc = $fh->open("<$filename");
if (not $rc) {
print "pi_rri($curmode)-E: failed to open file $filename\n";
return;
}
$ucb->{att_ok} = 1;
$ucb->{att_file} = $filename;
$ucb->{att_fh} = $fh;
delete $ucb->{att_eof};
&{$ctl->{usethdl}}($ucb); # setup unit registers
}
}
#-------------------------------------------------------------------------------
sub serv11_attdet_wonly { # generic out only att/det handler
my ($det,$ucb) = @_;
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
if ($det) { # detach handling
serv11_detach_gen($ucb);
} else { # attach handling
my $filename = cget_file();
return if $cmd_bad or cget_chkblank();
if (not -e $filename) {
print STDERR "pi_rri($curmode)-I: file $filename will be created\n";
} elsif (not -w $filename) {
print STDERR "pi_rri($curmode)-E: file $filename is not writeable\n";
return;
}
my $fh = new FileHandle;
my $rc = $fh->open(">$filename");
if (not $rc) {
print STDERR "pi_rri($curmode)-E: failed to open file $filename\n";
return;
}
autoflush $fh;
$ucb->{att_ok} = 1;
$ucb->{att_file} = $filename;
$ucb->{att_fh} = $fh;
delete $ucb->{att_eof};
&{$ctl->{usethdl}}($ucb); # setup unit registers
}
}
#-------------------------------------------------------------------------------
sub serv11_attdet_term { # generic term att/det handler
my ($det,$ucb) = @_;
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
if ($det) { # detach handling
my $port_str = $ucb->{att_port};
my $teldsc = $telnettbl{$port_str};
close $teldsc->{fh_data} if defined $teldsc->{fh_data};
close $teldsc->{fh_port} if defined $teldsc->{fh_port};
delete $telnettbl{$port_str};
delete $ucb->{att_port};
$ucb->{att_ok} = 0;
$serv11_fds_update = 1; # request update of select mask
} else { # attach handling
my $port = cget_gdat(16, 10);
return if $cmd_bad or cget_chkblank();
my $port_str = sprintf("%6.6d", $port);
if (exists $telnettbl{$port_str}) {
printf STDERR "pi_rri($curmode)-E: port %d already attached\n", $port;
return;
}
my $fh_port = new FileHandle;
my $proto = getprotobyname('tcp');
if (not socket($fh_port, PF_INET, SOCK_STREAM, $proto)) {
printf STDERR "pi_rri($curmode)-E: error in socket(): $!\n";
return;
}
if (not setsockopt($fh_port, SOL_SOCKET, SO_REUSEADDR, 1)) {
printf STDERR "pi_rri($curmode)-E: error in setsocketopt(): $!\n";
return;
}
my $host = pack('C4', 0,0,0,0);
my $addr = pack('S n a4 x8', 2, $port, $host);
if (not bind($fh_port, $addr)) {
printf STDERR "pi_rri($curmode)-E: error in bind(): $!\n";
return;
}
if (not listen($fh_port, 1)) {
printf STDERR "pi_rri($curmode)-E: error in listen(): $!\n";
return;
}
$telnettbl{$port_str} = {};
$telnettbl{$port_str}->{port} = $port;
$telnettbl{$port_str}->{state} = TELNET_STATE_LISTEN;
$telnettbl{$port_str}->{fh_port} = $fh_port;
$telnettbl{$port_str}->{ucb} = $ucb;
$ucb->{att_ok} = 1;
$ucb->{att_port} = $port_str;
$serv11_fds_update = 1; # request update of select mask
}
}
#-------------------------------------------------------------------------------
sub serv11_probe_cpu { # cpu: probe handler
my ($ctl) = @_;
serv11_probe_gen($ctl);
return unless $ctl->{probe_ok};
my $reglist = $ctl->{reglist};
my $partbl = $ctl->{partbl};
my $text = "";
my $exadep = \&serv11_exadep_cpu;
push @{$reglist}, {name => "r0", hdl => \&serv11_exadep_cpu};
push @{$reglist}, {name => "r1", hdl => \&serv11_exadep_cpu};
push @{$reglist}, {name => "r2", hdl => \&serv11_exadep_cpu};
push @{$reglist}, {name => "r3", hdl => \&serv11_exadep_cpu};
push @{$reglist}, {name => "r4", hdl => \&serv11_exadep_cpu};
push @{$reglist}, {name => "r5", hdl => \&serv11_exadep_cpu};
push @{$reglist}, {name => "sp", hdl => \&serv11_exadep_cpu};
push @{$reglist}, {name => "pc", hdl => \&serv11_exadep_cpu};
push @{$reglist}, {name => "psw", hdl => \&serv11_exadep_cpu};
push @{$reglist}, {name => "stklim", addr => CPU_STKLIM};
push @{$reglist}, {name => "pirq" , addr => CPU_PIRQ};
push @{$reglist}, {name => "mbrk" , addr => CPU_MBRK};
push @{$reglist}, {name => "cpuerr", addr => CPU_CPUERR};
push @{$reglist}, {name => "hisize", addr => CPU_HISIZE};
push @{$reglist}, {name => "losize", addr => CPU_LOSIZE};
my ($ival,$rval) = serv11_exec_probe(CPU_SDREG, "ir");
if (defined $ival && defined $rval) {
push @{$reglist}, {name => "sr", addr => CPU_SDREG, attr => REGATTR_RBWR};
push @{$reglist}, {name => "dr", addr => CPU_SDREG, attr => REGATTR_RBRD};
}
push @{$reglist}, {name => "mmr0" , addr => CPU_MMR0};
push @{$reglist}, {name => "mmr1" , addr => CPU_MMR1};
push @{$reglist}, {name => "mmr2" , addr => CPU_MMR2};
push @{$reglist}, {name => "mmr3" , addr => CPU_MMR3};
my @rval;
serv11_rri_wreg("wal", PDPCP_ADDR_AL, CPU_LOSIZE); # i/o page in 16 bit mode
serv11_rri_rreg("rm", PDPCP_ADDR_MEM);
my $rc = serv11_rri_exec(\@rval);
my $memsize = ($rval[0]+1)<<6; # memsize in bytes
$ctl->{memsize} = $memsize;
$text .= ($text)?";":"" . sprintf("mem=%dkb",$memsize/1024.);
$ctl->{probe_text} = $text;
}
#-------------------------------------------------------------------------------
sub serv11_attn_cpu { # cpu: attention handler
my ($ctl,$force) = @_;
return if $force;
print "CPU halted\n";
$serv11_active = 0;
serv11_cexec_shoreg(1);
}
#-------------------------------------------------------------------------------
sub serv11_exadep_cpu { # cpu: exa/dep handler
my ($dep,$dsc,$val) = @_;
my $name = $dsc->{name};
my $rrireg;
$name =~ s/^sp$/r6/;
$name =~ s/^pc$/r7/;
if ($dep) {
if ($name =~ /^r([0-7])$/) {
$rrireg = PDPCP_ADDR_R0 + int $1;
} elsif ($name eq "psw") {
$rrireg = PDPCP_ADDR_PSW;
} else {
print_fatal("serv11_exadep_cpu() called with bad name '$name'");
}
my @rval;
serv11_rri_wreg("r$name", $rrireg, $val);
my $rc = serv11_rri_exec(\@rval);
return;
} else {
if ($name =~ /^r([0-7])$/) {
$rrireg = PDPCP_ADDR_R0 + int $1;
} elsif ($name eq "psw") {
$rrireg = PDPCP_ADDR_PSW;
} else {
print_fatal("serv11_exadep_cpu() called with bad name '$name'");
}
my @rval;
serv11_rri_rreg("r$name", $rrireg);
my $rc = serv11_rri_exec(\@rval);
return $rval[0];
}
}
#-------------------------------------------------------------------------------
sub serv11_ichr_dl11 {
my ($ucb,$dref) = @_;
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
my @rval;
my $rc;
my $que_old = scalar( @{$ucb->{rcvque}} );
push @{$ucb->{rcvque}}, @$dref;
my $que_new = scalar( @{$ucb->{rcvque}} );
if ($que_old == 0 && $que_new > 0) {
serv11_rri_ibrb($ctl);
serv11_rri_ribr("RCSR", $ctl, DL11_RCSR);
$rc = serv11_rri_exec(\@rval);
if (($rval[0] & DL11_RCSR_M_RDONE) == 0) { # RBUF not full
my $data = shift @{$ucb->{rcvque}};
serv11_rri_wibr("RBUF", $ctl, DL11_RBUF, $data & 0377);
$rc = serv11_rri_exec(\@rval);
}
}
}
#-------------------------------------------------------------------------------
sub serv11_attn_dl11 {
my ($ctl,$force) = @_;
my $ucb = $serv11_unittbl{$ctl->{units}[0]};
my @rval;
my $rc;
my $nxbuf = $ctl->{nxbuf_min};
my $nxbuf_val = 0;
$nxbuf = $ctl->{nxbuf} if defined $ctl->{nxbuf};
serv11_rri_ibrb($ctl);
for (my $i=0; $i<$nxbuf; $i++) {
serv11_rri_ribr("XBUF", $ctl, DL11_XBUF);
}
# select(undef, undef, undef, 5.0); # ! hack
# printf $fh_log "HACK -- wait on DL11 attn\n"; # ! hack
$rc = serv11_rri_exec(\@rval);
my $rrdy;
for (my $i=0; $i<$nxbuf; $i++) {
my $ochr = $rval[$i] & DL11_XBUF_M_XBUF;
my $xval = $rval[$i] & DL11_XBUF_M_XVAL;
$rrdy = $rval[$i] & DL11_XBUF_M_RRDY;
$ochr = $ochr & 0177 if $ucb->{rcv7bit}; # drop parity bit
my $chr = chr($ochr);
my $str = ($ochr>=040 && $ochr<0177) ? "$chr" : sprintf "\\%3.3o",$ochr;
if (exists $opts{tserv} && $ctl->{trace} &&
($xval || not $force)) {
printf $fh_log
"serv -- DL11.%s xbuf=%6.6o xval=%s rrdy=%s rcvq=%3d sndq=%3d",
$ctl->{ctlname}, $rval[$i],
($xval ? "y" : "n"), ($rrdy ? "y" : "n"),
scalar( @{$ucb->{rcvque}} ), scalar( @{$ucb->{sndque}} );
printf $fh_log " char=\"%s\"", $str if $xval;
print $fh_log "\n";
}
if ($xval) {
$nxbuf_val += 1;
my $sndqueref = $ucb->{sndque};
my $ochr_last = 0;
$ochr_last = $$sndqueref[-1] if scalar(@$sndqueref) > 0;
push @{$ucb->{sndque}}, $ochr;
if ($ucb->{att_ok}) {
telnet_writehdl($ucb);
} else {
if ($ctl->{ctlname} eq "TTA") { # for console
while (scalar( @{$ucb->{sndque}} )) {
my $byte = shift @{$ucb->{sndque}};
my $str = "";
if ($byte>=040 && $byte<0177) {
$str = chr($byte);
} elsif ($byte==011) {
$str = "\t";
} elsif ($byte==012) {
$str = "\n";
} elsif ($byte==015) {
$str = "\r";
} else {
$str = sprintf "<%3.3o>", $byte if $byte!=000;
}
print $str;
}
}
if ($ucb->{logfile}) {
my $fh = $ucb->{logfh};
if (not defined $ucb->{logfh}) {
my $logfile = $ucb->{logfile};
my $rc;
$fh = $ucb->{logfh} = new FileHandle;
$rc = $ucb->{logfh}->open(">$logfile");
if (not $rc) {
printf STDERR "pi_rri-E: failed to open $logfile for write\n";
$fh = undef;
} else {
autoflush $fh;
}
}
print $fh $str if $fh;
}
}
# if ($ochr_last == 015 && $ochr == 012) {
# while (scalar( @{$ucb->{sndque}} )) {
# my $byte = shift @{$ucb->{sndque}};
# my $chr = chr($byte);
# if ($byte>=040 && $byte <=177) {
# print $chr
# } else {
# if ($byte != 000 && $byte != 012 && $byte != 015) {
# printf "<%3.3o>", $byte
# }
# }
# }
# print "\n";
# }
}
}
if ($rrdy && scalar( @{$ucb->{rcvque}} ) ) {
my $data = shift @{$ucb->{rcvque}};
serv11_rri_wibr("RBUF", $ctl, DL11_RBUF, $data & 0377);
$rc = serv11_rri_exec(\@rval);
}
$ctl->{nxbuf} = next_nxbuf($ctl, $nxbuf, $nxbuf_val);
}
#-------------------------------------------------------------------------------
sub serv11_uset_lp11 {
my ($ucb) = @_;
my @rval;
my $lpcs = ($ucb->{att_ok}) ? 0 : LP11_CSR_M_ERR;
serv11_rri_uset($ucb, "LPCS", LP11_CSR, $lpcs);
my $rc = serv11_rri_exec(\@rval);
}
#-------------------------------------------------------------------------------
sub serv11_attn_lp11 {
my ($ctl,$force) = @_;
my $ucb = $serv11_unittbl{$ctl->{units}[0]};
my @rval;
my $rc;
my $nxbuf = $ctl->{nxbuf_min};
my $nxbuf_val = 0;
$nxbuf = $ctl->{nxbuf} if defined $ctl->{nxbuf};
serv11_rri_ibrb($ctl);
for (my $i=0; $i<$nxbuf; $i++) {
serv11_rri_ribr("LPBU", $ctl, LP11_BUF);
}
$rc = serv11_rri_exec(\@rval);
for (my $i=0; $i<$nxbuf; $i++) {
my $ochr = $rval[$i] & LP11_BUF_M_BUF;
my $oval = $rval[$i] & LP11_BUF_M_VAL;
my $chr = chr($ochr);
my $str = "$chr";
if (exists $opts{tserv} && $ctl->{trace} &&
($oval || not $force)) {
printf $fh_log
"serv -- LP11 buf=%6.6o val=%s ",
$rval[$i], ($oval ? "y" : "n");
printf $fh_log " char=\"%s\"", $str if $oval;
print $fh_log "\n";
}
if ($oval) {
$nxbuf_val += 1;
my $fh = $ucb->{att_fh};
if ($fh) {
print $fh $str;
} else {
printf STDERR "pi_rri($curmode)-E: spurious output '%s' for %s\n",
$str, $ucb->{unitname};
}
}
}
$ctl->{nxbuf} = next_nxbuf($ctl, $nxbuf, $nxbuf_val);
}
#-------------------------------------------------------------------------------
sub serv11_uset_pc11 {
my ($ucb) = @_;
my @rval;
my $text;
my $addr;
my $data;
if ($ucb->{unitname} eq "PTR") { # if reader
$text = "PRCS";
$addr = PC11_RCSR;
$data = ($ucb->{att_ok}) ? 0 : PC11_RCSR_M_ERR;
} else { # if puncher
$text = "PPCS";
$addr = PC11_PCSR;
$data = ($ucb->{att_ok}) ? 0 : PC11_PCSR_M_ERR;
}
serv11_rri_uset($ucb, $text, $addr, $data);
my $rc = serv11_rri_exec(\@rval);
}
#-------------------------------------------------------------------------------
sub serv11_attdet_pc11 { # pc11 att/det handler
my ($det,$ucb) = @_;
if ($ucb->{unitname} eq "PTR") { # if reader
serv11_attdet_ronly($det, $ucb); # use read-only file
} else { # if puncher
serv11_attdet_wonly($det, $ucb); # use write-only file
}
}
#-------------------------------------------------------------------------------
sub serv11_attn_pc11 {
my ($ctl,$force) = @_;
my $ucb_ptr = $serv11_unittbl{$ctl->{units}[0]};
my $ucb_ptp = $serv11_unittbl{$ctl->{units}[1]};
my @rval;
my $rc;
my $nxbuf = $ctl->{nxbuf_min};
my $nxbuf_val = 0;
$nxbuf = $ctl->{nxbuf} if defined $ctl->{nxbuf};
serv11_rri_ibrb($ctl);
for (my $i=0; $i<$nxbuf; $i++) {
serv11_rri_ribr("PPBUF", $ctl, PC11_PBUF);
}
$rc = serv11_rri_exec(\@rval);
my $rrdy;
for (my $i=0; $i<$nxbuf; $i++) {
my $ochr = $rval[$i] & PC11_PBUF_M_PBUF;
my $pval = $rval[$i] & PC11_PBUF_M_PVAL;
$rrdy = $rval[$i] & PC11_PBUF_M_RBUSY;
if (exists $opts{tserv} && $ctl->{trace} &&
($pval || not $force)) {
printf $fh_log
"serv -- PC11 pbuf=%6.6o pval=%s rrdy=%s \n",
$rval[$i], ($pval ? "y" : "n"), ($rrdy ? "y" : "n");
}
if ($pval) {
$nxbuf_val += 1;
my $fh = $ucb_ptp->{att_fh};
if ($fh) {
print $fh chr($ochr);
} else {
printf STDERR "pi_rri($curmode)-E: spurious output '%3.3o' for %s\n",
$ochr, $ucb_ptp->{unitname};
}
}
}
if ($rrdy) {
my $fh = $ucb_ptr->{att_fh};
if ($fh && (not $ucb_ptr->{att_eof}) ) {
my $char = getc($fh);
if (defined $char) {
serv11_rri_wibr("PRBUF", $ctl, PC11_RBUF, ord($char) & 0377);
$rc = serv11_rri_exec(\@rval);
} else {
serv11_rri_uset($ucb_ptr, "PRCS", PC11_RCSR, PC11_RCSR_M_ERR);
$rc = serv11_rri_exec(\@rval);
$ucb_ptr->{att_eof} = 1;
}
} else {
printf STDERR "pi_rri($curmode)-E: spurious reader busy for %s\n",
$ucb_ptr->{unitname};
}
}
$ctl->{nxbuf} = next_nxbuf($ctl, $nxbuf, $nxbuf_val);
}
#-------------------------------------------------------------------------------
sub serv11_uset_rk11 {
my ($ucb) = @_;
my @rval;
my $rkds = 0;
$rkds = $ucb->{ctlunit}<<(RKDS_V_ID);
if ($ucb->{att_ok}) { # drive available
$rkds |= RKDS_M_HDEN; # always high density
$rkds |= RKDS_M_SOK; # always sector counter OK ?FIXME?
$rkds |= RKDS_M_DRY; # drive available
$rkds |= RKDS_M_ADRY; # access available
$rkds |= RKDS_M_WPS if $ucb->{att_wpro}; # in case write protected
}
$ucb->{rkds} = $rkds;
serv11_rri_uset($ucb, "RKDS", RK11_RKDS, $rkds);
my $rc = serv11_rri_exec(\@rval);
}
#-------------------------------------------------------------------------------
# geometry: c=203;h=2;s=12 ==> 4872 blocks ==> 2 494 464 bytes
#
# several error conditions are only approximately handled:
# OVR: when detected, no transfer done (should trim size)
sub serv11_attn_rk11 {
my ($ctl,$force) = @_;
my @rval;
my $blksize = $ctl->{blksize};
serv11_rri_ibrb($ctl);
serv11_rri_ribr("RKWC", $ctl, RK11_RKWC);
serv11_rri_ribr("RKBA", $ctl, RK11_RKBA);
serv11_rri_ribr("RKDA", $ctl, RK11_RKDA);
serv11_rri_ribr("RKMR", $ctl, RK11_RKMR); # read to monitor CRDONE
serv11_rri_ribr("RKCS", $ctl, RK11_RKCS);
my $rc = serv11_rri_exec(\@rval);
my $rkwc = $rval[0];
my $rkba = $rval[1];
my $rkda = $rval[2];
my $rkmr = $rval[3];
my $rkcs = $rval[4];
my $se = $rkda & RKDA_B_SC;
my $hd = ($rkda>>RKDA_V_SUR ) & RKDA_B_SUR;
my $cy = ($rkda>>RKDA_V_CYL ) & RKDA_B_CYL;
my $dr = ($rkda>>RKDA_V_DRSEL) & RKDA_B_DRSEL;
my $go = ($rkcs & RKCS_M_GO) != 0;
my $fu = ($rkcs>>RKCS_V_FUNC) & RKCS_B_FUNC;
my $mex = ($rkcs>>RKCS_V_MEX ) & RKCS_B_MEX;
my $nwrd = ((~$rkwc) & 0xffff) + 1; # transfer size in words
my $nbyt = 2*$nwrd; # transfer size in bytes
my $nblk = int (($nbyt+$blksize-1)/$blksize);# transfer size in blocks
my $addr = $mex<<16 | $rkba; # 18 bit memory address
my $lbn = $se + RK11_NUMSE*$hd + RK11_NUMSE*RK11_NUMHD*$cy;
my $ucb = $serv11_unittbl{$ctl->{units}[$dr]};
my $rkds = $ucb->{rkds};
if (not defined $rkds) {
printf $fh_log
"serv -- RK11 ERROR: no rri device init, assume ds=0 for drive %d\n", $dr;
$rkds = $ucb->{rkds} = $rkds = 0;
}
if ($go == 0) { # quit here if no go bit set
if (exists $opts{tserv} && $ctl->{trace}) {
if (not $force) {
printf $fh_log "serv -- RK11 cs=%6.6o go=0, spurious attn\n", $rkcs;
}
}
return;
}
my $rker = 0;
my $msg = "";
if ($fu != RKCS_CRESET && # function not control reset
(not $ucb->{att_ok})) { # and drive not attached
$rker = RKER_M_NXD; # --> abort with NXD error
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
if ($fu == RKCS_SEEK || $fu == RKCS_DRESET) {
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_SBCLR) | 1<<($dr));
}
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
serv11_attn_rk11_logerr($ctl, $rker);
} elsif ($fu != RKCS_WRITE && # function neither read
$fu != RKCS_READ && # nor write
($rkcs & RKCS_M_FMT)) { # and FMT set
$rker = RKER_M_PGE; # --> abort with PGE error
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
if ($fu == RKCS_SEEK || $fu == RKCS_DRESET) {
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_SBCLR) | 1<<($dr));
}
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
serv11_attn_rk11_logerr($ctl, $rker);
} else {
if ($fu == RKCS_CRESET) { # Control reset -------------------
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_CRESET));
} elsif ($fu == RKCS_WRITE) { # Write ---------------------------
# Note: WRITE+FMT is just like WRITE
$rker |= RKER_M_NXS if $se >= RK11_NUMSE;
$rker |= RKER_M_NXC if $cy >= RK11_NUMCY;
$rker |= RKER_M_WLO if $ucb->{att_wpro};
$rker |= RKER_M_DRE if $rkcs & RKCS_M_IBA; # not yet supported ! FIXME !
$rker |= RKER_M_DRE if $rkcs & RKCS_M_RWA; # will never be supported
if ($rker) {
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
serv11_attn_rk11_logerr($ctl, $rker);
} else {
my $icb = {rdmahdl => \&serv11_rdma_rk11,
func => "write",
ctl => $ctl,
ucb => $ucb,
lbn => $lbn,
nblk => $nblk,
nwrd => $nwrd,
addr => $addr,
nwdone => 0,
rkcs => $rkcs, # later needed for MEX update
rkda => $rkda # later needed in RKDA update
};
push @serv11_icbque, $icb;
}
} elsif ($fu == RKCS_READ) { # Read ----------------------------
$rker |= RKER_M_NXS if ($se >= RK11_NUMSE);
$rker |= RKER_M_NXC if ($cy >= RK11_NUMCY);
$rker |= RKER_M_DRE if $rkcs & RKCS_M_IBA; # not yet supported ! FIXME !
$rker |= RKER_M_DRE if $rkcs & RKCS_M_RWA; # will never be supported
if ($rker) {
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
serv11_attn_rk11_logerr($ctl, $rker);
} else {
if ($rkcs & RKCS_M_FMT) {
my $icb = {rdmahdl => \&serv11_rdma_rk11,
func => "rdfmt",
ctl => $ctl,
ucb => $ucb,
lbn => $lbn,
nblk => $nwrd, # #blocks == #words for RD FMT !!
nwrd => $nwrd,
addr => $addr,
nwdone => 0,
rkcs => $rkcs, # later needed for MEX update
rkda => $rkda # later needed in RKDA update
};
push @serv11_icbque, $icb;
} else {
my $icb = {rdmahdl => \&serv11_rdma_rk11,
func => "read",
ctl => $ctl,
ucb => $ucb,
lbn => $lbn,
nblk => $nblk,
nwrd => $nwrd,
addr => $addr,
nwdone => 0,
rkcs => $rkcs, # later needed for MEX update
rkda => $rkda # later needed in RKDA update
};
push @serv11_icbque, $icb;
}
}
} elsif ($fu == RKCS_WCHK) { # Write Check ---------------------
$rker |= RKER_M_NXS if $se >= RK11_NUMSE;
$rker |= RKER_M_NXC if $cy >= RK11_NUMCY;
$rker |= RKER_M_DRE if $rkcs & RKCS_M_IBA; # not yet supported ! FIXME !
$rker |= RKER_M_DRE if $rkcs & RKCS_M_RWA; # will never be supported
if ($rker) {
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
serv11_attn_rk11_logerr($ctl, $rker);
} else {
my $icb = {rdmahdl => \&serv11_rdma_rk11,
func => "wrcheck",
ctl => $ctl,
ucb => $ucb,
lbn => $lbn,
nblk => $nblk,
nwrd => $nwrd,
addr => $addr,
nwdone => 0,
rkcs => $rkcs, # later needed for MEX update
rkda => $rkda # later needed in RKDA update
};
push @serv11_icbque, $icb;
}
} elsif ($fu == RKCS_SEEK) { # Seek ----------------------------
$rker |= RKER_M_NXS if ($se >= RK11_NUMSE);
$rker |= RKER_M_NXC if ($cy >= RK11_NUMCY);
if ($rker) {
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_SBCLR) | 1<<($dr));
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
serv11_attn_rk11_logerr($ctl, $rker);
} else {
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
$rkds &= ~(RKDS_B_SC); # replace current sector number
$rkds |= $se;
$ucb->{rkds} = $rkds;
serv11_rri_wibr("RKDS", $ctl, RK11_RKDS, $rkds);
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<($dr)); # issue seek done
}
} elsif ($fu == RKCS_RCHK) { # Read Check ----------------------
$rker |= RKER_M_NXS if $se >= RK11_NUMSE;
$rker |= RKER_M_NXC if $cy >= RK11_NUMCY;
$rker |= RKER_M_DRE if $rkcs & RKCS_M_IBA; # not yet supported ! FIXME !
$rker |= RKER_M_DRE if $rkcs & RKCS_M_RWA; # will never be supported
if ($rker) {
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
serv11_attn_rk11_logerr($ctl, $rker);
} else {
my $icb = {rdmahdl => \&serv11_rdma_rk11,
func => "rdcheck",
ctl => $ctl,
ucb => $ucb,
lbn => $lbn,
nblk => $nblk,
nwrd => $nwrd,
addr => $addr,
nwdone => 0,
rkcs => $rkcs, # later needed for MEX update
rkda => $rkda # later needed in RKDA update
};
push @serv11_icbque, $icb;
}
} elsif ($fu == RKCS_DRESET) { # Drive Reset ---------------------
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<($dr)); # issue seek done
} elsif ($fu == RKCS_WLOCK) { # Write Lock ----------------------
$ucb->{rkds} |= RKDS_M_WPS; # set RKDS write protect flag
$ucb->{att_wpro} = 1; # set UCB write protect flag
serv11_rri_wibr("RKDS", $ctl, RK11_RKDS, $ucb->{rkds});
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
}
}
if (exists $opts{tserv} && $ctl->{trace}) {
printf $fh_log "serv -- RK11 cs=%6.6o da=%6.6o wc=%6.6o",
$rkcs, $rkda, $rkwc;
printf $fh_log " ad=%6.6o", $addr;
printf $fh_log " fu=%d dchs=%d,%3d,%d,%2d", $fu, $dr, $cy, $hd, $se;
printf $fh_log " lbn=%4d nw,nb=%5d,%2d", $lbn, $nwrd, $nblk;
print $fh_log "\n";
}
$rc = serv11_rri_exec(\@rval);
}
#-------------------------------------------------------------------------------
sub serv11_attn_rk11_logerr {
my ($ctl,$rker) = @_;
if (exists $opts{tserv}) {
printf $fh_log "serv -- RK11 er=%6.6o ERROR ABORT\n", $rker;
}
}
#-------------------------------------------------------------------------------
sub serv11_rdma_rk11 {
my ($icb) = @_;
my $ctl = $icb->{ctl};
my $ucb = $icb->{ucb};
my $addr = $icb->{addr};
my $blksize = $ctl->{blksize};
my @rval;
my $rc = 1; # default ok, make code below shorter FIXME
my $rker = 0;
# printf "+++x1 func=%5s addr=%6.6o nblk=%2d nwdone=%3d\n",
# $icb->{func}, $addr, $icb->{nblk}, $icb->{nwdone};
if ($icb->{func} eq "read") { # --- read function --------------
if ($icb->{nwdone} == 0) { # new block ?
$rker |= RKER_M_OVR if $icb->{lbn} >= RK11_NUMBL;
$rc = serv11_icb_disk_read($icb) if not $rker;
$rker |= RKER_M_CSE if not $rc; # forward disk I/O error
}
if (not $rker) {
my $nwdma = int($blksize/2) - $icb->{nwdone};
$nwdma = $icb->{nwrd} if $nwdma > $icb->{nwrd};
$nwdma = $serv11_rdma_chunk if $nwdma > $serv11_rdma_chunk;
my $beg = $icb->{nwdone};
my $end = $beg + $nwdma - 1;
my $buf = $icb->{buf};
serv11_rri_lalh($icb->{addr}, 3);
serv11_rri_wblk($nwdma, [ @$buf[$beg..$end] ]);
$rc = serv11_rri_exec(\@rval); # FIXME: handle dma I/O error
$stat_tab{rdisk} += 2*$nwdma;
$icb->{nwdone} += $nwdma;
$icb->{nwrd} -= $nwdma;
$icb->{addr} += 2*$nwdma;
if ((not $rker) && # no error and
($icb->{nwdone} == int($blksize/2) || # block done or
$icb->{nwrd} == 0) ) { # all done
$icb->{nwdone} = 0;
$icb->{lbn} += 1;
$icb->{nblk} -= 1;
}
}
if ((not $rker) && $icb->{nwrd}) { # if no error found and not done yet
push @serv11_icbque, $icb; # requeue
return;
}
} elsif ($icb->{func} eq "rdfmt") { # --- read format function -------
$rker |= RKER_M_OVR if $icb->{lbn} >= RK11_NUMBL;
if (not $rker) {
my $cy = $icb->{lbn}/(RK11_NUMHD*RK11_NUMSE);
my $da = $cy<<(RKDA_V_CYL);
my @buf = ($da);
serv11_rri_lalh($icb->{addr}, 3);
serv11_rri_wblk(1, [ @buf ]);
$rc = serv11_rri_exec(\@rval); # FIXME: handle dma I/O error
$stat_tab{rdisk} += 2;
$icb->{nwrd} -= 1;
$icb->{addr} += 2;
$icb->{lbn} += 1;
$icb->{nblk} -= 1;
}
if ((not $rker) && $icb->{nwrd}) { # if no error found and not done yet
push @serv11_icbque, $icb; # requeue
return;
}
} elsif ($icb->{func} eq "write") { # --- write function -------------
$icb->{buf} = [] if $icb->{nwdone} == 0;
my $nwdma = int($blksize/2) - $icb->{nwdone};
$nwdma = $icb->{nwrd} if $nwdma > $icb->{nwrd};
$nwdma = $serv11_rdma_chunk if $nwdma > $serv11_rdma_chunk;
serv11_rri_lalh($icb->{addr}, 3);
serv11_rri_rblk($nwdma);
$rc = serv11_rri_exec(\@rval); # FIXME: handle dma I/O error
$stat_tab{wdisk} += 2*$nwdma;
$icb->{nwdone} += $nwdma;
$icb->{nwrd} -= $nwdma;
$icb->{addr} += 2*$nwdma;
push @{$icb->{buf}}, @{$rval[0]};
if ((not $rker) && # no error and
($icb->{nwdone} == int($blksize/2) || # block done or
$icb->{nwrd} == 0) ) { # all done
$rc = serv11_icb_disk_write($icb); # FIXME: handle file I/O error
$icb->{nwdone} = 0;
$icb->{lbn} += 1;
$icb->{nblk} -= 1;
$rker |= RKER_M_OVR if $icb->{nblk} && $icb->{lbn} >= RK11_NUMBL;
}
if ((not $rker) && $icb->{nwrd}) { # if no error found and not done yet
push @serv11_icbque, $icb; # requeue
return;
}
} elsif ($icb->{func} eq "wrcheck") { # --- write check function -------
if ($icb->{nwdone} == 0) { # new block ?
$rker |= RKER_M_OVR if $icb->{lbn} >= RK11_NUMBL;
$rc = serv11_icb_disk_read($icb) if not $rker;
$rker |= RKER_M_CSE if not $rc; # forward disk I/O error
if ((not $rker)) {
$icb->{bufdsk} = $icb->{buf};
$icb->{buf} = [];
}
}
my $nwdma = int($blksize/2) - $icb->{nwdone};
$nwdma = $icb->{nwrd} if $nwdma > $icb->{nwrd};
$nwdma = $serv11_rdma_chunk if $nwdma > $serv11_rdma_chunk;
serv11_rri_lalh($icb->{addr}, 3);
serv11_rri_rblk($nwdma);
$rc = serv11_rri_exec(\@rval); # FIXME: handle dma I/O error
$stat_tab{wdisk} += 2*$nwdma;
$icb->{nwdone} += $nwdma;
$icb->{nwrd} -= $nwdma;
$icb->{addr} += 2*$nwdma;
push @{$icb->{buf}}, @{$rval[0]};
if ((not $rker) && # no error and
($icb->{nwdone} == int($blksize/2) || # block done or
$icb->{nwrd} == 0)) { # all done
my $bufdsk = $icb->{bufdsk};
my $bufmem = $icb->{buf};
my $nwmem = scalar(@{$bufmem});
for (my $i=0; $i<$nwmem; $i++) {
$rker |= RKER_M_WCE if $bufdsk->[$i] != $bufmem->[$i];
}
$icb->{nwdone} = 0;
$icb->{lbn} += 1;
$icb->{nblk} -= 1;
$rker |= RKER_M_OVR if $icb->{nblk} && $icb->{lbn} >= RK11_NUMBL;
}
my $stop = ($rker & ~RKER_M_WCE) != 0 || # any hard error
(($rker & RKER_M_WCE) && $icb->{rkcs} & RKCS_M_SSE);
if ((not $stop) && $icb->{nwrd}) { # if no error found and not done yet
push @serv11_icbque, $icb; # requeue
return;
}
} elsif ($icb->{func} eq "rdcheck") { # --- read check function --------
$rker |= RKER_M_OVR if $icb->{lbn} >= RK11_NUMBL;
if (not $rker) {
my $nwdma = int($blksize/2);
$nwdma = $icb->{nwrd} if $nwdma > $icb->{nwrd};
# Note: rkwc is decremented; rkba is untouched, no DMA transfer done
$icb->{nwrd} -= $nwdma;
$icb->{lbn} += 1;
$icb->{nblk} -= 1;
}
if ((not $rker) && $icb->{nwrd}) { # if no error found and not done yet
push @serv11_icbque, $icb; # requeue
return;
}
} else { # --- unkown function ------------
printf "pi_rri-E: unknown func=%s for serv11_rdma_rk11\n", $icb->{func};
}
# common handling for dma transfer completion
my $ba = $icb->{addr} &0177776; # get lower 16 bits
my $mex = ($icb->{addr} >> 16) & 03; # get upper 2 bits
my $lbn = $icb->{lbn};
my $nwrd = $icb->{nwrd};
my $end = $lbn;
my $se = $end % RK11_NUMSE;
$end = int ($end / RK11_NUMSE);
my $hd = $end % RK11_NUMHD;
$end = int ($end / RK11_NUMHD);
my $cy = $end;
my $da = ($icb->{rkda} & RKDA_M_DRSEL) |
$se | $hd<<(RKDA_V_SUR) | $cy<<(RKDA_V_CYL);
my $cs = ($icb->{rkcs} & (~RKCS_M_MEX)) | ($mex << RKCS_V_MEX);
serv11_rri_ibrb($ctl);
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker) if $rker;
serv11_rri_wibr("RKWC", $ctl, RK11_RKWC, (-$nwrd)&0177777);
serv11_rri_wibr("RKBA", $ctl, RK11_RKBA, $ba);
serv11_rri_wibr("RKDA", $ctl, RK11_RKDA, $da);
serv11_rri_wibr("RKCS", $ctl, RK11_RKCS, $cs) if ($cs != $icb->{rkcs});
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
serv11_attn_rk11_logerr($ctl, $rker) if $rker;
$rc = serv11_rri_exec(\@rval);
}
#-------------------------------------------------------------------------------
# read one disk block at lbn, returns $icb->{buf}
sub serv11_icb_disk_read { # read one dsk file block
my ($icb) = @_;
my $ucb = $icb->{ucb};
my $ctl = $icb->{ctl};
my $fh = $ucb->{att_fh};
my $fsize = $ucb->{att_nbyt};
my $lbn = $icb->{lbn};
my $blksize = $ctl->{blksize};
my $seekpos = $lbn*$blksize;
my $sysbuf;
my $msg = "";
my $rc = 0;
$icb->{buf} = undef;
if ($seekpos < $fsize) {
($rc,$sysbuf) = file_seek_read($fh, $seekpos, $blksize);
$icb->{buf} = conv_buf2wlist($sysbuf);
} else {
$rc = $blksize; # setup good rc
$msg = " past eof zero buf";
$icb->{buf} = [];
while ($blksize > 0) {
push @{$icb->{buf}}, 0;
$blksize -= 2;
}
}
if (exists $opts{tserv} && $ctl->{trace}) {
printf $fh_log "disk -- %3s read lbn=%5d rc=%d%s\n",
$ucb->{unitname}, $lbn, $rc, $msg;
}
return $rc;
}
#-------------------------------------------------------------------------------
# write one disk block at lbn, takes data from $icb->{buf}
sub serv11_icb_disk_write { # write one dsk file block
my ($icb) = @_;
my $ucb = $icb->{ucb};
my $ctl = $icb->{ctl};
my $fh = $ucb->{att_fh};
my $fsize = $ucb->{att_nbyt};
my $lbn = $icb->{lbn};
my $blksize = $ctl->{blksize};
my $seekpos = $lbn*$blksize;
my $sysbuf = "";
my $rc;
if (scalar(@{$icb->{buf}}) > int($blksize/2)) {
print_fatal "serv11_icb_disk_write: buf too long";
}
while (scalar(@{$icb->{buf}}) < int($blksize/2)) { # zero pad to block size
push @{$icb->{buf}}, 0;
}
if ($fsize <= $seekpos) { # extend dsk file ?
my $zerobuf = chr(0) x $blksize;
my $cnt = 0;
file_seek($fh, $fsize);
while ($fsize <= $seekpos) {
file_write($fh, $zerobuf);
$fsize += $blksize;
$cnt += 1;
}
if (exists $opts{tserv} && $ctl->{trace}) {
printf $fh_log "disk -- %3s extended by %d blocks\n",
$ucb->{unitname}, $cnt;
}
$ucb->{att_nbyt} = $fsize;
}
$sysbuf = conv_wlist2buf($icb->{buf});
$rc = file_seek_write($fh, $seekpos, $sysbuf);
if (exists $opts{tserv} && $ctl->{trace}) {
printf $fh_log "disk -- %3s write lbn=%5d rc=%d\n",
$ucb->{unitname}, $lbn, $rc;
}
return $rc;
}
#-------------------------------------------------------------------------------
sub serv11_rri_init { # issue rri init command
my ($aname,$addr,$data) = @_;
push @rri_cmdlist, {cname => "init",
aname => $aname,
addr => $addr,
data => $data,
ref_stat => $rri_ref_sdef,
msk_stat => $rri_msk_sdef};
return undef;
}
#-------------------------------------------------------------------------------
sub serv11_rri_attn { # issue rri attn command
my ($aname) = @_;
push @rri_cmdlist, {cname => "attn",
aname => $aname,
ref_stat => $rri_ref_sdef,
msk_stat => $rri_msk_sdef};
$rri_cmdlist[$#rri_cmdlist]->{get_data} = 1;
return $rri_rvalcnt++;
}
#-------------------------------------------------------------------------------
sub serv11_rri_stat { # issue rri stat command
my ($aname) = @_;
push @rri_cmdlist, {cname => "stat",
aname => $aname,
ref_stat => $rri_ref_sdef,
msk_stat => $rri_msk_sdef};
$rri_cmdlist[$#rri_cmdlist]->{get_data} = 1;
return $rri_rvalcnt++;
}
#-------------------------------------------------------------------------------
sub serv11_rri_rreg { # issue rri rreg command
my ($aname,$addr) = @_;
push @rri_cmdlist, {cname => "rreg",
aname => $aname,
addr => $addr,
ref_stat => $rri_ref_sdef,
msk_stat => $rri_msk_sdef};
$rri_cmdlist[$#rri_cmdlist]->{get_data} = 1;
return $rri_rvalcnt++;
}
#-------------------------------------------------------------------------------
sub serv11_rri_wreg { # issue rri wreg command
my ($aname,$addr,$data) = @_;
push @rri_cmdlist, {cname => "wreg",
aname => $aname,
addr => $addr,
data => $data,
ref_stat => $rri_ref_sdef,
msk_stat => $rri_msk_sdef};
return undef;
}
#-------------------------------------------------------------------------------
sub serv11_rri_rblk { # issue rri rblk command
my ($nblk) = @_;
push @rri_cmdlist, {cname => "rblk",
aname => "brm",
addr => PDPCP_ADDR_MEMI,
nblk => $nblk,
ref_stat => $rri_ref_sdef,
msk_stat => $rri_msk_sdef};
$rri_cmdlist[$#rri_cmdlist]->{get_rblk} = 1;
return $rri_rvalcnt++;
}
#-------------------------------------------------------------------------------
sub serv11_rri_wblk { # issue rri wblk command
my ($nblk,$dref) = @_;
push @rri_cmdlist, {cname => "wblk",
aname => "bwm",
addr => PDPCP_ADDR_MEMI,
nblk => $nblk,
dat_wblk => $dref,
ref_stat => $rri_ref_sdef,
msk_stat => $rri_msk_sdef};
return undef;
}
#-------------------------------------------------------------------------------
sub serv11_rri_lalh { # issue pdpcp lal and lah commands
my ($addr,$mode) = @_;
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr&0xffff); # lower 16 bits
if ($mode>=1 and $mode<=3) {
my $data = ($addr>>16)&0x3f | $mode<<6;
serv11_rri_wreg("wah", PDPCP_ADDR_AH, $data); # upper 6 bits
}
if ($mode<0 or $mode>3) {
print STDERR "pi_rri($curmode)-E: bad mode $mode in serv11_exec_rblk()\n";
}
}
#-------------------------------------------------------------------------------
sub serv11_rri_ibrb { # issue rbus set base address
my ($ctl) = @_;
serv11_rri_wreg("wibrb", PDPCP_ADDR_IBRB, $ctl->{ibrb});
return undef;
}
#-------------------------------------------------------------------------------
sub serv11_rri_ribr { # issue rbus read
my ($aname,$ctl,$off) = @_;
my $ibroff = $ctl->{base} + $off - $ctl->{ibrb};
return serv11_rri_rreg($aname, PDPCP_ADDR_IBR+int($ibroff/2));
}
#-------------------------------------------------------------------------------
sub serv11_rri_wibr { # issue rbus write
my ($aname,$ctl,$off,$data) = @_;
my $ibroff = $ctl->{base} + $off - $ctl->{ibrb};
return serv11_rri_wreg($aname, PDPCP_ADDR_IBR+int($ibroff/2), $data);
}
#-------------------------------------------------------------------------------
sub serv11_rri_clear {
@rri_cmdlist = ();
$rri_rvalcnt = 0;
}
#-------------------------------------------------------------------------------
sub serv11_rri_exec {
my ($dref) = @_;
my $rc = 0;
return $rc if scalar(@rri_cmdlist) == 0;
rri_cmdlist_exec(\@rri_cmdlist);
$rc = rri_cmdlist_check_stat(\@rri_cmdlist);
if ($rc) {
print "pi_rri($curmode)-E: serv11_rri_exec error - dump follows\n";
if (exists $opts{log} && $opts{log} ne "") {
print $fh_log "pi_rri($curmode)-E: serv11_rri_exec error - dump follows\n";
}
}
if ($rc || exists $opts{dserv}) {
rri_cmdlist_dump(\@rri_cmdlist, 0, $fh_log);
}
@{$dref} = ();
foreach my $ele (@rri_cmdlist) {
push @{$dref}, $ele->{rcv_data} if $ele->{get_data};
push @{$dref}, $ele->{rcv_rblk} if $ele->{get_rblk};
}
@rri_cmdlist = ();
$rri_rvalcnt = 0;
return $rc;
}
#-------------------------------------------------------------------------------
sub serv11_rri_uset { # issue rbus uset writes
my $ucb = shift @_;
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
my $first = 1;
while (scalar(@_)) {
my $text = shift @_;
my $addr = shift @_;
my $data = shift @_;
my $key = "uset_" . $text;
if ((not defined $ctl->{$key}) || $ctl->{$key} != $data) {
serv11_rri_ibrb($ctl) if $first;
$first = 0;
serv11_rri_wibr($text, $ctl, $addr, $data);
$ctl->{$key} = $data;
if (exists $opts{tserv} && $ctl->{trace}) {
printf $fh_log "uset -- %s %s %6.6o\n",
$ctl->{ctltype}, $ucb->{unitname}, $data;
}
}
}
}
#-------------------------------------------------------------------------------
sub serv11_exec_rblk {
my ($addr,$mode,$dref,$nword) = @_;
my @rval;
serv11_rri_lalh($addr,$mode);
while ($nword>0) {
my $nblk = $nword;
$nblk = 256 if $nblk > 256;
$nword -= $nblk;
my $idref = serv11_rri_rblk($nblk);
my $rc = serv11_rri_exec(\@rval);
return $rc if $rc;
push @$dref, @{$rval[$idref]};
}
return 0;
}
#-------------------------------------------------------------------------------
sub serv11_exec_wblk {
my ($addr,$mode,$dref) = @_;
my @rval;
serv11_rri_lalh($addr,$mode);
my $nword = scalar(@$dref);
my $offset = 0;
if ($nword == 0) {
print "pi_rri($curmode)-W: spurious serv11_exec_wblk() with 0 data length\n";
return;
}
while ($nword>0) {
my $nblk = $nword;
$nblk = 256 if $nblk > 256;
my $beg = $offset;
my $end = $offset+$nblk-1;
serv11_rri_wblk($nblk, [ @$dref[$beg..$end] ]);
$nword -= $nblk;
$offset += $nblk;
my $rc = serv11_rri_exec(\@rval);
return $rc if $rc;
}
return 0;
}
#-------------------------------------------------------------------------------
sub serv11_exec_probe {
my ($addr,$mode) = @_;
my $iib;
my $irb;
if ($mode =~ /i/) {
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr); # i/o page in 16 bit mode
serv11_rri_rreg("rm", PDPCP_ADDR_MEM);
$iib = $#rri_cmdlist;
}
if ($mode =~ /r/) {
my $ibrbase = $addr & ~(077); # ibr-base => drop last 6 bits
my $ibroff = $addr & (077); # ibr-offset => take last 6 bits
serv11_rri_wreg("wibrb", PDPCP_ADDR_IBRB, $ibrbase);
serv11_rri_rreg("ribr", PDPCP_ADDR_IBR + int($ibroff/2));
$irb = $#rri_cmdlist;
}
rri_cmdlist_exec(\@rri_cmdlist);
rri_cmdlist_dump(\@rri_cmdlist, 0) if exists $opts{dserv};
my $ival;
my $rval;
if (defined $iib) {
$ival =$rri_cmdlist[$iib]->{rcv_data} if not $rri_cmdlist[$iib]->{err_stat};
}
if (defined $irb) {
$rval =$rri_cmdlist[$irb]->{rcv_data} if not $rri_cmdlist[$irb]->{err_stat};
}
serv11_rri_clear();
return ($ival, $rval);
}
#-------------------------------------------------------------------------------
sub next_nxbuf { # calculate next nxbuf value
my ($ctl,$nxbuf,$nxbuf_val) = @_;
if ($nxbuf_val <= $nxbuf/2) {
$nxbuf -= $ctl->{nxbuf_inc};
} else {
$nxbuf += $ctl->{nxbuf_inc};
}
$nxbuf = $ctl->{nxbuf_min} if $nxbuf < $ctl->{nxbuf_min};
$nxbuf = $ctl->{nxbuf_max} if $nxbuf > $ctl->{nxbuf_max};
return $nxbuf;
}
#-------------------------------------------------------------------------------
sub telnet_readhdl { # telnet: socket read handler
my ($teldsc) = @_;
my $ucb = $teldsc->{ucb};
if ($teldsc->{state} == TELNET_STATE_LISTEN) {
my $fh_data = new FileHandle;
if (not accept($fh_data, $teldsc->{fh_port})) {
printf STDERR "pi_rri($curmode)-E: erro in accept(): $!\n";
return; # FIXME: error handling ??
}
printf "connect on port %s for %s\n", $teldsc->{port}, $ucb->{unitname};
my $buf;
my $rc;
$buf = pack("C3", TELNET_CODE_IAC, TELNET_CODE_WILL, TELNET_OPT_LINE);
$rc = syswrite($fh_data, $buf, length($buf));
$buf = pack("C3", TELNET_CODE_IAC, TELNET_CODE_WILL, TELNET_OPT_SGA);
$rc = syswrite($fh_data, $buf, length($buf));
$buf = pack("C3", TELNET_CODE_IAC, TELNET_CODE_WILL, TELNET_OPT_ECHO);
$rc = syswrite($fh_data, $buf, length($buf));
$buf = pack("C3", TELNET_CODE_IAC, TELNET_CODE_WILL, TELNET_OPT_BIN);
$rc = syswrite($fh_data, $buf, length($buf));
$buf = pack("C3", TELNET_CODE_IAC, TELNET_CODE_DO, TELNET_OPT_BIN);
$rc = syswrite($fh_data, $buf, length($buf));
$teldsc->{state} = TELNET_STATE_STREAM;
$teldsc->{fh_data} = $fh_data;
$buf = sprintf("\r\nconnect on port %s for %s\r\n\r\n",
$teldsc->{port}, $ucb->{unitname});
$rc = syswrite($fh_data, $buf, length($buf));
telnet_writehdl($ucb);
$serv11_fds_update = 1;
} else {
my $buf;
my $rc;
$rc = sysread($teldsc->{fh_data}, $buf, 64);
if ($rc == 0) {
printf "disconnect on port %s for %s\n", $teldsc->{port}, $ucb->{unitname};
close ($teldsc->{fh_data});
delete $teldsc->{fh_data};
$teldsc->{state} = TELNET_STATE_LISTEN;
$serv11_fds_update = 1;
} else {
my @int = unpack("C*", $buf);
foreach my $byt (@int) {
if ($teldsc->{state} == TELNET_STATE_STREAM) { # state: stream
if ($byt == TELNET_CODE_IAC) {
$teldsc->{state} = TELNET_STATE_IAC;
} else {
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
my @bytes;
push @bytes, $byt;
&{$ctl->{ichrhdl}}($ucb, \@bytes); # call ichr handler
}
} elsif ($teldsc->{state} == TELNET_STATE_IAC) { # state: IAC seen
if ($byt == TELNET_CODE_WILL ||
$byt == TELNET_CODE_WONT ||
$byt == TELNET_CODE_DO ||
$byt == TELNET_CODE_DONT) {
$teldsc->{state} = TELNET_STATE_CMD;
} elsif ($byt == TELNET_CODE_SB) {
$teldsc->{state} = TELNET_STATE_SUBNEG;
} else {
$teldsc->{state} = TELNET_STATE_STREAM;
}
} elsif ($teldsc->{state} == TELNET_STATE_CMD) { # state: cmd seen
$teldsc->{state} = 0;
} elsif ($teldsc->{state} == TELNET_STATE_SUBNEG) { # state: subneg
if ($byt == TELNET_CODE_IAC) {
$teldsc->{state} = TELNET_STATE_SUBIAC;
}
} elsif ($teldsc->{state} == TELNET_STATE_SUBIAC) { # state: subneg+IAC
$teldsc->{state} = TELNET_STATE_STREAM;
}
}
}
}
}
#-------------------------------------------------------------------------------
sub telnet_writehdl { # telnet: write handler
my ($ucb) = @_;
my $teldsc = $telnettbl{$ucb->{att_port}};
return if $teldsc->{state} == TELNET_STATE_LISTEN;
while (scalar( @{$ucb->{sndque}} )) {
my $byte = shift @{$ucb->{sndque}};
syswrite($teldsc->{fh_data}, pack("C1",$byte), 1);
## FIXME: escape IAC !!
## if ($byte == TELNET_CODE_CR) {
## syswrite($teldsc->{fh_data}, pack("C1",TELNET_CODE_LF), 1);
## }
}
}
#-------------------------------------------------------------------------------
sub pdp11_disassemble {
my ($pc,$d0,$d1,$d2) = @_;
my @mem = ($d0,0,0);
$mem[1] = $d1 if defined $d1;
$mem[2] = $d2 if defined $d2;
my $code = shift @mem;
foreach my $ele (@pdp11_opcode_tbl) {
if (($code & (~($ele->{mask})) ) == $ele->{code}) {
my $name = $ele->{name};
my $type = $ele->{type};
my $str = $name;
if ($type eq "0arg") {
return ($name,1);
} elsif ($type eq "1arg" or $type eq "1fpp") {
my $dst = $code & 077;
my $pref = ($type eq "1fpp") ? "f" : "r";
my ($dst_str,$dst_nw,$dst_ta) =
pdp11_disassemble_regmod($dst, $mem[0], $pc+2, $pref);
shift @mem if ($dst_nw);
$str = "$name $dst_str";
if ($dst_ta) {
$str .= " " x (27-length($str)) if length($str)<27;
$str .= "; $dst_ta";
}
return ($str, 1+$dst_nw);
} elsif ($type eq "2arg") {
my $src = ($code>>6) & 077;
my $dst = $code & 077;
my ($src_str,$src_nw,$src_ta) =
pdp11_disassemble_regmod($src, $mem[0], $pc+2);
shift @mem if ($src_nw);
my ($dst_str,$dst_nw,$dst_ta) =
pdp11_disassemble_regmod($dst, $mem[0], $pc+2+2*$src_nw);
shift @mem if ($dst_nw);
$str = "$name $src_str,$dst_str";
if ($src_ta or $dst_ta) {
$str .= " " x (27-length($str)) if length($str)<27;
$str .= ";";
$str .= " $src_ta" if $src_ta;
$str .= " $dst_ta" if $dst_ta;
}
return ($str, 1+$src_nw+$dst_nw);
} elsif ($type eq "rdst") {
my $reg = ($code>>6) & 07;
my $src = $code & 077;
my ($src_str,$src_nw,$src_ta) =
pdp11_disassemble_regmod($src, $mem[0], $pc+2);
shift @mem if ($src_nw);
$str = "$name $src_str,r$reg";
if ($src_ta) {
$str .= " " x (27-length($str)) if length($str)<27;
$str .= "; $src_ta";
}
return ($str, 1+$src_nw);
} elsif ($type eq "1reg") {
my $reg = $code & 07;
my $reg_str = "r$reg";
$reg_str = "sp" if $reg == 6;
$reg_str = "pc" if $reg == 7;
return ("$name $reg_str", 1);
} elsif ($type eq "br") {
my $off = $code & 0177;
my $sign = "+";
if ($code & 0200) {
$off = -(((~$off) & 0177)+1);
$sign = "-";
}
my $str = sprintf "$name .%s%d.", $sign, abs(2*$off);
$str .= " " x (27-length($str)) if length($str)<27;
$str .= sprintf "; -> %6.6o", (($pc+2)+2*$off)&0177777;
return ($str, 1);
} elsif ($type eq "sob") {
my $reg = ($code>>6) & 07;
my $off = $code & 077;
my $str = sprintf "$name r%d,.-%d.", $reg, 2*$off;
$str .= " " x (27-length($str)) if length($str)<27;
$str .= sprintf "; -> %6.6o", ($pc+2)-2*$off;
return ($str, 1);
} elsif ($type eq "trap") {
my $off = $code & 0377;
my $str = sprintf "$name %3.3o", $off;
return ($str, 1);
} elsif ($type eq "spl") {
my $off = $code & 07;
my $str = sprintf "$name %d", $off;
return ($str, 1);
} elsif ($type eq "ccop") {
my $cc = $code & 017;
return ("nop",1) if ($cc == 0);
return ("ccc",1) if ($code == 0257);
return ("scc",1) if ($code == 0277);
my $str = "";
my $del = "";
if ($code & 010) { $str .= $del . $name . "n", $del = "+" }
if ($code & 004) { $str .= $del . $name . "z", $del = "+" }
if ($code & 002) { $str .= $del . $name . "v", $del = "+" }
if ($code & 001) { $str .= $del . $name . "c", $del = "+" }
return ($str, 1);
} elsif ($type eq "jsr") {
my $reg = ($code>>6) & 07;
my $dst = $code & 077;
my ($dst_str,$dst_nw,$dst_ta) =
pdp11_disassemble_regmod($dst, $mem[0], $pc+2);
shift @mem if ($dst_nw);
$str = "$name r$reg,$dst_str";
if ($dst_ta) {
$str .= " " x (27-length($str)) if length($str)<27;
$str .= "; $dst_ta";
}
return ($str, 1+$dst_nw);
} elsif ($type eq "mark") {
my $off = $code & 077;
my $str = sprintf "$name %3.3o", $off;
return ($str, 1);
} elsif ($type eq "rfpp") {
my $reg = ($code>>6) & 03;
my $dst = $code & 077;
my ($dst_str,$dst_nw,$dst_ta) =
pdp11_disassemble_regmod($dst, $mem[0], $pc+2, "f");
shift @mem if ($dst_nw);
$str = "$name f$reg,$dst_str";
if ($dst_ta) {
$str .= " " x (27-length($str)) if length($str)<27;
$str .= "; $dst_ta";
}
return ($str, 1+$dst_nw);
} else {
return ("?type?",1);
}
}
}
return ("=inval=",1);
}
#-------------------------------------------------------------------------------
sub pdp11_disassemble_regmod {
my ($regmod,$data,$pc,$pref) = @_;
my $mod = ($regmod>>3) & 07;
my $reg = $regmod & 07;
$pref = "r" if not defined $pref or $reg>5;
my $reg_str = "r$reg";
$reg_str = "sp" if $reg == 6;
$reg_str = "pc" if $reg == 7;
if ($mod == 0) { # mode 0: Rx { Fx for float }
$reg_str = "f$reg" if defined $pref && $pref eq "f" && $reg<=5;
return ($reg_str, 0, "");
} elsif ($mod == 1) { # mode 1: (Rx)
return ("($reg_str)", 0, "");
} elsif ($mod == 2 || $mod == 3) { # mode 2/3: (Rx)+ @(Rx)+
my $ind = ($mod == 3) ? "@" : "";
if ($reg != 7) { # if reg != pc
return ("$ind($reg_str)+", 0, "");
} else { # if reg == pc
my $str = sprintf "$ind#%6.6o", $data; # 27 -> #nnn; 37 -> @#nnn
return ($str, 1, "");
}
} elsif ($mod == 4 || $mod == 5) { # mode 4/5: -(Rx) @-(Rx)
my $ind = ($mod == 5) ? "@" : "";
return ("$ind-($reg_str)", 0, "");
} elsif ($mod == 6 || $mod == 7) { # mode 6/7: nn(Rx) @nn(Rx)
my $ind = ($mod == 7) ? "@" : "";
my $data_str = sprintf "%o", $data;
my $ta_str = "";
$ta_str = sprintf "%6.6o",($pc+2+$data)&0177777 if ($reg==7);
return ("$ind$data_str($reg_str)", 1, $ta_str);
}
}
#-------------------------------------------------------------------------------
sub file_seek { # fseek wrapper
my ($fh,$pos) = @_;
my $rc;
my $offset = $pos;
my $whence = 0;
if ($pos < 0) { # if offset<0 -> seek to EOF
$offset = 0;
$whence = 2;
}
$rc = $fh->seek($offset, $whence);
if (not $rc) {
print "pi_rri($curmode)-E: file_seek failed\n";
$rc = 0;
}
return $rc;
}
#-------------------------------------------------------------------------------
sub file_read { # fread wrapper
my ($fh,$nbyte) = @_;
my $rc;
my $buf = "";
$rc = $fh->read($buf, $nbyte);
if ($rc != $nbyte) {
print "pi_rri($curmode)-E: file_read failed, got $rc, expectd $nbyte\n";
$rc = 0;
}
return ($rc, $buf);
}
#-------------------------------------------------------------------------------
sub file_seek_read { # fseek+fread wrapper
my ($fh,$pos,$nbyte) = @_;
my $rc;
my $buf;
$rc = file_seek($fh, $pos);
($rc,$buf) = file_read($fh, $nbyte) if $rc;
return ($rc, $buf);
}
#-------------------------------------------------------------------------------
sub file_write { # fwrite wrapper
my ($fh,$buf) = @_;
my $rc;
$rc = print $fh $buf;
if (not $rc) {
print "pi_rri($curmode)-E: file_write failed\n";
$rc = 0;
}
return $rc;
}
#-------------------------------------------------------------------------------
sub file_seek_write { # fseek+fwrite wrapper
my ($fh,$pos,$buf) = @_;
my $rc;
$rc = file_seek($fh, $pos);
$rc = file_write($fh, $buf) if $rc;
return $rc;
}
#-------------------------------------------------------------------------------
sub raw_get9_crc_16bit { # read 16 bit value
my ($dref) = @_;
my $idl = raw_get9_crc();
my $idh = undef;
$idh = raw_get9_crc() if defined $idl;
if (defined $idh) {
my $idat = $idl | ($idh<<8);
$$dref = $idat;
return 1;
}
print "pi_rri($curmode)-E: receive time out\n";
print $fh_log "ERR -- receive time out in raw_get9_crc_16bit\n";
return 0;
}
#-------------------------------------------------------------------------------
sub raw_get9_crc_8bit { # read 8bit value
my ($dref) = @_;
my $idat = raw_get9_crc();
if (defined $idat) {
$$dref = $idat;
return 1;
}
return 0;
}
#-------------------------------------------------------------------------------
sub raw_get9_crc_check { # get 9bit, block, crc, ref value
my ($ref,$case) = @_;
my $dat = raw_get9_crc();
if (defined $dat) {
return 1 if ($dat == $ref);
printf "pi_rri($curmode)-E: receive $case mismatch" .
" found=0x%3.3x expect=0x%3.3x\n",
$dat, $ref;
return 0;
}
return 0;
}
#-------------------------------------------------------------------------------
sub raw_get9_check { # get 9bit, block, expect ref value
my ($ref,$case) = @_;
my $dat = raw_get9();
if (defined $dat) {
return 1 if ($dat == $ref);
printf "pi_rri($curmode)-E: receive $case mismatch" .
" found=0x%3.3x expect=0x%3.3x\n",
$dat, $ref;
return 0;
}
return 0;
}
#-------------------------------------------------------------------------------
sub raw_get9_checksop { # get 9bit, block, expect SOP
my $dat;
while(1) {
$dat = raw_get9();
last unless defined $dat;
last if ($dat != D9ATTN);
if ($serv11_active) {
$serv11_attn_seen = 1;
} else {
printf "pi_rri($curmode)-W: unexpected ATTN comma dropped\n";
}
}
if (defined $dat) {
return 1 if ($dat == D9SOP);
printf "pi_rri($curmode)-E: expect sop, but found=0x%3.3x\n", $dat;
}
return 0;
}
#-------------------------------------------------------------------------------
sub raw_get9_checkeop { # get 9bit, block, expect EOP
my $dat;
$dat = raw_get9();
if (defined $dat) {
return 1 if ($dat == D9EOP);
printf "pi_rri($curmode)-E: expect eop, but found=0x%3.3x\n", $dat;
}
return 0;
}
#-------------------------------------------------------------------------------
sub raw_get9_crc { # get 9bit, block, update crc
my $dat = raw_get9();
$icrc = $crc8_tbl[$icrc ^ $dat] if (defined $dat && $dat < 0x100);
return $dat;
}
#-------------------------------------------------------------------------------
sub raw_get9 { # get 9bit, block
my $nidle = 0;
my $dat = undef;
while (1) {
$dat = raw_rcv9_to($raw_timeout);
last unless defined $dat;
last if $dat != D9IDLE;
$nidle += 1;
}
## print "pi_rri($curmode)-I: dropped $nidle idle commas\n" if $nidle;
print "pi_rri($curmode)-E: receive time out\n" unless defined $dat;
print $fh_log "ERR -- receive time out in raw_get9\n" unless defined $dat;
return $dat;
}
#-------------------------------------------------------------------------------
sub raw_snd9_crc { # put 9bit to RX, update crc
my ($dat) = @_;
raw_snd9($dat);
$ocrc = $crc8_tbl[$ocrc ^ $dat] if ($dat < 0x100);
}
#-------------------------------------------------------------------------------
sub raw_snd9 { # put 9bit to RX
my ($dat) = @_;
if (exists $opts{tio9}) {
print $fh_log conv_etime(\$tlast_tio9),
"[$curchan] snd9 ", conv_dat9($dat);
printf $fh_log " sndq=%3d", scalar(@que_snd);
print $fh_log " -- idle" if $dat == D9IDLE;
print $fh_log " -- sop " if $dat == D9SOP;
print $fh_log " -- eop " if $dat == D9EOP;
print $fh_log " -- nak " if $dat == D9NAK;
print $fh_log " -- attn" if $dat == D9ATTN;
print $fh_log "\n";
}
$stat_tab{osop} += 1 if $dat == D9SOP;
if ($dat >= 0x100) {
raw_snd8(CPREF | ($dat & 0x0f));
} else {
if ( $dat == CESC ||
($dat >= CPREF && $dat <= (CPREF+NCOMM)) ) {
raw_snd8(CESC);
raw_snd8(CEN1 | ($dat & 0x0f));
$stat_tab{oesc} += 1;
} else {
raw_snd8($dat);
}
}
}
#-------------------------------------------------------------------------------
sub raw_snd8 { # put 8bit to RX
my ($dat) = @_;
if (exists $opts{tio8}) {
print $fh_log conv_etime(\$tlast_tio8),
"[$curchan] snd8 ", conv_dat8($dat),"\n";
}
$stat_tab{obyte} += 1;
push @que_snd, int $dat;
}
#-------------------------------------------------------------------------------
sub raw_rcv9 { # get 9bit from TX, non-blocking
return raw_rcv9_to(0.);
}
#-------------------------------------------------------------------------------
sub raw_rcv8 { # get 8bit from TX, non-blocking
return raw_rcv8_to(0.);
}
#-------------------------------------------------------------------------------
sub raw_rcv9_to {
my ($timeout) = @_;
my $dat8 = raw_rcv8_to($timeout);
my $dat9 = undef;
if (defined $dat8) {
if ($dat8 == CESC) {
$stat_tab{iesc} += 1;
$raw_rcv_esc = 1;
$dat8 = raw_rcv8_to($timeout);
return $dat8 unless defined $dat8;
}
if ($raw_rcv_esc) {
$dat9 = CPREF | ($dat8 & 0x0f);
$raw_rcv_esc = 0;
} else {
if ($dat8>= CPREF && $dat8<=(CPREF+NCOMM) ) {
$dat9 = 0x100 | ($dat8 & 0x0f);
} else {
$dat9 = $dat8;
}
}
}
if (defined $dat9) {
$stat_tab{att} += 1 if $dat9 == D9ATTN;
##print "+++9 attn seen\n" if $dat9==D9ATTN;
if (exists $opts{tio9}) {
print $fh_log conv_etime(\$tlast_tio9),
"[$curchan] rcv9 ", conv_dat9($dat9);
printf $fh_log " rcvq=%3d", scalar(@que_rcv);
print $fh_log " -- idle" if $dat9 == D9IDLE;
print $fh_log " -- sop " if $dat9 == D9SOP;
print $fh_log " -- eop " if $dat9 == D9EOP;
print $fh_log " -- nak " if $dat9 == D9NAK;
print $fh_log " -- attn" if $dat9 == D9ATTN;
print $fh_log "\n";
}
}
return $dat9;
}
#-------------------------------------------------------------------------------
sub raw_rcv8_to { # get 8bit from TX, expl. time-out
my ($timeout) = @_;
my $buf;
my $dat;
&{$chan_tab{$curchan}{write}}(); # flush write queue before read
&{$chan_tab{$curchan}{read}}($timeout) unless @que_rcv;
$dat = shift @que_rcv;
if (exists $opts{tio8} and defined $dat) {
print $fh_log conv_etime(\$tlast_tio8),
"[$curchan] rcv8 ", conv_dat8($dat),"\n";
}
$stat_tab{ibyte} += 1;
return $dat;
}
#-------------------------------------------------------------------------------
sub wait_sel_filercv { # poll/wait for TX to be ready
my ($timeout) = @_;
my $nfound=-1;
my $fds_rd;
while ($nfound<0) {
$nfound = select($fds_rd=$fdset_filercv, undef, undef, $timeout);
next if ($nfound == -1) and $! == EINTR;
die "select error: $!" unless $nfound >= 0;
}
return $nfound;
}
#-------------------------------------------------------------------------------
sub fifo_open { # chan fifo: open handler
my ($arg) = @_;
my ($file,$keep) = split /,/,$arg;
my $file_base = $file ? $file : "rlink_cext_fifo";
my $file_snd = $file_base . "_rx";
my $file_rcv = $file_base . "_tx";
$fifo_keep = $keep;
$fdset_filercv = "";
print_fatal("I/O mode already set to --$curchan") if ($curchan);
if (-e $file_snd) {
print_fatal("$file_snd exists but is not a pipe") unless (-p $file_snd);
} else {
mkfifo($file_snd, 0666) || die "can't mkfifo $file_snd: $!";
print "pi_rri[fifo]-I: created fifo $file_snd\n";
}
if (-e $file_rcv) {
print_fatal("$file_rcv exists but is not a pipe") unless (-p $file_rcv);
} else {
mkfifo($file_rcv, 0666) || die "can't mkfifo $file_rcv: $!";
print "pi_rri[fifo]-I: created fifo $file_rcv\n";
}
$fh_snd = new FileHandle;
$fh_rcv = new FileHandle;
print "pi_rri[fifo]-I: wait to connect to $file_snd\n";
sysopen ($fh_snd, $file_snd, O_WRONLY) || die "can't open $file_snd: $!";
print "pi_rri[fifo]-I: connected to $file_snd\n";
sysopen ($fh_rcv, $file_rcv, O_RDONLY) || die "can't open $file_rcv: $!";
print "pi_rri[fifo]-I: connected to $file_rcv\n";
vec($fdset_filercv, fileno($fh_rcv), 1) = 1;
$curchan = "fifo";
}
#-------------------------------------------------------------------------------
sub fifo_close { # chan fifo: close handler
if ($fifo_keep) {
print "pi_rri[fifo]-I: signal 'keep-alive' to tb\n";
raw_snd8(CESC);
raw_snd8(CESC);
&{$chan_tab{$curchan}{write}}();
}
close $fh_snd;
close $fh_rcv;
$fh_snd = undef;
$fh_rcv = undef;
$curchan = undef;
}
#-------------------------------------------------------------------------------
sub term_open { # term fifo: open handler
my ($arg) = @_;
my ($dev,$baud,$break) = split /,/,$arg;
$dev = "/dev/ttyS0" unless $dev;
$baud = 115200 unless $baud;
$break = 0 unless $break;
$fdset_filercv = "";
print_fatal("I/O mode already set to --$curchan") if ($curchan);
$fh_snd = new FileHandle;
$fh_rcv = $fh_snd; # same file handle for read and write
sysopen ($fh_snd, $dev, O_RDWR|O_NOCTTY) || # read/write, not control TTY
die "can't open $dev: $!";
my $fd = fileno($fh_snd);
vec($fdset_filercv, $fd, 1) = 1;
$curchan = "term";
print_fatal("$dev is not a TTY") unless isatty($fd);
$term_oldtios = new POSIX::Termios;
$term_oldtios->getattr($fd) || die "getattr failed: $!";
## term_tios_print($term_oldtios);
my $newtios = new POSIX::Termios;
$newtios->getattr($fd) || die "getattr failed: $!"; ## hack for cygwin !!
my $c_iflag = &POSIX::BRKINT; # ignore parity errors (??? WRONG??)
my $c_oflag = 0;
my $c_cflag = &POSIX::CS8 | # 8 bit chars
&POSIX::CSTOPB | # 2 stop bits
&POSIX::CREAD | # enable receiver
&POSIX::CLOCAL | # ignore modem control
LINUX_CRTSCTS; # enable hardware flow control
my $c_lflag = 0;
my $speed = 0;
$speed = &POSIX::B9600 if $baud == 9600;
$speed = &POSIX::B19200 if $baud == 19200;
$speed = &POSIX::B38400 if $baud == 38400;
$speed = LINUX_B57600 if $baud == 57600; # hack, only for linux
$speed = LINUX_B115200 if $baud == 115200; # hack, only for linux
$speed = LINUX_B230400 if $baud == 230400; # hack, only for linux
$speed = LINUX_B460800 if $baud == 460800; # hack, only for linux
$speed = LINUX_B500000 if $baud == 500000; # hack, only for linux
$speed = LINUX_B921600 if $baud == 921600; # hack, only for linux
$speed = LINUX_B1000000 if $baud ==1000000; # hack, only for linux
$speed = LINUX_B2000000 if $baud ==2000000; # hack, only for linux
$speed = LINUX_B3000000 if $baud ==3000000; # hack, only for linux
print_fatal("speed $baud not supported") unless $speed != 0;
$c_cflag |= $speed;
$newtios->setiflag($c_iflag);
$newtios->setoflag($c_oflag);
$newtios->setcflag($c_cflag);
$newtios->setlflag($c_lflag);
$newtios->setcc(&POSIX::VEOF, 0); # undef
$newtios->setcc(&POSIX::VEOL, 0); # undef
$newtios->setcc(&POSIX::VERASE, 0); # undef
$newtios->setcc(&POSIX::VINTR, 0); # undef
$newtios->setcc(&POSIX::VKILL, 0); # undef
$newtios->setcc(&POSIX::VQUIT, 0); # undef
$newtios->setcc(&POSIX::VSUSP, 0); # undef
$newtios->setcc(&POSIX::VSTART, 0); # undef
$newtios->setcc(&POSIX::VSTOP, 0); # undef
$newtios->setcc(&POSIX::VMIN, 1); # wait for 1 char
$newtios->setcc(&POSIX::VTIME, 0); #
## term_tios_print($newtios);
$newtios->setattr($fd) || die "setattr failed: $!";
if ($break) {
tcsendbreak($fd, 0) || die "tcsendbreak failed: $!";
raw_snd8 (0x80);
&{$chan_tab{$curchan}{write}}(); # write 10000000 for autobaud
}
}
#-------------------------------------------------------------------------------
sub term_close { # chan term: close handler
$term_oldtios->setattr(fileno($fh_snd)) || die "setattr failed: $!";
close $fh_snd;
$fh_snd = undef;
$fh_rcv = undef;
$curchan = undef;
}
#-------------------------------------------------------------------------------
sub term_tios_print {
my ($tios) = @_;
my $iflag = $tios->getiflag;
my $oflag = $tios->getoflag;
my $cflag = $tios->getcflag;
my $lflag = $tios->getlflag;
printf "iflag = %8.8x:", $iflag;
print " BRKINT" if $iflag & &POSIX::BRKINT;
print " ICRNL " if $iflag & &POSIX::ICRNL;
print " IGNBRK" if $iflag & &POSIX::IGNBRK;
print " IGNCR " if $iflag & &POSIX::IGNCR;
print " IGNPAR" if $iflag & &POSIX::IGNPAR;
print " INLCR " if $iflag & &POSIX::INLCR;
print " INPCK " if $iflag & &POSIX::INPCK;
print " ISTRIP" if $iflag & &POSIX::ISTRIP;
print " IXOFF " if $iflag & &POSIX::IXOFF;
print " IXON " if $iflag & &POSIX::IXON;
print " PARMRK" if $iflag & &POSIX::PARMRK;
print "\n";
printf "oflag = %8.8x:", $oflag;
print " OPOST " if $oflag & &POSIX::OPOST;
print "\n";
printf "cflag = %8.8x:", $cflag;
print " CLOCAL" if $cflag & &POSIX::CLOCAL;
print " CREAD " if $cflag & &POSIX::CREAD;
print " CS5 " if ($cflag & &POSIX::CSIZE) == &POSIX::CS5;
print " CS6 " if ($cflag & &POSIX::CSIZE) == &POSIX::CS6;
print " CS7 " if ($cflag & &POSIX::CSIZE) == &POSIX::CS7;
print " CS8 " if ($cflag & &POSIX::CSIZE) == &POSIX::CS8;
print " CSTOPB" if $cflag & &POSIX::CSTOPB;
print " HUPCL " if $cflag & &POSIX::HUPCL;
print " PARENB" if $cflag & &POSIX::PARENB;
print " PARODD" if $cflag & &POSIX::PARODD;
my $sbits = &POSIX::B50 | &POSIX::B75 | &POSIX::B110 | &POSIX::B134 |
&POSIX::B150 | &POSIX::B200 | &POSIX::B300 | &POSIX::B600 |
&POSIX::B1200 | &POSIX::B1800 | &POSIX::B2400 | &POSIX::B4800 |
&POSIX::B9600 | &POSIX::B19200 | &POSIX::B38400;
print " B0 " if ($cflag & $sbits) == &POSIX::B0;
print " B50 " if ($cflag & $sbits) == &POSIX::B50;
print " B75 " if ($cflag & $sbits) == &POSIX::B75;
print " B110 " if ($cflag & $sbits) == &POSIX::B110;
print " B134 " if ($cflag & $sbits) == &POSIX::B134;
print " B150 " if ($cflag & $sbits) == &POSIX::B150;
print " B200 " if ($cflag & $sbits) == &POSIX::B200;
print " B300 " if ($cflag & $sbits) == &POSIX::B300;
print " B600 " if ($cflag & $sbits) == &POSIX::B600;
print " B1200 " if ($cflag & $sbits) == &POSIX::B1200;
print " B1800 " if ($cflag & $sbits) == &POSIX::B1800;
print " B2400 " if ($cflag & $sbits) == &POSIX::B2400;
print " B4800 " if ($cflag & $sbits) == &POSIX::B4800;
print " B9600 " if ($cflag & $sbits) == &POSIX::B9600;
print " B19200" if ($cflag & $sbits) == &POSIX::B19200;
print " B38400" if ($cflag & $sbits) == &POSIX::B38400;
print "\n";
printf "lflag = %8.8x:", $lflag;
print " ECHO " if $lflag & &POSIX::ECHO;
print " ECHOE " if $lflag & &POSIX::ECHOE;
print " ECHOK " if $lflag & &POSIX::ECHOK;
print " ECHONL" if $lflag & &POSIX::ECHONL;
print " ICANON" if $lflag & &POSIX::ICANON;
print " IEXTEN" if $lflag & &POSIX::IEXTEN;
print " ISIG " if $lflag & &POSIX::ISIG;
print " NOFLSH" if $lflag & &POSIX::NOFLSH;
print " TOSTOP" if $lflag & &POSIX::TOSTOP;
print "\n";
printf "cc(VEOF) = %3.3o\n", $tios->getcc(&POSIX::VEOF);
printf "cc(VEOL) = %3.3o\n", $tios->getcc(&POSIX::VEOL);
printf "cc(VERASE)= %3.3o\n", $tios->getcc(&POSIX::VERASE);
printf "cc(VINTR) = %3.3o\n", $tios->getcc(&POSIX::VINTR);
printf "cc(VKILL) = %3.3o\n", $tios->getcc(&POSIX::VKILL);
printf "cc(VQUIT) = %3.3o\n", $tios->getcc(&POSIX::VQUIT);
printf "cc(VSUSP) = %3.3o\n", $tios->getcc(&POSIX::VSUSP);
printf "cc(VSTART)= %3.3o\n", $tios->getcc(&POSIX::VSTART);
printf "cc(VSTOP) = %3.3o\n", $tios->getcc(&POSIX::VSTOP);
printf "cc(VMIN) = %3.3o\n", $tios->getcc(&POSIX::VMIN);
printf "cc(VTIME) = %3.3o\n", $tios->getcc(&POSIX::VTIME);
# printf "cc(NCCS) = %3.3o\n", $tios->getcc(&POSIX::NCCS);
}
#-------------------------------------------------------------------------------
sub genio_read { # generic io: read handler
my ($timeout) = @_;
my $tstart;
my $rc;
$tstart = get_time() if exists $opts{tiob};
if (wait_sel_filercv($timeout)) {
my $buf;
while (not defined $rc) {
$rc = sysread($fh_rcv, $buf, 64);
next if (not defined $rc) and $! == EINTR;
die "sysread fifo error: $!" unless defined $rc;
}
if (exists $opts{tiob}) {
printf $fh_log "%s[$curchan] read %3d bytes in %8.6f sec\n",
conv_etime(\$tlast_tiob), $rc, get_time()-$tstart;
}
if ($rc) {
push @que_rcv, unpack("C*", $buf);
}
}
### if (defined $rc) {
### printf "+++1 _read $timeout rc=%d\n", $rc;
### } else {
### printf "+++1 _read $timeout rc=undef\n";
### }
return $rc;
}
#-------------------------------------------------------------------------------
sub genio_write { # generic io: write handler
## printf "+++2 _write q=%d\n", scalar @que_snd;
if (scalar @que_snd) {
my $buf = pack("C*", @que_snd);
while (length($buf)) {
while(1) { # read rcv fifo before writing
my $rc = genio_read(0.); # to avoid blocking under cygwin
last unless defined $rc and $rc > 0;
}
my $nwrite = length($buf);
### $nwrite = 1; # <-- when is this really needed ???
### printf "+++2a _write nw=%d\n", $nwrite;
my $rc = syswrite($fh_snd, $buf, $nwrite);
next if (not defined $rc) and $! == EINTR;
die "syswrite fifo error: $!" unless defined $rc;
if (exists $opts{tiob}) {
printf $fh_log "%s[$curchan] write %3d bytes", conv_etime(\$tlast_tiob), $rc;
printf $fh_log " of %3d in queue", length($buf) if $rc < length($buf);
print $fh_log "\n";
}
last if $rc == length($buf);
$buf = substr($buf, $rc);
}
@que_snd = ();
}
}
#-------------------------------------------------------------------------------
sub cget_chkblank { # check for unused chars in cmd line
$cmd_rest =~ s/^\s*//;
if ($cmd_rest ne "") {
print "pi_rri($curmode)-E: extra data ignored: \"$cmd_rest\"\n";
print " for command: \"$cmd_line\"\n";
$cmd_bad = 1;
}
return $cmd_bad;
}
#-------------------------------------------------------------------------------
sub cget_tagval2_gdat { # get tag=v1[,v2], generic base
my ($tag,$nbit,$dbase) = @_;
my $dat;
my $msk = undef;
$cmd_rest =~ s/^\s*//;
### print "+++2 |$cmd_rest|$tag|$nbit|$dbase|\n";
if ($cmd_rest =~ /^$tag=/) {
$cmd_rest = $';
if ($cmd_rest =~ /^-/) {
$cmd_rest = $';
return (0,0xffff);
} else {
$dat = cget_gdat($nbit, $dbase);
if ($cmd_rest =~ /^,/) {
$cmd_rest = $';
$msk = cget_gdat($nbit, $dbase);
}
return ($dat, $msk);
}
}
return (undef, undef);
}
#-------------------------------------------------------------------------------
sub cget_tagval_gdat { # get tag=val, generic base
my ($tag,$nbit,$dbase,$min,$max) = @_;
$cmd_rest =~ s/^\s*//;
if ($cmd_rest =~ /^$tag=/) {
$cmd_rest = $';
return cget_gdat($nbit, $dbase,$min,$max);
}
return undef;
}
#-------------------------------------------------------------------------------
sub cget_gdat { # get generic base value
my ($nbit,$dbase,$min,$max) = @_;
my $dat;
$cmd_rest =~ s/^\s*//;
### print "+++1 |$nbit|$dbase|$cmd_rest|\n";
if ($cmd_rest =~ /^[xXoObBdD]"/) {
if ($cmd_rest =~ /^[xX]"([0-9a-fA-F]+)"/) {
$cmd_rest = $';
$dat = hex $1;
} elsif ($cmd_rest =~ /^[oO]"([0-7]+)"/) {
$cmd_rest = $';
$dat = oct $1;
} elsif ($cmd_rest =~ /^[bB]"([01]+)"/) {
$cmd_rest = $';
my $odat = sget_bdat($nbit, $1);
$dat = $odat if defined $odat;
} elsif ($cmd_rest =~ /^[dD]"([+-]?[0-9]+)"/) {
$cmd_rest = $';
my $odat = (int $1) & ((1<<$nbit)-1);
$dat = $odat;
}
} else {
if ($cmd_rest =~ /^([+-]?[0-9]+)\./) {
$cmd_rest = $';
my $odat = (int $1) & ((1<<$nbit)-1);
$dat = $odat;
} elsif ($dbase == 16 && $cmd_rest =~ /^([0-9a-fA-F]+)/) {
$cmd_rest = $';
$dat = hex $1;
} elsif ($dbase == 8 && $cmd_rest =~ /^([0-7]+)/) {
$cmd_rest = $';
$dat = oct $1;
} elsif ($dbase == 2 && $cmd_rest =~ /^([01]+)/) {
$cmd_rest = $';
my $odat = sget_bdat($nbit, $1);
$dat = $odat if defined $odat;
} elsif ($dbase == 10 && $cmd_rest =~ /^([0-9]+)/) {
$cmd_rest = $';
$dat = int $1;
}
}
if (not defined $dat) {
$cmd_bad = 1;
print "pi_rri($curmode)-E: cget_gdat error in \"$cmd_rest\" (base=$dbase)\n";
return undef;
}
if (defined $min && $dat < $min) {
$cmd_bad = 1;
print "pi_rri($curmode)-E: cget_gdat range error, $dat < $min\n";
return undef;
}
if (defined $max && $dat > $max) {
$cmd_bad = 1;
print "pi_rri($curmode)-E: cget_gdat range error, $dat > $max\n";
return undef;
}
return $dat;
}
#-------------------------------------------------------------------------------
sub cget_name { # get name \w+
$cmd_rest =~ s/^\s*//;
if ($cmd_rest =~ /^(\w+)/) {
$cmd_rest = $';
return $1;
}
$cmd_bad = 1;
print "pi_rri($curmode)-E: cget_name error in \"$cmd_rest\"\n";
return undef;
}
#-------------------------------------------------------------------------------
sub cget_bool { # get boolean [01]
$cmd_rest =~ s/^\s*//;
if ($cmd_rest =~ /^([01])/) {
$cmd_rest = $';
return int($1);
}
$cmd_bad = 1;
print "pi_rri($curmode)-E: cget_name error in \"$cmd_rest\"\n";
return undef;
}
#-------------------------------------------------------------------------------
sub cget_file { # get filename [\w\/.]+
$cmd_rest =~ s/^\s*//;
if ($cmd_rest =~ /^([\w\/.-]+)/) {
$cmd_rest = $';
return $1;
}
$cmd_bad = 1;
print "pi_rri($curmode)-E: cget_file error in \"$cmd_rest\"\n";
return undef;
}
#-------------------------------------------------------------------------------
sub cget_ucb { # get ucb (read name, return ucb)
my ($type,$name) = @_;
$name = cget_name() unless defined $name;
return undef if not defined $name;
$name = uc($name);
$name .= "0" if length($name)==2;
if (not exists $serv11_unittbl{$name}) {
$cmd_bad = 1;
print "pi_rri($curmode)-E: unknown device unit $name\n";
return undef;
}
my $ucb = $serv11_unittbl{$name};
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
if (not $ctl->{probe_ok}) {
$cmd_bad = 1;
print "pi_rri($curmode)-E: device controller $name not available\n";
return undef;
}
if (defined $type) {
if ($ctl->{type} ne $type) {
$cmd_bad = 1;
print "pi_rri($curmode)-E: $name is not type=$type\n";
return undef;
}
}
return $ucb;
}
#-------------------------------------------------------------------------------
sub cget_opt { # get option
my ($opt) = @_;
if ($cmd_rest =~ /^\s*$opt\b/) { # opt found, followed by non \w
$cmd_rest = $';
return 1;
}
return 0;
}
#-------------------------------------------------------------------------------
sub cget_optset { # get option set
my ($optset) = @_;
my $optout = "";
while ($cmd_rest =~ /\s*-([a-zA-Z])\b/) { # any -x found
$cmd_rest = $';
my $optchar = $1;
if ($optset =~ /$optchar/) { # char in optset ?
$optout .= $optchar;
} else {
$cmd_bad = 1;
print "pi_rri($curmode)-E: unexpected option -$optchar\n";
}
}
return $optout;
}
#-------------------------------------------------------------------------------
sub cget_regrange { # get register/memory range
my $ctl;
my $beg;
my $end;
if (cchk_number()) { # numerical address
$beg = cget_gdat(22,8);
$end = $beg;
if ($cmd_rest =~ m{^:}) {
$cmd_rest =~ s{^:}{};
$end = cget_gdat(22,8);
} elsif ($cmd_rest =~ m{^/}) {
$cmd_rest =~ s{^/}{};
$end = $beg + cget_gdat(22,8) - 2;
}
} else { # symbolical address
my $regtbl;
my $ctlnam = uc(cget_name());
my $begnam = lc($ctlnam);
my $endnam;
if (exists $serv11_ctltbl{CPU}->{regtbl}->{$begnam}) {
$ctlnam = "CPU";
$regtbl = $serv11_ctltbl{CPU}->{regtbl};
} elsif (exists $serv11_ctltbl{$ctlnam}->{regtbl}) {
$regtbl = $serv11_ctltbl{$ctlnam}->{regtbl};
$begnam = lc(cget_name());
} else {
print "pi_rri($curmode)-E: '$begnam' neither controller nor" .
" cpu register name\n";
$cmd_bad = 1;
return (undef, undef, undef);
}
$ctl = $serv11_ctltbl{$ctlnam};
if (not $ctl->{probe_ok}) {
print "pi_rri($curmode)-E: '$ctlnam' not available\n";
$cmd_bad = 1;
return (undef, undef, undef);
}
my $reglist = $ctl->{reglist};
$beg = 0;
$end = scalar @{$reglist}-1;
if ($begnam ne "state") {
$endnam = $begnam;
if ($cmd_rest =~ m{^:}) {
$cmd_rest =~ s{^:}{};
$endnam = lc(cget_name());
}
if (not exists $regtbl->{$begnam}) {
print "pi_rri($curmode)-E: '$begnam' not register in '$ctlnam'\n";
$cmd_bad = 1;
return (undef, undef, undef);
}
if (not exists $regtbl->{$endnam}) {
print "pi_rri($curmode)-E: '$endnam' not register in '$ctlnam'\n";
$cmd_bad = 1;
return (undef, undef, undef);
}
$beg = $regtbl->{$begnam};
$end = $regtbl->{$endnam};
}
}
if (defined $beg && defined $end && $beg > $end) {
my $tmp = $beg;
$beg = $end;
$end = $tmp;
}
return ($ctl, $beg, $end);
}
#-------------------------------------------------------------------------------
sub cchk_number { # check for number. any gdat value
# except for plain hex (e.g. 'dead')
return 1 if $cmd_rest =~ /^\s*([0-9]+)/;
return 1 if $cmd_rest =~ /^\s*([+-]?[0-9]+)\./;
return 1 if $cmd_rest =~ /^\s*[xX]"([0-9a-fA-F]+)"/;
return 1 if $cmd_rest =~ /^\s*[oO]"([0-9]+)"/;
return 1 if $cmd_rest =~ /^\s*[bB]"([01]+)"/;
return 1 if $cmd_rest =~ /^\s*[dD]"([+-]?[0-9]+)"/;
return 0;
}
#-------------------------------------------------------------------------------
sub sget_bdat { # convert 01 string -> binary value
my ($nbit,$str) = @_;
my $nchar = length($str);
my $odat = 0;
my $i;
return undef if ($nchar != $nbit);
for ($i = 0; $i < $nchar; $i++) {
$odat *= 2;
$odat += 1 if substr($str, $i, 1) eq "1";
}
return $odat;
}
#-------------------------------------------------------------------------------
sub conv_etime { # generate timestamp string
my ($ref_elast) = @_;
my $etime = get_time()-$time0;
my $str = sprintf "%12.6f ", $etime;
if (defined $ref_elast) {
my $dt = $etime - $$ref_elast;
$$ref_elast = $etime;
$str .= sprintf "(%10.6f) ", $dt;
}
return $str;
}
#-------------------------------------------------------------------------------
sub conv_dat9 {
my ($dat9) = @_;
return (($dat9 & 0x100) ? "1" : "0") . " " . conv_dat8($dat9);
}
#-------------------------------------------------------------------------------
sub conv_dat8 {
my ($dat8) = @_;
my $buf = "";
vec($buf,0,8) = int $dat8;
return unpack("B8",$buf);
}
#-------------------------------------------------------------------------------
sub conv_str2bytes { # string to bytelist; handle \n\r
my ($str,$dref,$esc) = @_;
while (length($str)) {
if ($esc && $str =~ /^\\n/) {
push @{$dref}, 0015; # send CR
$str = $';
} elsif ($esc && $str =~ /^\\r/) {
push @{$dref}, 0013; # send LF
$str = $';
} else {
my $chr = substr($str,0,1);
push @{$dref}, ord($chr);
$str = substr($str,1);
}
}
}
#-------------------------------------------------------------------------------
sub conv_buf2wlist { # string buffer -> word list
my ($buf) = @_;
my @sysbyt;
my $nw = int(length($buf)/2);
my $dref = [];
my $i;
push @sysbyt, unpack("C*", $buf);
for ($i=0; $i<$nw; $i++) {
my $bl = shift @sysbyt; # lsb is first
my $bh = shift @sysbyt;
push @{$dref}, 256*$bh + $bl;
}
return $dref;
}
#-------------------------------------------------------------------------------
sub conv_wlist2buf { # word list -> string buffer
my ($dref) = @_;
my @sysbyt;
my $buf;
foreach my $word (@{$dref}) {
my $bl = $word & 0xff;
my $bh = ($word>>8) & 0xff;
push @sysbyt, $bl; # lsb is first
push @sysbyt, $bh;
}
$buf = pack("C*", @sysbyt);
return $buf;
}
#-------------------------------------------------------------------------------
sub conv_byte2ascii2 { # byte -> 2 charcter ASCII display
my ($byte) = @_;
if ($byte >= 32 && $byte < 128) {
return chr($byte) . " ";
} else {
my $str = "..";
$str = "\\0" if $byte == 000; # NUL 000 -> \0
$str = "\\a" if $byte == 007; # BEL 007 -> \a
$str = "\\b" if $byte == 010; # BS 010 -> \b
$str = "\\t" if $byte == 011; # TAB 011 -> \t
$str = "\\n" if $byte == 012; # LF 012 -> \n
$str = "\\v" if $byte == 013; # VT 013 -> \v
$str = "\\f" if $byte == 014; # FF 014 -> \f
$str = "\\r" if $byte == 015; # CR 015 -> \r
return $str;
}
}
#-------------------------------------------------------------------------------
sub gconv_dat16 {
my ($dat,$dbase) = @_;
if ($dbase == 2) {
my $bufl = "";
my $bufh = "";
vec($bufl,0,8) = int ($dat & 0xff);
vec($bufh,0,8) = int (($dat>>8) & 0xff);
return unpack("B8",$bufh) . unpack("B8",$bufl);
} elsif ($dbase == 8) {
return sprintf "%6.6o", int $dat;
} elsif ($dbase == 16) {
return sprintf "%4.4x", int $dat;
} else {
return "??dbase??";
}
}
#-------------------------------------------------------------------------------
sub hdl_sigint { # SIGINT handler
if ($sigint_count == 1) {
print STDERR "\a"; # send beep
} elsif ($sigint_count == 2) {
print STDERR "pi_rri($curmode)-W: not responding on ^C, next will abort\n";
} elsif ($sigint_count == 3) {
print STDERR "pi_rri($curmode)-E: ^C abort\n";
exit(1);
}
$sigint_count += 1;
}
#-------------------------------------------------------------------------------
sub get_time {
my ($sec, $usec) = gettimeofday();
return $sec + 1.e-6 * $usec;
}
#-------------------------------------------------------------------------------
sub get_timestamp {
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
return sprintf "%2.2d:%2.2d:%2.2d", $hour, $min, $sec;
}
#-------------------------------------------------------------------------------
sub filename_expand { # expand $nnn in name
my ($file) = @_;
my $fileexp = $file;
while($fileexp =~ /\$(\w+)/) {
if (exists $ENV{$1}) {
$fileexp = $` . $ENV{$1} . $';
} else {
printf "pi_rri-E: environment variable \$%s not defined\n", $1;
$fileexp = $` . "\$?" . $1 . "?" . $';
}
}
return $fileexp;
}
#-------------------------------------------------------------------------------
sub print_fatal {
my ($msg) = @_;
print STDERR "pi_rri($curmode)-F: $msg\n";
exit 1;
}
#-------------------------------------------------------------------------------
sub print_help {
print "usage: pi_rri\n";
print " --help this message\n";
print " --int force interactive mode\n";
print " --trace trace\n";
printf "CPREF %2.2x\n", CPREF;
printf "NCOMM %2.2x\n", NCOMM;
printf "CESC %2.2x\n", CESC;
printf "CEN1 %2.2x\n", CEN1;
}
Reference in New Issue View Git Blame Copy Permalink