1 |
2 |
wfjm |
#!/usr/bin/perl -w
|
2 |
|
|
# $Id: pi_rri 314 2010-07-09 17:38:41Z mueller $
|
3 |
|
|
#
|
4 |
|
|
# Copyright 2007-2010 by Walter F.J. Mueller
|
5 |
|
|
#
|
6 |
|
|
# This program is free software; you may redistribute and/or modify it under
|
7 |
|
|
# the terms of the GNU General Public License as published by the Free
|
8 |
|
|
# Software Foundation, either version 2, or at your option any later version.
|
9 |
|
|
#
|
10 |
|
|
# This program is distributed in the hope that it will be useful, but
|
11 |
|
|
# WITHOUT ANY WARRANTY, without even the implied warranty of MERCHANTABILITY
|
12 |
|
|
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
13 |
|
|
# for complete details.
|
14 |
|
|
#
|
15 |
|
|
# Revision History:
|
16 |
|
|
# Date Rev Version Comment
|
17 |
|
|
# 2010-06-27 310 1.6.2 fix autoflush for fh_log; duplicate exec err to log
|
18 |
|
|
# 2010-06-18 306 1.6.1 PDPCP_ADDR_IBRB now 020, PDPCP_ADDR_IBR now 0200;
|
19 |
|
|
# ibrbase now just drops the 6 lsb's; pdpcp mode:
|
20 |
|
|
# rename librb -> wibrb; finished cp/rri overhaul
|
21 |
|
|
# 2010-06-13 305 1.6 change PDPCP_ADDR_ assignments, add PDPCP_FUNC_
|
22 |
|
|
# constants; adapt pdpcp mode to changed rri addr and
|
23 |
|
|
# stim file format; emulate old 'sta' behaviour with
|
24 |
|
|
# new 'stapc' command; rename lal,lah -> wal,wah and
|
25 |
|
|
# implement locally; adapt serv11 mode to new rri
|
26 |
|
|
# 2010-06-11 303 1.5.1 add cmd_inter; flush{"line"} after interactive cmd
|
27 |
|
|
# added readline support.
|
28 |
|
|
# 2010-06-07 302 1.5 use sop/eop framing instead of soc+chaining
|
29 |
|
|
# 2010-06-06 301 1.4.18 rename .rpmon->.rbmon; NCOMM=4 (new eop,nak commas)
|
30 |
|
|
# 2010-06-03 299 1.4.17 adapt .reset to new rbus init decode
|
31 |
|
|
# 2010-05-05 288 1.4.16 first preliminary implementation of eval based
|
32 |
|
|
# perl macro's via @@pmac; add ^C signal handler;
|
33 |
|
|
# added optional min/max check for cget_gdat() and
|
34 |
|
|
# cget_tagval_gdat().
|
35 |
|
|
# 2010-05-02 287 1.4.15 enable hardware flow control in termios
|
36 |
|
|
# 2010-05-01 286 1.4.14 add .sinit command for rri and pdpcp modes;
|
37 |
|
|
# add 500k,1M,2M,3M baudrates, check value now
|
38 |
|
|
# 2010-04-26 284 1.4.13 add error check for GetOptions
|
39 |
|
|
# 2010-04-25 283 1.4.12 raw_rcv9_to: handle undef as return value correctly
|
40 |
|
|
# 2009-10-11 244 1.4.11 support > 115kbaud speed; new stat output in log;
|
41 |
|
|
# use nxbuf_max=8 as default;
|
42 |
|
|
# 2009-09-27 242 1.4.10 add "ERR --" messages in log file; fix usage of
|
43 |
|
|
# uninitialized vars in serv11_exec_probe();
|
44 |
|
|
# 2009-09-25 241 1.4.9 BUGFIX: serv11_server_attn_get() now or's attn bits
|
45 |
|
|
# 2009-09-20 240 1.4.8 serv11_rri_uset cache under $ctl, not in unittbl
|
46 |
|
|
# 2009-09-13 238 1.4.7 add ctlname for DL11 log entries; only TTA output
|
47 |
|
|
# written to stdout when no terminal attached.
|
48 |
|
|
# 2009-07-26 236 1.4.6 fix cpraw mode and .mode error handling;
|
49 |
|
|
# 2009-07-12 233 1.4.5 add attach/detach support for term; telnet support;
|
50 |
|
|
# 2009-07-05 232 1.4.4 add cchk_number(), cget_regrange(); rename _atdt_ to
|
51 |
|
|
# _attdet_; serv11: add exa/dep command; removed
|
52 |
|
|
# rr[0-7], wr[0-7], rmem, and wmem commands; new probe
|
53 |
|
|
# handling, use {probe_[ir]val} and {probemask};
|
54 |
|
|
# serv11: command parser supports abbeviations;
|
55 |
|
|
# serv11: add set/sho command, reorganize ls* cmds;
|
56 |
|
|
# serv11: add {trace} parameter; rri_sideband() flush;
|
57 |
|
|
# 2009-07-04 231 1.4.3 first reglist definitions; add CPU in _ctltbl;
|
58 |
|
|
# add serv11_probe_cpu();
|
59 |
|
|
# 2009-06-28 230 1.4.2 use serv11_atdt_pc11(), remove atdt via ucb hack;
|
60 |
|
|
# add serv11_rri_uset(); pc11 now fully supported;
|
61 |
|
|
# attn log message now gives device; use -e as file
|
62 |
|
|
# test; add ptape boot mode support; lsconf output
|
63 |
|
|
# sorted by ibus address;
|
64 |
|
|
# 2009-06-21 228 1.4.1 BUGFIX: correct typo in RK6 ucb; reorganize init
|
65 |
|
|
# handling, introduce usethdl; reorganize attach;
|
66 |
|
|
# add atdthdl at ctl or ucb level; add det command;
|
67 |
|
|
# 2009-06-20 227 1.4 nxbuf_min,max,inc now a ctl property;
|
68 |
|
|
# 2009-06-14 226 1.3.31 add very preliminary lp11 device handling
|
69 |
|
|
# 2009-06-11 225 1.3.30 quick hack to add dl11 log files.
|
70 |
|
|
# 2009-05-30 220 1.3.29 add papertape boot code;
|
71 |
|
|
# 2009-05-24 219 1.3.28 add papertape hook as dev "PC" units "PTR" and "PTP"
|
72 |
|
|
# 2009-05-21 217 1.3.27 rk11: now error message when init not done
|
73 |
|
|
# 2009-05-17 216 1.3.26 BUGFIX:rk11: fix read/write logic for short sectors;
|
74 |
|
|
# BUGFIX:rk11: re-work the seek complete handling
|
75 |
|
|
# add read/write check support; add PGE error support;
|
76 |
|
|
# 2009-05-13 215 1.3.25 dl11: drop parity bit in transmit path;
|
77 |
|
|
# rk11: add read/write format; set SOK at init time;
|
78 |
|
|
# 2009-05-10 214 1.3.24 BUGFIX: in serv11_attn_rk11() RKER was written
|
79 |
|
|
# instead of RKMR for RKCS_DRESET, _WLOCK, _SEEK
|
80 |
|
|
# 2009-04-11 206 1.3.23 add --int to force interactive mode
|
81 |
|
|
# fix handling of odd length records in lsabs
|
82 |
|
|
# 2008-12-14 177 1.3.22 correct DL11_BASE_B to 176500 (was RL address)
|
83 |
|
|
# 2008-11-28 173 1.3.21 serv11_rri_lalh(): allow now mode =0,1,2 and 3;
|
84 |
|
|
# serv11_rdma_rk11(): use mode=3 in rri_lalh, thus
|
85 |
|
|
# enable 22bit and ubmap simultaneously.
|
86 |
|
|
# add proper MEX update for RKCS in rdma_rk11.
|
87 |
|
|
# add proper DRSEL propagation for RKDA in rdma_rk11.
|
88 |
|
|
# 2008-05-30 151 1.3.20 BUGFIX: corrected @que_rcv logic in serv11 input
|
89 |
|
|
# loop, TT0 output will not longer hang sometimes;
|
90 |
|
|
# disable the attn+ioto(16 or 63 ms) hack;
|
91 |
|
|
# 2008-05-23 150 1.3.19 tio[89b] messages: to $fh_log now, add delta-time;
|
92 |
|
|
# fixes in disk extend logic and messages; add the
|
93 |
|
|
# (^c form of ( command; add adaptive read vector
|
94 |
|
|
# in serv11_attn_dl11;
|
95 |
|
|
# 2008-05-22 149 1.3.18 add term_tios_print, fixes for --term under cygwin;
|
96 |
|
|
# 2008-05-22 148 1.3.17 add (,< short-cut commands
|
97 |
|
|
# 2008-05-18 147 1.3.16 ATTN comma drop now warning, -W (was -I);
|
98 |
|
|
# 2008-05-12 145 1.3.15 rename ldpta -> ldabs
|
99 |
|
|
# 2008-05-09 144 1.3.14 disable call in attn_dispatch(1) (needs busy logic)
|
100 |
|
|
# 2008-05-01 142 1.3.13 serv11: add stop,cont,reset; add $force for attn
|
101 |
|
|
# handlers; use attn+ioto(16ms) to avoid TTO hangs
|
102 |
|
|
# 2008-05-01 141 1.3.12 write TTO char-by-char now to STDOUT
|
103 |
|
|
# 2008-04-25 138 1.3.11 show ccc/scc for code 000257/000277 in disassembler
|
104 |
|
|
# 2008-04-19 137 1.3.10 minor fix disassembler: use f reg prefix for f4,f5
|
105 |
|
|
# 2008-04-18 136 1.3.9 hack in a poor man's output to console...
|
106 |
|
|
# 2008-04-13 135 1.3.8 substitute environment variables in cmd file names
|
107 |
|
|
# 2008-04-11 134 1.3.7 allow line comments starting with ";" (for simh)
|
108 |
|
|
# 2008-04-06 133 1.3.6 fix file check in serv11_cexec_ldpta; fix wrong
|
109 |
|
|
# opcode for mfps; fixed bug in disassembling mode=77
|
110 |
|
|
# add -a for lsmem;
|
111 |
|
|
# 2008-04-04 132 1.3.5 add in disassembler non-11/70 and fpp codes;
|
112 |
|
|
# add (>|>>)file option for lsmem (redirect to file)
|
113 |
|
|
# 2008-03-39 131 1.3.4 lsmem -m: use now wide (3 word) symbolic dump format
|
114 |
|
|
# add ldpta command (load paper tape abs format)
|
115 |
|
|
# add start and step command
|
116 |
|
|
# 2008-03-24 129 1.3.3 allow comments when in serv11 server mode.
|
117 |
|
|
# check attach file size; zero-fill after partial
|
118 |
|
|
# block write; reorganize dsk file and rdma handling
|
119 |
|
|
# leading blanks now ignored in commands
|
120 |
|
|
# 2008-03-22 128 1.3.2 fully functional server mode (todo: TT <-> telnet)
|
121 |
|
|
# 2008-03-19 127 1.3.1 very preliminary server mode now working
|
122 |
|
|
# 2008-03-09 124 1.3 add serv11 mode; add PDP11 disamssebler
|
123 |
|
|
# 2008-03-02 121 1.2.5 the default .sdef now checks for hard errors.
|
124 |
|
|
# the _open handlers for rri and pdpcp setup default
|
125 |
|
|
# Add .cerr, .merr as ignored directives for pdpcp
|
126 |
|
|
# 2008-02-24 119 1.2.4 added lah,rps,wps command in .pdpcp mode
|
127 |
|
|
# 2008-02-16 116 1.2.3 add librb,[rw]ibr,and wtlam to pdpcp command set
|
128 |
|
|
# 2007-12-25 105 1.2.2 for rri mode add .dbas[io] (set base for data vals)
|
129 |
|
|
# add ${par}, ${par:=val}, ${par:-val} substitution
|
130 |
|
|
# allow parameter definition via par=val lines
|
131 |
|
|
# add $[..perl code..] escape to embed perl code
|
132 |
|
|
# allow @file(arg1,arg2,arg3,...); print .wtlam wait
|
133 |
|
|
# 2007-11-24 98 1.2.1 adapt to new rri internal init handling
|
134 |
|
|
# 2007-11-18 96 1.2 add 'read before write' logic to avoid deadlocks
|
135 |
|
|
# under cygwin broken fifo (size=1 !) implementation
|
136 |
|
|
# 2007-10-12 88 1.1.4 fix some -w issues
|
137 |
|
|
# 2007-09-23 84 1.1.3 .reset command in pdpcp mode; keep-alive in --fifo
|
138 |
|
|
# 2007-09-16 83 1.1.2 add --cmax; full --term implemented
|
139 |
|
|
# 2007-09-09 80 1.1.1 add --run; modularize I/O handling; initial --term
|
140 |
|
|
# proper return code / retry loop for sysread/write
|
141 |
|
|
# 2007-09-09 80 1.1 new non-blocking/blocking handling; ignore IDLE's
|
142 |
|
|
# and unexpected ATTN commas; add _flush; add
|
143 |
|
|
# data check handling, command chaining, 'pdpcp' mode.
|
144 |
|
|
# 2007-09-02 79 1.0.1 implement 'rri' mode
|
145 |
|
|
# 2007-09-01 78 1.0 Initial version
|
146 |
|
|
|
147 |
|
|
use 5.005; # require Perl 5.005 or higher
|
148 |
|
|
use strict; # require strict checking
|
149 |
|
|
|
150 |
|
|
use FileHandle;
|
151 |
|
|
use POSIX qw(mkfifo isatty :termios_h);
|
152 |
|
|
use Fcntl qw(O_WRONLY O_RDONLY O_NOCTTY);
|
153 |
|
|
use Errno qw(EINTR);
|
154 |
|
|
use Time::HiRes qw(gettimeofday);
|
155 |
|
|
use Socket;
|
156 |
|
|
use Term::ReadLine;
|
157 |
|
|
|
158 |
|
|
use constant CPREF => 0x80;
|
159 |
|
|
use constant NCOMM => 4;
|
160 |
|
|
use constant CESC => CPREF|0x0f ;
|
161 |
|
|
use constant CEN1 => (~CPREF)&0xf0;
|
162 |
|
|
use constant D9IDLE => 0x100;
|
163 |
|
|
use constant D9SOP => 0x101;
|
164 |
|
|
use constant D9EOP => 0x102;
|
165 |
|
|
use constant D9NAK => 0x103;
|
166 |
|
|
use constant D9ATTN => 0x104;
|
167 |
|
|
|
168 |
|
|
use constant PDPCP_ADDR_CONF => 000;
|
169 |
|
|
use constant PDPCP_ADDR_CNTL => 001;
|
170 |
|
|
use constant PDPCP_ADDR_STAT => 002;
|
171 |
|
|
use constant PDPCP_ADDR_PSW => 003;
|
172 |
|
|
use constant PDPCP_ADDR_AL => 004;
|
173 |
|
|
use constant PDPCP_ADDR_AH => 005;
|
174 |
|
|
use constant PDPCP_ADDR_MEM => 006;
|
175 |
|
|
use constant PDPCP_ADDR_MEMI => 007;
|
176 |
|
|
use constant PDPCP_ADDR_R0 => 010;
|
177 |
|
|
use constant PDPCP_ADDR_PC => 017;
|
178 |
|
|
use constant PDPCP_ADDR_IBRB => 020;
|
179 |
|
|
use constant PDPCP_ADDR_IBR => 0200;
|
180 |
|
|
|
181 |
|
|
use constant PDPCP_FUNC_NOOP => 000;
|
182 |
|
|
use constant PDPCP_FUNC_STA => 001;
|
183 |
|
|
use constant PDPCP_FUNC_STO => 002;
|
184 |
|
|
use constant PDPCP_FUNC_CONT => 003;
|
185 |
|
|
use constant PDPCP_FUNC_STEP => 004;
|
186 |
|
|
use constant PDPCP_FUNC_RST => 017;
|
187 |
|
|
|
188 |
|
|
use constant LINUX_B57600 => 0010001; # B57600 not part of POSIX package !
|
189 |
|
|
use constant LINUX_B115200 => 0010002; # in linux these values are in
|
190 |
|
|
use constant LINUX_B230400 => 0010003; # termios.h, specifically in
|
191 |
|
|
use constant LINUX_B460800 => 0010004; # /usr/include/bits/termios.h
|
192 |
|
|
use constant LINUX_B500000 => 0010005;
|
193 |
|
|
use constant LINUX_B576000 => 0010006;
|
194 |
|
|
use constant LINUX_B921600 => 0010007;
|
195 |
|
|
use constant LINUX_B1000000 => 0010010;
|
196 |
|
|
use constant LINUX_B2000000 => 0010013;
|
197 |
|
|
use constant LINUX_B3000000 => 0010015;
|
198 |
|
|
|
199 |
|
|
use constant LINUX_CRTSCTS => 020000000000; # ! Not part of POSIX !!
|
200 |
|
|
|
201 |
|
|
use Getopt::Long;
|
202 |
|
|
|
203 |
|
|
my %opts = ();
|
204 |
|
|
|
205 |
|
|
GetOptions(\%opts, "help", "int", "trace",
|
206 |
|
|
"tio8", "tio9", "tiob",
|
207 |
|
|
"dserv", "tserv", "log:s",
|
208 |
|
|
"fifo:s", "term:s",
|
209 |
|
|
"timeout=f", "cmax=i",
|
210 |
|
|
"run=s",
|
211 |
|
|
)
|
212 |
|
|
or die "bad options";
|
213 |
|
|
|
214 |
|
|
sub init_regtbl; # initialize regtbl from reglist
|
215 |
|
|
sub get_command;
|
216 |
|
|
sub do_command;
|
217 |
|
|
sub read_command;
|
218 |
|
|
sub setpar_command;
|
219 |
|
|
sub nomode_open;
|
220 |
|
|
sub nomode_flush;
|
221 |
|
|
sub nomode_close;
|
222 |
|
|
sub nomode_cexec;
|
223 |
|
|
sub cpraw_open;
|
224 |
|
|
sub cpraw_flush;
|
225 |
|
|
sub cpraw_close;
|
226 |
|
|
sub cpraw_cexec;
|
227 |
|
|
sub do_cprx;
|
228 |
|
|
sub do_cptx;
|
229 |
|
|
sub cpraw_tx_match_now;
|
230 |
|
|
sub cpraw_tx_match;
|
231 |
|
|
sub rri_open;
|
232 |
|
|
sub rri_flush;
|
233 |
|
|
sub rri_close;
|
234 |
|
|
sub rri_cexec;
|
235 |
|
|
sub rri_cget_stat;
|
236 |
|
|
sub rri_cget_addr;
|
237 |
|
|
sub rri_cget_nblk;
|
238 |
|
|
sub rri_sideband;
|
239 |
|
|
sub rri_cmdlist_do;
|
240 |
|
|
sub rri_cmdlist_dump;
|
241 |
|
|
sub rri_cmdlist_exec;
|
242 |
|
|
sub rri_cmdlist_check_stat;
|
243 |
|
|
sub rri_cmdlist_get_rval;
|
244 |
|
|
sub rri_cmdlist_conv_rval;
|
245 |
|
|
sub rri_ref_check; # check reference data (1=err)
|
246 |
|
|
sub pdpcp_open;
|
247 |
|
|
sub pdpcp_flush;
|
248 |
|
|
sub pdpcp_close;
|
249 |
|
|
sub pdpcp_cexec;
|
250 |
|
|
sub pdpcp_cmd_rreg;
|
251 |
|
|
sub pdpcp_cmd_wreg;
|
252 |
|
|
sub serv11_open;
|
253 |
|
|
sub serv11_flush;
|
254 |
|
|
sub serv11_close;
|
255 |
|
|
sub serv11_cexec;
|
256 |
|
|
sub serv11_cexec_shoreg;
|
257 |
|
|
sub serv11_cexec_shommu_ssrx;
|
258 |
|
|
sub serv11_cexec_shommu_sadr;
|
259 |
|
|
sub serv11_cexec_ldabs;
|
260 |
|
|
sub serv11_cexec_shoconf;
|
261 |
|
|
sub serv11_cexec_shoatt;
|
262 |
|
|
sub serv11_cexec_attdet;
|
263 |
|
|
sub serv11_cexec_boot;
|
264 |
|
|
sub serv11_cexec_exa;
|
265 |
|
|
sub serv11_cexec_dep;
|
266 |
|
|
sub serv11_config;
|
267 |
|
|
sub serv11_init_dispatch;
|
268 |
|
|
sub serv11_server;
|
269 |
|
|
sub serv11_server_attn_get;
|
270 |
|
|
sub serv11_server_attn_dispatch;
|
271 |
|
|
sub serv11_probe_gen; # generic probe handler
|
272 |
|
|
sub serv11_init_gen; # generic controller init handler
|
273 |
|
|
sub serv11_detach_gen; # generic detach handler
|
274 |
|
|
sub serv11_attdet_disk; # generic disk att/det handler
|
275 |
|
|
sub serv11_attdet_ronly; # generic in only att/det handler
|
276 |
|
|
sub serv11_attdet_wonly; # generic out only att/det handler
|
277 |
|
|
sub serv11_attdet_term; # generic term att/det handler
|
278 |
|
|
sub serv11_probe_cpu; # cpu: probe handler
|
279 |
|
|
sub serv11_attn_cpu; # cpu: attention handler
|
280 |
|
|
sub serv11_exadep_cpu; # cpu: exa/dep handler
|
281 |
|
|
sub serv11_ichr_dl11;
|
282 |
|
|
sub serv11_attn_dl11;
|
283 |
|
|
sub serv11_uset_lp11;
|
284 |
|
|
sub serv11_attn_lp11;
|
285 |
|
|
sub serv11_uset_pc11;
|
286 |
|
|
sub serv11_attdet_pc11;
|
287 |
|
|
sub serv11_attn_pc11;
|
288 |
|
|
sub serv11_uset_rk11;
|
289 |
|
|
sub serv11_attn_rk11;
|
290 |
|
|
sub serv11_attn_rk11_logerr;
|
291 |
|
|
sub serv11_rdma_rk11;
|
292 |
|
|
sub serv11_icb_disk_read; # read one dsk file block
|
293 |
|
|
sub serv11_icb_disk_write; # write one dsk file block
|
294 |
|
|
sub serv11_rri_init; # issue rri init command
|
295 |
|
|
sub serv11_rri_attn; # issue rri attn command
|
296 |
|
|
sub serv11_rri_stat; # issue rri stat command
|
297 |
|
|
sub serv11_rri_rreg; # issue rri rreg command
|
298 |
|
|
sub serv11_rri_wreg; # issue rri wreg command
|
299 |
|
|
sub serv11_rri_rblk; # issue rri rblk command
|
300 |
|
|
sub serv11_rri_wblk; # issue rri wblk command
|
301 |
|
|
sub serv11_rri_lalh; # issue pdpcp lal and lah commands
|
302 |
|
|
sub serv11_rri_ibrb; # issue rbus set base address
|
303 |
|
|
sub serv11_rri_ribr; # issue rbus read
|
304 |
|
|
sub serv11_rri_wibr; # issue rbus write
|
305 |
|
|
sub serv11_rri_clear;
|
306 |
|
|
sub serv11_rri_exec;
|
307 |
|
|
sub serv11_rri_uset; # issue rbus uset writes
|
308 |
|
|
sub serv11_exec_rblk;
|
309 |
|
|
sub serv11_exec_wblk;
|
310 |
|
|
sub serv11_exec_probe;
|
311 |
|
|
sub next_nxbuf; # calculate next nxbuf value
|
312 |
|
|
sub telnet_readhdl; # telnet: socket read handler
|
313 |
|
|
sub telnet_writehdl; # telnet: write handler
|
314 |
|
|
sub pdp11_disassemble; # simple PDP11 disassembler
|
315 |
|
|
sub pdp11_disassemble_regmod; # helper
|
316 |
|
|
sub file_seek; # fseek wrapper
|
317 |
|
|
sub file_read; # fread wrapper
|
318 |
|
|
sub file_seek_read; # fseek+fread wrapper
|
319 |
|
|
sub file_write; # fwrite wrapper
|
320 |
|
|
sub file_seek_write; # fseek+fwrite wrapper
|
321 |
|
|
sub raw_get9_crc_16bit; # read 16 bit value
|
322 |
|
|
sub raw_get9_crc_8bit; # read 8bit value
|
323 |
|
|
sub raw_get9_crc_check; # get 9bit, block, crc, ref value
|
324 |
|
|
sub raw_get9_check; # get 9bit, block, expect ref value
|
325 |
|
|
sub raw_get9_checksop; # get 9bit, block, expect 'sop'
|
326 |
|
|
sub raw_get9_checkeop; # get 9bit, block, expect 'eop'
|
327 |
|
|
sub raw_get9_crc; # get 9bit, block, update crc
|
328 |
|
|
sub raw_get9; # get 9bit, block
|
329 |
|
|
sub raw_snd9_crc; # put 9bit to RX, update crc
|
330 |
|
|
sub raw_snd9; # put 9bit to RX
|
331 |
|
|
sub raw_snd8; # put 8bit to RX
|
332 |
|
|
sub raw_rcv9; # get 9bit from TX, non-blocking
|
333 |
|
|
sub raw_rcv8; # get 8bit from TX, non-blocking
|
334 |
|
|
sub raw_rcv9_to; # get 9bit from TX, expl. time-out
|
335 |
|
|
sub raw_rcv8_to; # get 8bit from TX, expl. time-out
|
336 |
|
|
sub wait_sel_filercv; # poll/wait for RCV to be ready
|
337 |
|
|
sub fifo_open; # chan fifo: open handler
|
338 |
|
|
sub fifo_close; # chan fifo: close handler
|
339 |
|
|
sub term_open; # chan term: open handler
|
340 |
|
|
sub term_close; # chan term: close handler
|
341 |
|
|
sub term_tios_print; # chan term: print termios state
|
342 |
|
|
sub genio_read; # generic io: read handler
|
343 |
|
|
sub genio_write; # generic io: write handler
|
344 |
|
|
sub cget_chkblank; # check for unused chars in cmd line
|
345 |
|
|
sub cget_tagval2_gdat; # get tag=v1[,v2], generic base
|
346 |
|
|
sub cget_tagval_gdat; # get tag=val, generic base
|
347 |
|
|
sub cget_gdat; # get generic base value
|
348 |
|
|
sub cget_name; # get name \w+
|
349 |
|
|
sub cget_bool; # get boolean [01]
|
350 |
|
|
sub cget_file; # get filename [\w\/.]+
|
351 |
|
|
sub cget_ucb; # get ucb (read name, return ucb)
|
352 |
|
|
sub cget_opt; # get option
|
353 |
|
|
sub cget_optset; # get option set
|
354 |
|
|
sub cget_regrange; # get register/memory range
|
355 |
|
|
sub cchk_number; # check for number. any gdat value
|
356 |
|
|
sub sget_bdat; # convert 01 string -> binary value
|
357 |
|
|
sub conv_etime; # generate timestamp string
|
358 |
|
|
sub conv_dat9;
|
359 |
|
|
sub conv_dat8;
|
360 |
|
|
sub conv_str2bytes; # string to bytelist; handle \n
|
361 |
|
|
sub conv_buf2wlist; # string buffer -> word list
|
362 |
|
|
sub conv_wlist2buf; # word list -> string buffer
|
363 |
|
|
sub conv_byte2ascii2; # byte -> 2 charcter ASCII display
|
364 |
|
|
sub gconv_dat16;
|
365 |
|
|
sub hdl_sigint; # SIGINT handler
|
366 |
|
|
sub get_time;
|
367 |
|
|
sub get_timestamp;
|
368 |
|
|
sub filename_expand; # expand $nnn in name
|
369 |
|
|
sub print_fatal;
|
370 |
|
|
sub print_help;
|
371 |
|
|
|
372 |
|
|
my %stat_tab = ( obyte => 0.,
|
373 |
|
|
oesc => 0.,
|
374 |
|
|
osop => 0.,
|
375 |
|
|
ibyte => 0.,
|
376 |
|
|
iesc => 0.,
|
377 |
|
|
att => 0.,
|
378 |
|
|
xreg => 0.,
|
379 |
|
|
xblk => 0.,
|
380 |
|
|
rdisk => 0.,
|
381 |
|
|
wdisk => 0.);
|
382 |
|
|
my %stat_tab_last = %stat_tab;
|
383 |
|
|
|
384 |
|
|
my %mode_tab = (nomode => {open => \&nomode_open,
|
385 |
|
|
flush => \&nomode_flush,
|
386 |
|
|
close => \&nomode_close,
|
387 |
|
|
cmd => \&nomode_cexec},
|
388 |
|
|
cpraw => {open => \&cpraw_open,
|
389 |
|
|
flush => \&cpraw_flush,
|
390 |
|
|
close => \&cpraw_close,
|
391 |
|
|
cmd => \&cpraw_cexec},
|
392 |
|
|
rri => {open => \&rri_open,
|
393 |
|
|
flush => \&rri_flush,
|
394 |
|
|
close => \&rri_close,
|
395 |
|
|
cmd => \&rri_cexec},
|
396 |
|
|
pdpcp => {open => \&pdpcp_open,
|
397 |
|
|
flush => \&pdpcp_flush,
|
398 |
|
|
close => \&pdpcp_close,
|
399 |
|
|
cmd => \&pdpcp_cexec},
|
400 |
|
|
serv11 => {open => \&serv11_open,
|
401 |
|
|
flush => \&serv11_flush,
|
402 |
|
|
close => \&serv11_close,
|
403 |
|
|
cmd => \&serv11_cexec}
|
404 |
|
|
);
|
405 |
|
|
|
406 |
|
|
my %chan_tab = (fifo => {open => \&fifo_open,
|
407 |
|
|
close => \&fifo_close,
|
408 |
|
|
read => \&genio_read,
|
409 |
|
|
write => \&genio_write},
|
410 |
|
|
term => {open => \&term_open,
|
411 |
|
|
close => \&term_close,
|
412 |
|
|
read => \&genio_read,
|
413 |
|
|
write => \&genio_write}
|
414 |
|
|
);
|
415 |
|
|
|
416 |
|
|
my $curmode = "nomode";
|
417 |
|
|
my $curcmd = \&nomode_cexec;
|
418 |
|
|
my $curchan = undef;
|
419 |
|
|
my @cmdfh;
|
420 |
|
|
my @cmdfn;
|
421 |
|
|
my @cmdargs;
|
422 |
|
|
my $time0 = -1;
|
423 |
|
|
my $tlast_tio8 = 0;
|
424 |
|
|
my $tlast_tio9 = 0;
|
425 |
|
|
my $tlast_tiob = 0;
|
426 |
|
|
|
427 |
|
|
my @que_rcv;
|
428 |
|
|
my @que_snd;
|
429 |
|
|
|
430 |
|
|
my @cpraw_tx_read;
|
431 |
|
|
my @cpraw_tx_expt;
|
432 |
|
|
|
433 |
|
|
my $fh_log = *STDOUT;
|
434 |
|
|
my $fh_snd;
|
435 |
|
|
my $fh_rcv;
|
436 |
|
|
my $fdset_filercv;
|
437 |
|
|
my $fifo_keep;
|
438 |
|
|
my $term_oldtios;
|
439 |
|
|
my $raw_rcv_esc = 0;
|
440 |
|
|
my $raw_timeout = 1.;
|
441 |
|
|
my $cmax = 16;
|
442 |
|
|
|
443 |
|
|
my $cmd_line;
|
444 |
|
|
my $cmd_rest;
|
445 |
|
|
my $cmd_bad;
|
446 |
|
|
my $cmd_inter; # interactive cmd flag
|
447 |
|
|
|
448 |
|
|
my $term;
|
449 |
|
|
if (-t STDIN) {
|
450 |
|
|
$term = new Term::ReadLine 'pi_rri';
|
451 |
|
|
}
|
452 |
|
|
|
453 |
|
|
my %par; # params for command line substitution
|
454 |
|
|
my $sigint_count = 0; # SIGINT counter
|
455 |
|
|
|
456 |
|
|
use constant TELNET_CODE_NULL => 0;
|
457 |
|
|
use constant TELNET_CODE_LF => 10;
|
458 |
|
|
use constant TELNET_CODE_CR => 13;
|
459 |
|
|
use constant TELNET_CODE_ESC => 27;
|
460 |
|
|
use constant TELNET_CODE_SE => 240;
|
461 |
|
|
use constant TELNET_CODE_NOP => 241;
|
462 |
|
|
use constant TELNET_CODE_IP => 244;
|
463 |
|
|
use constant TELNET_CODE_GA => 249;
|
464 |
|
|
use constant TELNET_CODE_SB => 250;
|
465 |
|
|
use constant TELNET_CODE_WILL => 251;
|
466 |
|
|
use constant TELNET_CODE_WONT => 252;
|
467 |
|
|
use constant TELNET_CODE_DO => 253;
|
468 |
|
|
use constant TELNET_CODE_DONT => 254;
|
469 |
|
|
use constant TELNET_CODE_IAC => 255;
|
470 |
|
|
|
471 |
|
|
use constant TELNET_OPT_BIN => 0;
|
472 |
|
|
use constant TELNET_OPT_ECHO => 1;
|
473 |
|
|
use constant TELNET_OPT_SGA => 3;
|
474 |
|
|
use constant TELNET_OPT_TTYP => 24;
|
475 |
|
|
use constant TELNET_OPT_LINE => 34;
|
476 |
|
|
|
477 |
|
|
use constant TELNET_STATE_LISTEN => -1;
|
478 |
|
|
use constant TELNET_STATE_STREAM => 0;
|
479 |
|
|
use constant TELNET_STATE_IAC => 1;
|
480 |
|
|
use constant TELNET_STATE_CMD => 2;
|
481 |
|
|
use constant TELNET_STATE_SUBNEG => 3;
|
482 |
|
|
use constant TELNET_STATE_SUBIAC => 4;
|
483 |
|
|
|
484 |
|
|
#
|
485 |
|
|
# %telnettbl->{snum} --> telnet session table, hash of hashes, key'ed by port
|
486 |
|
|
# -> {port} port number (int)
|
487 |
|
|
# -> {state} state: (_LISTEN|_STREAM|_IAC|_CMD|_SUBNEG|_SUBIAC)
|
488 |
|
|
# -> {fh_port} file handle of port socket (for listen)
|
489 |
|
|
# -> {fh_data} file handle of data socket
|
490 |
|
|
# -> {ucb} ucb the port is attached to
|
491 |
|
|
#
|
492 |
|
|
|
493 |
|
|
my %telnettbl;
|
494 |
|
|
|
495 |
|
|
my $rri_ref_sdef = 0x00; # by default check for 'hard' errors
|
496 |
|
|
my $rri_msk_sdef = 0xf0; # ignore the status bits + attn flag
|
497 |
|
|
my %rri_amtbl;
|
498 |
|
|
my @rri_cmdlist;
|
499 |
|
|
my $rri_rvalcnt = 0;
|
500 |
|
|
my $rri_ncmdmax = undef;
|
501 |
|
|
my $rri_dbasi = 2; # default input base
|
502 |
|
|
my $rri_dbaso = 8; # default output base
|
503 |
|
|
my $rri_nodfill = " " x 5; # filler string for "d=-" stanzas
|
504 |
|
|
|
505 |
|
|
my %rri_cname2cmd = (rreg => 0, # c_rri_cmd_rreg : slv3 := "000";
|
506 |
|
|
rblk => 1, # c_rri_cmd_rblk : slv3 := "001";
|
507 |
|
|
wreg => 2, # c_rri_cmd_wreg : slv3 := "010";
|
508 |
|
|
wblk => 3, # c_rri_cmd_wblk : slv3 := "011";
|
509 |
|
|
stat => 4, # c_rri_cmd_stat : slv3 := "100";
|
510 |
|
|
attn => 5, # c_rri_cmd_attn : slv3 := "101";
|
511 |
|
|
init => 6); # c_rri_cmd_init : slv3 := "110";
|
512 |
|
|
|
513 |
|
|
my @crc8_tbl = ( 0, 29, 58, 39, 116, 105, 78, 83, # from gen_crc8_tbl
|
514 |
|
|
232, 245, 210, 207, 156, 129, 166, 187,
|
515 |
|
|
205, 208, 247, 234, 185, 164, 131, 158,
|
516 |
|
|
37, 56, 31, 2, 81, 76, 107, 118,
|
517 |
|
|
135, 154, 189, 160, 243, 238, 201, 212,
|
518 |
|
|
111, 114, 85, 72, 27, 6, 33, 60,
|
519 |
|
|
74, 87, 112, 109, 62, 35, 4, 25,
|
520 |
|
|
162, 191, 152, 133, 214, 203, 236, 241,
|
521 |
|
|
19, 14, 41, 52, 103, 122, 93, 64,
|
522 |
|
|
251, 230, 193, 220, 143, 146, 181, 168,
|
523 |
|
|
222, 195, 228, 249, 170, 183, 144, 141,
|
524 |
|
|
54, 43, 12, 17, 66, 95, 120, 101,
|
525 |
|
|
148, 137, 174, 179, 224, 253, 218, 199,
|
526 |
|
|
124, 97, 70, 91, 8, 21, 50, 47,
|
527 |
|
|
89, 68, 99, 126, 45, 48, 23, 10,
|
528 |
|
|
177, 172, 139, 150, 197, 216, 255, 226,
|
529 |
|
|
38, 59, 28, 1, 82, 79, 104, 117,
|
530 |
|
|
206, 211, 244, 233, 186, 167, 128, 157,
|
531 |
|
|
235, 246, 209, 204, 159, 130, 165, 184,
|
532 |
|
|
3, 30, 57, 36, 119, 106, 77, 80,
|
533 |
|
|
161, 188, 155, 134, 213, 200, 239, 242,
|
534 |
|
|
73, 84, 115, 110, 61, 32, 7, 26,
|
535 |
|
|
108, 113, 86, 75, 24, 5, 34, 63,
|
536 |
|
|
132, 153, 190, 163, 240, 237, 202, 215,
|
537 |
|
|
53, 40, 15, 18, 65, 92, 123, 102,
|
538 |
|
|
221, 192, 231, 250, 169, 180, 147, 142,
|
539 |
|
|
248, 229, 194, 223, 140, 145, 182, 171,
|
540 |
|
|
16, 13, 42, 55, 100, 121, 94, 67,
|
541 |
|
|
178, 175, 136, 149, 198, 219, 252, 225,
|
542 |
|
|
90, 71, 96, 125, 46, 51, 20, 9,
|
543 |
|
|
127, 98, 69, 88, 11, 22, 49, 44,
|
544 |
|
|
151, 138, 173, 176, 227, 254, 217, 196);
|
545 |
|
|
|
546 |
|
|
my $ocrc = 0;
|
547 |
|
|
my $icrc = 0;
|
548 |
|
|
my $kpid = -1;
|
549 |
|
|
|
550 |
|
|
my @pdp11_opcode_tbl = (
|
551 |
|
|
{code=>0000000, mask=>0000000, name=>"halt", type=>"0arg"},
|
552 |
|
|
{code=>0000001, mask=>0000000, name=>"wait", type=>"0arg"},
|
553 |
|
|
{code=>0000002, mask=>0000000, name=>"rti ", type=>"0arg"},
|
554 |
|
|
{code=>0000003, mask=>0000000, name=>"bpt ", type=>"0arg"},
|
555 |
|
|
{code=>0000004, mask=>0000000, name=>"iot ", type=>"0arg"},
|
556 |
|
|
{code=>0000005, mask=>0000000, name=>"reset",type=>"0arg"},
|
557 |
|
|
{code=>0000006, mask=>0000000, name=>"rtt ", type=>"0arg"},
|
558 |
|
|
{code=>0000007, mask=>0000000, name=>"!!mfpt", type=>"0arg"},
|
559 |
|
|
{code=>0000100, mask=>0000077, name=>"jmp ", type=>"1arg"},
|
560 |
|
|
{code=>0000200, mask=>0000007, name=>"rts ", type=>"1reg"},
|
561 |
|
|
{code=>0000230, mask=>0000007, name=>"spl ", type=>"spl"},
|
562 |
|
|
{code=>0000240, mask=>0000017, name=>"cl", type=>"ccop"},
|
563 |
|
|
{code=>0000260, mask=>0000017, name=>"se", type=>"ccop"},
|
564 |
|
|
{code=>0000300, mask=>0000077, name=>"swap", type=>"1arg"},
|
565 |
|
|
{code=>0000400, mask=>0000377, name=>"br ", type=>"br"},
|
566 |
|
|
{code=>0001000, mask=>0000377, name=>"bne ", type=>"br"},
|
567 |
|
|
{code=>0001400, mask=>0000377, name=>"beq ", type=>"br"},
|
568 |
|
|
{code=>0002000, mask=>0000377, name=>"bge ", type=>"br"},
|
569 |
|
|
{code=>0002400, mask=>0000377, name=>"blt ", type=>"br"},
|
570 |
|
|
{code=>0003000, mask=>0000377, name=>"bgt ", type=>"br"},
|
571 |
|
|
{code=>0003400, mask=>0000377, name=>"ble ", type=>"br"},
|
572 |
|
|
{code=>0004000, mask=>0000777, name=>"jsr ", type=>"jsr"},
|
573 |
|
|
{code=>0005000, mask=>0000077, name=>"clr ", type=>"1arg"},
|
574 |
|
|
{code=>0005100, mask=>0000077, name=>"com ", type=>"1arg"},
|
575 |
|
|
{code=>0005200, mask=>0000077, name=>"inc ", type=>"1arg"},
|
576 |
|
|
{code=>0005300, mask=>0000077, name=>"dec ", type=>"1arg"},
|
577 |
|
|
{code=>0005400, mask=>0000077, name=>"neg ", type=>"1arg"},
|
578 |
|
|
{code=>0005500, mask=>0000077, name=>"adc ", type=>"1arg"},
|
579 |
|
|
{code=>0005600, mask=>0000077, name=>"sbc ", type=>"1arg"},
|
580 |
|
|
{code=>0005700, mask=>0000077, name=>"tst ", type=>"1arg"},
|
581 |
|
|
{code=>0006000, mask=>0000077, name=>"ror ", type=>"1arg"},
|
582 |
|
|
{code=>0006100, mask=>0000077, name=>"rol ", type=>"1arg"},
|
583 |
|
|
{code=>0006200, mask=>0000077, name=>"asr ", type=>"1arg"},
|
584 |
|
|
{code=>0006300, mask=>0000077, name=>"asl ", type=>"1arg"},
|
585 |
|
|
{code=>0006400, mask=>0000077, name=>"mark", type=>"mark"},
|
586 |
|
|
{code=>0006500, mask=>0000077, name=>"mfpi", type=>"1arg"},
|
587 |
|
|
{code=>0006600, mask=>0000077, name=>"mtpi", type=>"1arg"},
|
588 |
|
|
{code=>0006700, mask=>0000077, name=>"sxt ", type=>"1arg"},
|
589 |
|
|
{code=>0007000, mask=>0000077, name=>"!!csm", type=>"1arg"},
|
590 |
|
|
{code=>0007200, mask=>0000077, name=>"!!tstset",type=>"1arg"},
|
591 |
|
|
{code=>0007300, mask=>0000077, name=>"!!wrtlck",type=>"1arg"},
|
592 |
|
|
{code=>0010000, mask=>0007777, name=>"mov ", type=>"2arg"},
|
593 |
|
|
{code=>0020000, mask=>0007777, name=>"cmp ", type=>"2arg"},
|
594 |
|
|
{code=>0030000, mask=>0007777, name=>"bit ", type=>"2arg"},
|
595 |
|
|
{code=>0040000, mask=>0007777, name=>"bic ", type=>"2arg"},
|
596 |
|
|
{code=>0050000, mask=>0007777, name=>"bis ", type=>"2arg"},
|
597 |
|
|
{code=>0060000, mask=>0007777, name=>"add ", type=>"2arg"},
|
598 |
|
|
{code=>0070000, mask=>0000777, name=>"mul ", type=>"rdst"},
|
599 |
|
|
{code=>0071000, mask=>0000777, name=>"div ", type=>"rdst"},
|
600 |
|
|
{code=>0072000, mask=>0000777, name=>"ash ", type=>"rdst"},
|
601 |
|
|
{code=>0073000, mask=>0000777, name=>"ashc", type=>"rdst"},
|
602 |
|
|
{code=>0074000, mask=>0000777, name=>"xor ", type=>"rdst"},
|
603 |
|
|
{code=>0077000, mask=>0000777, name=>"sob ", type=>"sob"},
|
604 |
|
|
{code=>0100000, mask=>0000377, name=>"bpl ", type=>"br"},
|
605 |
|
|
{code=>0100400, mask=>0000377, name=>"bmi ", type=>"br"},
|
606 |
|
|
{code=>0101000, mask=>0000377, name=>"bhi ", type=>"br"},
|
607 |
|
|
{code=>0101400, mask=>0000377, name=>"blos", type=>"br"},
|
608 |
|
|
{code=>0102000, mask=>0000377, name=>"bvc ", type=>"br"},
|
609 |
|
|
{code=>0102400, mask=>0000377, name=>"bvs ", type=>"br"},
|
610 |
|
|
{code=>0103000, mask=>0000377, name=>"bcc ", type=>"br"},
|
611 |
|
|
{code=>0103400, mask=>0000377, name=>"bcs ", type=>"br"},
|
612 |
|
|
{code=>0104000, mask=>0000377, name=>"emt ", type=>"trap"},
|
613 |
|
|
{code=>0104400, mask=>0000377, name=>"trap", type=>"trap"},
|
614 |
|
|
{code=>0105000, mask=>0000077, name=>"clrb", type=>"1arg"},
|
615 |
|
|
{code=>0105100, mask=>0000077, name=>"comb", type=>"1arg"},
|
616 |
|
|
{code=>0105200, mask=>0000077, name=>"incb", type=>"1arg"},
|
617 |
|
|
{code=>0105300, mask=>0000077, name=>"decb", type=>"1arg"},
|
618 |
|
|
{code=>0105400, mask=>0000077, name=>"negb", type=>"1arg"},
|
619 |
|
|
{code=>0105500, mask=>0000077, name=>"adcb", type=>"1arg"},
|
620 |
|
|
{code=>0105600, mask=>0000077, name=>"sbcb", type=>"1arg"},
|
621 |
|
|
{code=>0105700, mask=>0000077, name=>"tstb", type=>"1arg"},
|
622 |
|
|
{code=>0106000, mask=>0000077, name=>"rorb", type=>"1arg"},
|
623 |
|
|
{code=>0106100, mask=>0000077, name=>"rolb", type=>"1arg"},
|
624 |
|
|
{code=>0106200, mask=>0000077, name=>"asrb", type=>"1arg"},
|
625 |
|
|
{code=>0106300, mask=>0000077, name=>"aslb", type=>"1arg"},
|
626 |
|
|
{code=>0106400, mask=>0000077, name=>"!!mtps", type=>"1arg"},
|
627 |
|
|
{code=>0106500, mask=>0000077, name=>"mfpd", type=>"1arg"},
|
628 |
|
|
{code=>0106600, mask=>0000077, name=>"mtpd", type=>"1arg"},
|
629 |
|
|
{code=>0106700, mask=>0000077, name=>"!!mfps", type=>"1arg"},
|
630 |
|
|
{code=>0110000, mask=>0007777, name=>"movb", type=>"2arg"},
|
631 |
|
|
{code=>0120000, mask=>0007777, name=>"cmpb", type=>"2arg"},
|
632 |
|
|
{code=>0130000, mask=>0007777, name=>"bitb", type=>"2arg"},
|
633 |
|
|
{code=>0140000, mask=>0007777, name=>"bicb", type=>"2arg"},
|
634 |
|
|
{code=>0150000, mask=>0007777, name=>"bisb", type=>"2arg"},
|
635 |
|
|
{code=>0160000, mask=>0007777, name=>"sub ", type=>"2arg"},
|
636 |
|
|
{code=>0170000, mask=>0000000, name=>"!!cfcc", type=>"0arg"},
|
637 |
|
|
{code=>0170001, mask=>0000000, name=>"!!setf", type=>"0arg"},
|
638 |
|
|
{code=>0170011, mask=>0000000, name=>"!!setd", type=>"0arg"},
|
639 |
|
|
{code=>0170002, mask=>0000000, name=>"!!seti", type=>"0arg"},
|
640 |
|
|
{code=>0170012, mask=>0000000, name=>"!!setl", type=>"0arg"},
|
641 |
|
|
{code=>0170100, mask=>0000077, name=>"!!ldfps",type=>"1fpp"},
|
642 |
|
|
{code=>0170200, mask=>0000077, name=>"!!stfps",type=>"1fpp"},
|
643 |
|
|
{code=>0170300, mask=>0000077, name=>"!!stst", type=>"1fpp"},
|
644 |
|
|
{code=>0170400, mask=>0000077, name=>"!!clrf", type=>"1fpp"},
|
645 |
|
|
{code=>0170500, mask=>0000077, name=>"!!tstf", type=>"1fpp"},
|
646 |
|
|
{code=>0170600, mask=>0000077, name=>"!!absf", type=>"1fpp"},
|
647 |
|
|
{code=>0170700, mask=>0000077, name=>"!!negf", type=>"1fpp"},
|
648 |
|
|
{code=>0171000, mask=>0000377, name=>"!!mulf", type=>"rfpp"},
|
649 |
|
|
{code=>0171400, mask=>0000377, name=>"!!modf", type=>"rfpp"},
|
650 |
|
|
{code=>0172000, mask=>0000377, name=>"!!addf", type=>"rfpp"},
|
651 |
|
|
{code=>0172400, mask=>0000377, name=>"!!ldf", type=>"rfpp"},
|
652 |
|
|
{code=>0173000, mask=>0000377, name=>"!!subf", type=>"rfpp"},
|
653 |
|
|
{code=>0173400, mask=>0000377, name=>"!!cmpf", type=>"rfpp"},
|
654 |
|
|
{code=>0174000, mask=>0000377, name=>"!!stf", type=>"rfpp"},
|
655 |
|
|
{code=>0174400, mask=>0000377, name=>"!!divf", type=>"rfpp"},
|
656 |
|
|
{code=>0175000, mask=>0000377, name=>"!!stexp",type=>"rfpp"},
|
657 |
|
|
{code=>0175400, mask=>0000377, name=>"!!stcif",type=>"rfpp"},
|
658 |
|
|
{code=>0176000, mask=>0000377, name=>"!!stcfd",type=>"rfpp"},
|
659 |
|
|
{code=>0176400, mask=>0000377, name=>"!!ldexp",type=>"rfpp"},
|
660 |
|
|
{code=>0177000, mask=>0000377, name=>"!!ldcif",type=>"rfpp"},
|
661 |
|
|
{code=>0177400, mask=>0000377, name=>"!!ldcdf",type=>"rfpp"}
|
662 |
|
|
);
|
663 |
|
|
|
664 |
|
|
use constant BIT00 => 0000001;
|
665 |
|
|
use constant BIT01 => 0000002;
|
666 |
|
|
use constant BIT02 => 0000004;
|
667 |
|
|
use constant BIT03 => 0000010;
|
668 |
|
|
use constant BIT04 => 0000020;
|
669 |
|
|
use constant BIT05 => 0000040;
|
670 |
|
|
use constant BIT06 => 0000100;
|
671 |
|
|
use constant BIT07 => 0000200;
|
672 |
|
|
use constant BIT08 => 0000400;
|
673 |
|
|
use constant BIT09 => 0001000;
|
674 |
|
|
use constant BIT10 => 0002000;
|
675 |
|
|
use constant BIT11 => 0004000;
|
676 |
|
|
use constant BIT12 => 0010000;
|
677 |
|
|
use constant BIT13 => 0020000;
|
678 |
|
|
use constant BIT14 => 0040000;
|
679 |
|
|
use constant BIT15 => 0100000;
|
680 |
|
|
|
681 |
|
|
use constant REGATTR_RBMBOX => 0000001; # rbus is mailbox, skip on exa loop
|
682 |
|
|
use constant REGATTR_RBRD => 0000002; # by default read on rbus
|
683 |
|
|
use constant REGATTR_RBWR => 0000004; # by default write on rbus
|
684 |
|
|
use constant REGATTR_IBMBOX => 0000010; # ibus is mailbox, skip on exa loop
|
685 |
|
|
|
686 |
|
|
# some common defs
|
687 |
|
|
|
688 |
|
|
my @partbl_nxbuf = ( nxbuf_min => { type => "hval:d" },
|
689 |
|
|
nxbuf_inc => { type => "hval:d" },
|
690 |
|
|
nxbuf_max => { type => "hval:d" },
|
691 |
|
|
nxbuf => { type => "hval:d" } );
|
692 |
|
|
|
693 |
|
|
# CPU general defs
|
694 |
|
|
|
695 |
|
|
use constant CPU_MMR3 => 0172516;
|
696 |
|
|
use constant CPU_SDREG => 0177570;
|
697 |
|
|
use constant CPU_MMR0 => 0177572;
|
698 |
|
|
use constant CPU_MMR1 => 0177574;
|
699 |
|
|
use constant CPU_MMR2 => 0177576;
|
700 |
|
|
use constant CPU_LOSIZE => 0177760;
|
701 |
|
|
use constant CPU_HISIZE => 0177762;
|
702 |
|
|
use constant CPU_SYSID => 0177764;
|
703 |
|
|
use constant CPU_CPUERR => 0177766;
|
704 |
|
|
use constant CPU_MBRK => 0177770;
|
705 |
|
|
use constant CPU_PIRQ => 0177772;
|
706 |
|
|
use constant CPU_STKLIM => 0177774;
|
707 |
|
|
use constant CPU_PSW => 0177776;
|
708 |
|
|
|
709 |
|
|
# DL11 general defs
|
710 |
|
|
use constant DL11_BASE_A => 0177560;
|
711 |
|
|
use constant DL11_BASE_B => 0176500;
|
712 |
|
|
|
713 |
|
|
# DL11 address offsets
|
714 |
|
|
use constant DL11_RCSR => 00;
|
715 |
|
|
use constant DL11_RBUF => 02;
|
716 |
|
|
use constant DL11_XCSR => 04;
|
717 |
|
|
use constant DL11_XBUF => 06;
|
718 |
|
|
|
719 |
|
|
# DL11 register defs
|
720 |
|
|
use constant DL11_RCSR_M_RDONE => BIT07;
|
721 |
|
|
use constant DL11_XCSR_M_XRDY => BIT07;
|
722 |
|
|
use constant DL11_XBUF_M_RRDY => BIT09;
|
723 |
|
|
use constant DL11_XBUF_M_XVAL => BIT08;
|
724 |
|
|
use constant DL11_XBUF_M_XBUF => 0377;
|
725 |
|
|
|
726 |
|
|
my @reglist_dl11 = ({name => "rcsr",
|
727 |
|
|
offset => DL11_RCSR},
|
728 |
|
|
{name => "rbuf",
|
729 |
|
|
offset => DL11_RBUF,
|
730 |
|
|
attr => REGATTR_IBMBOX},
|
731 |
|
|
{name => "xcsr",
|
732 |
|
|
offset => DL11_XCSR},
|
733 |
|
|
{name => "xbuf",
|
734 |
|
|
offset => DL11_XBUF,
|
735 |
|
|
attr => REGATTR_RBMBOX});
|
736 |
|
|
|
737 |
|
|
my %partbl_dl11 = ( trace => { type => "hval:b" },
|
738 |
|
|
@partbl_nxbuf );
|
739 |
|
|
|
740 |
|
|
# LP11 general defs
|
741 |
|
|
use constant LP11_BASE => 0177514;
|
742 |
|
|
|
743 |
|
|
# LP11 address offsets
|
744 |
|
|
use constant LP11_CSR => 00;
|
745 |
|
|
use constant LP11_BUF => 02;
|
746 |
|
|
|
747 |
|
|
# LP11 register defs
|
748 |
|
|
use constant LP11_CSR_M_ERR => BIT15;
|
749 |
|
|
use constant LP11_BUF_M_VAL => BIT08;
|
750 |
|
|
use constant LP11_BUF_M_BUF => 0177;
|
751 |
|
|
|
752 |
|
|
my @reglist_lp11 = ({name => "csr",
|
753 |
|
|
offset => LP11_CSR},
|
754 |
|
|
{name => "buf",
|
755 |
|
|
offset => LP11_BUF,
|
756 |
|
|
attr => REGATTR_RBMBOX});
|
757 |
|
|
my %partbl_lp11 = ( trace => { type => "hval:b" },
|
758 |
|
|
@partbl_nxbuf );
|
759 |
|
|
|
760 |
|
|
# PC11 address offsets
|
761 |
|
|
use constant PC11_RCSR => 00;
|
762 |
|
|
use constant PC11_RBUF => 02;
|
763 |
|
|
use constant PC11_PCSR => 04;
|
764 |
|
|
use constant PC11_PBUF => 06;
|
765 |
|
|
|
766 |
|
|
# PC11 register defs
|
767 |
|
|
use constant PC11_RCSR_M_ERR => BIT15;
|
768 |
|
|
use constant PC11_PCSR_M_ERR => BIT15;
|
769 |
|
|
use constant PC11_PBUF_M_RBUSY => BIT09;
|
770 |
|
|
use constant PC11_PBUF_M_PVAL => BIT08;
|
771 |
|
|
use constant PC11_PBUF_M_PBUF => 0377;
|
772 |
|
|
|
773 |
|
|
my @reglist_pc11 = ({name => "rcsr",
|
774 |
|
|
offset => PC11_RCSR},
|
775 |
|
|
{name => "rbuf",
|
776 |
|
|
offset => PC11_RBUF,
|
777 |
|
|
attr => REGATTR_IBMBOX},
|
778 |
|
|
{name => "pcsr",
|
779 |
|
|
offset => PC11_PCSR},
|
780 |
|
|
{name => "pbuf",
|
781 |
|
|
offset => PC11_PBUF,
|
782 |
|
|
attr => REGATTR_RBMBOX});
|
783 |
|
|
my %partbl_pc11 = ( trace => { type => "hval:b" },
|
784 |
|
|
@partbl_nxbuf );
|
785 |
|
|
|
786 |
|
|
# RK11 general defs
|
787 |
|
|
use constant RK11_BASE => 0177400;
|
788 |
|
|
use constant RK11_NUMSE => 12; # number of sectors
|
789 |
|
|
use constant RK11_NUMHD => 2; # number of heads
|
790 |
|
|
use constant RK11_NUMCY => 203; # number of cylinders
|
791 |
|
|
use constant RK11_NUMDR => 8; # number of drives
|
792 |
|
|
use constant RK11_NUMBL => RK11_NUMSE * RK11_NUMHD * RK11_NUMCY;
|
793 |
|
|
use constant RK11_BLKSIZE => 512; # disk block size
|
794 |
|
|
use constant RK11_VOLSIZE => RK11_BLKSIZE * RK11_NUMBL; # disk volume size
|
795 |
|
|
|
796 |
|
|
# RK11 address offsets
|
797 |
|
|
use constant RK11_RKDS => 00;
|
798 |
|
|
use constant RK11_RKER => 02;
|
799 |
|
|
use constant RK11_RKCS => 04;
|
800 |
|
|
use constant RK11_RKWC => 06;
|
801 |
|
|
use constant RK11_RKBA => 010;
|
802 |
|
|
use constant RK11_RKDA => 012;
|
803 |
|
|
use constant RK11_RKMR => 014;
|
804 |
|
|
|
805 |
|
|
# RK11 register defs
|
806 |
|
|
|
807 |
|
|
use constant RKDS_M_ID => 0160000; # ID: drive number
|
808 |
|
|
use constant RKDS_V_ID => 13;
|
809 |
|
|
use constant RKDS_B_ID => 0007;
|
810 |
|
|
use constant RKDS_M_HDEN => BIT11; # HDEN: high density drive (rk05)
|
811 |
|
|
use constant RKDS_M_DRU => BIT10; # DRU: drive unsafe
|
812 |
|
|
use constant RKDS_M_SIN => BIT09; # SIN: seek incomplete
|
813 |
|
|
use constant RKDS_M_SOK => BIT08; # SOK: sector counter OK
|
814 |
|
|
use constant RKDS_M_DRY => BIT07; # DRY: drive ready
|
815 |
|
|
use constant RKDS_M_ADRY => BIT06; # ADRY: access ready
|
816 |
|
|
use constant RKDS_M_WPS => BIT05; # WPS: write protect
|
817 |
|
|
use constant RKDS_B_SC => 0017; # SC: sector counter
|
818 |
|
|
|
819 |
|
|
use constant RKER_M_DRE => BIT15; # DRE: drive error
|
820 |
|
|
use constant RKER_M_OVR => BIT14; # OVR: overrun
|
821 |
|
|
use constant RKER_M_WLO => BIT13; # WLO: write lock violation
|
822 |
|
|
use constant RKER_M_PGE => BIT11; # PGE: programming error
|
823 |
|
|
use constant RKER_M_NXM => BIT10; # NXM: non existent memory
|
824 |
|
|
use constant RKER_M_NXD => BIT07; # NXD: non existent drive
|
825 |
|
|
use constant RKER_M_NXC => BIT06; # NXC: non existent cylinder
|
826 |
|
|
use constant RKER_M_NXS => BIT05; # NXS: non existent sector
|
827 |
|
|
use constant RKER_M_CSE => BIT01; # CSE: check sum error
|
828 |
|
|
use constant RKER_M_WCE => BIT00; # WCE: write check error
|
829 |
|
|
|
830 |
|
|
use constant RKCS_M_MAINT => BIT12; # MAINT: maintenance mode
|
831 |
|
|
use constant RKCS_M_IBA => BIT11; # IBA: inhibit increment RKBA
|
832 |
|
|
use constant RKCS_M_FMT => BIT10; # FMT: format
|
833 |
|
|
use constant RKCS_M_RWA => BIT09; # RWA: read-write all
|
834 |
|
|
use constant RKCS_M_SSE => BIT08; # SSE: stop on soft errors
|
835 |
|
|
use constant RKCS_M_MEX => 0000060; # MEX: memory extension
|
836 |
|
|
use constant RKCS_V_MEX => 4;
|
837 |
|
|
use constant RKCS_B_MEX => 0003;
|
838 |
|
|
use constant RKCS_V_FUNC => 1; # FUNC: function
|
839 |
|
|
use constant RKCS_B_FUNC => 0007;
|
840 |
|
|
use constant RKCS_CRESET => 0;
|
841 |
|
|
use constant RKCS_WRITE => 1;
|
842 |
|
|
use constant RKCS_READ => 2;
|
843 |
|
|
use constant RKCS_WCHK => 3;
|
844 |
|
|
use constant RKCS_SEEK => 4;
|
845 |
|
|
use constant RKCS_RCHK => 5;
|
846 |
|
|
use constant RKCS_DRESET => 6;
|
847 |
|
|
use constant RKCS_WLOCK => 7;
|
848 |
|
|
use constant RKCS_M_GO => BIT00; # GO: go bit
|
849 |
|
|
|
850 |
|
|
use constant RKDA_M_DRSEL => 0160000; # DRSEL: drive number
|
851 |
|
|
use constant RKDA_V_DRSEL => 13;
|
852 |
|
|
use constant RKDA_B_DRSEL => 0007;
|
853 |
|
|
use constant RKDA_M_CYL => 0017740; # CYL: cyclinder address
|
854 |
|
|
use constant RKDA_V_CYL => 5;
|
855 |
|
|
use constant RKDA_B_CYL => 0377;
|
856 |
|
|
use constant RKDA_M_SUR => 0000020; # SUR: surface
|
857 |
|
|
use constant RKDA_V_SUR => 4;
|
858 |
|
|
use constant RKDA_B_SUR => 0001;
|
859 |
|
|
use constant RKDA_B_SC => 0017; # SC: sector address
|
860 |
|
|
|
861 |
|
|
use constant RKMR_M_RID => 0160000; # RID: drive id for RKDS RB read
|
862 |
|
|
use constant RKMR_V_RID => 13;
|
863 |
|
|
use constant RKMR_V_CRDONE => 11; # CRDONE: control reset done
|
864 |
|
|
use constant RKMR_V_SBCLR => 10; # SBCLR: clear SBUSY's with SDONE
|
865 |
|
|
use constant RKMR_V_CRESET => 9; # CRESET: initiate control reset
|
866 |
|
|
use constant RKMR_V_FDONE => 8; # FDONE: initiate function done
|
867 |
|
|
|
868 |
|
|
my @reglist_rk11 = ({name => "rkds",
|
869 |
|
|
offset => RK11_RKDS},
|
870 |
|
|
{name => "rker",
|
871 |
|
|
offset => RK11_RKER},
|
872 |
|
|
{name => "rkcs",
|
873 |
|
|
offset => RK11_RKCS},
|
874 |
|
|
{name => "rkwc",
|
875 |
|
|
offset => RK11_RKWC},
|
876 |
|
|
{name => "rkba",
|
877 |
|
|
offset => RK11_RKBA},
|
878 |
|
|
{name => "rkda",
|
879 |
|
|
offset => RK11_RKDA},
|
880 |
|
|
{name => "rkmr",
|
881 |
|
|
offset => RK11_RKMR});
|
882 |
|
|
|
883 |
|
|
my %partbl_rk11 = ( trace => { type => "hval:b" } );
|
884 |
|
|
|
885 |
|
|
# KWP general defs
|
886 |
|
|
|
887 |
|
|
my @reglist_kwp = ({name => "csr",
|
888 |
|
|
offset => 0},
|
889 |
|
|
{name => "csb",
|
890 |
|
|
offset => 2},
|
891 |
|
|
{name => "ctr",
|
892 |
|
|
offset => 4});
|
893 |
|
|
|
894 |
|
|
# KWL general defs
|
895 |
|
|
|
896 |
|
|
my @reglist_kwl = ({name => "csr",
|
897 |
|
|
offset => 0});
|
898 |
|
|
|
899 |
|
|
# IIST general defs
|
900 |
|
|
|
901 |
|
|
my @reglist_iist = ({name => "acr",
|
902 |
|
|
offset => 0},
|
903 |
|
|
{name => "adr",
|
904 |
|
|
offset => 2});
|
905 |
|
|
|
906 |
|
|
use constant BOOT_START => 02000;
|
907 |
|
|
|
908 |
|
|
my $serv11_fds_update = 1;
|
909 |
|
|
my $serv11_config_done = 0;
|
910 |
|
|
my $serv11_init_pending = 1;
|
911 |
|
|
my $serv11_rdma_chunk = 256;
|
912 |
|
|
|
913 |
|
|
my $serv11_init_anena = 0x8000; # enable attn
|
914 |
|
|
#my $serv11_init_anena = 0xC03f; # enable attn+ioto(63ms)
|
915 |
|
|
|
916 |
|
|
#
|
917 |
|
|
# %serv11_ctltbl->{dev} --> controller table; is hash of hashes
|
918 |
|
|
# -> {ctlname} controller name
|
919 |
|
|
# -> {ctltype} controller type (e.g. DL11)
|
920 |
|
|
# -> {devname} device name
|
921 |
|
|
# -> {type} device type: term, lpr, ptap, disk, tape, eth
|
922 |
|
|
# -> {units} array of unit names
|
923 |
|
|
# -> {base} controller base address
|
924 |
|
|
# -> {ibrb} controller base mapping for remote ib access
|
925 |
|
|
# -> {csroff} csr offset from base (for probing)
|
926 |
|
|
# -> {lam} lam number used by controller
|
927 |
|
|
# -> {nxbuf_min} nxbuf: minimal vector size
|
928 |
|
|
# -> {nxbuf_inc} nxbuf: vector size increment
|
929 |
|
|
# -> {nxbuf_max} nxbuf: maximal vector size
|
930 |
|
|
# -> {probehdl} address of probe handler
|
931 |
|
|
# -> {probemask} sides to be tested (set to "ir" if missing)
|
932 |
|
|
# -> {ichrhdl} address of input character handler
|
933 |
|
|
# -> {inithdl} address of controler init handler
|
934 |
|
|
# -> {usethdl} address of unit setup handler
|
935 |
|
|
# -> {attdethdl} address of attach/detach handler
|
936 |
|
|
# -> {attnhdl} address og attention handler
|
937 |
|
|
# -> {reglist} register list (array of regdsc's)
|
938 |
|
|
# -> {regtbl} register table (by name, created by ...)
|
939 |
|
|
# -> {partbl} parameter table (array of pardsc's)
|
940 |
|
|
# -> {blksize} block size (in bytes) {for disk}
|
941 |
|
|
# -> {volsize} volume size (in bytes) {for disk}
|
942 |
|
|
# -> {boot_mode} boot mode: "ptape" undef
|
943 |
|
|
# -> {boot_base} base address for boot code if not BOOT_START {for ptap}
|
944 |
|
|
# -> {boot_mode} boot mode: "ptape" undef
|
945 |
|
|
# -> {boot_entry} boot code entry point, relative to BOOT_START
|
946 |
|
|
# -> {boot_unit} offset from BOOT_START where unit number is stored
|
947 |
|
|
# -> {boot_code} array with boot loader code
|
948 |
|
|
#
|
949 |
|
|
# -> {memsize} memory size {for cpu}
|
950 |
|
|
#
|
951 |
|
|
# -> {nxbuf} nxbuf: current value
|
952 |
|
|
# -> {probe_ival} defined if cpu side probing ok
|
953 |
|
|
# -> {probe_rval} defined if rem side probing ok
|
954 |
|
|
# -> {probe_ok} true if required sides available (see probe_mask)
|
955 |
|
|
# -> {probe_text} text for "sho conf" generated during probe
|
956 |
|
|
|
957 |
|
|
my %serv11_ctltbl = (
|
958 |
|
|
CPU =>
|
959 |
|
|
{ ctlname => "CPU",
|
960 |
|
|
ctltype => "W11A",
|
961 |
|
|
type => "cpu",
|
962 |
|
|
base => CPU_PSW, # use psw to get it to top of list
|
963 |
|
|
lam => 0,
|
964 |
|
|
probehdl => \&serv11_probe_cpu,
|
965 |
|
|
probemask => "i",
|
966 |
|
|
attnhdl => \&serv11_attn_cpu,
|
967 |
|
|
reglist => [ ],
|
968 |
|
|
partbl => { }
|
969 |
|
|
},
|
970 |
|
|
|
971 |
|
|
TTA =>
|
972 |
|
|
{ ctlname => "TTA",
|
973 |
|
|
ctltype => "DL11",
|
974 |
|
|
devname => "TT",
|
975 |
|
|
type => "term",
|
976 |
|
|
units => ["TT0"],
|
977 |
|
|
base => DL11_BASE_A,
|
978 |
|
|
ibrb => DL11_BASE_A & ~(077),
|
979 |
|
|
csroff => 0,
|
980 |
|
|
lam => 1,
|
981 |
|
|
nxbuf_min => 2, # to disable nxbuf mechanism use
|
982 |
|
|
nxbuf_inc => 2, # min=1, inc=0, max=1
|
983 |
|
|
nxbuf_max => 8, # otherwise: min=2,inc=2,max=8
|
984 |
|
|
trace => 1,
|
985 |
|
|
probehdl => \&serv11_probe_gen,
|
986 |
|
|
ichrhdl => \&serv11_ichr_dl11,
|
987 |
|
|
attdethdl => \&serv11_attdet_term,
|
988 |
|
|
attnhdl => \&serv11_attn_dl11,
|
989 |
|
|
reglist => [ @reglist_dl11 ],
|
990 |
|
|
partbl => { %partbl_dl11 }
|
991 |
|
|
},
|
992 |
|
|
|
993 |
|
|
TTB =>
|
994 |
|
|
{ ctlname => "TTB",
|
995 |
|
|
ctltype => "DL11",
|
996 |
|
|
devname => "TT",
|
997 |
|
|
type => "term",
|
998 |
|
|
units => ["TT1"],
|
999 |
|
|
base => DL11_BASE_B,
|
1000 |
|
|
ibrb => DL11_BASE_B & ~(077),
|
1001 |
|
|
csroff => 0,
|
1002 |
|
|
lam => 2,
|
1003 |
|
|
nxbuf_min => 2,
|
1004 |
|
|
nxbuf_inc => 2,
|
1005 |
|
|
nxbuf_max => 8,
|
1006 |
|
|
trace => 1,
|
1007 |
|
|
probehdl => \&serv11_probe_gen,
|
1008 |
|
|
ichrhdl => \&serv11_ichr_dl11,
|
1009 |
|
|
attdethdl => \&serv11_attdet_term,
|
1010 |
|
|
attnhdl => \&serv11_attn_dl11,
|
1011 |
|
|
reglist => [ @reglist_dl11 ],
|
1012 |
|
|
partbl => { %partbl_dl11 }
|
1013 |
|
|
},
|
1014 |
|
|
|
1015 |
|
|
DZ =>
|
1016 |
|
|
{ ctlname => "DZ",
|
1017 |
|
|
ctltype => "DZ11",
|
1018 |
|
|
devname => "DZ",
|
1019 |
|
|
type => "term",
|
1020 |
|
|
units => ["DZ0","DZ1","DZ2","DZ3","DZ4","DZ5","DZ6","DZ7"],
|
1021 |
|
|
base => 0160100,
|
1022 |
|
|
ibrb => 0160100 & ~(077),
|
1023 |
|
|
csroff => 0,
|
1024 |
|
|
lam => 3,
|
1025 |
|
|
probehdl => \&serv11_probe_gen
|
1026 |
|
|
},
|
1027 |
|
|
|
1028 |
|
|
LP =>
|
1029 |
|
|
{ ctlname => "LP",
|
1030 |
|
|
ctltype => "LP11",
|
1031 |
|
|
devname => "LP",
|
1032 |
|
|
type => "lpr",
|
1033 |
|
|
units => ["LP0"],
|
1034 |
|
|
base => 0177514,
|
1035 |
|
|
ibrb => 0177514 & ~(077),
|
1036 |
|
|
csroff => 0,
|
1037 |
|
|
lam => 8,
|
1038 |
|
|
nxbuf_min => 2, # to disable nxbuf mechanism use
|
1039 |
|
|
nxbuf_inc => 2, # min=1, inc=0, max=1
|
1040 |
|
|
nxbuf_max => 8, # otherwise: min=2,inc=2,max=8
|
1041 |
|
|
trace => 1,
|
1042 |
|
|
probehdl => \&serv11_probe_gen,
|
1043 |
|
|
inithdl => \&serv11_init_gen,
|
1044 |
|
|
usethdl => \&serv11_uset_lp11,
|
1045 |
|
|
attdethdl => \&serv11_attdet_wonly,
|
1046 |
|
|
attnhdl => \&serv11_attn_lp11,
|
1047 |
|
|
reglist => [ @reglist_lp11 ],
|
1048 |
|
|
partbl => { %partbl_lp11 }
|
1049 |
|
|
},
|
1050 |
|
|
|
1051 |
|
|
PC =>
|
1052 |
|
|
{ ctlname => "PC",
|
1053 |
|
|
ctltype => "PC11",
|
1054 |
|
|
devname => "PC",
|
1055 |
|
|
type => "ptap",
|
1056 |
|
|
units => ["PTR","PTP"],
|
1057 |
|
|
base => 0177550,
|
1058 |
|
|
ibrb => 0177550 & ~(077),
|
1059 |
|
|
csroff => 0,
|
1060 |
|
|
lam => 10,
|
1061 |
|
|
nxbuf_min => 2,
|
1062 |
|
|
nxbuf_inc => 2,
|
1063 |
|
|
nxbuf_max => 8,
|
1064 |
|
|
trace => 1,
|
1065 |
|
|
probehdl => \&serv11_probe_gen,
|
1066 |
|
|
usethdl => \&serv11_uset_pc11,
|
1067 |
|
|
attdethdl => \&serv11_attdet_pc11,
|
1068 |
|
|
attnhdl => \&serv11_attn_pc11,
|
1069 |
|
|
reglist => [ @reglist_pc11 ],
|
1070 |
|
|
partbl => { %partbl_pc11 },
|
1071 |
|
|
boot_mode => "ptape",
|
1072 |
|
|
boot_base => 0017476,
|
1073 |
|
|
boot_entry=> 0017500,
|
1074 |
|
|
boot_code => [ # papertape lda loader, from dec-11-l2pc-po
|
1075 |
|
|
0000000, # C000: halt
|
1076 |
|
|
0010706, # astart: mov pc,sp
|
1077 |
|
|
0024646, # cmp -(sp),-(sp)
|
1078 |
|
|
0010705, # mov pc,r5
|
1079 |
|
|
0062705, 0000112, # add #000112,r5
|
1080 |
|
|
0005001, # clr r1
|
1081 |
|
|
0013716, 0177570, # B000: mov @#cp.dsr,(sp)
|
1082 |
|
|
0006016, # ror (sp)
|
1083 |
|
|
0103402, # bcs B001
|
1084 |
|
|
0005016, # clr (sp)
|
1085 |
|
|
0000403, # br B002
|
1086 |
|
|
0006316, # B001: asl (sp)
|
1087 |
|
|
0001001, # bne B002
|
1088 |
|
|
0010116, # mov r1,(sp)
|
1089 |
|
|
0005000, # B002: clr r0
|
1090 |
|
|
0004715, # jsr pc,(r5)
|
1091 |
|
|
0105303, # decb r3
|
1092 |
|
|
0001374, # bne B002
|
1093 |
|
|
0004715, # jsr pc,(r5)
|
1094 |
|
|
0004767, 0000074, # jsr pc,R000
|
1095 |
|
|
0010402, # mov r4,r2
|
1096 |
|
|
0162702, 0000004, # sub #000004,r2
|
1097 |
|
|
0022702, 0000002, # cmp #000002,r2
|
1098 |
|
|
0001441, # beq B007
|
1099 |
|
|
0004767, 0000054, # jsr pc,R000
|
1100 |
|
|
0061604, # add (sp),r4
|
1101 |
|
|
0010401, # mov r4,r1
|
1102 |
|
|
0004715, # B003: jsr pc,(r5)
|
1103 |
|
|
0002004, # bge B005
|
1104 |
|
|
0105700, # tstb r0
|
1105 |
|
|
0001753, # beq B002
|
1106 |
|
|
0000000, # B004: halt
|
1107 |
|
|
0000751, # br B002
|
1108 |
|
|
0110321, # B005: movb r3,(r1)+
|
1109 |
|
|
0000770, # br B003
|
1110 |
|
|
0016703, 0000152, # ldchr: mov p.prcs,r3
|
1111 |
|
|
0105213, # incb (r3)
|
1112 |
|
|
0105713, # B006: tstb (r3)
|
1113 |
|
|
0100376, # bpl B006
|
1114 |
|
|
0116303, 0000002, # movb 000002(r3),r3
|
1115 |
|
|
0060300, # add r3,r0
|
1116 |
|
|
0042703, 0177400, # bic #177400,r3
|
1117 |
|
|
0005302, # dec r2
|
1118 |
|
|
0000207, # rts pc
|
1119 |
|
|
0012667, 0000046, # R000: mov (sp)+,D000
|
1120 |
|
|
0004715, # jsr pc,(r5)
|
1121 |
|
|
0010304, # mov r3,r4
|
1122 |
|
|
0004715, # jsr pc,(r5)
|
1123 |
|
|
0000303, # swap r3
|
1124 |
|
|
0050304, # bis r3,r4
|
1125 |
|
|
0016707, 0000030, # mov D000,pc
|
1126 |
|
|
0004767, 0177752, # B007: jsr pc,R000
|
1127 |
|
|
0004715, # jsr pc,(r5)
|
1128 |
|
|
0105700, # tstb r0
|
1129 |
|
|
0001342, # bne B004
|
1130 |
|
|
0006204, # asr r4
|
1131 |
|
|
0103002, # bcc B008
|
1132 |
|
|
0000000, # halt
|
1133 |
|
|
0000700, # br B000
|
1134 |
|
|
0006304, # B008: asl r4
|
1135 |
|
|
0061604, # add (sp),r4
|
1136 |
|
|
0000114, # jmp (r4)
|
1137 |
|
|
0000000, # D000: .word 000000
|
1138 |
|
|
0012767, 0000352, 0000020, # L000: mov #000352,B009+2
|
1139 |
|
|
0012767, 0000765, 0000034, # mov #000765,D001
|
1140 |
|
|
0000167, 0177532, # jmp C000
|
1141 |
|
|
0016701, 0000026, # bstart: mov p.prcs,r1
|
1142 |
|
|
0012702, 0000352, # B009: mov #000352,r2
|
1143 |
|
|
0005211, # inc (r1)
|
1144 |
|
|
0105711, # B010: tstb (r1)
|
1145 |
|
|
0100376, # bpl B010
|
1146 |
|
|
0116162, 0000002, 0157400, # movb 000002(r1),157400(r2)
|
1147 |
|
|
0005267, 0177756, # inc B009+2
|
1148 |
|
|
0000765, # D001: br B009
|
1149 |
|
|
0177550 # p.prcs: .word 177550
|
1150 |
|
|
]
|
1151 |
|
|
},
|
1152 |
|
|
|
1153 |
|
|
RK =>
|
1154 |
|
|
{ ctlname => "RK",
|
1155 |
|
|
ctltype => "RK11/RK05",
|
1156 |
|
|
devname => "RK",
|
1157 |
|
|
type => "disk",
|
1158 |
|
|
units => ["RK0","RK1","RK2","RK3","RK4","RK5","RK6","RK7"],
|
1159 |
|
|
base => RK11_BASE,
|
1160 |
|
|
ibrb => RK11_BASE & ~(077),
|
1161 |
|
|
csroff => 4,
|
1162 |
|
|
lam => 4,
|
1163 |
|
|
trace => 1,
|
1164 |
|
|
probehdl => \&serv11_probe_gen,
|
1165 |
|
|
inithdl => \&serv11_init_gen,
|
1166 |
|
|
usethdl => \&serv11_uset_rk11,
|
1167 |
|
|
attdethdl => \&serv11_attdet_disk,
|
1168 |
|
|
attnhdl => \&serv11_attn_rk11,
|
1169 |
|
|
reglist => [ @reglist_rk11 ],
|
1170 |
|
|
partbl => { %partbl_rk11 },
|
1171 |
|
|
blksize => RK11_BLKSIZE,
|
1172 |
|
|
volsize => RK11_VOLSIZE,
|
1173 |
|
|
boot_entry=> BOOT_START + 002,
|
1174 |
|
|
boot_unit => BOOT_START + 010,
|
1175 |
|
|
boot_code => [ # rk05 boot loader - from simh pdp11_rk.c
|
1176 |
|
|
0042113, # "KD"
|
1177 |
|
|
0012706, BOOT_START, # MOV #boot_start, SP
|
1178 |
|
|
0012700, 0000000, # MOV #unit, R0 ; unit number
|
1179 |
|
|
0010003, # MOV R0, R3
|
1180 |
|
|
0000303, # SWAB R3
|
1181 |
|
|
0006303, # ASL R3
|
1182 |
|
|
0006303, # ASL R3
|
1183 |
|
|
0006303, # ASL R3
|
1184 |
|
|
0006303, # ASL R3
|
1185 |
|
|
0006303, # ASL R3
|
1186 |
|
|
0012701, 0177412, # MOV #RKDA, R1 ; rkda
|
1187 |
|
|
0010311, # MOV R3, (R1) ; load da
|
1188 |
|
|
0005041, # CLR -(R1) ; clear ba
|
1189 |
|
|
0012741, 0177000, # MOV #-256.*2, -(R1) ; load wc
|
1190 |
|
|
0012741, 0000005, # MOV #READ+GO, -(R1) ; read & go
|
1191 |
|
|
0005002, # CLR R2
|
1192 |
|
|
0005003, # CLR R3
|
1193 |
|
|
0012704, BOOT_START+020, # MOV #START+20, R4
|
1194 |
|
|
0005005, # CLR R5
|
1195 |
|
|
0105711, # TSTB (R1)
|
1196 |
|
|
0100376, # BPL .-2
|
1197 |
|
|
0105011, # CLRB (R1)
|
1198 |
|
|
0005007 # CLR PC (5007)
|
1199 |
|
|
]
|
1200 |
|
|
},
|
1201 |
|
|
|
1202 |
|
|
RL =>
|
1203 |
|
|
{ ctlname => "RL",
|
1204 |
|
|
ctltype => "RL11/RL02",
|
1205 |
|
|
devname => "RL",
|
1206 |
|
|
type => "disk",
|
1207 |
|
|
units => ["RL0","RL1","RL2","RL3"],
|
1208 |
|
|
base => 0174400,
|
1209 |
|
|
ibrb => 0174400 & ~(077),
|
1210 |
|
|
csroff => 0, # ???CHECK-ME???
|
1211 |
|
|
lam => 5,
|
1212 |
|
|
probehdl => \&serv11_probe_gen,
|
1213 |
|
|
boot_entry=> BOOT_START + 002,
|
1214 |
|
|
boot_unit => BOOT_START + 010,
|
1215 |
|
|
boot_code => [ # rl02 boot loader - from simh pdp11_rl.c
|
1216 |
|
|
0042114, # "LD"
|
1217 |
|
|
0012706, BOOT_START, # MOV #boot_start, SP
|
1218 |
|
|
0012700, 0000000, # MOV #unit, R0
|
1219 |
|
|
0010003, # MOV R0, R3
|
1220 |
|
|
0000303, # SWAB R3
|
1221 |
|
|
0012701, 0174400, # MOV #RLCS, R1 ; csr
|
1222 |
|
|
0012761, 0000013, 0000004, # MOV #13, 4(R1) ; clr err
|
1223 |
|
|
0052703, 0000004, # BIS #4, R3 ; unit+gstat
|
1224 |
|
|
0010311, # MOV R3, (R1) ; issue cmd
|
1225 |
|
|
0105711, # TSTB (R1) ; wait
|
1226 |
|
|
0100376, # BPL .-2
|
1227 |
|
|
0105003, # CLRB R3
|
1228 |
|
|
0052703, 0000010, # BIS #10, R3 ; unit+rdhdr
|
1229 |
|
|
0010311, # MOV R3, (R1) ; issue cmd
|
1230 |
|
|
0105711, # TSTB (R1) ; wait
|
1231 |
|
|
0100376, # BPL .-2
|
1232 |
|
|
0016102, 0000006, # MOV 6(R1), R2 ; get hdr
|
1233 |
|
|
0042702, 0000077, # BIC #77, R2 ; clr sector
|
1234 |
|
|
0005202, # INC R2 ; magic bit
|
1235 |
|
|
0010261, 0000004, # MOV R2, 4(R1) ; seek to 0
|
1236 |
|
|
0105003, # CLRB R3
|
1237 |
|
|
0052703, 0000006, # BIS #6, R3 ; unit+seek
|
1238 |
|
|
0010311, # MOV R3, (R1) ; issue cmd
|
1239 |
|
|
0105711, # TSTB (R1) ; wait
|
1240 |
|
|
0100376, # BPL .-2
|
1241 |
|
|
0005061, 0000002, # CLR 2(R1) ; clr ba
|
1242 |
|
|
0005061, 0000004, # CLR 4(R1) ; clr da
|
1243 |
|
|
0012761, 0177000, 0000006, # MOV #-512., 6(R1) ; set wc
|
1244 |
|
|
0105003, # CLRB R3
|
1245 |
|
|
0052703, 0000014, # BIS #14, R3 ; unit+read
|
1246 |
|
|
0010311, # MOV R3, (R1) ; issue cmd
|
1247 |
|
|
0105711, # TSTB (R1) ; wait
|
1248 |
|
|
0100376, # BPL .-2
|
1249 |
|
|
0042711, 0000377, # BIC #377, (R1)
|
1250 |
|
|
0005002, # CLR R2
|
1251 |
|
|
0005003, # CLR R3
|
1252 |
|
|
0012704, BOOT_START+020, # MOV #START+20, R4
|
1253 |
|
|
0005005, # CLR R5
|
1254 |
|
|
0005007 # CLR PC
|
1255 |
|
|
]
|
1256 |
|
|
},
|
1257 |
|
|
|
1258 |
|
|
|
1259 |
|
|
RP =>
|
1260 |
|
|
{ ctlname => "RP",
|
1261 |
|
|
ctltype => "RH70/RP06",
|
1262 |
|
|
devname => "RP",
|
1263 |
|
|
type => "disk",
|
1264 |
|
|
units => ["RP0","RP1","RP2","RP3"],
|
1265 |
|
|
base => 0176700,
|
1266 |
|
|
ibrb => 0176700 & ~(077),
|
1267 |
|
|
csroff => 0, # ???CHECK-ME???
|
1268 |
|
|
lam => 6,
|
1269 |
|
|
probehdl => \&serv11_probe_gen,
|
1270 |
|
|
boot_entry=> BOOT_START + 002,
|
1271 |
|
|
boot_unit => BOOT_START + 010,
|
1272 |
|
|
boot_code => [ # rp/rm boot loader - from simh pdp11_rp.c
|
1273 |
|
|
0042102, # "BD"
|
1274 |
|
|
0012706, BOOT_START, # mov #boot_start, sp
|
1275 |
|
|
0012700, 0000000, # mov #unit, r0
|
1276 |
|
|
0012701, 0176700, # mov #RPCS1, r1
|
1277 |
|
|
0012761, 0000040, 0000010, # mov #CS2_CLR, 10(r1) ; reset
|
1278 |
|
|
0010061, 0000010, # mov r0, 10(r1) ; set unit
|
1279 |
|
|
0012711, 0000021, # mov #RIP+GO, (r1) ; pack ack
|
1280 |
|
|
0012761, 0010000, 0000032, # mov #FMT16B, 32(r1) ; 16b mode
|
1281 |
|
|
0012761, 0177000, 0000002, # mov #-512., 2(r1) ; set wc
|
1282 |
|
|
0005061, 0000004, # clr 4(r1) ; clr ba
|
1283 |
|
|
0005061, 0000006, # clr 6(r1) ; clr da
|
1284 |
|
|
0005061, 0000034, # clr 34(r1) ; clr cyl
|
1285 |
|
|
0012711, 0000071, # mov #READ+GO, (r1) ; read
|
1286 |
|
|
0105711, # tstb (r1) ; wait
|
1287 |
|
|
0100376, # bpl .-2
|
1288 |
|
|
0005002, # clr R2
|
1289 |
|
|
0005003, # clr R3
|
1290 |
|
|
0012704, BOOT_START+020, # mov #start+020, r4
|
1291 |
|
|
0005005, # clr R5
|
1292 |
|
|
0105011, # clrb (r1)
|
1293 |
|
|
0005007 # clr PC
|
1294 |
|
|
]
|
1295 |
|
|
},
|
1296 |
|
|
|
1297 |
|
|
TM =>
|
1298 |
|
|
{ ctlname => "TM",
|
1299 |
|
|
ctltype => "TM11",
|
1300 |
|
|
devname => "TM",
|
1301 |
|
|
type => "tape",
|
1302 |
|
|
units => ["TM0","TM1","TM2","TM3","TM4","TM5","TM6","TM7"],
|
1303 |
|
|
base => 0172520,
|
1304 |
|
|
ibrb => 0172520 & ~(077),
|
1305 |
|
|
csroff => 2,
|
1306 |
|
|
lam => 7,
|
1307 |
|
|
probehdl => \&serv11_probe_gen,
|
1308 |
|
|
boot_entry=> BOOT_START + 002,
|
1309 |
|
|
boot_unit => BOOT_START + 010,
|
1310 |
|
|
boot_code => [ # tm11 boot2 (skip 1st record) - from simh pdp11_tm.c
|
1311 |
|
|
0046524, # boot_start: "TM"
|
1312 |
|
|
0012706, BOOT_START, # mov #boot_start, sp
|
1313 |
|
|
0012700, 0000000, # mov #unit_num, r0
|
1314 |
|
|
0012701, 0172526, # mov #172526, r1 ; mtcma
|
1315 |
|
|
0005011, # clr (r1)
|
1316 |
|
|
0012741, 0177777, # mov #-1, -(r1) ; mtbrc
|
1317 |
|
|
0010002, # mov r0,r2
|
1318 |
|
|
0000302, # swab r2
|
1319 |
|
|
0062702, 0060011, # add #60011, r2
|
1320 |
|
|
0010241, # mov r2, -(r1) ; space + go
|
1321 |
|
|
0105711, # tstb (r1) ; mtc
|
1322 |
|
|
0100376, # bpl .-2
|
1323 |
|
|
0010002, # mov r0,r2
|
1324 |
|
|
0000302, # swab r2
|
1325 |
|
|
0062702, 0060003, # add #60003, r2
|
1326 |
|
|
0010211, # mov r2, (r1) ; read + go
|
1327 |
|
|
0105711, # tstb (r1) ; mtc
|
1328 |
|
|
0100376, # bpl .-2
|
1329 |
|
|
0005002, # clr r2
|
1330 |
|
|
0005003, # clr r3
|
1331 |
|
|
0012704, BOOT_START+020, # mov #boot_start+20, r4
|
1332 |
|
|
0005005, # clr r5
|
1333 |
|
|
0005007 # clr r7
|
1334 |
|
|
]
|
1335 |
|
|
},
|
1336 |
|
|
|
1337 |
|
|
XU =>
|
1338 |
|
|
{ ctlname => "XU",
|
1339 |
|
|
ctltype => "DENUA",
|
1340 |
|
|
devname => "XU",
|
1341 |
|
|
type => "eth",
|
1342 |
|
|
units => ["XU0"],
|
1343 |
|
|
base => 0174510,
|
1344 |
|
|
ibrb => 0174510 & ~(077),
|
1345 |
|
|
csroff => 0,
|
1346 |
|
|
lam => 9,
|
1347 |
|
|
probehdl => \&serv11_probe_gen
|
1348 |
|
|
},
|
1349 |
|
|
|
1350 |
|
|
KWP =>
|
1351 |
|
|
{ ctlname => "KWP",
|
1352 |
|
|
ctltype => "KW11-P",
|
1353 |
|
|
devname => "--",
|
1354 |
|
|
type => "misc",
|
1355 |
|
|
base => 0172540,
|
1356 |
|
|
probehdl => \&serv11_probe_gen,
|
1357 |
|
|
probemask => "i",
|
1358 |
|
|
reglist => [ @reglist_kwp ]
|
1359 |
|
|
},
|
1360 |
|
|
|
1361 |
|
|
KWL =>
|
1362 |
|
|
{ ctlname => "KWL",
|
1363 |
|
|
ctltype => "KW11-L",
|
1364 |
|
|
devname => "--",
|
1365 |
|
|
type => "misc",
|
1366 |
|
|
base => 0177546,
|
1367 |
|
|
probehdl => \&serv11_probe_gen,
|
1368 |
|
|
probemask => "i",
|
1369 |
|
|
reglist => [ @reglist_kwl ]
|
1370 |
|
|
},
|
1371 |
|
|
|
1372 |
|
|
IIS =>
|
1373 |
|
|
{ ctlname => "IIS",
|
1374 |
|
|
ctltype => "IIST",
|
1375 |
|
|
devname => "--",
|
1376 |
|
|
type => "misc",
|
1377 |
|
|
base => 0177500,
|
1378 |
|
|
probehdl => \&serv11_probe_gen,
|
1379 |
|
|
probemask => "i",
|
1380 |
|
|
reglist => [ @reglist_iist ]
|
1381 |
|
|
}
|
1382 |
|
|
|
1383 |
|
|
);
|
1384 |
|
|
|
1385 |
|
|
#
|
1386 |
|
|
# %serv11_unittbl->{unit} --> unit table; is hash of hashes
|
1387 |
|
|
# -> {unitname} unit name
|
1388 |
|
|
# -> {ctlname} controller name
|
1389 |
|
|
# -> {ctlunit} unit number of controller {ctlname}
|
1390 |
|
|
# -> {devunit} device number for device $ucb->{ctlname}->{devname}
|
1391 |
|
|
# -> {rcvque} receive queue {for term}
|
1392 |
|
|
# -> {sndque} send queue {for term}
|
1393 |
|
|
# -> {rcv7bit} use only 7 bits in receive {for term}
|
1394 |
|
|
# -> {logfile} name of logfile
|
1395 |
|
|
# -> {logfh} file handle for logfile
|
1396 |
|
|
#
|
1397 |
|
|
|
1398 |
|
|
my %serv11_unittbl = (
|
1399 |
|
|
TT0 => { unitname => "TT0",
|
1400 |
|
|
ctlname => "TTA",
|
1401 |
|
|
ctlunit => 0,
|
1402 |
|
|
devunit => 0,
|
1403 |
|
|
rcvque => [],
|
1404 |
|
|
sndque => [],
|
1405 |
|
|
rcv7bit => 1,
|
1406 |
|
|
logfile => "pi_tt0.log",
|
1407 |
|
|
logfh => undef
|
1408 |
|
|
},
|
1409 |
|
|
TT1 => { unitname => "TT1",
|
1410 |
|
|
ctlname => "TTB",
|
1411 |
|
|
ctlunit => 0,
|
1412 |
|
|
devunit => 1,
|
1413 |
|
|
rcvque => [],
|
1414 |
|
|
sndque => [],
|
1415 |
|
|
rcv7bit => 1,
|
1416 |
|
|
logfile => "pi_tt1.log",
|
1417 |
|
|
logfh => undef
|
1418 |
|
|
},
|
1419 |
|
|
|
1420 |
|
|
DZ0 => { unitname => "DZ0",
|
1421 |
|
|
ctlname => "DZ",
|
1422 |
|
|
ctlunit => 0,
|
1423 |
|
|
devunit => 0,
|
1424 |
|
|
rcvque => [],
|
1425 |
|
|
sndque => []
|
1426 |
|
|
},
|
1427 |
|
|
DZ1 => { unitname => "DZ1",
|
1428 |
|
|
ctlname => "DZ",
|
1429 |
|
|
ctlunit => 1,
|
1430 |
|
|
devunit => 1,
|
1431 |
|
|
rcvque => [],
|
1432 |
|
|
sndque => []
|
1433 |
|
|
},
|
1434 |
|
|
DZ2 => { unitname => "DZ2",
|
1435 |
|
|
ctlname => "DZ",
|
1436 |
|
|
ctlunit => 2,
|
1437 |
|
|
devunit => 2,
|
1438 |
|
|
rcvque => [],
|
1439 |
|
|
sndque => []
|
1440 |
|
|
},
|
1441 |
|
|
DZ3 => { unitname => "DZ3",
|
1442 |
|
|
ctlname => "DZ",
|
1443 |
|
|
ctlunit => 3,
|
1444 |
|
|
devunit => 3,
|
1445 |
|
|
rcvque => [],
|
1446 |
|
|
sndque => []
|
1447 |
|
|
},
|
1448 |
|
|
DZ4 => { unitname => "DZ4",
|
1449 |
|
|
ctlname => "DZ",
|
1450 |
|
|
ctlunit => 4,
|
1451 |
|
|
devunit => 4,
|
1452 |
|
|
rcvque => [],
|
1453 |
|
|
sndque => []
|
1454 |
|
|
},
|
1455 |
|
|
DZ5 => { unitname => "DZ5",
|
1456 |
|
|
ctlname => "DZ",
|
1457 |
|
|
ctlunit => 5,
|
1458 |
|
|
devunit => 5,
|
1459 |
|
|
rcvque => [],
|
1460 |
|
|
sndque => []
|
1461 |
|
|
},
|
1462 |
|
|
DZ6 => { unitname => "DZ6",
|
1463 |
|
|
ctlname => "DZ",
|
1464 |
|
|
ctlunit => 6,
|
1465 |
|
|
devunit => 6,
|
1466 |
|
|
rcvque => [],
|
1467 |
|
|
sndque => []
|
1468 |
|
|
},
|
1469 |
|
|
DZ7 => { unitname => "DZ7",
|
1470 |
|
|
ctlname => "DZ",
|
1471 |
|
|
ctlunit => 7,
|
1472 |
|
|
devunit => 7,
|
1473 |
|
|
rcvque => [],
|
1474 |
|
|
sndque => []
|
1475 |
|
|
},
|
1476 |
|
|
|
1477 |
|
|
LP0 => { unitname => "LP0",
|
1478 |
|
|
ctlname => "LP",
|
1479 |
|
|
ctlunit => 0,
|
1480 |
|
|
devunit => 0,
|
1481 |
|
|
logfile => "pi_lp0.log",
|
1482 |
|
|
logfh => undef
|
1483 |
|
|
},
|
1484 |
|
|
|
1485 |
|
|
PTR => { unitname => "PTR",
|
1486 |
|
|
ctlname => "PC",
|
1487 |
|
|
ctlunit => 0,
|
1488 |
|
|
devunit => 0
|
1489 |
|
|
},
|
1490 |
|
|
|
1491 |
|
|
PTP => { unitname => "PTP",
|
1492 |
|
|
ctlname => "PC",
|
1493 |
|
|
ctlunit => 1,
|
1494 |
|
|
devunit => 1
|
1495 |
|
|
},
|
1496 |
|
|
|
1497 |
|
|
RK0 => { unitname => "RK0",
|
1498 |
|
|
ctlname => "RK",
|
1499 |
|
|
ctlunit => 0,
|
1500 |
|
|
devunit => 0
|
1501 |
|
|
},
|
1502 |
|
|
RK1 => { unitname => "RK1",
|
1503 |
|
|
ctlname => "RK",
|
1504 |
|
|
ctlunit => 1,
|
1505 |
|
|
devunit => 1
|
1506 |
|
|
},
|
1507 |
|
|
RK2 => { unitname => "RK2",
|
1508 |
|
|
ctlname => "RK",
|
1509 |
|
|
ctlunit => 2,
|
1510 |
|
|
devunit => 2
|
1511 |
|
|
},
|
1512 |
|
|
RK3 => { unitname => "RK3",
|
1513 |
|
|
ctlname => "RK",
|
1514 |
|
|
ctlunit => 3,
|
1515 |
|
|
devunit => 3
|
1516 |
|
|
},
|
1517 |
|
|
RK4 => { unitname => "RK4",
|
1518 |
|
|
ctlname => "RK",
|
1519 |
|
|
ctlunit => 4,
|
1520 |
|
|
devunit => 4
|
1521 |
|
|
},
|
1522 |
|
|
RK5 => { unitname => "RK5",
|
1523 |
|
|
ctlname => "RK",
|
1524 |
|
|
ctlunit => 5,
|
1525 |
|
|
devunit => 5
|
1526 |
|
|
},
|
1527 |
|
|
RK6 => { unitname => "RK6",
|
1528 |
|
|
ctlname => "RK",
|
1529 |
|
|
ctlunit => 6,
|
1530 |
|
|
devunit => 6
|
1531 |
|
|
},
|
1532 |
|
|
RK7 => { unitname => "RK7",
|
1533 |
|
|
ctlname => "RK",
|
1534 |
|
|
ctlunit => 7,
|
1535 |
|
|
devunit => 7
|
1536 |
|
|
},
|
1537 |
|
|
|
1538 |
|
|
RL0 => { unitname => "RL0",
|
1539 |
|
|
ctlname => "RL",
|
1540 |
|
|
ctlunit => 0,
|
1541 |
|
|
devunit => 0
|
1542 |
|
|
},
|
1543 |
|
|
RL1 => { unitname => "RL1",
|
1544 |
|
|
ctlname => "RL",
|
1545 |
|
|
ctlunit => 1,
|
1546 |
|
|
devunit => 1
|
1547 |
|
|
},
|
1548 |
|
|
RL2 => { unitname => "RL2",
|
1549 |
|
|
ctlname => "RL",
|
1550 |
|
|
ctlunit => 2,
|
1551 |
|
|
devunit => 2
|
1552 |
|
|
},
|
1553 |
|
|
RL3 => { unitname => "RL3",
|
1554 |
|
|
ctlname => "RL",
|
1555 |
|
|
ctlunit => 3,
|
1556 |
|
|
devunit => 3
|
1557 |
|
|
},
|
1558 |
|
|
|
1559 |
|
|
RP0 => { unitname => "RP0",
|
1560 |
|
|
ctlname => "RP",
|
1561 |
|
|
ctlunit => 0,
|
1562 |
|
|
devunit => 0
|
1563 |
|
|
},
|
1564 |
|
|
RP1 => { unitname => "RP1",
|
1565 |
|
|
ctlname => "RP",
|
1566 |
|
|
ctlunit => 1,
|
1567 |
|
|
devunit => 1
|
1568 |
|
|
},
|
1569 |
|
|
RP2 => { unitname => "RP2",
|
1570 |
|
|
ctlname => "RP",
|
1571 |
|
|
ctlunit => 2,
|
1572 |
|
|
devunit => 2
|
1573 |
|
|
},
|
1574 |
|
|
RP3 => { unitname => "RP3",
|
1575 |
|
|
ctlname => "RP",
|
1576 |
|
|
ctlunit => 3,
|
1577 |
|
|
devunit => 3
|
1578 |
|
|
},
|
1579 |
|
|
|
1580 |
|
|
TM0 => { unitname => "TM0",
|
1581 |
|
|
ctlname => "TM",
|
1582 |
|
|
ctlunit => 0,
|
1583 |
|
|
devunit => 0
|
1584 |
|
|
},
|
1585 |
|
|
TM1 => { unitname => "TM1",
|
1586 |
|
|
ctlname => "TM",
|
1587 |
|
|
ctlunit => 1,
|
1588 |
|
|
devunit => 1
|
1589 |
|
|
},
|
1590 |
|
|
TM2 => { unitname => "TM2",
|
1591 |
|
|
ctlname => "TM",
|
1592 |
|
|
ctlunit => 2,
|
1593 |
|
|
devunit => 2
|
1594 |
|
|
},
|
1595 |
|
|
TM3 => { unitname => "TM3",
|
1596 |
|
|
ctlname => "TM",
|
1597 |
|
|
ctlunit => 3,
|
1598 |
|
|
devunit => 3
|
1599 |
|
|
},
|
1600 |
|
|
TM4 => { unitname => "TM4",
|
1601 |
|
|
ctlname => "TM",
|
1602 |
|
|
ctlunit => 4,
|
1603 |
|
|
devunit => 4
|
1604 |
|
|
},
|
1605 |
|
|
TM5 => { unitname => "TM5",
|
1606 |
|
|
ctlname => "TM",
|
1607 |
|
|
ctlunit => 5,
|
1608 |
|
|
devunit => 5
|
1609 |
|
|
},
|
1610 |
|
|
TM6 => { unitname => "TM6",
|
1611 |
|
|
ctlname => "TM",
|
1612 |
|
|
ctlunit => 6,
|
1613 |
|
|
devunit => 6
|
1614 |
|
|
},
|
1615 |
|
|
TM7 => { unitname => "TM7",
|
1616 |
|
|
ctlname => "TM",
|
1617 |
|
|
ctlunit => 7,
|
1618 |
|
|
devunit => 7
|
1619 |
|
|
},
|
1620 |
|
|
|
1621 |
|
|
XU0 => { unitname => "XU0",
|
1622 |
|
|
ctlname => "XU",
|
1623 |
|
|
ctlunit => 0,
|
1624 |
|
|
devunit => 0
|
1625 |
|
|
}
|
1626 |
|
|
|
1627 |
|
|
);
|
1628 |
|
|
|
1629 |
|
|
my @serv11_attntbl;
|
1630 |
|
|
|
1631 |
|
|
my $serv11_active = 0;
|
1632 |
|
|
my $serv11_attn_mask = 0;
|
1633 |
|
|
my $serv11_attn_seen = 0;
|
1634 |
|
|
|
1635 |
|
|
my @serv11_icbque = ();
|
1636 |
|
|
|
1637 |
|
|
my $only_argv = 0;
|
1638 |
|
|
$only_argv = 1 if scalar(@ARGV) > 0;
|
1639 |
|
|
$only_argv = 0 if exists $opts{int};
|
1640 |
|
|
|
1641 |
|
|
#
|
1642 |
|
|
# -- Main program starts here ------------------------------------------------
|
1643 |
|
|
#
|
1644 |
|
|
|
1645 |
|
|
autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
|
1646 |
|
|
autoflush STDOUT 1 if (-t STDOUT); # autoflush if output into term
|
1647 |
|
|
|
1648 |
|
|
if (exists $opts{help}) {
|
1649 |
|
|
print_help();
|
1650 |
|
|
exit 0;
|
1651 |
|
|
}
|
1652 |
|
|
|
1653 |
|
|
$SIG{INT} = 'hdl_sigint'; # install ^C (SIGINT) handler
|
1654 |
|
|
|
1655 |
|
|
if (exists $opts{log} && $opts{log} ne "") {
|
1656 |
|
|
my $fh = new FileHandle;
|
1657 |
|
|
my $filename = $opts{log};
|
1658 |
|
|
$fh->open(">$filename") or die "couldn't open log file";
|
1659 |
|
|
$fh_log = $fh;
|
1660 |
|
|
autoflush $fh_log if (-t $fh);
|
1661 |
|
|
printf $fh_log "==== opened log file on %s\n", get_timestamp();
|
1662 |
|
|
}
|
1663 |
|
|
|
1664 |
|
|
$raw_timeout = $opts{timeout} if exists $opts{timeout};
|
1665 |
|
|
$cmax = $opts{cmax} if exists $opts{cmax};
|
1666 |
|
|
|
1667 |
|
|
if (exists $opts{run}) {
|
1668 |
|
|
if (not defined ($kpid=fork())) {
|
1669 |
|
|
die "cannot fork: $!";
|
1670 |
|
|
} elsif ($kpid == 0) { # in child
|
1671 |
|
|
exec "/bin/sh", "-c", $opts{run};
|
1672 |
|
|
die "failed to exec /bin/sh -c $opts{run}: $!";
|
1673 |
|
|
} else { # in parent
|
1674 |
|
|
}
|
1675 |
|
|
}
|
1676 |
|
|
|
1677 |
|
|
fifo_open($opts{fifo}) if (exists $opts{fifo});
|
1678 |
|
|
$time0 = get_time(); # do T0 after fifo open
|
1679 |
|
|
term_open($opts{term}) if (exists $opts{term});
|
1680 |
|
|
|
1681 |
|
|
while(1) {
|
1682 |
|
|
my $cmd = get_command();
|
1683 |
|
|
if (defined $cmd) {
|
1684 |
|
|
do_command($cmd);
|
1685 |
|
|
} else {
|
1686 |
|
|
do_command(".mode nomode");
|
1687 |
|
|
last;
|
1688 |
|
|
}
|
1689 |
|
|
}
|
1690 |
|
|
|
1691 |
|
|
if ($curchan) {
|
1692 |
|
|
&{$chan_tab{$curchan}{write}}(); # flush write queue before close
|
1693 |
|
|
&{$chan_tab{$curchan}{close}}();
|
1694 |
|
|
}
|
1695 |
|
|
|
1696 |
|
|
if (exists $opts{run}) {
|
1697 |
|
|
waitpid($kpid, 0);
|
1698 |
|
|
print "pi_rri($curmode)-I: exit status: $?\n" if $?;
|
1699 |
|
|
}
|
1700 |
|
|
0;
|
1701 |
|
|
|
1702 |
|
|
#-------------------------------------------------------------------------------
|
1703 |
|
|
|
1704 |
|
|
sub init_regtbl { # initialize regtbl from reglist
|
1705 |
|
|
foreach my $ctlname (sort keys %serv11_ctltbl) {
|
1706 |
|
|
my $ctl = $serv11_ctltbl{$ctlname};
|
1707 |
|
|
next unless defined $ctl->{reglist};
|
1708 |
|
|
|
1709 |
|
|
$ctl->{regtbl} = {};
|
1710 |
|
|
my $nregs = scalar (@{$ctl->{reglist}});
|
1711 |
|
|
|
1712 |
|
|
for (my $i = 0; $i<$nregs; $i++) {
|
1713 |
|
|
my $name = $ctl->{reglist}->[$i]->{name};
|
1714 |
|
|
$ctl->{regtbl}->{$name} = $i;
|
1715 |
|
|
$ctl->{reglist}->[$i]->{rank} = $i;
|
1716 |
|
|
##print "+++ 1a $ctl->{ctlname} $name $i\n";
|
1717 |
|
|
}
|
1718 |
|
|
}
|
1719 |
|
|
}
|
1720 |
|
|
|
1721 |
|
|
#-------------------------------------------------------------------------------
|
1722 |
|
|
|
1723 |
|
|
sub get_command {
|
1724 |
|
|
my $cmd;
|
1725 |
|
|
while (1) {
|
1726 |
|
|
|
1727 |
|
|
$cmd = read_command;
|
1728 |
|
|
return $cmd if (not defined $cmd); # quit if EOF
|
1729 |
|
|
|
1730 |
|
|
print "$cmd\n" if exists $opts{trace};
|
1731 |
|
|
|
1732 |
|
|
if ($cmd =~ m/^C/) { # ignore, but print "C ..." lines
|
1733 |
|
|
&{$mode_tab{$curmode}{flush}}("comm");
|
1734 |
|
|
print "$cmd\n" unless exists $opts{trace};
|
1735 |
|
|
next;
|
1736 |
|
|
}
|
1737 |
|
|
|
1738 |
|
|
$cmd =~ s{^\s*}{}; # remove leading blanks
|
1739 |
|
|
|
1740 |
|
|
next if $cmd =~ m/^#/; # ignore "# ...." lines
|
1741 |
|
|
next if $cmd =~ m/^;/; # ignore "; ...." lines
|
1742 |
|
|
|
1743 |
|
|
$cmd =~ s{--.*}{}; # remove comments after --
|
1744 |
|
|
$cmd =~ s{\s*$}{}; # remove trailing blanks
|
1745 |
|
|
next if $cmd eq ""; # ignore empty lines
|
1746 |
|
|
|
1747 |
|
|
return $cmd;
|
1748 |
|
|
}
|
1749 |
|
|
}
|
1750 |
|
|
|
1751 |
|
|
#-------------------------------------------------------------------------------
|
1752 |
|
|
|
1753 |
|
|
sub do_command {
|
1754 |
|
|
my ($cmd) = @_;
|
1755 |
|
|
|
1756 |
|
|
if ($cmd =~ /^\.mode\s*(\w*)/) { # .mode command
|
1757 |
|
|
if (exists $mode_tab{$1}) {
|
1758 |
|
|
&{$mode_tab{$curmode}{flush}}("mode");
|
1759 |
|
|
&{$mode_tab{$curmode}{close}}();
|
1760 |
|
|
print "pi_rri($curmode)-I: closed mode\n" unless $curmode eq "nomode";
|
1761 |
|
|
$curmode = $1;
|
1762 |
|
|
$curcmd = $mode_tab{$curmode}{cmd};
|
1763 |
|
|
print "pi_rri($curmode)-I: open mode\n" unless $curmode eq "nomode";
|
1764 |
|
|
&{$mode_tab{$curmode}{open}}();
|
1765 |
|
|
|
1766 |
|
|
} else {
|
1767 |
|
|
printf "pi_rri($curmode)-E: mode '%s' doesn't exist\n", $1;
|
1768 |
|
|
printf "pi_rri($curmode)-E: use %s\n", join ",", (sort keys %mode_tab);
|
1769 |
|
|
}
|
1770 |
|
|
|
1771 |
|
|
} else { # any other command
|
1772 |
|
|
$sigint_count = 0; # clear pending ^C's
|
1773 |
|
|
&$curcmd($cmd);
|
1774 |
|
|
&{$mode_tab{$curmode}{flush}}("line") if $cmd_inter;
|
1775 |
|
|
}
|
1776 |
|
|
}
|
1777 |
|
|
|
1778 |
|
|
#-------------------------------------------------------------------------------
|
1779 |
|
|
|
1780 |
|
|
sub read_command {
|
1781 |
|
|
my $cmd;
|
1782 |
|
|
|
1783 |
|
|
$cmd_inter = 0;
|
1784 |
|
|
|
1785 |
|
|
while (1) {
|
1786 |
|
|
|
1787 |
|
|
# read command line
|
1788 |
|
|
|
1789 |
|
|
if (scalar(@cmdfh)==0 && scalar(@ARGV)>0) {
|
1790 |
|
|
$cmd = shift @ARGV;
|
1791 |
|
|
} else {
|
1792 |
|
|
if (scalar(@cmdfh)) {
|
1793 |
|
|
my $fh = $cmdfh[$#cmdfh];
|
1794 |
|
|
$cmd = <$fh>;
|
1795 |
|
|
chomp $cmd if defined $cmd;
|
1796 |
|
|
if (defined $cmd && $cmd =~ /\\$/) { # continuation line ?
|
1797 |
|
|
$cmd = $`;
|
1798 |
|
|
my $cline = <$fh>;
|
1799 |
|
|
chomp $cline;
|
1800 |
|
|
$cmd .= $cline if defined $cline;
|
1801 |
|
|
}
|
1802 |
|
|
unless (defined $cmd) {
|
1803 |
|
|
$fh->close();
|
1804 |
|
|
pop @cmdfh;
|
1805 |
|
|
print "pi_rri($curmode)-I: close " . pop(@cmdfn) . "\n";
|
1806 |
|
|
&{$mode_tab{$curmode}{flush}}("file");
|
1807 |
|
|
pop @cmdargs;
|
1808 |
|
|
setpar_command($cmdargs[-1]) if scalar(@cmdargs);
|
1809 |
|
|
next;
|
1810 |
|
|
}
|
1811 |
|
|
} else {
|
1812 |
|
|
return undef if $only_argv;
|
1813 |
|
|
if (defined $term) {
|
1814 |
|
|
$cmd = $term->readline('>');
|
1815 |
|
|
} else {
|
1816 |
|
|
$cmd = ;
|
1817 |
|
|
}
|
1818 |
|
|
if (-t STDIN && -t STDOUT) {
|
1819 |
|
|
$cmd_inter = 1; # signal that cmd interactive
|
1820 |
|
|
}
|
1821 |
|
|
chomp $cmd if defined $cmd;
|
1822 |
|
|
return undef if not defined $cmd;
|
1823 |
|
|
if (defined $cmd && $cmd =~ /\\$/) { # continuation line ?
|
1824 |
|
|
$cmd = $`;
|
1825 |
|
|
my $cline = ;
|
1826 |
|
|
chomp $cline;
|
1827 |
|
|
$cmd .= $cline if defined $cline;
|
1828 |
|
|
}
|
1829 |
|
|
}
|
1830 |
|
|
}
|
1831 |
|
|
|
1832 |
|
|
# preprocess command line
|
1833 |
|
|
# handle substitutions
|
1834 |
|
|
|
1835 |
|
|
while ($cmd =~ /\$\{(\w*):([-=])(.*?)\}/) { # ${name:[-=]val} seen
|
1836 |
|
|
my $name = $1;
|
1837 |
|
|
my $typ = $2;
|
1838 |
|
|
my $val = $3;
|
1839 |
|
|
if (exists $par{$name}) {
|
1840 |
|
|
$cmd = $` . $par{$name} . $';
|
1841 |
|
|
} else {
|
1842 |
|
|
$cmd = $` . $val . $';
|
1843 |
|
|
$par{$name} = $val if ($typ eq "=");
|
1844 |
|
|
}
|
1845 |
|
|
}
|
1846 |
|
|
|
1847 |
|
|
while ($cmd =~ /\$\{(\w*)\}/) { # ${name} seen
|
1848 |
|
|
my $name = $1;
|
1849 |
|
|
if (exists $par{$name}) {
|
1850 |
|
|
$cmd = $` . $par{$name} . $';
|
1851 |
|
|
} else {
|
1852 |
|
|
print "pi_rri($curmode)-E: variable \"$name\" not defined\n";
|
1853 |
|
|
$cmd = $` . "\$?$name?" . $';
|
1854 |
|
|
}
|
1855 |
|
|
}
|
1856 |
|
|
|
1857 |
|
|
while ($cmd =~ /\$\[(.*)\]/) { # $[name] seen
|
1858 |
|
|
my $evalstr = $1;
|
1859 |
|
|
my $evalval = eval $evalstr;
|
1860 |
|
|
if ($@) {
|
1861 |
|
|
print "pi_rri($curmode)-E: eval error for \"$evalstr\"\n";
|
1862 |
|
|
print "pi_rri($curmode)-E: $@\n";
|
1863 |
|
|
$cmd = $` . "\$?$evalstr?" . $';
|
1864 |
|
|
} else {
|
1865 |
|
|
$evalval = "" unless defined $evalval;
|
1866 |
|
|
$cmd = $` . $evalval . $';
|
1867 |
|
|
}
|
1868 |
|
|
}
|
1869 |
|
|
|
1870 |
|
|
# handle asignments
|
1871 |
|
|
|
1872 |
|
|
if ($cmd =~ /^(\w*)=/) {
|
1873 |
|
|
my $name = $1;
|
1874 |
|
|
my $val = $';
|
1875 |
|
|
$val =~ s/--.*$//;
|
1876 |
|
|
$val =~ s/\s*$//;
|
1877 |
|
|
$par{$name} = $val;
|
1878 |
|
|
next;
|
1879 |
|
|
}
|
1880 |
|
|
|
1881 |
|
|
# handle @@xxx lines (pmac perl macros)
|
1882 |
|
|
|
1883 |
|
|
if ($cmd =~ /^\s*\@\@(\S*)\s*(.*)$/) { # is it a "@@xxx" macro call ?
|
1884 |
|
|
my $file = $1;
|
1885 |
|
|
my $args = $2;
|
1886 |
|
|
my $fileexp = filename_expand($file);
|
1887 |
|
|
|
1888 |
|
|
print_fatal "pmac file $fileexp not found" unless -r $fileexp;
|
1889 |
|
|
open (PMACFILE, "<$fileexp") or die "failed to open $fileexp: $!";
|
1890 |
|
|
my @code = ;
|
1891 |
|
|
close PMACFILE;
|
1892 |
|
|
my $code = join "", @code;
|
1893 |
|
|
##printf "+++1 code to execute from $fileexp:\n$code---\n";
|
1894 |
|
|
|
1895 |
|
|
$cmd_line = $cmd;
|
1896 |
|
|
$cmd_rest = $args;
|
1897 |
|
|
$cmd_bad = 0;
|
1898 |
|
|
|
1899 |
|
|
$sigint_count = 0; # clear pending ^C's
|
1900 |
|
|
{ eval $code; }
|
1901 |
|
|
if ($@) {
|
1902 |
|
|
print STDERR "pi_rri-E: compile error in $fileexp:\n";
|
1903 |
|
|
print STDERR $@;
|
1904 |
|
|
}
|
1905 |
|
|
next;
|
1906 |
|
|
}
|
1907 |
|
|
|
1908 |
|
|
# handle @xxx lines (pcmd command lists)
|
1909 |
|
|
|
1910 |
|
|
if ($cmd =~ /^\s*\@(.*)$/) { # is it a "@xxx" command ?
|
1911 |
|
|
my $file = $1;
|
1912 |
|
|
my $args = "";
|
1913 |
|
|
if ($file =~ /\((.*)\)$/) { # is it a "@xxx(args)" command ?
|
1914 |
|
|
$file = $`;
|
1915 |
|
|
$args = $1;
|
1916 |
|
|
}
|
1917 |
|
|
|
1918 |
|
|
my $fileexp = filename_expand($file);
|
1919 |
|
|
|
1920 |
|
|
print_fatal "pcmd file $fileexp not found" unless -r $fileexp;
|
1921 |
|
|
my $fh = new FileHandle;
|
1922 |
|
|
$fh->open("<$fileexp") or die "failed to open $fileexp: $!";
|
1923 |
|
|
print "pi_rri($curmode)-I: open $fileexp\n";
|
1924 |
|
|
push @cmdfh, $fh;
|
1925 |
|
|
push @cmdfn, $fileexp;
|
1926 |
|
|
push @cmdargs, $args;
|
1927 |
|
|
setpar_command($args);
|
1928 |
|
|
} else {
|
1929 |
|
|
return $cmd;
|
1930 |
|
|
}
|
1931 |
|
|
}
|
1932 |
|
|
}
|
1933 |
|
|
|
1934 |
|
|
#-------------------------------------------------------------------------------
|
1935 |
|
|
|
1936 |
|
|
sub setpar_command {
|
1937 |
|
|
my ($args) = @_;
|
1938 |
|
|
my @arglist = split /,/,$args;
|
1939 |
|
|
for (my $i=scalar(@arglist); $i<8; $i++) {
|
1940 |
|
|
$arglist[$i] = "";
|
1941 |
|
|
}
|
1942 |
|
|
for (my $i=0; $i
|
1943 |
|
|
my $name = $i+1;
|
1944 |
|
|
$par{"$name"} = $arglist[$i];
|
1945 |
|
|
}
|
1946 |
|
|
}
|
1947 |
|
|
|
1948 |
|
|
#-------------------------------------------------------------------------------
|
1949 |
|
|
|
1950 |
|
|
sub nomode_open {
|
1951 |
|
|
}
|
1952 |
|
|
|
1953 |
|
|
#-------------------------------------------------------------------------------
|
1954 |
|
|
|
1955 |
|
|
sub nomode_flush {
|
1956 |
|
|
my ($case) = @_;
|
1957 |
|
|
}
|
1958 |
|
|
|
1959 |
|
|
#-------------------------------------------------------------------------------
|
1960 |
|
|
|
1961 |
|
|
sub nomode_close {
|
1962 |
|
|
}
|
1963 |
|
|
|
1964 |
|
|
#-------------------------------------------------------------------------------
|
1965 |
|
|
|
1966 |
|
|
sub nomode_cexec {
|
1967 |
|
|
my ($cmd) = @_;
|
1968 |
|
|
print "pi_rri($curmode)-E: unknown command \"$cmd\"\n";
|
1969 |
|
|
}
|
1970 |
|
|
|
1971 |
|
|
#-------------------------------------------------------------------------------
|
1972 |
|
|
|
1973 |
|
|
sub cpraw_open {
|
1974 |
|
|
}
|
1975 |
|
|
|
1976 |
|
|
#-------------------------------------------------------------------------------
|
1977 |
|
|
|
1978 |
|
|
sub cpraw_flush {
|
1979 |
|
|
my ($case) = @_;
|
1980 |
|
|
cpraw_tx_match_now unless $case eq "line";
|
1981 |
|
|
}
|
1982 |
|
|
|
1983 |
|
|
#-------------------------------------------------------------------------------
|
1984 |
|
|
|
1985 |
|
|
sub cpraw_close {
|
1986 |
|
|
}
|
1987 |
|
|
|
1988 |
|
|
#-------------------------------------------------------------------------------
|
1989 |
|
|
# cprx 0 11110000
|
1990 |
|
|
# cptx 0 11110000
|
1991 |
|
|
|
1992 |
|
|
sub cpraw_cexec {
|
1993 |
|
|
my ($cmd) = @_;
|
1994 |
|
|
my $dat;
|
1995 |
|
|
if ($cmd =~ /^(cp[rt]x)\s+([01])\s+([01]{8})\s*/) {
|
1996 |
|
|
print "pi_rri($curmode)-E: extra data ignored: \"$'\"\n" if $';
|
1997 |
|
|
} else {
|
1998 |
|
|
print "pi_rri($curmode)-E: unknown cpraw command: \"$cmd\"\n";
|
1999 |
|
|
return;
|
2000 |
|
|
}
|
2001 |
|
|
$dat = vec(pack("B8",$3), 0,8);
|
2002 |
|
|
$dat += 0x100 if $2 eq "1";
|
2003 |
|
|
if ($1 eq "cprx") {
|
2004 |
|
|
do_cprx($dat);
|
2005 |
|
|
} else {
|
2006 |
|
|
do_cptx($dat);
|
2007 |
|
|
}
|
2008 |
|
|
}
|
2009 |
|
|
|
2010 |
|
|
#-------------------------------------------------------------------------------
|
2011 |
|
|
|
2012 |
|
|
sub do_cprx {
|
2013 |
|
|
my ($dat) = @_;
|
2014 |
|
|
raw_snd9($dat);
|
2015 |
|
|
cpraw_tx_match;
|
2016 |
|
|
}
|
2017 |
|
|
|
2018 |
|
|
#-------------------------------------------------------------------------------
|
2019 |
|
|
|
2020 |
|
|
sub do_cptx {
|
2021 |
|
|
my ($dat) = @_;
|
2022 |
|
|
push @cpraw_tx_expt, $dat;
|
2023 |
|
|
if ($dat == D9ATTN) { # attn comma ?
|
2024 |
|
|
print conv_etime(), ".wtlam\n";
|
2025 |
|
|
cpraw_tx_match_now; # if yes, force match now
|
2026 |
|
|
} else {
|
2027 |
|
|
cpraw_tx_match; # otherwise just queue
|
2028 |
|
|
}
|
2029 |
|
|
}
|
2030 |
|
|
|
2031 |
|
|
#-------------------------------------------------------------------------------
|
2032 |
|
|
|
2033 |
|
|
sub cpraw_tx_match_now {
|
2034 |
|
|
my $nexpt = scalar(@cpraw_tx_expt);
|
2035 |
|
|
|
2036 |
|
|
while (scalar(@cpraw_tx_expt)) {
|
2037 |
|
|
if (wait_sel_filercv(1.)) {
|
2038 |
|
|
cpraw_tx_match;
|
2039 |
|
|
} else {
|
2040 |
|
|
print "pi_rri($curmode)-I: time out waiting for cptx response\n";
|
2041 |
|
|
last;
|
2042 |
|
|
}
|
2043 |
|
|
}
|
2044 |
|
|
}
|
2045 |
|
|
|
2046 |
|
|
#-------------------------------------------------------------------------------
|
2047 |
|
|
|
2048 |
|
|
sub cpraw_tx_match {
|
2049 |
|
|
|
2050 |
|
|
while (1) {
|
2051 |
|
|
my $dat = raw_rcv9();
|
2052 |
|
|
last unless defined $dat;
|
2053 |
|
|
push @cpraw_tx_read, $dat;
|
2054 |
|
|
}
|
2055 |
|
|
|
2056 |
|
|
while (scalar(@cpraw_tx_expt)>0 &&
|
2057 |
|
|
scalar(@cpraw_tx_read)>0) {
|
2058 |
|
|
my $dat_e = shift @cpraw_tx_expt;
|
2059 |
|
|
my $dat_r = shift @cpraw_tx_read;
|
2060 |
|
|
|
2061 |
|
|
print conv_etime(), "cptx ", conv_dat9($dat_r), " CHECK ";
|
2062 |
|
|
if ($dat_e == $dat_r) {
|
2063 |
|
|
print "OK";
|
2064 |
|
|
} else {
|
2065 |
|
|
print "FAIL exp=", conv_dat9($dat_e);
|
2066 |
|
|
}
|
2067 |
|
|
print "\n";
|
2068 |
|
|
}
|
2069 |
|
|
|
2070 |
|
|
}
|
2071 |
|
|
|
2072 |
|
|
#-------------------------------------------------------------------------------
|
2073 |
|
|
|
2074 |
|
|
sub rri_open {
|
2075 |
|
|
$rri_ref_sdef = 0x00; # by default check for 'hard' errors
|
2076 |
|
|
$rri_msk_sdef = 0xf0; # ignore the status bits + attn flag
|
2077 |
|
|
}
|
2078 |
|
|
|
2079 |
|
|
#-------------------------------------------------------------------------------
|
2080 |
|
|
|
2081 |
|
|
sub rri_flush {
|
2082 |
|
|
my ($case) = @_;
|
2083 |
|
|
rri_cmdlist_do();
|
2084 |
|
|
}
|
2085 |
|
|
|
2086 |
|
|
#-------------------------------------------------------------------------------
|
2087 |
|
|
|
2088 |
|
|
sub rri_close {
|
2089 |
|
|
}
|
2090 |
|
|
|
2091 |
|
|
#-------------------------------------------------------------------------------
|
2092 |
|
|
# .cpmon 0|1
|
2093 |
|
|
# .rbmon 0|1
|
2094 |
|
|
# .scntl n 0|1
|
2095 |
|
|
# .sinit g8 g16
|
2096 |
|
|
# .sdef [s=g8]
|
2097 |
|
|
# .amclr
|
2098 |
|
|
# .amdef name g8
|
2099 |
|
|
# .reset
|
2100 |
|
|
# .wait n
|
2101 |
|
|
# .wtlam n
|
2102 |
|
|
# .cclst
|
2103 |
|
|
# rreg [d=g16] [s=g8]
|
2104 |
|
|
# rblk n [s=g8]
|
2105 |
|
|
# followed by n d=g16 data check values
|
2106 |
|
|
# wreg g16 [s=g8]
|
2107 |
|
|
# wblk n [s=g8]
|
2108 |
|
|
# followed by n g16 data values
|
2109 |
|
|
# stat [d=g16] [s=d8]
|
2110 |
|
|
# attn [d=g16] [s=d8]
|
2111 |
|
|
# init g16 [s=g8]
|
2112 |
|
|
|
2113 |
|
|
sub rri_cexec {
|
2114 |
|
|
my ($cmd) = @_;
|
2115 |
|
|
|
2116 |
|
|
$cmd_line = $cmd;
|
2117 |
|
|
$cmd_rest = "";
|
2118 |
|
|
$cmd_bad = 0;
|
2119 |
|
|
|
2120 |
|
|
if ($cmd =~ /^(\.cpmon|\.rbmon)\s+([01])/) { # .cpmon, .rbmon -------------
|
2121 |
|
|
my $ind = ($1 eq ".cpmon") ? 15 : 14;
|
2122 |
|
|
$cmd_rest = $';
|
2123 |
|
|
rri_sideband(0x00, ($ind<<8) + $2);
|
2124 |
|
|
|
2125 |
|
|
} elsif ($cmd =~ /^\.scntl\s+(\d+)\s([01])/) { # .scntl ------------------
|
2126 |
|
|
$cmd_rest = $';
|
2127 |
|
|
rri_sideband(0x00, ($1<<8) + $2);
|
2128 |
|
|
|
2129 |
|
|
} elsif ($cmd =~ /^\.sinit/) { # .sinit ------------------
|
2130 |
|
|
$cmd_rest = $';
|
2131 |
|
|
my $addr = cget_gdat(8,$rri_dbasi);
|
2132 |
|
|
my $data = cget_gdat(16,$rri_dbasi);
|
2133 |
|
|
rri_sideband($addr, $data) if (not $cmd_bad);
|
2134 |
|
|
|
2135 |
|
|
} elsif ($cmd =~ /^\.sdef/) { # .sdef -------------------------
|
2136 |
|
|
$cmd_rest = $';
|
2137 |
|
|
($rri_ref_sdef,$rri_msk_sdef) = cget_tagval2_gdat("s",8,2);
|
2138 |
|
|
|
2139 |
|
|
} elsif ($cmd =~ /^\.amclr/) { # .amclr ------------------------
|
2140 |
|
|
$cmd_rest = $';
|
2141 |
|
|
%rri_amtbl = ();
|
2142 |
|
|
|
2143 |
|
|
} elsif ($cmd =~ /^\.amdef\s+([a-zA-Z][a-zA-Z0-9]*)/) {# .amdef ------------
|
2144 |
|
|
$cmd_rest = $';
|
2145 |
|
|
my $name = $1;
|
2146 |
|
|
my $addr = cget_gdat(8,2);
|
2147 |
|
|
if (defined $addr) {
|
2148 |
|
|
$rri_amtbl{$name} = $addr;
|
2149 |
|
|
} else {
|
2150 |
|
|
$cmd_bad = 1;
|
2151 |
|
|
}
|
2152 |
|
|
|
2153 |
|
|
} elsif ($cmd =~ /^\.dbasi\s+(\d+)/) { # .dbasi -----------------------
|
2154 |
|
|
$cmd_rest = $';
|
2155 |
|
|
my $dbase = int $1;
|
2156 |
|
|
$rri_dbasi = $dbase;
|
2157 |
|
|
} elsif ($cmd =~ /^\.dbaso\s+(\d+)/) { # .dbaso -----------------------
|
2158 |
|
|
$cmd_rest = $';
|
2159 |
|
|
my $dbase = int $1;
|
2160 |
|
|
$rri_dbaso = $dbase;
|
2161 |
|
|
if ($rri_dbaso == 2) {
|
2162 |
|
|
$rri_nodfill = " " x 15;
|
2163 |
|
|
} elsif ($rri_dbaso == 8) {
|
2164 |
|
|
$rri_nodfill = " " x 5;
|
2165 |
|
|
} elsif ($rri_dbaso == 16) {
|
2166 |
|
|
$rri_nodfill = " " x 3;
|
2167 |
|
|
} else {
|
2168 |
|
|
$rri_nodfill = "???";
|
2169 |
|
|
}
|
2170 |
|
|
|
2171 |
|
|
} elsif ($cmd =~ /^\.reset/) { # .reset ------------------------
|
2172 |
|
|
$cmd_rest = $';
|
2173 |
|
|
print "pi_rri($curmode)-I: $cmd currently ignored\n";
|
2174 |
|
|
|
2175 |
|
|
} elsif ($cmd =~ /^\.wait\s+(\d+)/) { # .wait ------------------------
|
2176 |
|
|
$cmd_rest = $';
|
2177 |
|
|
my $delay = int $1;
|
2178 |
|
|
rri_cmdlist_do(); # flush before waiting
|
2179 |
|
|
for (my $i = 0; $i < $delay; $i++) {
|
2180 |
|
|
raw_snd9(D9IDLE);
|
2181 |
|
|
}
|
2182 |
|
|
|
2183 |
|
|
} elsif ($cmd =~ /^\.wtlam\s+(\d+)/) { # .wtlam ------------------------
|
2184 |
|
|
$cmd_rest = $';
|
2185 |
|
|
rri_cmdlist_do(); # flush before wait for ATTN
|
2186 |
|
|
my $tstart = get_time();
|
2187 |
|
|
raw_get9_check(D9ATTN, "wtlam"); # ???FIXME this is a hack...
|
2188 |
|
|
printf "-- .wtlam # wait for %7.3f sec\n", get_time()-$tstart;
|
2189 |
|
|
|
2190 |
|
|
} elsif ($cmd =~ /^\.cclst/) { # .cclst ------------------------
|
2191 |
|
|
$cmd_rest = $';
|
2192 |
|
|
$rri_ncmdmax = scalar(@rri_cmdlist) + 1; # force exec after next cmd
|
2193 |
|
|
|
2194 |
|
|
} elsif ($cmd =~ /^rreg/) { # rreg --------------------------
|
2195 |
|
|
$cmd_rest = $';
|
2196 |
|
|
my $addr = rri_cget_addr;
|
2197 |
|
|
my ($ref_data, $msk_data) = cget_tagval2_gdat("d",16,$rri_dbasi);
|
2198 |
|
|
my ($ref_stat, $msk_stat) = rri_cget_stat;
|
2199 |
|
|
if (not $cmd_bad) {
|
2200 |
|
|
push @rri_cmdlist, {cname => "rreg",
|
2201 |
|
|
addr => $addr,
|
2202 |
|
|
ref_data => $ref_data,
|
2203 |
|
|
msk_data => $msk_data,
|
2204 |
|
|
ref_stat => $ref_stat,
|
2205 |
|
|
msk_stat => $msk_stat};
|
2206 |
|
|
}
|
2207 |
|
|
|
2208 |
|
|
} elsif ($cmd =~ /^rblk/) { # rblk --------------------------
|
2209 |
|
|
$cmd_rest = $';
|
2210 |
|
|
my $addr = rri_cget_addr;
|
2211 |
|
|
my $nblk = rri_cget_nblk;
|
2212 |
|
|
my ($ref_stat, $msk_stat) = rri_cget_stat;
|
2213 |
|
|
my @ref_rblk;
|
2214 |
|
|
my @msk_rblk;
|
2215 |
|
|
my $i;
|
2216 |
|
|
cget_chkblank();
|
2217 |
|
|
for ($i = 0; $i < $nblk; $i++) {
|
2218 |
|
|
$cmd_rest = get_command() if ($cmd_rest eq "");
|
2219 |
|
|
$cmd_rest =~ s/^\s*//;
|
2220 |
|
|
my ($ref,$msk) = cget_tagval2_gdat("d",16,$rri_dbasi);
|
2221 |
|
|
push @ref_rblk, $ref;
|
2222 |
|
|
push @msk_rblk, $msk;
|
2223 |
|
|
}
|
2224 |
|
|
cget_chkblank();
|
2225 |
|
|
if (not $cmd_bad) {
|
2226 |
|
|
push @rri_cmdlist, {cname => "rblk",
|
2227 |
|
|
addr => $addr,
|
2228 |
|
|
nblk => $nblk,
|
2229 |
|
|
ref_rblk => [@ref_rblk],
|
2230 |
|
|
msk_rblk => [@msk_rblk],
|
2231 |
|
|
ref_stat => $ref_stat,
|
2232 |
|
|
msk_stat => $msk_stat};
|
2233 |
|
|
}
|
2234 |
|
|
|
2235 |
|
|
} elsif ($cmd =~ /^wreg/) { # wreg --------------------------
|
2236 |
|
|
$cmd_rest = $';
|
2237 |
|
|
my $addr = rri_cget_addr;
|
2238 |
|
|
my $data = cget_gdat(16,$rri_dbasi);
|
2239 |
|
|
my ($ref_stat, $msk_stat) = rri_cget_stat;
|
2240 |
|
|
if (not $cmd_bad) {
|
2241 |
|
|
push @rri_cmdlist, {cname => "wreg",
|
2242 |
|
|
addr => $addr,
|
2243 |
|
|
data => $data,
|
2244 |
|
|
ref_stat => $ref_stat,
|
2245 |
|
|
msk_stat => $msk_stat};
|
2246 |
|
|
}
|
2247 |
|
|
|
2248 |
|
|
} elsif ($cmd =~ /^wblk/) { # wblk --------------------------
|
2249 |
|
|
$cmd_rest = $';
|
2250 |
|
|
my $addr = rri_cget_addr;
|
2251 |
|
|
my $nblk = rri_cget_nblk;
|
2252 |
|
|
my ($ref_stat, $msk_stat) = rri_cget_stat;
|
2253 |
|
|
my @dat_wblk;
|
2254 |
|
|
my $i;
|
2255 |
|
|
cget_chkblank();
|
2256 |
|
|
for ($i = 0; $i < $nblk; $i++) {
|
2257 |
|
|
$cmd_rest = get_command() if ($cmd_rest eq "");
|
2258 |
|
|
$cmd_rest =~ s/^\s*//;
|
2259 |
|
|
push @dat_wblk, cget_gdat(16,$rri_dbasi);
|
2260 |
|
|
}
|
2261 |
|
|
cget_chkblank();
|
2262 |
|
|
if (not $cmd_bad) {
|
2263 |
|
|
push @rri_cmdlist, {cname => "wblk",
|
2264 |
|
|
addr => $addr,
|
2265 |
|
|
nblk => $nblk,
|
2266 |
|
|
dat_wblk => [@dat_wblk],
|
2267 |
|
|
ref_stat => $ref_stat,
|
2268 |
|
|
msk_stat => $msk_stat};
|
2269 |
|
|
}
|
2270 |
|
|
|
2271 |
|
|
} elsif ($cmd =~ /^stat/) { # stat --------------------------
|
2272 |
|
|
$cmd_rest = $';
|
2273 |
|
|
my ($ref_data, $msk_data) = cget_tagval_gdat("d",16,2);
|
2274 |
|
|
my ($ref_stat, $msk_stat) = rri_cget_stat;
|
2275 |
|
|
if (not $cmd_bad) {
|
2276 |
|
|
push @rri_cmdlist, {cname => "stat",
|
2277 |
|
|
ref_data => $ref_data,
|
2278 |
|
|
msk_data => $msk_data,
|
2279 |
|
|
ref_stat => $ref_stat,
|
2280 |
|
|
msk_stat => $msk_stat};
|
2281 |
|
|
}
|
2282 |
|
|
|
2283 |
|
|
} elsif ($cmd =~ /^attn/) { # attn --------------------------
|
2284 |
|
|
$cmd_rest = $';
|
2285 |
|
|
my ($ref_data, $msk_data) = cget_tagval_gdat("d",16,$rri_dbasi);
|
2286 |
|
|
my ($ref_stat, $msk_stat) = rri_cget_stat;
|
2287 |
|
|
if (not $cmd_bad) {
|
2288 |
|
|
push @rri_cmdlist, {cname => "attn",
|
2289 |
|
|
ref_data => $ref_data,
|
2290 |
|
|
msk_data => $msk_data,
|
2291 |
|
|
ref_stat => $ref_stat,
|
2292 |
|
|
msk_stat => $msk_stat};
|
2293 |
|
|
}
|
2294 |
|
|
|
2295 |
|
|
} elsif ($cmd =~ /^init/) { # init --------------------------
|
2296 |
|
|
$cmd_rest = $';
|
2297 |
|
|
my $addr = rri_cget_addr;
|
2298 |
|
|
my $data = cget_gdat(16,$rri_dbasi);
|
2299 |
|
|
my ($ref_stat, $msk_stat) = rri_cget_stat;
|
2300 |
|
|
if (not $cmd_bad) {
|
2301 |
|
|
push @rri_cmdlist, {cname => "init",
|
2302 |
|
|
addr => $addr,
|
2303 |
|
|
data => $data,
|
2304 |
|
|
ref_stat => $ref_stat,
|
2305 |
|
|
msk_stat => $msk_stat};
|
2306 |
|
|
}
|
2307 |
|
|
|
2308 |
|
|
} else {
|
2309 |
|
|
print "pi_rri($curmode)-E: unknown command: \"$cmd_line\"\n";
|
2310 |
|
|
}
|
2311 |
|
|
|
2312 |
|
|
cget_chkblank() unless $cmd_bad;
|
2313 |
|
|
if ($cmd_bad) {
|
2314 |
|
|
print "pi_rri($curmode)-E: parse error, command ignored: \"$cmd_line\"\n";
|
2315 |
|
|
} else {
|
2316 |
|
|
if (scalar(@rri_cmdlist) >= $cmax ||
|
2317 |
|
|
($rri_ncmdmax && scalar(@rri_cmdlist) >= $rri_ncmdmax)) {
|
2318 |
|
|
$rri_ncmdmax = undef;
|
2319 |
|
|
rri_cmdlist_do();
|
2320 |
|
|
}
|
2321 |
|
|
}
|
2322 |
|
|
}
|
2323 |
|
|
|
2324 |
|
|
#-------------------------------------------------------------------------------
|
2325 |
|
|
|
2326 |
|
|
sub rri_cget_stat {
|
2327 |
|
|
my ($dat, $msk) = cget_tagval2_gdat("s",8,2);
|
2328 |
|
|
if (defined $dat) {
|
2329 |
|
|
return ($dat, $msk);
|
2330 |
|
|
} else {
|
2331 |
|
|
return ($rri_ref_sdef, $rri_msk_sdef);
|
2332 |
|
|
}
|
2333 |
|
|
}
|
2334 |
|
|
|
2335 |
|
|
#-------------------------------------------------------------------------------
|
2336 |
|
|
|
2337 |
|
|
sub rri_cget_addr {
|
2338 |
|
|
my $odat;
|
2339 |
|
|
$cmd_rest =~ s/^\s*//;
|
2340 |
|
|
if ($cmd_rest =~ /^\.([a-zA-Z][a-zA-Z0-9]*)/) {
|
2341 |
|
|
$cmd_rest = $';
|
2342 |
|
|
if (exists $rri_amtbl{$1}) {
|
2343 |
|
|
$odat = $rri_amtbl{$1};
|
2344 |
|
|
if ($cmd_rest =~ /^\|/) {
|
2345 |
|
|
$cmd_rest = $';
|
2346 |
|
|
$odat |= cget_gdat(8,2);
|
2347 |
|
|
}
|
2348 |
|
|
} else {
|
2349 |
|
|
print "pi_rri($curmode)-E: undefined address mnemo: \"$1\"\n";
|
2350 |
|
|
$cmd_bad = 1;
|
2351 |
|
|
}
|
2352 |
|
|
} else {
|
2353 |
|
|
$odat = cget_gdat(8,2);
|
2354 |
|
|
}
|
2355 |
|
|
return $odat;
|
2356 |
|
|
}
|
2357 |
|
|
|
2358 |
|
|
#-------------------------------------------------------------------------------
|
2359 |
|
|
|
2360 |
|
|
sub rri_cget_nblk {
|
2361 |
|
|
my $odat;
|
2362 |
|
|
$cmd_rest =~ s/^\s*//;
|
2363 |
|
|
if ($cmd_rest =~ /^(\d*)/) {
|
2364 |
|
|
$cmd_rest = $';
|
2365 |
|
|
$odat = int $1;
|
2366 |
|
|
if ($odat <= 0 || $odat > 256) {
|
2367 |
|
|
print "pi_rri($curmode)-E: block length <0 or >256\n";
|
2368 |
|
|
$cmd_bad = 1;
|
2369 |
|
|
}
|
2370 |
|
|
} else {
|
2371 |
|
|
$cmd_bad = 1;
|
2372 |
|
|
}
|
2373 |
|
|
return $odat;
|
2374 |
|
|
}
|
2375 |
|
|
|
2376 |
|
|
#-------------------------------------------------------------------------------
|
2377 |
|
|
|
2378 |
|
|
sub rri_cmdlist_dump {
|
2379 |
|
|
my ($href,$dblk,$fh) = @_;
|
2380 |
|
|
my $fh_old;
|
2381 |
|
|
|
2382 |
|
|
$fh_old = select($fh) if defined $fh;
|
2383 |
|
|
|
2384 |
|
|
foreach my $ele (@$href) {
|
2385 |
|
|
|
2386 |
|
|
printf "-- %-4s",$ele->{cname};
|
2387 |
|
|
|
2388 |
|
|
printf " %-7s","[$ele->{aname}]" if exists $ele->{aname};
|
2389 |
|
|
|
2390 |
|
|
printf " c=%1.1x%1d%1d", $ele->{cmd}>>4, ($ele->{cmd}>>3)&0x1,
|
2391 |
|
|
$ele->{cmd}&0x7 if exists $ele->{cmd};
|
2392 |
|
|
|
2393 |
|
|
printf " a=%s",conv_dat8($ele->{addr}) if exists $ele->{addr};
|
2394 |
|
|
|
2395 |
|
|
printf " n=%d", $ele->{nblk} if exists $ele->{nblk};
|
2396 |
|
|
|
2397 |
|
|
printf " d=%s", gconv_dat16($ele->{data},$rri_dbaso) if exists $ele->{data};
|
2398 |
|
|
|
2399 |
|
|
if (exists $ele->{ref_data}) {
|
2400 |
|
|
if ((defined $ele->{msk_data} && $ele->{msk_data} == 0xffff)
|
2401 |
|
|
|| not defined $ele->{ref_data}) {
|
2402 |
|
|
printf " d=-%s", $rri_nodfill;
|
2403 |
|
|
} else {
|
2404 |
|
|
printf " d=%s", gconv_dat16($ele->{ref_data},$rri_dbaso);
|
2405 |
|
|
printf ",%s", gconv_dat16($ele->{msk_data},$rri_dbaso) if $ele->{msk_data};
|
2406 |
|
|
}
|
2407 |
|
|
}
|
2408 |
|
|
|
2409 |
|
|
if (defined $ele->{rcv_data}) {
|
2410 |
|
|
printf " D=%s%s", gconv_dat16($ele->{rcv_data},$rri_dbaso),
|
2411 |
|
|
($ele->{err_data} ? "(#)" : " ");
|
2412 |
|
|
}
|
2413 |
|
|
|
2414 |
|
|
if (exists $ele->{ref_stat}) {
|
2415 |
|
|
if ((defined $ele->{msk_stat} && $ele->{msk_stat} == 0xffff)
|
2416 |
|
|
|| not defined $ele->{ref_stat}) {
|
2417 |
|
|
printf " s=-";
|
2418 |
|
|
} else {
|
2419 |
|
|
printf " s=%s", conv_dat8($ele->{ref_stat});
|
2420 |
|
|
printf ",%s", conv_dat8($ele->{msk_stat}) if $ele->{msk_stat};
|
2421 |
|
|
}
|
2422 |
|
|
}
|
2423 |
|
|
|
2424 |
|
|
if (defined $ele->{rcv_stat}) {
|
2425 |
|
|
printf " S=%s%s", conv_dat8($ele->{rcv_stat}),
|
2426 |
|
|
($ele->{err_stat} ? "(#)" : " ");
|
2427 |
|
|
}
|
2428 |
|
|
|
2429 |
|
|
if (exists $ele->{ok}) {
|
2430 |
|
|
print ($ele->{ok} ? " OK" : "FAIL");
|
2431 |
|
|
} else {
|
2432 |
|
|
print " PEND";
|
2433 |
|
|
}
|
2434 |
|
|
|
2435 |
|
|
if (exists $ele->{dat_wblk} && $dblk) {
|
2436 |
|
|
my $i = 0;
|
2437 |
|
|
foreach ( @{$ele->{dat_wblk}} ) {
|
2438 |
|
|
printf "\n-- " if ($i % 8 == 0);
|
2439 |
|
|
printf " %s", gconv_dat16($_,$rri_dbaso);
|
2440 |
|
|
$i += 1;
|
2441 |
|
|
}
|
2442 |
|
|
}
|
2443 |
|
|
|
2444 |
|
|
if (exists $ele->{ref_rblk} && $dblk && scalar(@{$ele->{ref_rblk}}) ) {
|
2445 |
|
|
my $i;
|
2446 |
|
|
my $nblk = $ele->{nblk};
|
2447 |
|
|
for ($i = 0; $i < $nblk; $i++) {
|
2448 |
|
|
printf "\n-- " if ($i % 4 == 0);
|
2449 |
|
|
if ((defined $ele->{msk_rblk}[$i] && $ele->{msk_rblk}[$i] == 0xffff)
|
2450 |
|
|
|| not defined $ele->{ref_rblk}[$i]){
|
2451 |
|
|
printf " d=-%s %s", $rri_nodfill, $rri_nodfill;
|
2452 |
|
|
} else {
|
2453 |
|
|
printf " d=%s", gconv_dat16($ele->{ref_rblk}[$i],$rri_dbaso);
|
2454 |
|
|
if ($ele->{msk_rblk}[$i]) {
|
2455 |
|
|
printf ",%s", gconv_dat16($ele->{msk_rblk}[$i],$rri_dbaso);
|
2456 |
|
|
} else {
|
2457 |
|
|
print " ";
|
2458 |
|
|
}
|
2459 |
|
|
}
|
2460 |
|
|
}
|
2461 |
|
|
}
|
2462 |
|
|
|
2463 |
|
|
if (exists $ele->{rcv_rblk} && $dblk) {
|
2464 |
|
|
my $i;
|
2465 |
|
|
my $nblk = $ele->{nblk};
|
2466 |
|
|
for ($i = 0; $i < $nblk; $i++) {
|
2467 |
|
|
printf "\n-- " if ($i % 4 == 0);
|
2468 |
|
|
printf " D=%s%s ", gconv_dat16($ele->{rcv_rblk}[$i],$rri_dbaso),
|
2469 |
|
|
($ele->{err_rblk}[$i] ? "(#)" : " ");
|
2470 |
|
|
}
|
2471 |
|
|
}
|
2472 |
|
|
|
2473 |
|
|
printf "\n";
|
2474 |
|
|
}
|
2475 |
|
|
|
2476 |
|
|
select($fh_old) if defined $fh_old;
|
2477 |
|
|
|
2478 |
|
|
}
|
2479 |
|
|
|
2480 |
|
|
#-------------------------------------------------------------------------------
|
2481 |
|
|
|
2482 |
|
|
sub rri_sideband {
|
2483 |
|
|
my ($addr,$data) = @_;
|
2484 |
|
|
my $dl = $data & 0xff;
|
2485 |
|
|
my $dh = ($data>>8) & 0xff;
|
2486 |
|
|
rri_cmdlist_do();
|
2487 |
|
|
raw_snd8(CESC);
|
2488 |
|
|
raw_snd8(CESC);
|
2489 |
|
|
raw_snd8($addr); # ADDR
|
2490 |
|
|
raw_snd8($dl); # DL
|
2491 |
|
|
raw_snd8($dh); # DH
|
2492 |
|
|
&{$chan_tab{$curchan}{write}}(); # flush write queue
|
2493 |
|
|
}
|
2494 |
|
|
|
2495 |
|
|
#-------------------------------------------------------------------------------
|
2496 |
|
|
|
2497 |
|
|
sub rri_cmdlist_do {
|
2498 |
|
|
if (scalar(@rri_cmdlist)) {
|
2499 |
|
|
rri_cmdlist_exec(\@rri_cmdlist);
|
2500 |
|
|
rri_cmdlist_dump(\@rri_cmdlist, 1);
|
2501 |
|
|
@rri_cmdlist = ();
|
2502 |
|
|
}
|
2503 |
|
|
}
|
2504 |
|
|
|
2505 |
|
|
#-------------------------------------------------------------------------------
|
2506 |
|
|
|
2507 |
|
|
sub rri_cmdlist_exec {
|
2508 |
|
|
my ($href) = @_;
|
2509 |
|
|
my $seq = 0;
|
2510 |
|
|
my $nele = scalar(@$href);
|
2511 |
|
|
|
2512 |
|
|
return unless $nele;
|
2513 |
|
|
|
2514 |
|
|
$ocrc = 0;
|
2515 |
|
|
$icrc = 0;
|
2516 |
|
|
|
2517 |
|
|
raw_snd9(D9SOP);
|
2518 |
|
|
|
2519 |
|
|
foreach my $ele (@$href) {
|
2520 |
|
|
my $cname = $ele->{cname};
|
2521 |
|
|
my $cmd;
|
2522 |
|
|
|
2523 |
|
|
$cmd = $rri_cname2cmd{$cname};
|
2524 |
|
|
$cmd |= 0x08 if $seq < $nele-1; # set chain bit
|
2525 |
|
|
$cmd |= ($seq & 0xf) << 4; # set sequence number field
|
2526 |
|
|
$ele->{cmd} = $cmd;
|
2527 |
|
|
raw_snd9_crc($cmd);
|
2528 |
|
|
$seq += 1;
|
2529 |
|
|
|
2530 |
|
|
if ($cname eq "rreg") {
|
2531 |
|
|
$stat_tab{xreg} += 1;
|
2532 |
|
|
raw_snd9_crc($ele->{addr});
|
2533 |
|
|
raw_snd9($ocrc);
|
2534 |
|
|
} elsif ($cname eq "rblk") {
|
2535 |
|
|
$stat_tab{xblk} += 1;
|
2536 |
|
|
raw_snd9_crc($ele->{addr});
|
2537 |
|
|
raw_snd9_crc($ele->{nblk}-1);
|
2538 |
|
|
raw_snd9($ocrc);
|
2539 |
|
|
} elsif ($cname eq "wreg") {
|
2540 |
|
|
$stat_tab{xreg} += 1;
|
2541 |
|
|
raw_snd9_crc($ele->{addr});
|
2542 |
|
|
raw_snd9_crc( $ele->{data} & 0xff);
|
2543 |
|
|
raw_snd9_crc(($ele->{data}>>8) & 0xff);
|
2544 |
|
|
raw_snd9($ocrc);
|
2545 |
|
|
} elsif ($cname eq "wblk") {
|
2546 |
|
|
$stat_tab{xblk} += 1;
|
2547 |
|
|
raw_snd9_crc($ele->{addr});
|
2548 |
|
|
raw_snd9_crc($ele->{nblk}-1);
|
2549 |
|
|
raw_snd9($ocrc);
|
2550 |
|
|
foreach ( @{$ele->{dat_wblk}} ) {
|
2551 |
|
|
raw_snd9_crc( $_ & 0xff);
|
2552 |
|
|
raw_snd9_crc(($_>>8) & 0xff);
|
2553 |
|
|
}
|
2554 |
|
|
raw_snd9($ocrc);
|
2555 |
|
|
} elsif ($cname eq "stat") {
|
2556 |
|
|
raw_snd9($ocrc);
|
2557 |
|
|
} elsif ($cname eq "attn") {
|
2558 |
|
|
raw_snd9($ocrc);
|
2559 |
|
|
} elsif ($cname eq "init") {
|
2560 |
|
|
raw_snd9_crc($ele->{addr});
|
2561 |
|
|
raw_snd9_crc( $ele->{data} & 0xff);
|
2562 |
|
|
raw_snd9_crc(($ele->{data}>>8) & 0xff);
|
2563 |
|
|
raw_snd9($ocrc);
|
2564 |
|
|
}
|
2565 |
|
|
}
|
2566 |
|
|
|
2567 |
|
|
raw_snd9(D9EOP);
|
2568 |
|
|
|
2569 |
|
|
raw_get9_checksop() or return 0;
|
2570 |
|
|
|
2571 |
|
|
foreach my $ele (@$href) {
|
2572 |
|
|
my $cname = $ele->{cname};
|
2573 |
|
|
my $idat;
|
2574 |
|
|
my $ok = 1;
|
2575 |
|
|
|
2576 |
|
|
raw_get9_crc_check($ele->{cmd}, "cmd") or return 0;
|
2577 |
|
|
|
2578 |
|
|
if ($cname eq "rreg") {
|
2579 |
|
|
raw_get9_crc_16bit(\$ele->{rcv_data}) or return 0;
|
2580 |
|
|
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
|
2581 |
|
|
raw_get9_check($icrc, "crc") or return 0;
|
2582 |
|
|
} elsif ($cname eq "rblk") {
|
2583 |
|
|
raw_get9_crc_check($ele->{nblk}-1, "nblk") or return 0;
|
2584 |
|
|
for (my $i=0; $i<$ele->{nblk}; $i++) {
|
2585 |
|
|
my $data;
|
2586 |
|
|
my $err;
|
2587 |
|
|
raw_get9_crc_16bit(\$data) or return 0;
|
2588 |
|
|
push @{$ele->{rcv_rblk}}, $data;
|
2589 |
|
|
$err = rri_ref_check($data, $ele->{ref_rblk}[$i], $ele->{msk_rblk}[$i]);
|
2590 |
|
|
push @{$ele->{err_rblk}}, $err;
|
2591 |
|
|
$ok = 0 if $err;
|
2592 |
|
|
}
|
2593 |
|
|
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
|
2594 |
|
|
raw_get9_check($icrc, "crc") or return 0;
|
2595 |
|
|
} elsif ($cname eq "wreg") {
|
2596 |
|
|
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
|
2597 |
|
|
raw_get9_check($icrc, "crc") or return 0;
|
2598 |
|
|
} elsif ($cname eq "wblk") {
|
2599 |
|
|
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
|
2600 |
|
|
raw_get9_check($icrc, "crc") or return 0;
|
2601 |
|
|
} elsif ($cname eq "stat") {
|
2602 |
|
|
raw_get9_crc_8bit(\$ele->{rcv_ccmd}) or return 0;
|
2603 |
|
|
raw_get9_crc_16bit(\$ele->{rcv_data}) or return 0;
|
2604 |
|
|
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
|
2605 |
|
|
raw_get9_check($icrc, "crc") or return 0;
|
2606 |
|
|
} elsif ($cname eq "attn") {
|
2607 |
|
|
raw_get9_crc_16bit(\$ele->{rcv_data}) or return 0;
|
2608 |
|
|
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
|
2609 |
|
|
raw_get9_check($icrc, "crc") or return 0;
|
2610 |
|
|
} elsif ($cname eq "init") {
|
2611 |
|
|
raw_get9_crc_8bit(\$ele->{rcv_stat}) or return 0;
|
2612 |
|
|
raw_get9_check($icrc, "crc") or return 0;
|
2613 |
|
|
}
|
2614 |
|
|
|
2615 |
|
|
if (defined $ele->{rcv_data}) {
|
2616 |
|
|
$ele->{err_data} = rri_ref_check($ele->{rcv_data},
|
2617 |
|
|
$ele->{ref_data}, $ele->{msk_data});
|
2618 |
|
|
$ok = 0 if $ele->{err_data};
|
2619 |
|
|
}
|
2620 |
|
|
if (defined $ele->{rcv_stat}) {
|
2621 |
|
|
$ele->{err_stat} = rri_ref_check($ele->{rcv_stat},
|
2622 |
|
|
$ele->{ref_stat}, $ele->{msk_stat});
|
2623 |
|
|
$ok = 0 if $ele->{err_stat};
|
2624 |
|
|
}
|
2625 |
|
|
|
2626 |
|
|
$ele->{ok} = $ok;
|
2627 |
|
|
|
2628 |
|
|
}
|
2629 |
|
|
|
2630 |
|
|
raw_get9_checkeop() or return 0;
|
2631 |
|
|
|
2632 |
|
|
return 1;
|
2633 |
|
|
}
|
2634 |
|
|
|
2635 |
|
|
#-------------------------------------------------------------------------------
|
2636 |
|
|
|
2637 |
|
|
sub rri_cmdlist_check_stat {
|
2638 |
|
|
my ($href) = @_;
|
2639 |
|
|
|
2640 |
|
|
foreach my $ele (@$href) {
|
2641 |
|
|
return 1 if not exists $ele->{rcv_stat};
|
2642 |
|
|
return 1 if $ele->{err_stat};
|
2643 |
|
|
}
|
2644 |
|
|
|
2645 |
|
|
return 0;
|
2646 |
|
|
}
|
2647 |
|
|
|
2648 |
|
|
#-------------------------------------------------------------------------------
|
2649 |
|
|
|
2650 |
|
|
sub rri_cmdlist_get_rval {
|
2651 |
|
|
my ($href,$ind) = @_;
|
2652 |
|
|
my $nele = scalar(@$href);
|
2653 |
|
|
|
2654 |
|
|
return (undef, "#ind?#") if ($ind >= $nele);
|
2655 |
|
|
|
2656 |
|
|
return (undef, "#sta?#") if not exists $$href[$ind]->{rcv_stat};
|
2657 |
|
|
|
2658 |
|
|
return (undef, sprintf "#s=%2.2x#",$$href[$ind]->{rcv_stat})
|
2659 |
|
|
if $$href[$ind]->{err_stat};
|
2660 |
|
|
|
2661 |
|
|
return (undef, "#dat?#") if (not exists $$href[$ind]->{rcv_data});
|
2662 |
|
|
|
2663 |
|
|
return ($$href[$ind]->{rcv_data}, sprintf "%6.6o",$$href[$ind]->{rcv_data});
|
2664 |
|
|
}
|
2665 |
|
|
|
2666 |
|
|
#-------------------------------------------------------------------------------
|
2667 |
|
|
|
2668 |
|
|
sub rri_cmdlist_conv_rval {
|
2669 |
|
|
my ($href,$ind) = @_;
|
2670 |
|
|
my ($val,$str) = rri_cmdlist_get_rval($href, $ind);
|
2671 |
|
|
return $str;
|
2672 |
|
|
}
|
2673 |
|
|
|
2674 |
|
|
#-------------------------------------------------------------------------------
|
2675 |
|
|
|
2676 |
|
|
sub rri_ref_check { # check reference data (1=err)
|
2677 |
|
|
my ($rcv,$ref,$msk) = @_;
|
2678 |
|
|
if (defined $ref) {
|
2679 |
|
|
my $mask = (defined $msk) ? $msk : 0;
|
2680 |
|
|
my $mrcv = $rcv | $mask;
|
2681 |
|
|
my $mref = $ref | $mask;
|
2682 |
|
|
return 1 if $mrcv != $mref;
|
2683 |
|
|
}
|
2684 |
|
|
return 0;
|
2685 |
|
|
}
|
2686 |
|
|
|
2687 |
|
|
#-------------------------------------------------------------------------------
|
2688 |
|
|
|
2689 |
|
|
sub pdpcp_open {
|
2690 |
|
|
$rri_ref_sdef = 0x00; # by default check for 'hard' errors
|
2691 |
|
|
$rri_msk_sdef = 0x70; # ignore cpuhalt,cpugo and attn
|
2692 |
|
|
}
|
2693 |
|
|
|
2694 |
|
|
#-------------------------------------------------------------------------------
|
2695 |
|
|
|
2696 |
|
|
sub pdpcp_flush {
|
2697 |
|
|
my ($case) = @_;
|
2698 |
|
|
rri_cmdlist_do();
|
2699 |
|
|
}
|
2700 |
|
|
|
2701 |
|
|
#-------------------------------------------------------------------------------
|
2702 |
|
|
|
2703 |
|
|
sub pdpcp_close {
|
2704 |
|
|
}
|
2705 |
|
|
|
2706 |
|
|
#-------------------------------------------------------------------------------
|
2707 |
|
|
# .tocmd n
|
2708 |
|
|
# .tostp n
|
2709 |
|
|
# .togo n
|
2710 |
|
|
# .anena 0|1
|
2711 |
|
|
# .cpmon 0|1
|
2712 |
|
|
# .rbmon 0|1
|
2713 |
|
|
# .scntl n 0|1
|
2714 |
|
|
# .sinit g8 g16
|
2715 |
|
|
# .sdef [s=g8]
|
2716 |
|
|
# .cerr 0|1
|
2717 |
|
|
# .merr 0|1
|
2718 |
|
|
# .reset
|
2719 |
|
|
# .wait n
|
2720 |
|
|
# .cclst
|
2721 |
|
|
# rr* [d=g16] [s=g8]
|
2722 |
|
|
# wr* g16 [s=g8]
|
2723 |
|
|
# brm n [s=g8]
|
2724 |
|
|
# followed by n d=g16 data check values
|
2725 |
|
|
# bwm n [s=g8]
|
2726 |
|
|
# followed by n g16 data values
|
2727 |
|
|
# wal g16 [s=g8]
|
2728 |
|
|
# wah g16 [s=g8]
|
2729 |
|
|
# rps [d=g16] [s=g8]
|
2730 |
|
|
# wps g16 [s=g8]
|
2731 |
|
|
# rm [d=g16] [s=g8]
|
2732 |
|
|
# rmi [d=g16] [s=g8]
|
2733 |
|
|
# wm g16 [s=g8]
|
2734 |
|
|
# wmi g16 [s=g8]
|
2735 |
|
|
# stapc g16 [s=g8]
|
2736 |
|
|
# sta [s=g8]
|
2737 |
|
|
# sto [s=g8]
|
2738 |
|
|
# cont [s=g8]
|
2739 |
|
|
# step [s=g8]
|
2740 |
|
|
# rst [s=g8]
|
2741 |
|
|
# wibrb g16
|
2742 |
|
|
# ribr g6 [d=g16] [s=g8]
|
2743 |
|
|
# wibr g6 g16
|
2744 |
|
|
# wtgo
|
2745 |
|
|
# wtlam [d=g16]
|
2746 |
|
|
#
|
2747 |
|
|
|
2748 |
|
|
sub pdpcp_cexec {
|
2749 |
|
|
my ($cmd) = @_;
|
2750 |
|
|
my $cclast;
|
2751 |
|
|
my $aname;
|
2752 |
|
|
if ($cmd =~ /^([a-z0-9]*)/) {
|
2753 |
|
|
$aname = $1;
|
2754 |
|
|
}
|
2755 |
|
|
|
2756 |
|
|
$cmd =~ s/^rsp/rr6/; # rsp -> rr6
|
2757 |
|
|
$cmd =~ s/^rpc/rr7/; # rsp -> rr7
|
2758 |
|
|
$cmd =~ s/^wsp/wr6/; # wsp -> wr6
|
2759 |
|
|
$cmd =~ s/^wpc/wr7/; # wsp -> wr7
|
2760 |
|
|
|
2761 |
|
|
$cmd_line = $cmd;
|
2762 |
|
|
$cmd_rest = "";
|
2763 |
|
|
$cmd_bad = 0;
|
2764 |
|
|
|
2765 |
|
|
if ($cmd =~ /^\.to(cmd|stp|go)\s+(\d*)/) {# .tocmd, .tostp, .togo
|
2766 |
|
|
$cmd_rest = $';
|
2767 |
|
|
print "pi_rri($curmode)-I: $cmd currently ignored\n";
|
2768 |
|
|
|
2769 |
|
|
} elsif ($cmd =~ /^\.anena\s+([01])/) { # .anena ------------------------
|
2770 |
|
|
$cmd_rest = $';
|
2771 |
|
|
my $ena = int $1;
|
2772 |
|
|
my $ena_data = ($ena==0) ? 0x0000 : 0x8000;
|
2773 |
|
|
rri_cmdlist_do();
|
2774 |
|
|
push @rri_cmdlist, {cname => "init",
|
2775 |
|
|
aname => ".anena",
|
2776 |
|
|
addr => 0xff,
|
2777 |
|
|
data => $ena_data};
|
2778 |
|
|
rri_cmdlist_do();
|
2779 |
|
|
|
2780 |
|
|
} elsif ($cmd =~ /^(\.cpmon|\.rbmon)\s+([01])/) { # .cpmon, .rbmon ---------
|
2781 |
|
|
$cmd_rest = $';
|
2782 |
|
|
my $ind = ($1 eq ".cpmon") ? 15 : 14;
|
2783 |
|
|
$cmd_rest = $';
|
2784 |
|
|
rri_sideband(0x00, ($ind<<8) + $2);
|
2785 |
|
|
|
2786 |
|
|
} elsif ($cmd =~ /^\.scntl\s+(\d+)\s([01])/) { # .scntl ------------------
|
2787 |
|
|
$cmd_rest = $';
|
2788 |
|
|
rri_sideband(0x00, ($1<<8) + $2);
|
2789 |
|
|
|
2790 |
|
|
} elsif ($cmd =~ /^\.sinit/) { # .sinit ------------------
|
2791 |
|
|
$cmd_rest = $';
|
2792 |
|
|
my $addr = cget_gdat(8,$rri_dbasi);
|
2793 |
|
|
my $data = cget_gdat(16,$rri_dbasi);
|
2794 |
|
|
rri_sideband($addr, $data) if (not $cmd_bad);
|
2795 |
|
|
|
2796 |
|
|
} elsif ($cmd =~ /^\.sdef/) { # .sdef -------------------------
|
2797 |
|
|
$cmd_rest = $';
|
2798 |
|
|
($rri_ref_sdef,$rri_msk_sdef) = cget_tagval2_gdat("s",8,2);
|
2799 |
|
|
|
2800 |
|
|
} elsif ($cmd =~ /^\.[cm]err\s*[01]/) { # .[cm]err
|
2801 |
|
|
# ignore, no action
|
2802 |
|
|
|
2803 |
|
|
} elsif ($cmd =~ /^\.reset/) { # .reset ------------------------
|
2804 |
|
|
$cmd_rest = $';
|
2805 |
|
|
rri_cmdlist_do(); # flush before reset
|
2806 |
|
|
push @rri_cmdlist, {cname => "init",
|
2807 |
|
|
aname => ".reset",
|
2808 |
|
|
addr => 0x00,
|
2809 |
|
|
data => 0x01};
|
2810 |
|
|
rri_cmdlist_do(); # flush after reset
|
2811 |
|
|
|
2812 |
|
|
} elsif ($cmd =~ /^\.wait\s+(\d+)/) { # .wait ------------------------
|
2813 |
|
|
$cmd_rest = $';
|
2814 |
|
|
my $delay = int $1;
|
2815 |
|
|
rri_cmdlist_do(); # flush before waiting
|
2816 |
|
|
for (my $i = 0; $i < $delay; $i++) {
|
2817 |
|
|
raw_snd9(D9IDLE);
|
2818 |
|
|
}
|
2819 |
|
|
|
2820 |
|
|
} elsif ($cmd =~ /^\.cclst/) { # .cclst ------------------------
|
2821 |
|
|
$cmd_rest = $';
|
2822 |
|
|
$rri_ncmdmax = scalar(@rri_cmdlist) + 1; # force exec after next cmd
|
2823 |
|
|
|
2824 |
|
|
} elsif ($cmd =~ /^rr([0-7])/) { # rr* ---------------------------
|
2825 |
|
|
$cmd_rest = $';
|
2826 |
|
|
my $rnum = int $1;
|
2827 |
|
|
pdpcp_cmd_rreg($aname, PDPCP_ADDR_R0+$rnum);
|
2828 |
|
|
|
2829 |
|
|
} elsif ($cmd =~ /^wr([0-7])/) { # wr* ---------------------------
|
2830 |
|
|
$cmd_rest = $';
|
2831 |
|
|
my $rnum = int $1;
|
2832 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_R0+$rnum);
|
2833 |
|
|
|
2834 |
|
|
} elsif ($cmd =~ /^brm/) { # brm ---------------------------
|
2835 |
|
|
$cmd_rest = $';
|
2836 |
|
|
my $addr = PDPCP_ADDR_MEMI;
|
2837 |
|
|
my $nblk = rri_cget_nblk;
|
2838 |
|
|
my ($ref_stat, $msk_stat) = rri_cget_stat;
|
2839 |
|
|
my @ref_rblk;
|
2840 |
|
|
my @msk_rblk;
|
2841 |
|
|
my $i;
|
2842 |
|
|
cget_chkblank();
|
2843 |
|
|
for ($i = 0; $i < $nblk; $i++) {
|
2844 |
|
|
$cmd_rest = get_command() if ($cmd_rest eq "");
|
2845 |
|
|
$cmd_rest =~ s/^\s*//;
|
2846 |
|
|
my ($ref,$msk) = cget_tagval2_gdat("d",16,8);
|
2847 |
|
|
push @ref_rblk, $ref;
|
2848 |
|
|
push @msk_rblk, $msk;
|
2849 |
|
|
}
|
2850 |
|
|
cget_chkblank();
|
2851 |
|
|
if (not $cmd_bad) {
|
2852 |
|
|
push @rri_cmdlist, {cname => "rblk",
|
2853 |
|
|
aname => $aname,
|
2854 |
|
|
addr => $addr,
|
2855 |
|
|
nblk => $nblk,
|
2856 |
|
|
ref_rblk => [@ref_rblk],
|
2857 |
|
|
msk_rblk => [@msk_rblk],
|
2858 |
|
|
ref_stat => $ref_stat,
|
2859 |
|
|
msk_stat => $msk_stat};
|
2860 |
|
|
}
|
2861 |
|
|
|
2862 |
|
|
} elsif ($cmd =~ /^bwm/) { # bwm ---------------------------
|
2863 |
|
|
$cmd_rest = $';
|
2864 |
|
|
my $addr = PDPCP_ADDR_MEMI;
|
2865 |
|
|
my $nblk = rri_cget_nblk;
|
2866 |
|
|
my ($ref_stat, $msk_stat) = rri_cget_stat;
|
2867 |
|
|
my @dat_wblk;
|
2868 |
|
|
my $i;
|
2869 |
|
|
cget_chkblank();
|
2870 |
|
|
for ($i = 0; $i < $nblk; $i++) {
|
2871 |
|
|
$cmd_rest = get_command() if ($cmd_rest eq "");
|
2872 |
|
|
$cmd_rest =~ s/^\s*//;
|
2873 |
|
|
push @dat_wblk, cget_gdat(16,8);
|
2874 |
|
|
}
|
2875 |
|
|
cget_chkblank();
|
2876 |
|
|
if (not $cmd_bad) {
|
2877 |
|
|
push @rri_cmdlist, {cname => "wblk",
|
2878 |
|
|
aname => $aname,
|
2879 |
|
|
addr => $addr,
|
2880 |
|
|
nblk => $nblk,
|
2881 |
|
|
dat_wblk => [@dat_wblk],
|
2882 |
|
|
ref_stat => $ref_stat,
|
2883 |
|
|
msk_stat => $msk_stat};
|
2884 |
|
|
}
|
2885 |
|
|
|
2886 |
|
|
} elsif ($cmd =~ /^wal/) { # wal ---------------------------
|
2887 |
|
|
$cmd_rest = $';
|
2888 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_AL);
|
2889 |
|
|
|
2890 |
|
|
} elsif ($cmd =~ /^wah/) { # wah ---------------------------
|
2891 |
|
|
$cmd_rest = $';
|
2892 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_AH);
|
2893 |
|
|
|
2894 |
|
|
} elsif ($cmd =~ /^rps/) { # rps ---------------------------
|
2895 |
|
|
$cmd_rest = $';
|
2896 |
|
|
pdpcp_cmd_rreg($aname, PDPCP_ADDR_PSW);
|
2897 |
|
|
|
2898 |
|
|
} elsif ($cmd =~ /^wps/) { # wps ---------------------------
|
2899 |
|
|
$cmd_rest = $';
|
2900 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_PSW);
|
2901 |
|
|
|
2902 |
|
|
} elsif ($cmd =~ /^rmi/) { # rmi ---------------------------
|
2903 |
|
|
$cmd_rest = $';
|
2904 |
|
|
pdpcp_cmd_rreg($aname, PDPCP_ADDR_MEMI);
|
2905 |
|
|
|
2906 |
|
|
} elsif ($cmd =~ /^rm/) { # rm ----------------------------
|
2907 |
|
|
$cmd_rest = $';
|
2908 |
|
|
pdpcp_cmd_rreg($aname, PDPCP_ADDR_MEM);
|
2909 |
|
|
|
2910 |
|
|
} elsif ($cmd =~ /^wmi/) { # wmi ---------------------------
|
2911 |
|
|
$cmd_rest = $';
|
2912 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_MEMI);
|
2913 |
|
|
|
2914 |
|
|
} elsif ($cmd =~ /^wm/) { # wm ----------------------------
|
2915 |
|
|
$cmd_rest = $';
|
2916 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_MEM);
|
2917 |
|
|
|
2918 |
|
|
} elsif ($cmd =~ /^stapc/) { # stapc -------------------------
|
2919 |
|
|
$cmd_rest = $';
|
2920 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_PC);
|
2921 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_STA);
|
2922 |
|
|
|
2923 |
|
|
} elsif ($cmd =~ /^sta/) { # sta ---------------------------
|
2924 |
|
|
$cmd_rest = $';
|
2925 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_STA);
|
2926 |
|
|
|
2927 |
|
|
} elsif ($cmd =~ /^sto/) { # sto ---------------------------
|
2928 |
|
|
$cmd_rest = $';
|
2929 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_STO);
|
2930 |
|
|
|
2931 |
|
|
} elsif ($cmd =~ /^cont/) { # cont --------------------------
|
2932 |
|
|
$cmd_rest = $';
|
2933 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_CONT);
|
2934 |
|
|
|
2935 |
|
|
} elsif ($cmd =~ /^step/) { # step --------------------------
|
2936 |
|
|
$cmd_rest = $';
|
2937 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_STEP);
|
2938 |
|
|
|
2939 |
|
|
} elsif ($cmd =~ /^rst/) { # rst ---------------------------
|
2940 |
|
|
$cmd_rest = $';
|
2941 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_CNTL, PDPCP_FUNC_RST);
|
2942 |
|
|
|
2943 |
|
|
} elsif ($cmd =~ /^wibrb/) { # wibrb -------------------------
|
2944 |
|
|
$cmd_rest = $';
|
2945 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_IBRB);
|
2946 |
|
|
|
2947 |
|
|
} elsif ($cmd =~ /^ribr/) { # ribr --------------------------
|
2948 |
|
|
$cmd_rest = $';
|
2949 |
|
|
my $off = cget_gdat(6,8);
|
2950 |
|
|
pdpcp_cmd_rreg($aname, PDPCP_ADDR_IBR+int($off/2));
|
2951 |
|
|
|
2952 |
|
|
} elsif ($cmd =~ /^wibr/) { # wibr --------------------------
|
2953 |
|
|
$cmd_rest = $';
|
2954 |
|
|
my $off = cget_gdat(6,8);
|
2955 |
|
|
pdpcp_cmd_wreg($aname, PDPCP_ADDR_IBR+int($off/2));
|
2956 |
|
|
|
2957 |
|
|
} elsif ($cmd =~ /^wtgo/) { # wtgo --------------------------
|
2958 |
|
|
$cmd_rest = $';
|
2959 |
|
|
rri_cmdlist_do();
|
2960 |
|
|
my $tstart = get_time();
|
2961 |
|
|
raw_get9_check(D9ATTN, "wtgo"); # ???FIXME this is a hack...
|
2962 |
|
|
printf "-- wtgo # wait for %7.3f sec\n", get_time()-$tstart;
|
2963 |
|
|
push @rri_cmdlist, {cname => "attn",
|
2964 |
|
|
aname => ".wtgo"};
|
2965 |
|
|
|
2966 |
|
|
} elsif ($cmd =~ /^wtlam/) { # wtlam -------------------------
|
2967 |
|
|
$cmd_rest = $';
|
2968 |
|
|
my ($ref_data, $msk_data) = cget_tagval2_gdat("d",16,8);
|
2969 |
|
|
rri_cmdlist_do();
|
2970 |
|
|
my $tstart = get_time();
|
2971 |
|
|
raw_get9_check(D9ATTN, "wtgo"); # ???FIXME this is a hack...
|
2972 |
|
|
printf "-- wtlam # wait for %7.3f sec\n", get_time()-$tstart;
|
2973 |
|
|
push @rri_cmdlist, {cname => "attn",
|
2974 |
|
|
aname => ".wtlam",
|
2975 |
|
|
ref_data => $ref_data,
|
2976 |
|
|
msk_data => $msk_data};
|
2977 |
|
|
|
2978 |
|
|
} else {
|
2979 |
|
|
print "pi_rri($curmode)-E: unknown command: \"$cmd_line\"\n";
|
2980 |
|
|
}
|
2981 |
|
|
|
2982 |
|
|
cget_chkblank() unless $cmd_bad;
|
2983 |
|
|
if ($cmd_bad) {
|
2984 |
|
|
print "pi_rri($curmode)-E: parse error, command ignored: \"$cmd_line\"\n";
|
2985 |
|
|
} else {
|
2986 |
|
|
if (scalar(@rri_cmdlist) >= $cmax || $cclast ||
|
2987 |
|
|
($rri_ncmdmax && scalar(@rri_cmdlist) >= $rri_ncmdmax)) {
|
2988 |
|
|
$rri_ncmdmax = undef;
|
2989 |
|
|
rri_cmdlist_do();
|
2990 |
|
|
}
|
2991 |
|
|
}
|
2992 |
|
|
}
|
2993 |
|
|
|
2994 |
|
|
#-------------------------------------------------------------------------------
|
2995 |
|
|
|
2996 |
|
|
sub pdpcp_cmd_rreg {
|
2997 |
|
|
my ($aname,$addr) = @_;
|
2998 |
|
|
my ($ref_data,$msk_data) = cget_tagval2_gdat("d",16,8);
|
2999 |
|
|
my ($ref_stat,$msk_stat) = rri_cget_stat;
|
3000 |
|
|
if (not $cmd_bad) {
|
3001 |
|
|
push @rri_cmdlist, {cname => "rreg",
|
3002 |
|
|
aname => $aname,
|
3003 |
|
|
addr => $addr,
|
3004 |
|
|
ref_data => $ref_data,
|
3005 |
|
|
msk_data => $msk_data,
|
3006 |
|
|
ref_stat => $ref_stat,
|
3007 |
|
|
msk_stat => $msk_stat};
|
3008 |
|
|
}
|
3009 |
|
|
}
|
3010 |
|
|
|
3011 |
|
|
#-------------------------------------------------------------------------------
|
3012 |
|
|
|
3013 |
|
|
sub pdpcp_cmd_wreg {
|
3014 |
|
|
my ($aname,$addr,$data) = @_;
|
3015 |
|
|
my $ldata = (defined $data) ? $data : cget_gdat(16,8);
|
3016 |
|
|
my ($ref_stat,$msk_stat) = rri_cget_stat;
|
3017 |
|
|
if (not $cmd_bad) {
|
3018 |
|
|
push @rri_cmdlist, {cname => "wreg",
|
3019 |
|
|
aname => $aname,
|
3020 |
|
|
addr => $addr,
|
3021 |
|
|
data => $ldata,
|
3022 |
|
|
ref_stat => $ref_stat,
|
3023 |
|
|
msk_stat => $msk_stat};
|
3024 |
|
|
}
|
3025 |
|
|
}
|
3026 |
|
|
|
3027 |
|
|
#-------------------------------------------------------------------------------
|
3028 |
|
|
|
3029 |
|
|
sub serv11_open {
|
3030 |
|
|
$rri_ref_sdef = 0x00; # by default check for 'hard' errors
|
3031 |
|
|
$rri_msk_sdef = 0x70; # ignore cpuhalt,cpugo and attn
|
3032 |
|
|
|
3033 |
|
|
serv11_config() unless $serv11_config_done;
|
3034 |
|
|
}
|
3035 |
|
|
|
3036 |
|
|
#-------------------------------------------------------------------------------
|
3037 |
|
|
|
3038 |
|
|
sub serv11_flush {
|
3039 |
|
|
my ($case) = @_;
|
3040 |
|
|
}
|
3041 |
|
|
|
3042 |
|
|
#-------------------------------------------------------------------------------
|
3043 |
|
|
|
3044 |
|
|
sub serv11_close {
|
3045 |
|
|
}
|
3046 |
|
|
|
3047 |
|
|
#-------------------------------------------------------------------------------
|
3048 |
|
|
#
|
3049 |
|
|
# (string
|
3050 |
|
|
|
3051 |
|
|
# lspc
|
3052 |
|
|
# lsmem {-m|-a} g16{(:g16|nddd)} {(>|>>)file}
|
3053 |
|
|
# ldabs {-s} file
|
3054 |
|
|
# exa
|
3055 |
|
|
# dep g16
|
3056 |
|
|
# set ...
|
3057 |
|
|
# sho conf
|
3058 |
|
|
# sho att
|
3059 |
|
|
# sho regs
|
3060 |
|
|
# sho mmu
|
3061 |
|
|
# sho ubm[ap]
|
3062 |
|
|
# wtt "string"
|
3063 |
|
|
# attn
|
3064 |
|
|
# att file
|
3065 |
|
|
# det |all
|
3066 |
|
|
# init
|
3067 |
|
|
# boot
|
3068 |
|
|
# start g16
|
3069 |
|
|
# step
|
3070 |
|
|
# stop
|
3071 |
|
|
# cont
|
3072 |
|
|
# reset
|
3073 |
|
|
# server
|
3074 |
|
|
#
|
3075 |
|
|
|
3076 |
|
|
sub serv11_cexec {
|
3077 |
|
|
my ($cmd) = @_;
|
3078 |
|
|
|
3079 |
|
|
$cmd_line = $cmd;
|
3080 |
|
|
$cmd_rest = "";
|
3081 |
|
|
$cmd_bad = 0;
|
3082 |
|
|
|
3083 |
|
|
#
|
3084 |
|
|
# First handle 'special syntax commands: ( and <
|
3085 |
|
|
#
|
3086 |
|
|
|
3087 |
|
|
if ($cmd =~ /^([<(])/) { # < and ( short hands -----------
|
3088 |
|
|
my $str = $';
|
3089 |
|
|
my $ucb = cget_ucb("term", "tt0");
|
3090 |
|
|
return if $cmd_bad or cget_chkblank();
|
3091 |
|
|
|
3092 |
|
|
my @bytes;
|
3093 |
|
|
if ($1 eq "<") { # < command
|
3094 |
|
|
conv_str2bytes($str, \@bytes);
|
3095 |
|
|
push @bytes, 0015;
|
3096 |
|
|
} else { # ( command
|
3097 |
|
|
if ($str =~ /^\\([0-7]{3})$/) { # (\ooo escape
|
3098 |
|
|
push @bytes, oct $1;
|
3099 |
|
|
} elsif ($str =~ /^\\\^(.)$/) { # (^c escape
|
3100 |
|
|
my $byt = ord($1); # to byte value
|
3101 |
|
|
$byt -= 040 if ($byt >= 040); # map to control char
|
3102 |
|
|
$byt -= 040 if ($byt >= 040);
|
3103 |
|
|
$byt -= 040 if ($byt >= 040);
|
3104 |
|
|
push @bytes, $byt;
|
3105 |
|
|
} else {
|
3106 |
|
|
conv_str2bytes($str, \@bytes, 1);
|
3107 |
|
|
}
|
3108 |
|
|
}
|
3109 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
3110 |
|
|
&{$ctl->{ichrhdl}}($ucb, \@bytes);
|
3111 |
|
|
|
3112 |
|
|
return;
|
3113 |
|
|
}
|
3114 |
|
|
|
3115 |
|
|
#
|
3116 |
|
|
# Now prepare normal syntax commands
|
3117 |
|
|
#
|
3118 |
|
|
|
3119 |
|
|
if ($cmd =~ /^(\w+)\b/) { # get command name
|
3120 |
|
|
$cmd = $1;
|
3121 |
|
|
$cmd_rest = $';
|
3122 |
|
|
$cmd_rest =~ s/^\s*//;
|
3123 |
|
|
}
|
3124 |
|
|
|
3125 |
|
|
if ($cmd =~ /^lspc/) { # dump pc/ps -----------------
|
3126 |
|
|
return if cget_chkblank();
|
3127 |
|
|
serv11_cexec_shoreg(0);
|
3128 |
|
|
|
3129 |
|
|
} elsif ($cmd =~ /^lsmem/) { # dump memory --------------------
|
3130 |
|
|
my $opt_m = cget_opt("-m");
|
3131 |
|
|
my $opt_a = cget_opt("-a");
|
3132 |
|
|
my $abeg = cget_gdat(22, 8);
|
3133 |
|
|
return if $cmd_bad;
|
3134 |
|
|
my $aend = $abeg+64;
|
3135 |
|
|
my $fh = *STDOUT;
|
3136 |
|
|
my $redi = 0;
|
3137 |
|
|
if ($cmd_rest =~ /^:n(\d*)/) {
|
3138 |
|
|
$cmd_rest = $';
|
3139 |
|
|
$aend = $abeg + 2*(int $1);
|
3140 |
|
|
} elsif ($cmd_rest =~ /^:/) {
|
3141 |
|
|
$cmd_rest = $';
|
3142 |
|
|
$aend = cget_gdat(22, 8);
|
3143 |
|
|
return if $cmd_bad;
|
3144 |
|
|
}
|
3145 |
|
|
if ($cmd_rest =~ /^\s*(>{1,2})([\w\/.-]+)/) {
|
3146 |
|
|
$cmd_rest = $';
|
3147 |
|
|
my $oper = $1;
|
3148 |
|
|
my $file = $2;
|
3149 |
|
|
my $fh_new = new FileHandle;
|
3150 |
|
|
if ($fh_new->open("$oper$file")) {
|
3151 |
|
|
$fh = $fh_new;
|
3152 |
|
|
$redi = 1;
|
3153 |
|
|
} else {
|
3154 |
|
|
print "pi_rri($curmode)-E: failed to open output file $file\n";
|
3155 |
|
|
}
|
3156 |
|
|
}
|
3157 |
|
|
|
3158 |
|
|
$abeg &= 0xfffffffe;
|
3159 |
|
|
$aend &= 0xfffffffe;
|
3160 |
|
|
my $nword = int (($aend - $abeg)/2);
|
3161 |
|
|
$nword = 1 if $nword <= 1;
|
3162 |
|
|
|
3163 |
|
|
return if cget_chkblank();
|
3164 |
|
|
|
3165 |
|
|
my @data;
|
3166 |
|
|
my $rc = serv11_exec_rblk($abeg, 1, \@data, $nword);
|
3167 |
|
|
|
3168 |
|
|
my $inst_nw = 0;
|
3169 |
|
|
my $inst_str = "";
|
3170 |
|
|
printf $fh "Memory %8.8o:%8.8o:\n", $abeg, $aend;
|
3171 |
|
|
for (my $i=0; $i<$nword; $i++) {
|
3172 |
|
|
if ($opt_m) {
|
3173 |
|
|
($inst_str, $inst_nw) =
|
3174 |
|
|
pdp11_disassemble($abeg+2*$i, $data[$i],$data[$i+1],$data[$i+2]);
|
3175 |
|
|
printf $fh " %6.6o :", $abeg+2*$i;
|
3176 |
|
|
for (my $j=0; $j<3; $j++) {
|
3177 |
|
|
if ($j < $inst_nw) {
|
3178 |
|
|
printf $fh " %6.6o", (defined $data[$i+$j]) ? $data[$i+$j] : 0;
|
3179 |
|
|
} else {
|
3180 |
|
|
print $fh " ";
|
3181 |
|
|
}
|
3182 |
|
|
}
|
3183 |
|
|
printf $fh " # %s\n", $inst_str;
|
3184 |
|
|
$i += $inst_nw-1;
|
3185 |
|
|
|
3186 |
|
|
} elsif ($opt_a) {
|
3187 |
|
|
my $nline = $nword - $i;
|
3188 |
|
|
my $ascbuf;
|
3189 |
|
|
$nline = 4 if $nline > 4;
|
3190 |
|
|
printf $fh " %6.6o :", $abeg+2*$i;
|
3191 |
|
|
for (my $j=0; $j<$nline; $j++) {
|
3192 |
|
|
my $word = $data[$i+$j];
|
3193 |
|
|
my $bl = $word & 0377;
|
3194 |
|
|
my $bh = ($word>>8) & 0377;
|
3195 |
|
|
printf $fh " %3.3o %3.3o", $bl, $bh;
|
3196 |
|
|
$ascbuf .= " " . conv_byte2ascii2($bl);
|
3197 |
|
|
$ascbuf .= " " . conv_byte2ascii2($bh);
|
3198 |
|
|
}
|
3199 |
|
|
print $fh " " x (8*(4-$nline)+4);
|
3200 |
|
|
print $fh $ascbuf;
|
3201 |
|
|
print $fh "\n";
|
3202 |
|
|
$i += $nline-1;
|
3203 |
|
|
|
3204 |
|
|
} else {
|
3205 |
|
|
printf $fh " %6.6o : %6.6o\n", $abeg+2*$i, $data[$i];
|
3206 |
|
|
}
|
3207 |
|
|
}
|
3208 |
|
|
$fh->close() if $redi;
|
3209 |
|
|
|
3210 |
|
|
} elsif ($cmd =~ /^ldabs/) { # load absolute loader format ----
|
3211 |
|
|
my $opt_s = cget_opt("-s");
|
3212 |
|
|
my $file = cget_file();
|
3213 |
|
|
return if cget_chkblank();
|
3214 |
|
|
serv11_cexec_ldabs($file, $opt_s);
|
3215 |
|
|
|
3216 |
|
|
} elsif ($cmd =~ /^exa/) { # examine register or memory -----
|
3217 |
|
|
my $optset = cget_optset("ir");
|
3218 |
|
|
my ($ctl, $beg, $end) = cget_regrange();
|
3219 |
|
|
return if cget_chkblank();
|
3220 |
|
|
serv11_cexec_exa($optset, $ctl, $beg, $end);
|
3221 |
|
|
|
3222 |
|
|
|
3223 |
|
|
} elsif ($cmd =~ /^dep/) { # deposit register or memory -----
|
3224 |
|
|
my $optset = cget_optset("ir");
|
3225 |
|
|
my ($ctl, $beg, $end) = cget_regrange();
|
3226 |
|
|
my $data = cget_gdat(16, 8);
|
3227 |
|
|
return if cget_chkblank();
|
3228 |
|
|
serv11_cexec_dep($optset, $ctl, $beg, $end, $data);
|
3229 |
|
|
|
3230 |
|
|
|
3231 |
|
|
} elsif ($cmd =~ /^set/) { # set parameter ------------------
|
3232 |
|
|
my $what = cget_name();
|
3233 |
|
|
return if $cmd_bad;
|
3234 |
|
|
|
3235 |
|
|
if ($what =~ /^sim/) { # set sim[ulator] ------
|
3236 |
|
|
my $pnam = cget_name();
|
3237 |
|
|
my $val = cget_bool();
|
3238 |
|
|
return if $cmd_bad or cget_chkblank();
|
3239 |
|
|
my $ind;
|
3240 |
|
|
$ind = 15 if $pnam eq "cpmon";
|
3241 |
|
|
$ind = 14 if $pnam eq "rbmon";
|
3242 |
|
|
$ind = 13 if $pnam eq "tmu";
|
3243 |
|
|
if (defined $ind) {
|
3244 |
|
|
rri_sideband(0x00, ($ind<<8) + $val);
|
3245 |
|
|
} else {
|
3246 |
|
|
printf "pi_rri($curmode)-E: Invalid parameter '$pnam' for set sim\n";
|
3247 |
|
|
}
|
3248 |
|
|
|
3249 |
|
|
} else { # set ---------
|
3250 |
|
|
my $ctl = $serv11_ctltbl{uc($what)};
|
3251 |
|
|
if (defined $ctl) {
|
3252 |
|
|
my $partbl = $ctl->{partbl};
|
3253 |
|
|
if (defined $partbl) {
|
3254 |
|
|
my $pnam = cget_name();
|
3255 |
|
|
return if $cmd_bad;
|
3256 |
|
|
|
3257 |
|
|
my $pdsc = $partbl->{$pnam};
|
3258 |
|
|
if (defined $pdsc) {
|
3259 |
|
|
my $type = $pdsc->{type};
|
3260 |
|
|
if ($type =~ /^hval:([bdos])$/) {
|
3261 |
|
|
my $cnv = $1;
|
3262 |
|
|
my $val;
|
3263 |
|
|
if ($cnv eq "b") {
|
3264 |
|
|
$val = cget_bool();
|
3265 |
|
|
} elsif ($cnv eq "d") {
|
3266 |
|
|
$val = cget_gdat(32, 10);
|
3267 |
|
|
} elsif ($cnv eq "o") {
|
3268 |
|
|
$val = cget_gdat(32, 8);
|
3269 |
|
|
} elsif ($cnv eq "s") {
|
3270 |
|
|
$val = $cmd_rest;
|
3271 |
|
|
$val =~ s/^\s*//;
|
3272 |
|
|
$val =~ s/\s*$//;
|
3273 |
|
|
$cmd_rest = "";
|
3274 |
|
|
}
|
3275 |
|
|
return if $cmd_bad or cget_chkblank();
|
3276 |
|
|
$ctl->{$pnam} = $val;
|
3277 |
|
|
} else {
|
3278 |
|
|
print "pi_rri($curmode)-E: unexpected type $type in partbl\n";
|
3279 |
|
|
}
|
3280 |
|
|
} else {
|
3281 |
|
|
print "pi_rri($curmode)-E: '$pnam' not valid for 'set $what'\n";
|
3282 |
|
|
}
|
3283 |
|
|
} else {
|
3284 |
|
|
print "pi_rri($curmode)-I: nothing to set for '$what'\n";
|
3285 |
|
|
}
|
3286 |
|
|
} else {
|
3287 |
|
|
print "pi_rri($curmode)-E: unknown entity for 'set': \"$what\"\n";
|
3288 |
|
|
}
|
3289 |
|
|
}
|
3290 |
|
|
|
3291 |
|
|
} elsif ($cmd =~ /^sho/) { # show parameters ----------------
|
3292 |
|
|
my $what = cget_name();
|
3293 |
|
|
return if $cmd_bad;
|
3294 |
|
|
|
3295 |
|
|
if ($what =~ /^conf/) { # sho conf[iguration] --
|
3296 |
|
|
return if cget_chkblank();
|
3297 |
|
|
serv11_cexec_shoconf();
|
3298 |
|
|
|
3299 |
|
|
} elsif ($what =~ /^att/) { # sho att --------------
|
3300 |
|
|
return if cget_chkblank();
|
3301 |
|
|
serv11_cexec_shoatt();
|
3302 |
|
|
|
3303 |
|
|
} elsif ($what =~ /^regs/) { # sho regs -------------
|
3304 |
|
|
return if cget_chkblank();
|
3305 |
|
|
serv11_cexec_shoreg(1);
|
3306 |
|
|
|
3307 |
|
|
} elsif ($what =~ /^mmu/) { # sho mmu --------------
|
3308 |
|
|
return if cget_chkblank();
|
3309 |
|
|
serv11_cexec_shommu_ssrx;
|
3310 |
|
|
serv11_cexec_shommu_sadr(0172300, "KM");
|
3311 |
|
|
serv11_cexec_shommu_sadr(0172200, "SM");
|
3312 |
|
|
serv11_cexec_shommu_sadr(0177600, "UM");
|
3313 |
|
|
|
3314 |
|
|
} elsif ($what =~ /^ubm/) { # sho ubmap ------------
|
3315 |
|
|
return if cget_chkblank();
|
3316 |
|
|
|
3317 |
|
|
my @data;
|
3318 |
|
|
my $rc = serv11_exec_rblk(0170200, 0, \@data, 64);
|
3319 |
|
|
print "UNIBUS mapping registers:\n";
|
3320 |
|
|
for (my $i=0; $i<32; $i++) {
|
3321 |
|
|
printf " [%2d]: %2.2o,%6.6o\n", $i, $data[2*$i+1], $data[2*$i];
|
3322 |
|
|
}
|
3323 |
|
|
|
3324 |
|
|
} else { # sho ---------
|
3325 |
|
|
my $ctl = $serv11_ctltbl{uc($what)};
|
3326 |
|
|
if (defined $ctl) {
|
3327 |
|
|
my $partbl = $ctl->{partbl};
|
3328 |
|
|
if (defined $partbl) {
|
3329 |
|
|
foreach my $pnam (sort keys %{$partbl}) {
|
3330 |
|
|
my $pdsc = $partbl->{$pnam};
|
3331 |
|
|
my $type = $pdsc->{type};
|
3332 |
|
|
if ($type =~ /^hval:([bdos])$/) {
|
3333 |
|
|
my $cnv = $1;
|
3334 |
|
|
my $val = $ctl->{$pnam};
|
3335 |
|
|
my $val_str = $val;
|
3336 |
|
|
if (defined $val) {
|
3337 |
|
|
$val_str = ($val) ? "1 (yes)" : "0 (no)" if $cnv eq "b";
|
3338 |
|
|
$val_str = sprintf("%6d.", $val) if $cnv eq "d";
|
3339 |
|
|
$val_str = sprintf("%6.6o", $val) if $cnv eq "o";
|
3340 |
|
|
} else {
|
3341 |
|
|
$val_str = "";
|
3342 |
|
|
}
|
3343 |
|
|
printf "%4s %10s : %s\n", uc($what), $pnam, $val_str;
|
3344 |
|
|
} else {
|
3345 |
|
|
print "pi_rri($curmode)-E: unexpected type $type in partbl\n";
|
3346 |
|
|
}
|
3347 |
|
|
}
|
3348 |
|
|
} else {
|
3349 |
|
|
print "pi_rri($curmode)-I: nothing to show for '$what'\n";
|
3350 |
|
|
}
|
3351 |
|
|
} else {
|
3352 |
|
|
print "pi_rri($curmode)-E: unknown entity for 'sho': \"$what\"\n";
|
3353 |
|
|
}
|
3354 |
|
|
}
|
3355 |
|
|
|
3356 |
|
|
} elsif ($cmd =~ /^wtt/) { # write to TT decives -------------
|
3357 |
|
|
my $ucb = cget_ucb("term");
|
3358 |
|
|
my $str = "\\n";
|
3359 |
|
|
if ($cmd_rest =~ /^\s*"(.*)"\s*/) {
|
3360 |
|
|
$cmd_rest = $';
|
3361 |
|
|
$str = $1;
|
3362 |
|
|
}
|
3363 |
|
|
return if $cmd_bad or cget_chkblank();
|
3364 |
|
|
|
3365 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
3366 |
|
|
my @bytes;
|
3367 |
|
|
conv_str2bytes($str, \@bytes, 1);
|
3368 |
|
|
&{$ctl->{ichrhdl}}($ucb, \@bytes)
|
3369 |
|
|
|
3370 |
|
|
} elsif ($cmd =~ /^attn/) { # attn --------------------------
|
3371 |
|
|
return if cget_chkblank();
|
3372 |
|
|
serv11_server_attn_get();
|
3373 |
|
|
|
3374 |
|
|
} elsif ($cmd =~ /^att/) { # attach ------------------------
|
3375 |
|
|
my $ucb = cget_ucb();
|
3376 |
|
|
return if $cmd_bad;
|
3377 |
|
|
serv11_cexec_attdet(0,$ucb);
|
3378 |
|
|
|
3379 |
|
|
} elsif ($cmd =~ /^det/) { # detach ------------------------
|
3380 |
|
|
my $ucb = cget_ucb();
|
3381 |
|
|
return if cget_chkblank();
|
3382 |
|
|
serv11_cexec_attdet(1,$ucb);
|
3383 |
|
|
|
3384 |
|
|
} elsif ($cmd =~ /^init/) { # init --------------------------
|
3385 |
|
|
return if cget_chkblank();
|
3386 |
|
|
serv11_init_dispatch() if $serv11_init_pending;
|
3387 |
|
|
|
3388 |
|
|
} elsif ($cmd =~ /^boot/) { # boot --------------------------
|
3389 |
|
|
my $ucb = cget_ucb();
|
3390 |
|
|
return if $cmd_bad or cget_chkblank();
|
3391 |
|
|
serv11_cexec_boot($ucb);
|
3392 |
|
|
|
3393 |
|
|
} elsif ($cmd =~ /^start/) { # start --------------------------
|
3394 |
|
|
my $addr = cget_gdat(16, 8);
|
3395 |
|
|
return if cget_chkblank();
|
3396 |
|
|
my @rval;
|
3397 |
|
|
my $rc;
|
3398 |
|
|
serv11_rri_init(".anena", 0xff, $serv11_init_anena);# enable attn+ioto
|
3399 |
|
|
serv11_rri_attn("attn"); # discard old attn's
|
3400 |
|
|
serv11_rri_wreg("wpc", PDPCP_ADDR_PC, $addr);
|
3401 |
|
|
serv11_rri_wreg("sta", PDPCP_ADDR_CNTL, PDPCP_FUNC_STA);
|
3402 |
|
|
$rc = serv11_rri_exec(\@rval);
|
3403 |
|
|
|
3404 |
|
|
} elsif ($cmd =~ /^step/) { # step --------------------------
|
3405 |
|
|
my @rval;
|
3406 |
|
|
my $rc;
|
3407 |
|
|
serv11_rri_wreg("sta", PDPCP_ADDR_CNTL, PDPCP_FUNC_STEP);
|
3408 |
|
|
$rc = serv11_rri_exec(\@rval);
|
3409 |
|
|
serv11_cexec_shoreg(1);
|
3410 |
|
|
|
3411 |
|
|
} elsif ($cmd =~ /^stop/) { # stop --------------------------
|
3412 |
|
|
my @rval;
|
3413 |
|
|
my $rc;
|
3414 |
|
|
serv11_rri_wreg("sto", PDPCP_ADDR_CNTL, PDPCP_FUNC_STO);
|
3415 |
|
|
$rc = serv11_rri_exec(\@rval);
|
3416 |
|
|
serv11_cexec_shoreg(1);
|
3417 |
|
|
|
3418 |
|
|
} elsif ($cmd =~ /^cont/) { # cont --------------------------
|
3419 |
|
|
my @rval;
|
3420 |
|
|
my $rc;
|
3421 |
|
|
serv11_rri_wreg("sto", PDPCP_ADDR_CNTL, PDPCP_FUNC_CONT);
|
3422 |
|
|
$rc = serv11_rri_exec(\@rval);
|
3423 |
|
|
|
3424 |
|
|
} elsif ($cmd =~ /^reset/) { # reset -------------------------
|
3425 |
|
|
my @rval;
|
3426 |
|
|
my $rc;
|
3427 |
|
|
serv11_rri_wreg("rst", PDPCP_ADDR_CNTL, PDPCP_FUNC_RST);
|
3428 |
|
|
$rc = serv11_rri_exec(\@rval);
|
3429 |
|
|
|
3430 |
|
|
} elsif ($cmd =~ /^server/) { # enter server mode --------------
|
3431 |
|
|
return if cget_chkblank();
|
3432 |
|
|
serv11_server();
|
3433 |
|
|
|
3434 |
|
|
} else {
|
3435 |
|
|
print "pi_rri($curmode)-E: unknown command: \"$cmd_line\"\n";
|
3436 |
|
|
}
|
3437 |
|
|
}
|
3438 |
|
|
|
3439 |
|
|
|
3440 |
|
|
#-------------------------------------------------------------------------------
|
3441 |
|
|
|
3442 |
|
|
sub serv11_cexec_shoreg {
|
3443 |
|
|
my ($mode) = @_;
|
3444 |
|
|
my $ipc;
|
3445 |
|
|
my $ips;
|
3446 |
|
|
my @rval;
|
3447 |
|
|
|
3448 |
|
|
if ($mode > 0) {
|
3449 |
|
|
serv11_rri_rreg("rr0", PDPCP_ADDR_R0+0);
|
3450 |
|
|
serv11_rri_rreg("rr1", PDPCP_ADDR_R0+1);
|
3451 |
|
|
serv11_rri_rreg("rr2", PDPCP_ADDR_R0+2);
|
3452 |
|
|
serv11_rri_rreg("rr3", PDPCP_ADDR_R0+3);
|
3453 |
|
|
serv11_rri_rreg("rr4", PDPCP_ADDR_R0+4);
|
3454 |
|
|
serv11_rri_rreg("rr5", PDPCP_ADDR_R0+5);
|
3455 |
|
|
serv11_rri_rreg("rr6", PDPCP_ADDR_R0+6);
|
3456 |
|
|
}
|
3457 |
|
|
$ipc = serv11_rri_rreg("rr7", PDPCP_ADDR_R0+7);
|
3458 |
|
|
$ips = serv11_rri_rreg("rps", PDPCP_ADDR_PSW);
|
3459 |
|
|
|
3460 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
3461 |
|
|
|
3462 |
|
|
print "Processor registers and status:\n" if ($mode > 0);
|
3463 |
|
|
|
3464 |
|
|
my $ps_bin = gconv_dat16($rval[$ips],2);
|
3465 |
|
|
|
3466 |
|
|
printf " PC: %6.6o ", $rval[$ipc] if ($mode == 0);
|
3467 |
|
|
printf " PS: %6.6o", $rval[$ips];
|
3468 |
|
|
printf " cmo=%s",substr($ps_bin,0,2); # bit 15:14 -> 0,2
|
3469 |
|
|
printf " pmo=%s",substr($ps_bin,2,2); # bit 13:12 -> 2,2
|
3470 |
|
|
printf " set=%s",substr($ps_bin,4,1); # bit 11 -> 4
|
3471 |
|
|
printf " pri=%d",($rval[$ips]>>5)&0x7; # bit 07:05
|
3472 |
|
|
printf " t=%s", substr($ps_bin,11,1); # bit 04 -> 11,1
|
3473 |
|
|
printf " NZVC=%s", substr($ps_bin,12,4); # bit 03:00 -> 12,4
|
3474 |
|
|
print "\n";
|
3475 |
|
|
|
3476 |
|
|
if ($mode > 0) {
|
3477 |
|
|
printf " R0: %6.6o", $rval[0];
|
3478 |
|
|
printf " R1: %6.6o", $rval[1];
|
3479 |
|
|
printf " R2: %6.6o", $rval[2];
|
3480 |
|
|
printf " R3: %6.6o\n", $rval[3];
|
3481 |
|
|
printf " R4: %6.6o", $rval[4];
|
3482 |
|
|
printf " R5: %6.6o", $rval[5];
|
3483 |
|
|
printf " SP: %6.6o", $rval[6];
|
3484 |
|
|
printf " PC: %6.6o\n", $rval[$ipc];
|
3485 |
|
|
}
|
3486 |
|
|
}
|
3487 |
|
|
|
3488 |
|
|
#-------------------------------------------------------------------------------
|
3489 |
|
|
# ssr0 177572
|
3490 |
|
|
# ssr1 177574
|
3491 |
|
|
# ssr2 177576
|
3492 |
|
|
# ssr3 172516
|
3493 |
|
|
|
3494 |
|
|
sub serv11_cexec_shommu_ssrx {
|
3495 |
|
|
my @rval;
|
3496 |
|
|
|
3497 |
|
|
serv11_rri_wreg("wal", PDPCP_ADDR_AL, 0177572);
|
3498 |
|
|
my $issr0 = serv11_rri_rreg("rmi", PDPCP_ADDR_MEMI);
|
3499 |
|
|
my $issr1 = serv11_rri_rreg("rmi", PDPCP_ADDR_MEMI);
|
3500 |
|
|
my $issr2 = serv11_rri_rreg("rmi", PDPCP_ADDR_MEMI);
|
3501 |
|
|
serv11_rri_wreg("lal", PDPCP_ADDR_AL, 0172516);
|
3502 |
|
|
my $issr3 = serv11_rri_rreg("rmi", PDPCP_ADDR_MEMI);
|
3503 |
|
|
|
3504 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
3505 |
|
|
|
3506 |
|
|
print "MMU registers:\n";
|
3507 |
|
|
printf " SSR0: %6.6o\n", $rval[$issr0];
|
3508 |
|
|
printf " SSR1: %6.6o\n", $rval[$issr1];
|
3509 |
|
|
printf " SSR2: %6.6o\n", $rval[$issr2];
|
3510 |
|
|
printf " SSR3: %6.6o\n", $rval[$issr3];
|
3511 |
|
|
|
3512 |
|
|
}
|
3513 |
|
|
|
3514 |
|
|
#-------------------------------------------------------------------------------
|
3515 |
|
|
#
|
3516 |
|
|
# Note: The ptape maindec's have even size records, except possibly for the
|
3517 |
|
|
# last one, and always start at an even address.
|
3518 |
|
|
# The lda's extracted with UPD2 PIP from the xxdp22 disk have often
|
3519 |
|
|
# records with 503 byte payload, starting at even and odd addresses.
|
3520 |
|
|
# Since blkw only handles even sized transfers on even addresses some
|
3521 |
|
|
# magic with the %oddbyt hash is needed to handle this correctly.
|
3522 |
|
|
#
|
3523 |
|
|
sub serv11_cexec_ldabs {
|
3524 |
|
|
my ($file,$opt_s) = @_;
|
3525 |
|
|
if (not -r $file) {
|
3526 |
|
|
print "pi_rri($curmode)-E: file $file not found or readable\n";
|
3527 |
|
|
return;
|
3528 |
|
|
}
|
3529 |
|
|
my $fh = new FileHandle;
|
3530 |
|
|
|
3531 |
|
|
$fh->open("<$file") or die "unexpected open failure";
|
3532 |
|
|
|
3533 |
|
|
my $chrnum = 0; # char number in block
|
3534 |
|
|
my $blknum = 0; # block number
|
3535 |
|
|
my $bytcnt = 0; # byte count
|
3536 |
|
|
my $ldaddr = 0; # load address
|
3537 |
|
|
my $chksum = 0; # check sum
|
3538 |
|
|
my $addr = 0; # current address
|
3539 |
|
|
my @data; # data array for transfer
|
3540 |
|
|
my %oddbyt; # odd byte cache
|
3541 |
|
|
my $word;
|
3542 |
|
|
|
3543 |
|
|
while (1) {
|
3544 |
|
|
my $buf;
|
3545 |
|
|
my $rc = $fh->read($buf,1);
|
3546 |
|
|
if ($rc == 0) {
|
3547 |
|
|
print "pi_rri($curmode)-E: unexpected EOF in $file\n" unless $chrnum == 0;
|
3548 |
|
|
return;
|
3549 |
|
|
}
|
3550 |
|
|
|
3551 |
|
|
return if $rc != 1;
|
3552 |
|
|
my $byt = ord($buf);
|
3553 |
|
|
$chksum = ($chksum + $byt) & 0377;
|
3554 |
|
|
|
3555 |
|
|
if ($chrnum == 0) { # in blank tape
|
3556 |
|
|
if ($byt == 0) {
|
3557 |
|
|
next;
|
3558 |
|
|
} elsif ($byt == 1) {
|
3559 |
|
|
$chrnum += 1;
|
3560 |
|
|
} else {
|
3561 |
|
|
printf "pi_rri($curmode)-E: unexpected start-of-block %3.3o in $file\n",
|
3562 |
|
|
$byt;
|
3563 |
|
|
return;
|
3564 |
|
|
}
|
3565 |
|
|
|
3566 |
|
|
} elsif ($chrnum == 1) { # 001 frame seen
|
3567 |
|
|
if ($byt == 0) {
|
3568 |
|
|
$chrnum += 1;
|
3569 |
|
|
} else {
|
3570 |
|
|
printf "pi_rri($curmode)-E: unexpected 2nd char %3.3o in $file\n",
|
3571 |
|
|
$byt;
|
3572 |
|
|
return;
|
3573 |
|
|
}
|
3574 |
|
|
|
3575 |
|
|
} elsif ($chrnum == 2) { # byte count low
|
3576 |
|
|
$bytcnt = $byt & 0377;
|
3577 |
|
|
$chrnum += 1;
|
3578 |
|
|
} elsif ($chrnum == 3) { # byte count high
|
3579 |
|
|
$bytcnt |= ($byt & 0377)<<8;
|
3580 |
|
|
$chrnum += 1;
|
3581 |
|
|
|
3582 |
|
|
} elsif ($chrnum == 4) { # load address low
|
3583 |
|
|
$ldaddr = $byt & 0377;
|
3584 |
|
|
$chrnum += 1;
|
3585 |
|
|
} elsif ($chrnum == 5) { # load address high
|
3586 |
|
|
$ldaddr |= ($byt & 0377)<<8;
|
3587 |
|
|
$chrnum += 1;
|
3588 |
|
|
printf "pi_rri($curmode)-I: block %3d, length %5d byte,".
|
3589 |
|
|
" address %6.6o:%6.6o\n",
|
3590 |
|
|
$blknum, ($bytcnt-6), $ldaddr, $ldaddr+($bytcnt-6)-1;
|
3591 |
|
|
|
3592 |
|
|
$addr = $ldaddr; # setup current address
|
3593 |
|
|
$word = 0;
|
3594 |
|
|
if (($addr & 01) == 1 && $bytcnt > 6) { # setup even byte if known...
|
3595 |
|
|
$word = $oddbyt{sprintf("%6.6o",$addr)};
|
3596 |
|
|
if (not defined $word) {
|
3597 |
|
|
printf "pi_rri($curmode)-W: no low byte data for %6.6o\n", $addr;
|
3598 |
|
|
$word = 0;
|
3599 |
|
|
}
|
3600 |
|
|
}
|
3601 |
|
|
|
3602 |
|
|
} elsif ($chrnum == $bytcnt) { # check sum byte
|
3603 |
|
|
if ($chksum != 0) {
|
3604 |
|
|
printf "pi_rri($curmode)-E: check sum error %3.3o in $file\n",
|
3605 |
|
|
$chksum;
|
3606 |
|
|
return;
|
3607 |
|
|
}
|
3608 |
|
|
if ($chrnum == 6) {
|
3609 |
|
|
printf "pi_rri($curmode)-I: start address %6.6o\n", $ldaddr;
|
3610 |
|
|
return;
|
3611 |
|
|
} else {
|
3612 |
|
|
if (($addr & 01) == 1) { # high byte not yet seen
|
3613 |
|
|
push @data, $word; # zero fill high byte
|
3614 |
|
|
$oddbyt{sprintf("%6.6o",$addr)} = $word; # store even byte for later
|
3615 |
|
|
# note that address is odd here
|
3616 |
|
|
}
|
3617 |
|
|
serv11_exec_wblk($ldaddr, 0, \@data);
|
3618 |
|
|
@data = ();
|
3619 |
|
|
}
|
3620 |
|
|
$chrnum = 0;
|
3621 |
|
|
$blknum += 1;
|
3622 |
|
|
|
3623 |
|
|
} else { # in data
|
3624 |
|
|
if (($addr & 01) == 0) { # low byte
|
3625 |
|
|
$word = $byt & 0377;
|
3626 |
|
|
$addr += 1;
|
3627 |
|
|
} else { # high byte
|
3628 |
|
|
$word |= ($byt & 0377)<<8;
|
3629 |
|
|
push @data, $word;
|
3630 |
|
|
$addr += 1;
|
3631 |
|
|
}
|
3632 |
|
|
$chrnum += 1;
|
3633 |
|
|
}
|
3634 |
|
|
}
|
3635 |
|
|
|
3636 |
|
|
$fh->close();
|
3637 |
|
|
}
|
3638 |
|
|
|
3639 |
|
|
#-------------------------------------------------------------------------------
|
3640 |
|
|
# sadr format:
|
3641 |
|
|
# offset 0: DR[0] I space
|
3642 |
|
|
# offset 20: DR[0] D space
|
3643 |
|
|
# offset 40: AR[0] I space
|
3644 |
|
|
# offset 60: AR[0] D space
|
3645 |
|
|
#
|
3646 |
|
|
sub serv11_cexec_shommu_sadr {
|
3647 |
|
|
my ($base,$mode) = @_;
|
3648 |
|
|
my @data;
|
3649 |
|
|
my $rc = serv11_exec_rblk($base, 0, \@data, 32);
|
3650 |
|
|
|
3651 |
|
|
for (my $i=0; $i<16; $i++) {
|
3652 |
|
|
my $space = ($i<8) ? "I" : "D";
|
3653 |
|
|
my $ind = $i%8;
|
3654 |
|
|
my $dr = $data[$i];
|
3655 |
|
|
my $ar = $data[$i+16];
|
3656 |
|
|
my $dr_bin = gconv_dat16($dr,2);
|
3657 |
|
|
my $dr_acf = $dr&0xf; # bit 3:0
|
3658 |
|
|
|
3659 |
|
|
printf " %s-%s[%d]: %6.6o,%6.6o", $mode,$space,$ind, $dr, $ar;
|
3660 |
|
|
printf " slf=%3d", ($dr>>8)&0xff;
|
3661 |
|
|
printf " aib=%s", substr($dr_bin,8,2); # bit 7:6 -> 8,2
|
3662 |
|
|
printf " acf=%d", $dr_acf;
|
3663 |
|
|
print "\n";
|
3664 |
|
|
}
|
3665 |
|
|
|
3666 |
|
|
}
|
3667 |
|
|
|
3668 |
|
|
#-------------------------------------------------------------------------------
|
3669 |
|
|
|
3670 |
|
|
sub serv11_cexec_shoconf {
|
3671 |
|
|
foreach my $ctlname (sort { $serv11_ctltbl{$b}->{base} <=>
|
3672 |
|
|
$serv11_ctltbl{$a}->{base} }
|
3673 |
|
|
keys %serv11_ctltbl) {
|
3674 |
|
|
my $ctl = $serv11_ctltbl{$ctlname};
|
3675 |
|
|
my $mask = $ctl->{probemask};
|
3676 |
|
|
my $ival = $ctl->{probe_ival};
|
3677 |
|
|
my $rval = $ctl->{probe_rval};
|
3678 |
|
|
my $ib_str = ($mask =~ /i/) ? ( (defined $ival) ? "y" : "n" ) : "-";
|
3679 |
|
|
my $rb_str = ($mask =~ /r/) ? ( (defined $rval) ? "y" : "n" ) : "-";
|
3680 |
|
|
printf "%-3s %-9s %4s: %s ib=%s rb=%s lam=%s boot=%s", $ctlname,
|
3681 |
|
|
$ctl->{ctltype}, $ctl->{type},
|
3682 |
|
|
($ctl->{base} ? sprintf("%6.6o", $ctl->{base}) : "......"),
|
3683 |
|
|
$ib_str, $rb_str,
|
3684 |
|
|
(exists $ctl->{lam} ? sprintf("%2d",$ctl->{lam}) : " -"),
|
3685 |
|
|
(exists $ctl->{boot_code} ? "y" : "n");
|
3686 |
|
|
printf " %s",$ctl->{probe_text} if $ctl->{probe_text};
|
3687 |
|
|
print "\n";
|
3688 |
|
|
}
|
3689 |
|
|
}
|
3690 |
|
|
|
3691 |
|
|
#-------------------------------------------------------------------------------
|
3692 |
|
|
|
3693 |
|
|
sub serv11_cexec_shoatt {
|
3694 |
|
|
foreach my $unitname (sort keys %serv11_unittbl) {
|
3695 |
|
|
my $ucb = $serv11_unittbl{$unitname};
|
3696 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
3697 |
|
|
next unless $ctl->{probe_ok};
|
3698 |
|
|
next unless $ucb->{att_ok};
|
3699 |
|
|
printf "%-3s : ", $unitname;
|
3700 |
|
|
if ($ctl->{type} eq "disk") {
|
3701 |
|
|
printf "nblk=%6d wp=%s file=%s",
|
3702 |
|
|
$ucb->{att_nblk},
|
3703 |
|
|
($ucb->{att_wpro} ? "y" : "n"),
|
3704 |
|
|
$ucb->{att_file};
|
3705 |
|
|
} elsif ($ctl->{type} eq "tape") {
|
3706 |
|
|
printf "wp=%s file=%s",
|
3707 |
|
|
($ucb->{att_wpro} ? "y" : "n"),
|
3708 |
|
|
$ucb->{att_file};
|
3709 |
|
|
} elsif ($ctl->{type} eq "term") {
|
3710 |
|
|
printf "port=%s",
|
3711 |
|
|
$ucb->{att_port};
|
3712 |
|
|
}
|
3713 |
|
|
print "\n";
|
3714 |
|
|
}
|
3715 |
|
|
}
|
3716 |
|
|
|
3717 |
|
|
#-------------------------------------------------------------------------------
|
3718 |
|
|
|
3719 |
|
|
sub serv11_cexec_attdet {
|
3720 |
|
|
my ($det,$ucb) = @_;
|
3721 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
3722 |
|
|
|
3723 |
|
|
my $attdethdl = $ctl->{attdethdl};
|
3724 |
|
|
|
3725 |
|
|
if (not defined $attdethdl) {
|
3726 |
|
|
printf "pi_rri($curmode)-E: attach/detach not supported for %s\n",
|
3727 |
|
|
$ucb->{unitname};
|
3728 |
|
|
return;
|
3729 |
|
|
}
|
3730 |
|
|
|
3731 |
|
|
&{$attdethdl}($det, $ucb); # call handler
|
3732 |
|
|
|
3733 |
|
|
}
|
3734 |
|
|
|
3735 |
|
|
#-------------------------------------------------------------------------------
|
3736 |
|
|
|
3737 |
|
|
sub serv11_cexec_boot {
|
3738 |
|
|
my ($ucb) = @_;
|
3739 |
|
|
my @rval;
|
3740 |
|
|
my $rc;
|
3741 |
|
|
|
3742 |
|
|
my $unitname = $ucb->{unitname};
|
3743 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
3744 |
|
|
|
3745 |
|
|
if (not exists $ctl->{boot_code}) {
|
3746 |
|
|
print "pi_rri($curmode)-E: device $unitname not bootable\n";
|
3747 |
|
|
return;
|
3748 |
|
|
}
|
3749 |
|
|
|
3750 |
|
|
serv11_init_dispatch() if $serv11_init_pending;
|
3751 |
|
|
|
3752 |
|
|
my @boot_code = @{$ctl->{boot_code}};
|
3753 |
|
|
my $boot_length = scalar(@boot_code);
|
3754 |
|
|
my $boot_mode = $ctl->{boot_mode};
|
3755 |
|
|
my $boot_entry = $ctl->{boot_entry};
|
3756 |
|
|
|
3757 |
|
|
$boot_mode = "disk" unless defined $boot_mode;
|
3758 |
|
|
|
3759 |
|
|
if ($boot_mode eq "disk") {
|
3760 |
|
|
my $boot_unit = $ctl->{boot_unit};
|
3761 |
|
|
$boot_code[int (($boot_unit-(BOOT_START))/2)] =
|
3762 |
|
|
$ucb->{ctlunit}; # patch in unit num
|
3763 |
|
|
$rc = serv11_exec_wblk(BOOT_START, 0, \@boot_code, $boot_length);
|
3764 |
|
|
|
3765 |
|
|
} elsif ($boot_mode eq "ptape") {
|
3766 |
|
|
my $boot_base = $ctl->{boot_base};
|
3767 |
|
|
my $memsize = 56 * 1024; # FIXME: check memtop !!!
|
3768 |
|
|
$memsize = 56*1024 if ($memsize > 56*1024);
|
3769 |
|
|
my $nblk8k = $memsize/020000;
|
3770 |
|
|
my $offset = ($nblk8k-1) * 020000;
|
3771 |
|
|
$boot_base += $offset;
|
3772 |
|
|
$boot_entry += $offset;
|
3773 |
|
|
$rc = serv11_exec_wblk($boot_base, 0, \@boot_code, $boot_length);
|
3774 |
|
|
|
3775 |
|
|
} else {
|
3776 |
|
|
print_fatal("unsupported boot mode '$boot_mode' in serv11_cexec_boot");
|
3777 |
|
|
}
|
3778 |
|
|
|
3779 |
|
|
serv11_rri_init(".anena", 0xff, $serv11_init_anena); # enable attn+ioto
|
3780 |
|
|
serv11_rri_attn("attn"); # discard old attn's
|
3781 |
|
|
serv11_rri_wreg("wpc", PDPCP_ADDR_PC, $boot_entry);
|
3782 |
|
|
serv11_rri_wreg("sta", PDPCP_ADDR_CNTL, PDPCP_FUNC_STA);
|
3783 |
|
|
|
3784 |
|
|
$rc = serv11_rri_exec(\@rval);
|
3785 |
|
|
}
|
3786 |
|
|
|
3787 |
|
|
#-------------------------------------------------------------------------------
|
3788 |
|
|
|
3789 |
|
|
sub serv11_cexec_exa {
|
3790 |
|
|
my ($optset,$ctl,$beg,$end) = @_;
|
3791 |
|
|
|
3792 |
|
|
if (not defined $ctl) { # numerical address
|
3793 |
|
|
for (my $addr=$beg; $addr<=$end; $addr+=2) {
|
3794 |
|
|
my @rval;
|
3795 |
|
|
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr);
|
3796 |
|
|
serv11_rri_rreg("rm", PDPCP_ADDR_MEM);
|
3797 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
3798 |
|
|
printf "mem %6.6o : %6.6o\n", $addr, $rval[0];
|
3799 |
|
|
}
|
3800 |
|
|
|
3801 |
|
|
} else {
|
3802 |
|
|
|
3803 |
|
|
my $reglist = $ctl->{reglist};
|
3804 |
|
|
for (my $i=$beg; $i<=$end; $i++) {
|
3805 |
|
|
my $dsc = $reglist->[$i];
|
3806 |
|
|
last if not defined $reglist->[$i];
|
3807 |
|
|
my $name = $dsc->{name};
|
3808 |
|
|
my $addr = $dsc->{addr};
|
3809 |
|
|
my $offset = $dsc->{offset};
|
3810 |
|
|
my $attr = $dsc->{attr};
|
3811 |
|
|
my $val;
|
3812 |
|
|
my $addr_str = "......";
|
3813 |
|
|
my $acs_str = "ib";
|
3814 |
|
|
my $val_str = "......";
|
3815 |
|
|
my $com_str = "";
|
3816 |
|
|
|
3817 |
|
|
$addr = $ctl->{base} + $offset if defined $offset;
|
3818 |
|
|
|
3819 |
|
|
$attr = 0 unless defined $attr;
|
3820 |
|
|
|
3821 |
|
|
$acs_str = "rb" if ($attr & REGATTR_RBRD);
|
3822 |
|
|
$acs_str = "ib" if $optset =~ /i/;
|
3823 |
|
|
$acs_str = "rb" if $optset =~ /r/;
|
3824 |
|
|
|
3825 |
|
|
if ($end > $beg &&
|
3826 |
|
|
( ( ($attr & REGATTR_IBMBOX) && $acs_str eq "ib" ) ||
|
3827 |
|
|
( ($attr & REGATTR_RBMBOX) && $acs_str eq "rb" )
|
3828 |
|
|
) ) {
|
3829 |
|
|
$com_str = "mailbox skipped";
|
3830 |
|
|
|
3831 |
|
|
} else {
|
3832 |
|
|
|
3833 |
|
|
my $exadethdl = $dsc->{hdl};
|
3834 |
|
|
if (defined $dsc->{hdl}) {
|
3835 |
|
|
$acs_str = " ";
|
3836 |
|
|
$val = &{$dsc->{hdl}}(0, $dsc);
|
3837 |
|
|
|
3838 |
|
|
} else {
|
3839 |
|
|
if ($acs_str eq "rb") {
|
3840 |
|
|
my $ibrbase = $addr & ~(077);
|
3841 |
|
|
my $ibroff = $addr - $ibrbase;
|
3842 |
|
|
serv11_rri_wreg("wibrb", PDPCP_ADDR_IBRB, $ibrbase);
|
3843 |
|
|
serv11_rri_rreg("ribr", PDPCP_ADDR_IBR + int($ibroff/2));
|
3844 |
|
|
$acs_str = "rb";
|
3845 |
|
|
} else {
|
3846 |
|
|
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr);
|
3847 |
|
|
serv11_rri_rreg("rm", PDPCP_ADDR_MEM);
|
3848 |
|
|
$acs_str = "ib";
|
3849 |
|
|
}
|
3850 |
|
|
my @rval;
|
3851 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
3852 |
|
|
$val = $rval[0];
|
3853 |
|
|
}
|
3854 |
|
|
}
|
3855 |
|
|
|
3856 |
|
|
$addr_str = sprintf("%6.6o", $addr) if defined $addr;
|
3857 |
|
|
$val_str = sprintf("%6.6o", $val) if defined $val;
|
3858 |
|
|
printf "%4s %6s %2s %6s : %6s", $ctl->{ctlname}, $name,
|
3859 |
|
|
$acs_str, $addr_str, $val_str;
|
3860 |
|
|
print " $com_str" if defined $com_str;
|
3861 |
|
|
print "\n";
|
3862 |
|
|
}
|
3863 |
|
|
|
3864 |
|
|
}
|
3865 |
|
|
}
|
3866 |
|
|
|
3867 |
|
|
#-------------------------------------------------------------------------------
|
3868 |
|
|
|
3869 |
|
|
sub serv11_cexec_dep {
|
3870 |
|
|
my ($optset,$ctl,$beg,$end,$data) = @_;
|
3871 |
|
|
|
3872 |
|
|
if (not defined $ctl) { # numerical address
|
3873 |
|
|
for (my $addr=$beg; $addr<=$end; $addr+=2) {
|
3874 |
|
|
my @rval;
|
3875 |
|
|
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr);
|
3876 |
|
|
serv11_rri_wreg("wm", PDPCP_ADDR_MEM, $data);
|
3877 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
3878 |
|
|
}
|
3879 |
|
|
|
3880 |
|
|
} else {
|
3881 |
|
|
|
3882 |
|
|
my $reglist = $ctl->{reglist};
|
3883 |
|
|
for (my $i=$beg; $i<=$end; $i++) {
|
3884 |
|
|
my $dsc = $reglist->[$i];
|
3885 |
|
|
last if not defined $reglist->[$i];
|
3886 |
|
|
my $name = $dsc->{name};
|
3887 |
|
|
my $addr = $dsc->{addr};
|
3888 |
|
|
my $offset = $dsc->{offset};
|
3889 |
|
|
my $attr = $dsc->{attr};
|
3890 |
|
|
my $acs_str = "ib";
|
3891 |
|
|
|
3892 |
|
|
$addr = $ctl->{base} + $offset if defined $offset;
|
3893 |
|
|
|
3894 |
|
|
$attr = 0 unless defined $attr;
|
3895 |
|
|
|
3896 |
|
|
$acs_str = "rb" if ($attr & REGATTR_RBWR);
|
3897 |
|
|
$acs_str = "ib" if $optset =~ /i/;
|
3898 |
|
|
$acs_str = "rb" if $optset =~ /r/;
|
3899 |
|
|
|
3900 |
|
|
my $exadethdl = $dsc->{hdl};
|
3901 |
|
|
if (defined $dsc->{hdl}) {
|
3902 |
|
|
$acs_str = " ";
|
3903 |
|
|
&{$dsc->{hdl}}(1, $dsc, $data);
|
3904 |
|
|
|
3905 |
|
|
} else {
|
3906 |
|
|
if ($acs_str eq "rb") {
|
3907 |
|
|
my $ibrbase = $addr & ~(077);
|
3908 |
|
|
my $ibroff = $addr - $ibrbase;
|
3909 |
|
|
serv11_rri_wreg("wibrb", PDPCP_ADDR_IBRB, $ibrbase);
|
3910 |
|
|
serv11_rri_wreg("wibr", PDPCP_ADDR_IBR + int($ibroff/2), $data);
|
3911 |
|
|
$acs_str = "rb";
|
3912 |
|
|
} else {
|
3913 |
|
|
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr);
|
3914 |
|
|
serv11_rri_wreg("wm", PDPCP_ADDR_MEM, $data);
|
3915 |
|
|
$acs_str = "ib";
|
3916 |
|
|
}
|
3917 |
|
|
my @rval;
|
3918 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
3919 |
|
|
}
|
3920 |
|
|
|
3921 |
|
|
}
|
3922 |
|
|
|
3923 |
|
|
}
|
3924 |
|
|
|
3925 |
|
|
}
|
3926 |
|
|
|
3927 |
|
|
#-------------------------------------------------------------------------------
|
3928 |
|
|
# config is called once on the first entering of serv11 mode
|
3929 |
|
|
#
|
3930 |
|
|
sub serv11_config {
|
3931 |
|
|
$serv11_config_done = 1;
|
3932 |
|
|
|
3933 |
|
|
foreach my $ctlname (sort keys %serv11_ctltbl) {
|
3934 |
|
|
my $ctl = $serv11_ctltbl{$ctlname};
|
3935 |
|
|
$ctl->{probemask} = "ir" unless defined $ctl->{probemask};
|
3936 |
|
|
&{$ctl->{probehdl}}($ctl) if exists $ctl->{probehdl};
|
3937 |
|
|
}
|
3938 |
|
|
|
3939 |
|
|
if (not $serv11_ctltbl{CPU}->{probe_ok}) {
|
3940 |
|
|
print_fatal("probe of CPU failed in serv11_open()");
|
3941 |
|
|
}
|
3942 |
|
|
|
3943 |
|
|
init_regtbl();
|
3944 |
|
|
serv11_cexec_shoconf();
|
3945 |
|
|
}
|
3946 |
|
|
|
3947 |
|
|
#-------------------------------------------------------------------------------
|
3948 |
|
|
|
3949 |
|
|
sub serv11_init_dispatch {
|
3950 |
|
|
foreach my $ctlname (sort keys %serv11_ctltbl) {
|
3951 |
|
|
my $ctl = $serv11_ctltbl{$ctlname};
|
3952 |
|
|
&{$ctl->{inithdl}}($ctl) if (exists $ctl->{inithdl} && $ctl->{probe_ok});
|
3953 |
|
|
}
|
3954 |
|
|
$serv11_init_pending = 0;
|
3955 |
|
|
}
|
3956 |
|
|
|
3957 |
|
|
#-------------------------------------------------------------------------------
|
3958 |
|
|
|
3959 |
|
|
sub serv11_server {
|
3960 |
|
|
my $old_timeout = $raw_timeout;
|
3961 |
|
|
my $nfound;
|
3962 |
|
|
my $fds_rd_act = "";
|
3963 |
|
|
my $fds_rd;
|
3964 |
|
|
my $stat_delta = 10.;
|
3965 |
|
|
my $stat_count = 0;
|
3966 |
|
|
|
3967 |
|
|
my $fno_rcv = fileno($fh_rcv);
|
3968 |
|
|
my $fno_stdin = fileno(STDIN);
|
3969 |
|
|
|
3970 |
|
|
my @telfno2dsc;
|
3971 |
|
|
|
3972 |
|
|
@serv11_attntbl = ();
|
3973 |
|
|
foreach my $ctlname (sort keys %serv11_ctltbl) {
|
3974 |
|
|
my $ctl = $serv11_ctltbl{$ctlname};
|
3975 |
|
|
if ($ctl->{probe_ok} && exists $ctl->{lam} && exists $ctl->{attnhdl}) {
|
3976 |
|
|
push @serv11_attntbl, [1<<($ctl->{lam}), $ctl->{attnhdl}, $ctl];
|
3977 |
|
|
}
|
3978 |
|
|
}
|
3979 |
|
|
|
3980 |
|
|
$raw_timeout = 30.;
|
3981 |
|
|
$serv11_active = 1;
|
3982 |
|
|
print "pi_rri($curmode)-I: entering server mode\n";
|
3983 |
|
|
|
3984 |
|
|
my $time_stat = get_time() + $stat_delta;
|
3985 |
|
|
|
3986 |
|
|
while ($serv11_active) {
|
3987 |
|
|
my $time_now = get_time();
|
3988 |
|
|
if ($time_now >= $time_stat) {
|
3989 |
|
|
##serv11_server_attn_dispatch(1);
|
3990 |
|
|
if ($stat_count % 20 == 0) {
|
3991 |
|
|
printf $fh_log "stat -- ";
|
3992 |
|
|
printf $fh_log " obyte oesc osop ibyte iesc att";
|
3993 |
|
|
printf $fh_log " xreg xblk rdisk wdisk";
|
3994 |
|
|
printf $fh_log "\n";
|
3995 |
|
|
}
|
3996 |
|
|
$stat_count += 1;
|
3997 |
|
|
my $dt = $stat_delta;
|
3998 |
|
|
|
3999 |
|
|
printf $fh_log "stat -- %s", get_timestamp();
|
4000 |
|
|
printf $fh_log " %6.0f", ($stat_tab{obyte} - $stat_tab_last{obyte})/$dt;
|
4001 |
|
|
printf $fh_log " %4.0f", ($stat_tab{oesc} - $stat_tab_last{oesc})/$dt;
|
4002 |
|
|
printf $fh_log " %4.0f", ($stat_tab{osop} - $stat_tab_last{osop})/$dt;
|
4003 |
|
|
printf $fh_log " %6.0f", ($stat_tab{ibyte} - $stat_tab_last{ibyte})/$dt;
|
4004 |
|
|
printf $fh_log " %4.0f", ($stat_tab{iesc} - $stat_tab_last{iesc})/$dt;
|
4005 |
|
|
printf $fh_log " %3.0f", ($stat_tab{att} - $stat_tab_last{att})/$dt;
|
4006 |
|
|
printf $fh_log " %5.0f", ($stat_tab{xreg} - $stat_tab_last{xreg})/$dt;
|
4007 |
|
|
printf $fh_log " %4.0f", ($stat_tab{xblk} - $stat_tab_last{xblk})/$dt;
|
4008 |
|
|
printf $fh_log " %6.0f", ($stat_tab{rdisk} - $stat_tab_last{rdisk})/$dt;
|
4009 |
|
|
printf $fh_log " %6.0f", ($stat_tab{wdisk} - $stat_tab_last{wdisk})/$dt;
|
4010 |
|
|
printf $fh_log "\n";
|
4011 |
|
|
%stat_tab_last = %stat_tab;
|
4012 |
|
|
|
4013 |
|
|
while ($time_stat < $time_now) {
|
4014 |
|
|
$time_stat += $stat_delta;
|
4015 |
|
|
}
|
4016 |
|
|
}
|
4017 |
|
|
|
4018 |
|
|
my $timeout = $time_stat - $time_now;
|
4019 |
|
|
|
4020 |
|
|
# set timeout=0 if some unfinished business is still pending
|
4021 |
|
|
|
4022 |
|
|
$timeout = 0. if $serv11_attn_mask != 0; # attn mask not yet worked down
|
4023 |
|
|
$timeout = 0. if scalar(@serv11_icbque); # icb queue non empty
|
4024 |
|
|
$timeout = 0. if scalar(@que_rcv); # still input chars in buffer
|
4025 |
|
|
|
4026 |
|
|
if ($serv11_fds_update) {
|
4027 |
|
|
$fds_rd_act = "";
|
4028 |
|
|
vec($fds_rd_act, $fno_rcv, 1) = 1;
|
4029 |
|
|
vec($fds_rd_act, $fno_stdin, 1) = 1;
|
4030 |
|
|
|
4031 |
|
|
@telfno2dsc = ();
|
4032 |
|
|
foreach my $port_str (keys %telnettbl) {
|
4033 |
|
|
my $teldsc = $telnettbl{$port_str};
|
4034 |
|
|
my $fno;
|
4035 |
|
|
if ($teldsc->{state} == TELNET_STATE_LISTEN) {
|
4036 |
|
|
$fno = fileno($teldsc->{fh_port});
|
4037 |
|
|
} else {
|
4038 |
|
|
$fno = fileno($teldsc->{fh_data});
|
4039 |
|
|
}
|
4040 |
|
|
vec($fds_rd_act, $fno, 1) = 1;
|
4041 |
|
|
push @telfno2dsc, [$fno, $teldsc];
|
4042 |
|
|
}
|
4043 |
|
|
$serv11_fds_update = 0;
|
4044 |
|
|
}
|
4045 |
|
|
|
4046 |
|
|
##printf $fh_log "+++1 select $timeout, rcvq=%d\n", scalar(@que_rcv);
|
4047 |
|
|
$nfound = select($fds_rd=$fds_rd_act, undef, undef, $timeout);
|
4048 |
|
|
##printf $fh_log "+++2 select $nfound\n";
|
4049 |
|
|
|
4050 |
|
|
if (vec($fds_rd, $fno_stdin, 1)) {
|
4051 |
|
|
my $cmd = ;
|
4052 |
|
|
if (defined $cmd) {
|
4053 |
|
|
chomp $cmd;
|
4054 |
|
|
|
4055 |
|
|
$cmd = "lspc" unless $cmd ne "";
|
4056 |
|
|
|
4057 |
|
|
$cmd =~ s{^\s*}{}; # remove leading blanks
|
4058 |
|
|
$cmd =~ s{--.*}{}; # remove comments after --
|
4059 |
|
|
$cmd =~ s{\s*$}{}; # remove trailing blanks
|
4060 |
|
|
|
4061 |
|
|
|
4062 |
|
|
if ($cmd eq "quit") {
|
4063 |
|
|
$serv11_active = 0;
|
4064 |
|
|
} else {
|
4065 |
|
|
if ($cmd =~ m/^C/) { # ignore, but log "C ..." lines
|
4066 |
|
|
print $fh_log "$cmd\n";
|
4067 |
|
|
} elsif ($cmd =~ m/^#/) { # ignore "# ...." lines
|
4068 |
|
|
} elsif ($cmd =~ m/^;/) { # ignore "; ...." lines
|
4069 |
|
|
} else { # otherwise execute
|
4070 |
|
|
serv11_cexec($cmd);
|
4071 |
|
|
}
|
4072 |
|
|
}
|
4073 |
|
|
} else { # handle ^D
|
4074 |
|
|
$serv11_active = 0;
|
4075 |
|
|
}
|
4076 |
|
|
}
|
4077 |
|
|
|
4078 |
|
|
# process next input char if read will not block (either fd ready for
|
4079 |
|
|
# input, or still chars in queue).
|
4080 |
|
|
|
4081 |
|
|
if (vec($fds_rd, $fno_rcv, 1) || scalar(@que_rcv)) {
|
4082 |
|
|
my $dat = raw_rcv9_to(0.);
|
4083 |
|
|
if (not defined $dat) {
|
4084 |
|
|
print "pi_rri($curmode)-I: spurious select on rcv channel\n";
|
4085 |
|
|
next;
|
4086 |
|
|
} elsif ($dat == D9IDLE) {
|
4087 |
|
|
next;
|
4088 |
|
|
} elsif ($dat == D9ATTN) {
|
4089 |
|
|
serv11_server_attn_get();
|
4090 |
|
|
} else {
|
4091 |
|
|
printf "pi_rri($curmode)-I: spurious char on server wait: %3.3x\n",
|
4092 |
|
|
$dat;
|
4093 |
|
|
next;
|
4094 |
|
|
}
|
4095 |
|
|
}
|
4096 |
|
|
|
4097 |
|
|
# process telnet sessions
|
4098 |
|
|
foreach (@telfno2dsc) {
|
4099 |
|
|
my $fno = $_->[0];
|
4100 |
|
|
if (vec($fds_rd, $fno, 1)) {
|
4101 |
|
|
my $teldsc = $_->[1];
|
4102 |
|
|
telnet_readhdl($teldsc);
|
4103 |
|
|
}
|
4104 |
|
|
}
|
4105 |
|
|
|
4106 |
|
|
if ($serv11_attn_mask != 0) {
|
4107 |
|
|
serv11_server_attn_dispatch(0);
|
4108 |
|
|
}
|
4109 |
|
|
|
4110 |
|
|
if (scalar(@serv11_icbque)) {
|
4111 |
|
|
my $icb = shift @serv11_icbque;
|
4112 |
|
|
&{$icb->{rdmahdl}}($icb);
|
4113 |
|
|
}
|
4114 |
|
|
|
4115 |
|
|
if ($serv11_attn_mask == 0 && $serv11_attn_seen) {
|
4116 |
|
|
$serv11_attn_seen = 0;
|
4117 |
|
|
serv11_server_attn_get();
|
4118 |
|
|
}
|
4119 |
|
|
|
4120 |
|
|
}
|
4121 |
|
|
|
4122 |
|
|
$raw_timeout = $old_timeout;
|
4123 |
|
|
$serv11_active = 0;
|
4124 |
|
|
print "pi_rri($curmode)-I: leaving server mode\n";
|
4125 |
|
|
}
|
4126 |
|
|
|
4127 |
|
|
#-------------------------------------------------------------------------------
|
4128 |
|
|
|
4129 |
|
|
sub serv11_server_attn_get {
|
4130 |
|
|
my @rval;
|
4131 |
|
|
my $rc;
|
4132 |
|
|
|
4133 |
|
|
serv11_rri_attn("attn");
|
4134 |
|
|
$rc = serv11_rri_exec(\@rval);
|
4135 |
|
|
|
4136 |
|
|
my $mask_old = $serv11_attn_mask;
|
4137 |
|
|
$serv11_attn_mask |= $rval[0]; # or-in new attn flags
|
4138 |
|
|
|
4139 |
|
|
if (exists $opts{tserv}) {
|
4140 |
|
|
printf $fh_log "serv -- attn %s :", gconv_dat16($serv11_attn_mask, 2);
|
4141 |
|
|
foreach my $adsc (@serv11_attntbl) {
|
4142 |
|
|
my $msk = $adsc->[0];
|
4143 |
|
|
my $ctl = $adsc->[2];
|
4144 |
|
|
if ($serv11_attn_mask & $msk) {
|
4145 |
|
|
my $pref = "";
|
4146 |
|
|
my $suff = "";
|
4147 |
|
|
if ($mask_old & $msk) { # old flags are in ()
|
4148 |
|
|
$pref = "(";
|
4149 |
|
|
$suff = ")";
|
4150 |
|
|
}
|
4151 |
|
|
printf $fh_log " %s%s%s", $pref, $ctl->{ctlname}, $suff;
|
4152 |
|
|
}
|
4153 |
|
|
}
|
4154 |
|
|
printf $fh_log "\n";
|
4155 |
|
|
}
|
4156 |
|
|
|
4157 |
|
|
}
|
4158 |
|
|
|
4159 |
|
|
#-------------------------------------------------------------------------------
|
4160 |
|
|
|
4161 |
|
|
sub serv11_server_attn_dispatch {
|
4162 |
|
|
my ($force) = @_;
|
4163 |
|
|
foreach my $adsc (@serv11_attntbl) {
|
4164 |
|
|
my $msk = $adsc->[0];
|
4165 |
|
|
my $hdl = $adsc->[1];
|
4166 |
|
|
my $ctl = $adsc->[2];
|
4167 |
|
|
if (($serv11_attn_mask & $msk) || $force) {
|
4168 |
|
|
$serv11_attn_mask &= ~$msk;
|
4169 |
|
|
&{$hdl}($ctl,$force);
|
4170 |
|
|
}
|
4171 |
|
|
}
|
4172 |
|
|
}
|
4173 |
|
|
|
4174 |
|
|
#-------------------------------------------------------------------------------
|
4175 |
|
|
|
4176 |
|
|
sub serv11_probe_gen { # generic probe handler
|
4177 |
|
|
my ($ctl) = @_;
|
4178 |
|
|
my $mask = $ctl->{probemask};
|
4179 |
|
|
my $addr = $ctl->{base};
|
4180 |
|
|
$addr += $ctl->{csroff} if defined $ctl->{csroff};
|
4181 |
|
|
my ($ival,$rval) = serv11_exec_probe($addr, $mask);
|
4182 |
|
|
$ctl->{probe_ival} = $ival;
|
4183 |
|
|
$ctl->{probe_rval} = $rval;
|
4184 |
|
|
$ctl->{probe_ok} = 1;
|
4185 |
|
|
$ctl->{probe_ok} = 0 if ($mask =~ /i/ && ! defined $ival);
|
4186 |
|
|
$ctl->{probe_ok} = 0 if ($mask =~ /r/ && ! defined $rval);
|
4187 |
|
|
}
|
4188 |
|
|
|
4189 |
|
|
#-------------------------------------------------------------------------------
|
4190 |
|
|
|
4191 |
|
|
sub serv11_init_gen { # generic controller init handler
|
4192 |
|
|
my ($ctl) = @_;
|
4193 |
|
|
|
4194 |
|
|
if (exists $ctl->{usethdl}) {
|
4195 |
|
|
foreach my $unitname (@{$ctl->{units}}) {
|
4196 |
|
|
my $ucb = $serv11_unittbl{$unitname};
|
4197 |
|
|
&{$ctl->{usethdl}}($ucb);
|
4198 |
|
|
}
|
4199 |
|
|
} else {
|
4200 |
|
|
printf "pi_rri($curmode)-E: usethdl not defined for %s\n", $ctl->{ctlname};
|
4201 |
|
|
}
|
4202 |
|
|
}
|
4203 |
|
|
|
4204 |
|
|
#-------------------------------------------------------------------------------
|
4205 |
|
|
|
4206 |
|
|
sub serv11_detach_gen { # generic detach handler
|
4207 |
|
|
my ($ucb) = @_;
|
4208 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
4209 |
|
|
|
4210 |
|
|
if ($ucb->{att_ok}) {
|
4211 |
|
|
my $fh = $ucb->{att_fh};
|
4212 |
|
|
$fh->close() or die "Unexpected close error";
|
4213 |
|
|
$ucb->{att_ok} = 0;
|
4214 |
|
|
delete $ucb->{att_file};
|
4215 |
|
|
delete $ucb->{att_nbyt};
|
4216 |
|
|
delete $ucb->{att_nblk};
|
4217 |
|
|
delete $ucb->{att_wpro};
|
4218 |
|
|
delete $ucb->{att_fh};
|
4219 |
|
|
delete $ucb->{att_eof};
|
4220 |
|
|
&{$ctl->{usethdl}}($ucb); # setup unit registers
|
4221 |
|
|
|
4222 |
|
|
} else {
|
4223 |
|
|
printf "pi_rri($curmode)-E: no file attached for %s\n", $ucb->{unitname};
|
4224 |
|
|
}
|
4225 |
|
|
}
|
4226 |
|
|
|
4227 |
|
|
#-------------------------------------------------------------------------------
|
4228 |
|
|
|
4229 |
|
|
sub serv11_attdet_disk { # generic disk att/det handler
|
4230 |
|
|
my ($det,$ucb) = @_;
|
4231 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
4232 |
|
|
|
4233 |
|
|
if ($det) { # detach handling
|
4234 |
|
|
serv11_detach_gen($ucb);
|
4235 |
|
|
|
4236 |
|
|
} else { # attach handling
|
4237 |
|
|
if (cget_opt("-w")) { # -w remount
|
4238 |
|
|
return if $cmd_bad or cget_chkblank();
|
4239 |
|
|
my $fh = $ucb->{att_fh};
|
4240 |
|
|
if ($fh) { # mounted and open ?
|
4241 |
|
|
if (-w $fh) { # file writable ?
|
4242 |
|
|
$ucb->{att_wpro} = 0; # remove write protect
|
4243 |
|
|
&{$ctl->{usethdl}}($ucb); # setup unit registers
|
4244 |
|
|
} else {
|
4245 |
|
|
printf "pi_rri($curmode)-E: file %s (for %s) is write protected\n",
|
4246 |
|
|
$ucb->{att_file}, $ucb->{unitname};
|
4247 |
|
|
return;
|
4248 |
|
|
}
|
4249 |
|
|
} else {
|
4250 |
|
|
printf "pi_rri($curmode)-E: no file attached for %s\n",
|
4251 |
|
|
$ucb->{unitname};
|
4252 |
|
|
return;
|
4253 |
|
|
}
|
4254 |
|
|
|
4255 |
|
|
} else { # normal (non -w) handling
|
4256 |
|
|
my $opt_r = cget_opt("-r");
|
4257 |
|
|
my $filename = cget_file();
|
4258 |
|
|
return if $cmd_bad or cget_chkblank();
|
4259 |
|
|
|
4260 |
|
|
if (not -e $filename) {
|
4261 |
|
|
print "pi_rri($curmode)-E: file $filename not found\n";
|
4262 |
|
|
return;
|
4263 |
|
|
}
|
4264 |
|
|
if (not -r $filename) {
|
4265 |
|
|
print "pi_rri($curmode)-E: file $filename is not readable\n";
|
4266 |
|
|
return;
|
4267 |
|
|
}
|
4268 |
|
|
|
4269 |
|
|
my $wpro = $opt_r;
|
4270 |
|
|
if (! $wpro && ! -w $filename) {
|
4271 |
|
|
print "pi_rri($curmode)-I: file $filename is write protected\n";
|
4272 |
|
|
$wpro = 1;
|
4273 |
|
|
}
|
4274 |
|
|
|
4275 |
|
|
my $filesize = -s $filename;
|
4276 |
|
|
|
4277 |
|
|
if (defined $ctl->{volsize}) {
|
4278 |
|
|
if ($filesize < $ctl->{volsize}) {
|
4279 |
|
|
printf "pi_rri($curmode)-W: dsk file too small, %s requires %d".
|
4280 |
|
|
" file $filename has %d bytes\n",
|
4281 |
|
|
$ucb->{unitname}, $ctl->{volsize}, $filesize;
|
4282 |
|
|
}
|
4283 |
|
|
}
|
4284 |
|
|
|
4285 |
|
|
my $fh = new FileHandle;
|
4286 |
|
|
sysopen ($fh, $filename, $wpro ? O_RDONLY : O_RDWR)
|
4287 |
|
|
or die "Unexpected sysopen error";
|
4288 |
|
|
|
4289 |
|
|
$ucb->{att_ok} = 1;
|
4290 |
|
|
$ucb->{att_file} = $filename;
|
4291 |
|
|
$ucb->{att_nbyt} = $filesize;
|
4292 |
|
|
$ucb->{att_wpro} = $wpro;
|
4293 |
|
|
$ucb->{att_fh} = $fh;
|
4294 |
|
|
|
4295 |
|
|
$ucb->{att_nblk} = int ($ucb->{att_nbyt}/512);
|
4296 |
|
|
if ($ucb->{att_nbyt}%512 != 0) {
|
4297 |
|
|
print "pi_rri($curmode)-I: size $filename not multiple of 512\n";
|
4298 |
|
|
}
|
4299 |
|
|
&{$ctl->{usethdl}}($ucb); # setup unit registers
|
4300 |
|
|
}
|
4301 |
|
|
}
|
4302 |
|
|
}
|
4303 |
|
|
|
4304 |
|
|
#-------------------------------------------------------------------------------
|
4305 |
|
|
|
4306 |
|
|
sub serv11_attdet_ronly { # generic in only att/det handler
|
4307 |
|
|
my ($det,$ucb) = @_;
|
4308 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
4309 |
|
|
|
4310 |
|
|
if ($det) { # detach handling
|
4311 |
|
|
serv11_detach_gen($ucb);
|
4312 |
|
|
|
4313 |
|
|
} else { # attach handling
|
4314 |
|
|
my $filename = cget_file();
|
4315 |
|
|
return if $cmd_bad or cget_chkblank();
|
4316 |
|
|
|
4317 |
|
|
if (not -e $filename) {
|
4318 |
|
|
print "pi_rri($curmode)-E: file $filename not found\n";
|
4319 |
|
|
return;
|
4320 |
|
|
}
|
4321 |
|
|
if (not -r $filename) {
|
4322 |
|
|
print "pi_rri($curmode)-E: file $filename is not readable\n";
|
4323 |
|
|
return;
|
4324 |
|
|
}
|
4325 |
|
|
|
4326 |
|
|
my $fh = new FileHandle;
|
4327 |
|
|
my $rc = $fh->open("<$filename");
|
4328 |
|
|
if (not $rc) {
|
4329 |
|
|
print "pi_rri($curmode)-E: failed to open file $filename\n";
|
4330 |
|
|
return;
|
4331 |
|
|
}
|
4332 |
|
|
|
4333 |
|
|
$ucb->{att_ok} = 1;
|
4334 |
|
|
$ucb->{att_file} = $filename;
|
4335 |
|
|
$ucb->{att_fh} = $fh;
|
4336 |
|
|
delete $ucb->{att_eof};
|
4337 |
|
|
|
4338 |
|
|
&{$ctl->{usethdl}}($ucb); # setup unit registers
|
4339 |
|
|
}
|
4340 |
|
|
}
|
4341 |
|
|
|
4342 |
|
|
#-------------------------------------------------------------------------------
|
4343 |
|
|
|
4344 |
|
|
sub serv11_attdet_wonly { # generic out only att/det handler
|
4345 |
|
|
my ($det,$ucb) = @_;
|
4346 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
4347 |
|
|
|
4348 |
|
|
if ($det) { # detach handling
|
4349 |
|
|
serv11_detach_gen($ucb);
|
4350 |
|
|
|
4351 |
|
|
} else { # attach handling
|
4352 |
|
|
my $filename = cget_file();
|
4353 |
|
|
return if $cmd_bad or cget_chkblank();
|
4354 |
|
|
|
4355 |
|
|
if (not -e $filename) {
|
4356 |
|
|
print STDERR "pi_rri($curmode)-I: file $filename will be created\n";
|
4357 |
|
|
} elsif (not -w $filename) {
|
4358 |
|
|
print STDERR "pi_rri($curmode)-E: file $filename is not writeable\n";
|
4359 |
|
|
return;
|
4360 |
|
|
}
|
4361 |
|
|
|
4362 |
|
|
my $fh = new FileHandle;
|
4363 |
|
|
my $rc = $fh->open(">$filename");
|
4364 |
|
|
if (not $rc) {
|
4365 |
|
|
print STDERR "pi_rri($curmode)-E: failed to open file $filename\n";
|
4366 |
|
|
return;
|
4367 |
|
|
}
|
4368 |
|
|
|
4369 |
|
|
autoflush $fh;
|
4370 |
|
|
|
4371 |
|
|
$ucb->{att_ok} = 1;
|
4372 |
|
|
$ucb->{att_file} = $filename;
|
4373 |
|
|
$ucb->{att_fh} = $fh;
|
4374 |
|
|
delete $ucb->{att_eof};
|
4375 |
|
|
|
4376 |
|
|
&{$ctl->{usethdl}}($ucb); # setup unit registers
|
4377 |
|
|
}
|
4378 |
|
|
}
|
4379 |
|
|
|
4380 |
|
|
#-------------------------------------------------------------------------------
|
4381 |
|
|
|
4382 |
|
|
sub serv11_attdet_term { # generic term att/det handler
|
4383 |
|
|
my ($det,$ucb) = @_;
|
4384 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
4385 |
|
|
|
4386 |
|
|
if ($det) { # detach handling
|
4387 |
|
|
my $port_str = $ucb->{att_port};
|
4388 |
|
|
my $teldsc = $telnettbl{$port_str};
|
4389 |
|
|
close $teldsc->{fh_data} if defined $teldsc->{fh_data};
|
4390 |
|
|
close $teldsc->{fh_port} if defined $teldsc->{fh_port};
|
4391 |
|
|
delete $telnettbl{$port_str};
|
4392 |
|
|
delete $ucb->{att_port};
|
4393 |
|
|
$ucb->{att_ok} = 0;
|
4394 |
|
|
$serv11_fds_update = 1; # request update of select mask
|
4395 |
|
|
|
4396 |
|
|
} else { # attach handling
|
4397 |
|
|
my $port = cget_gdat(16, 10);
|
4398 |
|
|
return if $cmd_bad or cget_chkblank();
|
4399 |
|
|
my $port_str = sprintf("%6.6d", $port);
|
4400 |
|
|
if (exists $telnettbl{$port_str}) {
|
4401 |
|
|
printf STDERR "pi_rri($curmode)-E: port %d already attached\n", $port;
|
4402 |
|
|
return;
|
4403 |
|
|
}
|
4404 |
|
|
my $fh_port = new FileHandle;
|
4405 |
|
|
my $proto = getprotobyname('tcp');
|
4406 |
|
|
if (not socket($fh_port, PF_INET, SOCK_STREAM, $proto)) {
|
4407 |
|
|
printf STDERR "pi_rri($curmode)-E: error in socket(): $!\n";
|
4408 |
|
|
return;
|
4409 |
|
|
}
|
4410 |
|
|
if (not setsockopt($fh_port, SOL_SOCKET, SO_REUSEADDR, 1)) {
|
4411 |
|
|
printf STDERR "pi_rri($curmode)-E: error in setsocketopt(): $!\n";
|
4412 |
|
|
return;
|
4413 |
|
|
}
|
4414 |
|
|
|
4415 |
|
|
my $host = pack('C4', 0,0,0,0);
|
4416 |
|
|
my $addr = pack('S n a4 x8', 2, $port, $host);
|
4417 |
|
|
if (not bind($fh_port, $addr)) {
|
4418 |
|
|
printf STDERR "pi_rri($curmode)-E: error in bind(): $!\n";
|
4419 |
|
|
return;
|
4420 |
|
|
}
|
4421 |
|
|
|
4422 |
|
|
if (not listen($fh_port, 1)) {
|
4423 |
|
|
printf STDERR "pi_rri($curmode)-E: error in listen(): $!\n";
|
4424 |
|
|
return;
|
4425 |
|
|
}
|
4426 |
|
|
|
4427 |
|
|
$telnettbl{$port_str} = {};
|
4428 |
|
|
$telnettbl{$port_str}->{port} = $port;
|
4429 |
|
|
$telnettbl{$port_str}->{state} = TELNET_STATE_LISTEN;
|
4430 |
|
|
$telnettbl{$port_str}->{fh_port} = $fh_port;
|
4431 |
|
|
$telnettbl{$port_str}->{ucb} = $ucb;
|
4432 |
|
|
|
4433 |
|
|
$ucb->{att_ok} = 1;
|
4434 |
|
|
$ucb->{att_port} = $port_str;
|
4435 |
|
|
|
4436 |
|
|
$serv11_fds_update = 1; # request update of select mask
|
4437 |
|
|
|
4438 |
|
|
}
|
4439 |
|
|
|
4440 |
|
|
}
|
4441 |
|
|
|
4442 |
|
|
#-------------------------------------------------------------------------------
|
4443 |
|
|
|
4444 |
|
|
sub serv11_probe_cpu { # cpu: probe handler
|
4445 |
|
|
my ($ctl) = @_;
|
4446 |
|
|
|
4447 |
|
|
serv11_probe_gen($ctl);
|
4448 |
|
|
return unless $ctl->{probe_ok};
|
4449 |
|
|
|
4450 |
|
|
my $reglist = $ctl->{reglist};
|
4451 |
|
|
my $partbl = $ctl->{partbl};
|
4452 |
|
|
my $text = "";
|
4453 |
|
|
|
4454 |
|
|
my $exadep = \&serv11_exadep_cpu;
|
4455 |
|
|
|
4456 |
|
|
push @{$reglist}, {name => "r0", hdl => \&serv11_exadep_cpu};
|
4457 |
|
|
push @{$reglist}, {name => "r1", hdl => \&serv11_exadep_cpu};
|
4458 |
|
|
push @{$reglist}, {name => "r2", hdl => \&serv11_exadep_cpu};
|
4459 |
|
|
push @{$reglist}, {name => "r3", hdl => \&serv11_exadep_cpu};
|
4460 |
|
|
push @{$reglist}, {name => "r4", hdl => \&serv11_exadep_cpu};
|
4461 |
|
|
push @{$reglist}, {name => "r5", hdl => \&serv11_exadep_cpu};
|
4462 |
|
|
push @{$reglist}, {name => "sp", hdl => \&serv11_exadep_cpu};
|
4463 |
|
|
push @{$reglist}, {name => "pc", hdl => \&serv11_exadep_cpu};
|
4464 |
|
|
push @{$reglist}, {name => "psw", hdl => \&serv11_exadep_cpu};
|
4465 |
|
|
|
4466 |
|
|
push @{$reglist}, {name => "stklim", addr => CPU_STKLIM};
|
4467 |
|
|
push @{$reglist}, {name => "pirq" , addr => CPU_PIRQ};
|
4468 |
|
|
push @{$reglist}, {name => "mbrk" , addr => CPU_MBRK};
|
4469 |
|
|
push @{$reglist}, {name => "cpuerr", addr => CPU_CPUERR};
|
4470 |
|
|
push @{$reglist}, {name => "hisize", addr => CPU_HISIZE};
|
4471 |
|
|
push @{$reglist}, {name => "losize", addr => CPU_LOSIZE};
|
4472 |
|
|
|
4473 |
|
|
my ($ival,$rval) = serv11_exec_probe(CPU_SDREG, "ir");
|
4474 |
|
|
if (defined $ival && defined $rval) {
|
4475 |
|
|
push @{$reglist}, {name => "sr", addr => CPU_SDREG, attr => REGATTR_RBWR};
|
4476 |
|
|
push @{$reglist}, {name => "dr", addr => CPU_SDREG, attr => REGATTR_RBRD};
|
4477 |
|
|
}
|
4478 |
|
|
|
4479 |
|
|
push @{$reglist}, {name => "mmr0" , addr => CPU_MMR0};
|
4480 |
|
|
push @{$reglist}, {name => "mmr1" , addr => CPU_MMR1};
|
4481 |
|
|
push @{$reglist}, {name => "mmr2" , addr => CPU_MMR2};
|
4482 |
|
|
push @{$reglist}, {name => "mmr3" , addr => CPU_MMR3};
|
4483 |
|
|
|
4484 |
|
|
my @rval;
|
4485 |
|
|
serv11_rri_wreg("wal", PDPCP_ADDR_AL, CPU_LOSIZE); # i/o page in 16 bit mode
|
4486 |
|
|
serv11_rri_rreg("rm", PDPCP_ADDR_MEM);
|
4487 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
4488 |
|
|
my $memsize = ($rval[0]+1)<<6; # memsize in bytes
|
4489 |
|
|
$ctl->{memsize} = $memsize;
|
4490 |
|
|
|
4491 |
|
|
$text .= ($text)?";":"" . sprintf("mem=%dkb",$memsize/1024.);
|
4492 |
|
|
|
4493 |
|
|
$ctl->{probe_text} = $text;
|
4494 |
|
|
|
4495 |
|
|
}
|
4496 |
|
|
|
4497 |
|
|
#-------------------------------------------------------------------------------
|
4498 |
|
|
|
4499 |
|
|
sub serv11_attn_cpu { # cpu: attention handler
|
4500 |
|
|
my ($ctl,$force) = @_;
|
4501 |
|
|
return if $force;
|
4502 |
|
|
print "CPU halted\n";
|
4503 |
|
|
$serv11_active = 0;
|
4504 |
|
|
serv11_cexec_shoreg(1);
|
4505 |
|
|
}
|
4506 |
|
|
|
4507 |
|
|
#-------------------------------------------------------------------------------
|
4508 |
|
|
|
4509 |
|
|
sub serv11_exadep_cpu { # cpu: exa/dep handler
|
4510 |
|
|
my ($dep,$dsc,$val) = @_;
|
4511 |
|
|
my $name = $dsc->{name};
|
4512 |
|
|
my $rrireg;
|
4513 |
|
|
|
4514 |
|
|
$name =~ s/^sp$/r6/;
|
4515 |
|
|
$name =~ s/^pc$/r7/;
|
4516 |
|
|
|
4517 |
|
|
if ($dep) {
|
4518 |
|
|
if ($name =~ /^r([0-7])$/) {
|
4519 |
|
|
$rrireg = PDPCP_ADDR_R0 + int $1;
|
4520 |
|
|
} elsif ($name eq "psw") {
|
4521 |
|
|
$rrireg = PDPCP_ADDR_PSW;
|
4522 |
|
|
} else {
|
4523 |
|
|
print_fatal("serv11_exadep_cpu() called with bad name '$name'");
|
4524 |
|
|
}
|
4525 |
|
|
my @rval;
|
4526 |
|
|
serv11_rri_wreg("r$name", $rrireg, $val);
|
4527 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
4528 |
|
|
return;
|
4529 |
|
|
|
4530 |
|
|
} else {
|
4531 |
|
|
if ($name =~ /^r([0-7])$/) {
|
4532 |
|
|
$rrireg = PDPCP_ADDR_R0 + int $1;
|
4533 |
|
|
} elsif ($name eq "psw") {
|
4534 |
|
|
$rrireg = PDPCP_ADDR_PSW;
|
4535 |
|
|
} else {
|
4536 |
|
|
print_fatal("serv11_exadep_cpu() called with bad name '$name'");
|
4537 |
|
|
}
|
4538 |
|
|
my @rval;
|
4539 |
|
|
serv11_rri_rreg("r$name", $rrireg);
|
4540 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
4541 |
|
|
return $rval[0];
|
4542 |
|
|
}
|
4543 |
|
|
|
4544 |
|
|
}
|
4545 |
|
|
|
4546 |
|
|
#-------------------------------------------------------------------------------
|
4547 |
|
|
|
4548 |
|
|
sub serv11_ichr_dl11 {
|
4549 |
|
|
my ($ucb,$dref) = @_;
|
4550 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
4551 |
|
|
my @rval;
|
4552 |
|
|
my $rc;
|
4553 |
|
|
|
4554 |
|
|
my $que_old = scalar( @{$ucb->{rcvque}} );
|
4555 |
|
|
push @{$ucb->{rcvque}}, @$dref;
|
4556 |
|
|
my $que_new = scalar( @{$ucb->{rcvque}} );
|
4557 |
|
|
|
4558 |
|
|
if ($que_old == 0 && $que_new > 0) {
|
4559 |
|
|
serv11_rri_ibrb($ctl);
|
4560 |
|
|
serv11_rri_ribr("RCSR", $ctl, DL11_RCSR);
|
4561 |
|
|
$rc = serv11_rri_exec(\@rval);
|
4562 |
|
|
if (($rval[0] & DL11_RCSR_M_RDONE) == 0) { # RBUF not full
|
4563 |
|
|
my $data = shift @{$ucb->{rcvque}};
|
4564 |
|
|
serv11_rri_wibr("RBUF", $ctl, DL11_RBUF, $data & 0377);
|
4565 |
|
|
$rc = serv11_rri_exec(\@rval);
|
4566 |
|
|
}
|
4567 |
|
|
}
|
4568 |
|
|
}
|
4569 |
|
|
|
4570 |
|
|
#-------------------------------------------------------------------------------
|
4571 |
|
|
|
4572 |
|
|
sub serv11_attn_dl11 {
|
4573 |
|
|
my ($ctl,$force) = @_;
|
4574 |
|
|
my $ucb = $serv11_unittbl{$ctl->{units}[0]};
|
4575 |
|
|
my @rval;
|
4576 |
|
|
my $rc;
|
4577 |
|
|
my $nxbuf = $ctl->{nxbuf_min};
|
4578 |
|
|
my $nxbuf_val = 0;
|
4579 |
|
|
|
4580 |
|
|
$nxbuf = $ctl->{nxbuf} if defined $ctl->{nxbuf};
|
4581 |
|
|
|
4582 |
|
|
serv11_rri_ibrb($ctl);
|
4583 |
|
|
for (my $i=0; $i<$nxbuf; $i++) {
|
4584 |
|
|
serv11_rri_ribr("XBUF", $ctl, DL11_XBUF);
|
4585 |
|
|
}
|
4586 |
|
|
|
4587 |
|
|
# select(undef, undef, undef, 5.0); # ! hack
|
4588 |
|
|
# printf $fh_log "HACK -- wait on DL11 attn\n"; # ! hack
|
4589 |
|
|
|
4590 |
|
|
$rc = serv11_rri_exec(\@rval);
|
4591 |
|
|
|
4592 |
|
|
my $rrdy;
|
4593 |
|
|
for (my $i=0; $i<$nxbuf; $i++) {
|
4594 |
|
|
my $ochr = $rval[$i] & DL11_XBUF_M_XBUF;
|
4595 |
|
|
my $xval = $rval[$i] & DL11_XBUF_M_XVAL;
|
4596 |
|
|
$rrdy = $rval[$i] & DL11_XBUF_M_RRDY;
|
4597 |
|
|
$ochr = $ochr & 0177 if $ucb->{rcv7bit}; # drop parity bit
|
4598 |
|
|
my $chr = chr($ochr);
|
4599 |
|
|
my $str = ($ochr>=040 && $ochr<0177) ? "$chr" : sprintf "\\%3.3o",$ochr;
|
4600 |
|
|
if (exists $opts{tserv} && $ctl->{trace} &&
|
4601 |
|
|
($xval || not $force)) {
|
4602 |
|
|
printf $fh_log
|
4603 |
|
|
"serv -- DL11.%s xbuf=%6.6o xval=%s rrdy=%s rcvq=%3d sndq=%3d",
|
4604 |
|
|
$ctl->{ctlname}, $rval[$i],
|
4605 |
|
|
($xval ? "y" : "n"), ($rrdy ? "y" : "n"),
|
4606 |
|
|
scalar( @{$ucb->{rcvque}} ), scalar( @{$ucb->{sndque}} );
|
4607 |
|
|
printf $fh_log " char=\"%s\"", $str if $xval;
|
4608 |
|
|
print $fh_log "\n";
|
4609 |
|
|
}
|
4610 |
|
|
|
4611 |
|
|
if ($xval) {
|
4612 |
|
|
$nxbuf_val += 1;
|
4613 |
|
|
my $sndqueref = $ucb->{sndque};
|
4614 |
|
|
my $ochr_last = 0;
|
4615 |
|
|
$ochr_last = $$sndqueref[-1] if scalar(@$sndqueref) > 0;
|
4616 |
|
|
|
4617 |
|
|
push @{$ucb->{sndque}}, $ochr;
|
4618 |
|
|
|
4619 |
|
|
if ($ucb->{att_ok}) {
|
4620 |
|
|
telnet_writehdl($ucb);
|
4621 |
|
|
} else {
|
4622 |
|
|
if ($ctl->{ctlname} eq "TTA") { # for console
|
4623 |
|
|
while (scalar( @{$ucb->{sndque}} )) {
|
4624 |
|
|
my $byte = shift @{$ucb->{sndque}};
|
4625 |
|
|
my $str = "";
|
4626 |
|
|
if ($byte>=040 && $byte<0177) {
|
4627 |
|
|
$str = chr($byte);
|
4628 |
|
|
} elsif ($byte==011) {
|
4629 |
|
|
$str = "\t";
|
4630 |
|
|
} elsif ($byte==012) {
|
4631 |
|
|
$str = "\n";
|
4632 |
|
|
} elsif ($byte==015) {
|
4633 |
|
|
$str = "\r";
|
4634 |
|
|
} else {
|
4635 |
|
|
$str = sprintf "<%3.3o>", $byte if $byte!=000;
|
4636 |
|
|
}
|
4637 |
|
|
print $str;
|
4638 |
|
|
}
|
4639 |
|
|
}
|
4640 |
|
|
|
4641 |
|
|
if ($ucb->{logfile}) {
|
4642 |
|
|
my $fh = $ucb->{logfh};
|
4643 |
|
|
if (not defined $ucb->{logfh}) {
|
4644 |
|
|
my $logfile = $ucb->{logfile};
|
4645 |
|
|
my $rc;
|
4646 |
|
|
$fh = $ucb->{logfh} = new FileHandle;
|
4647 |
|
|
$rc = $ucb->{logfh}->open(">$logfile");
|
4648 |
|
|
if (not $rc) {
|
4649 |
|
|
printf STDERR "pi_rri-E: failed to open $logfile for write\n";
|
4650 |
|
|
$fh = undef;
|
4651 |
|
|
} else {
|
4652 |
|
|
autoflush $fh;
|
4653 |
|
|
}
|
4654 |
|
|
}
|
4655 |
|
|
print $fh $str if $fh;
|
4656 |
|
|
}
|
4657 |
|
|
}
|
4658 |
|
|
|
4659 |
|
|
# if ($ochr_last == 015 && $ochr == 012) {
|
4660 |
|
|
# while (scalar( @{$ucb->{sndque}} )) {
|
4661 |
|
|
# my $byte = shift @{$ucb->{sndque}};
|
4662 |
|
|
# my $chr = chr($byte);
|
4663 |
|
|
# if ($byte>=040 && $byte <=177) {
|
4664 |
|
|
# print $chr
|
4665 |
|
|
# } else {
|
4666 |
|
|
# if ($byte != 000 && $byte != 012 && $byte != 015) {
|
4667 |
|
|
# printf "<%3.3o>", $byte
|
4668 |
|
|
# }
|
4669 |
|
|
# }
|
4670 |
|
|
# }
|
4671 |
|
|
# print "\n";
|
4672 |
|
|
# }
|
4673 |
|
|
}
|
4674 |
|
|
}
|
4675 |
|
|
|
4676 |
|
|
if ($rrdy && scalar( @{$ucb->{rcvque}} ) ) {
|
4677 |
|
|
my $data = shift @{$ucb->{rcvque}};
|
4678 |
|
|
serv11_rri_wibr("RBUF", $ctl, DL11_RBUF, $data & 0377);
|
4679 |
|
|
$rc = serv11_rri_exec(\@rval);
|
4680 |
|
|
}
|
4681 |
|
|
|
4682 |
|
|
$ctl->{nxbuf} = next_nxbuf($ctl, $nxbuf, $nxbuf_val);
|
4683 |
|
|
}
|
4684 |
|
|
|
4685 |
|
|
#-------------------------------------------------------------------------------
|
4686 |
|
|
|
4687 |
|
|
sub serv11_uset_lp11 {
|
4688 |
|
|
my ($ucb) = @_;
|
4689 |
|
|
my @rval;
|
4690 |
|
|
|
4691 |
|
|
my $lpcs = ($ucb->{att_ok}) ? 0 : LP11_CSR_M_ERR;
|
4692 |
|
|
|
4693 |
|
|
serv11_rri_uset($ucb, "LPCS", LP11_CSR, $lpcs);
|
4694 |
|
|
|
4695 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
4696 |
|
|
}
|
4697 |
|
|
|
4698 |
|
|
#-------------------------------------------------------------------------------
|
4699 |
|
|
|
4700 |
|
|
sub serv11_attn_lp11 {
|
4701 |
|
|
my ($ctl,$force) = @_;
|
4702 |
|
|
my $ucb = $serv11_unittbl{$ctl->{units}[0]};
|
4703 |
|
|
my @rval;
|
4704 |
|
|
my $rc;
|
4705 |
|
|
my $nxbuf = $ctl->{nxbuf_min};
|
4706 |
|
|
my $nxbuf_val = 0;
|
4707 |
|
|
|
4708 |
|
|
$nxbuf = $ctl->{nxbuf} if defined $ctl->{nxbuf};
|
4709 |
|
|
|
4710 |
|
|
serv11_rri_ibrb($ctl);
|
4711 |
|
|
for (my $i=0; $i<$nxbuf; $i++) {
|
4712 |
|
|
serv11_rri_ribr("LPBU", $ctl, LP11_BUF);
|
4713 |
|
|
}
|
4714 |
|
|
|
4715 |
|
|
$rc = serv11_rri_exec(\@rval);
|
4716 |
|
|
|
4717 |
|
|
for (my $i=0; $i<$nxbuf; $i++) {
|
4718 |
|
|
my $ochr = $rval[$i] & LP11_BUF_M_BUF;
|
4719 |
|
|
my $oval = $rval[$i] & LP11_BUF_M_VAL;
|
4720 |
|
|
my $chr = chr($ochr);
|
4721 |
|
|
my $str = "$chr";
|
4722 |
|
|
if (exists $opts{tserv} && $ctl->{trace} &&
|
4723 |
|
|
($oval || not $force)) {
|
4724 |
|
|
printf $fh_log
|
4725 |
|
|
"serv -- LP11 buf=%6.6o val=%s ",
|
4726 |
|
|
$rval[$i], ($oval ? "y" : "n");
|
4727 |
|
|
printf $fh_log " char=\"%s\"", $str if $oval;
|
4728 |
|
|
print $fh_log "\n";
|
4729 |
|
|
}
|
4730 |
|
|
|
4731 |
|
|
if ($oval) {
|
4732 |
|
|
$nxbuf_val += 1;
|
4733 |
|
|
my $fh = $ucb->{att_fh};
|
4734 |
|
|
if ($fh) {
|
4735 |
|
|
print $fh $str;
|
4736 |
|
|
} else {
|
4737 |
|
|
printf STDERR "pi_rri($curmode)-E: spurious output '%s' for %s\n",
|
4738 |
|
|
$str, $ucb->{unitname};
|
4739 |
|
|
}
|
4740 |
|
|
}
|
4741 |
|
|
}
|
4742 |
|
|
|
4743 |
|
|
$ctl->{nxbuf} = next_nxbuf($ctl, $nxbuf, $nxbuf_val);
|
4744 |
|
|
}
|
4745 |
|
|
|
4746 |
|
|
#-------------------------------------------------------------------------------
|
4747 |
|
|
|
4748 |
|
|
sub serv11_uset_pc11 {
|
4749 |
|
|
my ($ucb) = @_;
|
4750 |
|
|
my @rval;
|
4751 |
|
|
my $text;
|
4752 |
|
|
my $addr;
|
4753 |
|
|
my $data;
|
4754 |
|
|
|
4755 |
|
|
if ($ucb->{unitname} eq "PTR") { # if reader
|
4756 |
|
|
$text = "PRCS";
|
4757 |
|
|
$addr = PC11_RCSR;
|
4758 |
|
|
$data = ($ucb->{att_ok}) ? 0 : PC11_RCSR_M_ERR;
|
4759 |
|
|
} else { # if puncher
|
4760 |
|
|
$text = "PPCS";
|
4761 |
|
|
$addr = PC11_PCSR;
|
4762 |
|
|
$data = ($ucb->{att_ok}) ? 0 : PC11_PCSR_M_ERR;
|
4763 |
|
|
}
|
4764 |
|
|
|
4765 |
|
|
serv11_rri_uset($ucb, $text, $addr, $data);
|
4766 |
|
|
|
4767 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
4768 |
|
|
}
|
4769 |
|
|
|
4770 |
|
|
#-------------------------------------------------------------------------------
|
4771 |
|
|
|
4772 |
|
|
sub serv11_attdet_pc11 { # pc11 att/det handler
|
4773 |
|
|
my ($det,$ucb) = @_;
|
4774 |
|
|
|
4775 |
|
|
if ($ucb->{unitname} eq "PTR") { # if reader
|
4776 |
|
|
serv11_attdet_ronly($det, $ucb); # use read-only file
|
4777 |
|
|
} else { # if puncher
|
4778 |
|
|
serv11_attdet_wonly($det, $ucb); # use write-only file
|
4779 |
|
|
}
|
4780 |
|
|
|
4781 |
|
|
}
|
4782 |
|
|
|
4783 |
|
|
#-------------------------------------------------------------------------------
|
4784 |
|
|
|
4785 |
|
|
sub serv11_attn_pc11 {
|
4786 |
|
|
my ($ctl,$force) = @_;
|
4787 |
|
|
|
4788 |
|
|
my $ucb_ptr = $serv11_unittbl{$ctl->{units}[0]};
|
4789 |
|
|
my $ucb_ptp = $serv11_unittbl{$ctl->{units}[1]};
|
4790 |
|
|
my @rval;
|
4791 |
|
|
my $rc;
|
4792 |
|
|
my $nxbuf = $ctl->{nxbuf_min};
|
4793 |
|
|
my $nxbuf_val = 0;
|
4794 |
|
|
|
4795 |
|
|
$nxbuf = $ctl->{nxbuf} if defined $ctl->{nxbuf};
|
4796 |
|
|
|
4797 |
|
|
serv11_rri_ibrb($ctl);
|
4798 |
|
|
for (my $i=0; $i<$nxbuf; $i++) {
|
4799 |
|
|
serv11_rri_ribr("PPBUF", $ctl, PC11_PBUF);
|
4800 |
|
|
}
|
4801 |
|
|
|
4802 |
|
|
$rc = serv11_rri_exec(\@rval);
|
4803 |
|
|
|
4804 |
|
|
my $rrdy;
|
4805 |
|
|
for (my $i=0; $i<$nxbuf; $i++) {
|
4806 |
|
|
my $ochr = $rval[$i] & PC11_PBUF_M_PBUF;
|
4807 |
|
|
my $pval = $rval[$i] & PC11_PBUF_M_PVAL;
|
4808 |
|
|
$rrdy = $rval[$i] & PC11_PBUF_M_RBUSY;
|
4809 |
|
|
|
4810 |
|
|
if (exists $opts{tserv} && $ctl->{trace} &&
|
4811 |
|
|
($pval || not $force)) {
|
4812 |
|
|
printf $fh_log
|
4813 |
|
|
"serv -- PC11 pbuf=%6.6o pval=%s rrdy=%s \n",
|
4814 |
|
|
$rval[$i], ($pval ? "y" : "n"), ($rrdy ? "y" : "n");
|
4815 |
|
|
}
|
4816 |
|
|
|
4817 |
|
|
if ($pval) {
|
4818 |
|
|
$nxbuf_val += 1;
|
4819 |
|
|
my $fh = $ucb_ptp->{att_fh};
|
4820 |
|
|
if ($fh) {
|
4821 |
|
|
print $fh chr($ochr);
|
4822 |
|
|
} else {
|
4823 |
|
|
printf STDERR "pi_rri($curmode)-E: spurious output '%3.3o' for %s\n",
|
4824 |
|
|
$ochr, $ucb_ptp->{unitname};
|
4825 |
|
|
}
|
4826 |
|
|
}
|
4827 |
|
|
}
|
4828 |
|
|
|
4829 |
|
|
if ($rrdy) {
|
4830 |
|
|
my $fh = $ucb_ptr->{att_fh};
|
4831 |
|
|
if ($fh && (not $ucb_ptr->{att_eof}) ) {
|
4832 |
|
|
my $char = getc($fh);
|
4833 |
|
|
if (defined $char) {
|
4834 |
|
|
serv11_rri_wibr("PRBUF", $ctl, PC11_RBUF, ord($char) & 0377);
|
4835 |
|
|
$rc = serv11_rri_exec(\@rval);
|
4836 |
|
|
} else {
|
4837 |
|
|
serv11_rri_uset($ucb_ptr, "PRCS", PC11_RCSR, PC11_RCSR_M_ERR);
|
4838 |
|
|
$rc = serv11_rri_exec(\@rval);
|
4839 |
|
|
$ucb_ptr->{att_eof} = 1;
|
4840 |
|
|
}
|
4841 |
|
|
} else {
|
4842 |
|
|
printf STDERR "pi_rri($curmode)-E: spurious reader busy for %s\n",
|
4843 |
|
|
$ucb_ptr->{unitname};
|
4844 |
|
|
}
|
4845 |
|
|
}
|
4846 |
|
|
|
4847 |
|
|
$ctl->{nxbuf} = next_nxbuf($ctl, $nxbuf, $nxbuf_val);
|
4848 |
|
|
|
4849 |
|
|
}
|
4850 |
|
|
|
4851 |
|
|
#-------------------------------------------------------------------------------
|
4852 |
|
|
|
4853 |
|
|
sub serv11_uset_rk11 {
|
4854 |
|
|
my ($ucb) = @_;
|
4855 |
|
|
my @rval;
|
4856 |
|
|
|
4857 |
|
|
my $rkds = 0;
|
4858 |
|
|
|
4859 |
|
|
$rkds = $ucb->{ctlunit}<<(RKDS_V_ID);
|
4860 |
|
|
if ($ucb->{att_ok}) { # drive available
|
4861 |
|
|
$rkds |= RKDS_M_HDEN; # always high density
|
4862 |
|
|
$rkds |= RKDS_M_SOK; # always sector counter OK ?FIXME?
|
4863 |
|
|
$rkds |= RKDS_M_DRY; # drive available
|
4864 |
|
|
$rkds |= RKDS_M_ADRY; # access available
|
4865 |
|
|
$rkds |= RKDS_M_WPS if $ucb->{att_wpro}; # in case write protected
|
4866 |
|
|
}
|
4867 |
|
|
$ucb->{rkds} = $rkds;
|
4868 |
|
|
|
4869 |
|
|
serv11_rri_uset($ucb, "RKDS", RK11_RKDS, $rkds);
|
4870 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
4871 |
|
|
}
|
4872 |
|
|
|
4873 |
|
|
#-------------------------------------------------------------------------------
|
4874 |
|
|
# geometry: c=203;h=2;s=12 ==> 4872 blocks ==> 2 494 464 bytes
|
4875 |
|
|
#
|
4876 |
|
|
# several error conditions are only approximately handled:
|
4877 |
|
|
# OVR: when detected, no transfer done (should trim size)
|
4878 |
|
|
|
4879 |
|
|
sub serv11_attn_rk11 {
|
4880 |
|
|
my ($ctl,$force) = @_;
|
4881 |
|
|
my @rval;
|
4882 |
|
|
my $blksize = $ctl->{blksize};
|
4883 |
|
|
|
4884 |
|
|
serv11_rri_ibrb($ctl);
|
4885 |
|
|
serv11_rri_ribr("RKWC", $ctl, RK11_RKWC);
|
4886 |
|
|
serv11_rri_ribr("RKBA", $ctl, RK11_RKBA);
|
4887 |
|
|
serv11_rri_ribr("RKDA", $ctl, RK11_RKDA);
|
4888 |
|
|
serv11_rri_ribr("RKMR", $ctl, RK11_RKMR); # read to monitor CRDONE
|
4889 |
|
|
serv11_rri_ribr("RKCS", $ctl, RK11_RKCS);
|
4890 |
|
|
|
4891 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
4892 |
|
|
|
4893 |
|
|
my $rkwc = $rval[0];
|
4894 |
|
|
my $rkba = $rval[1];
|
4895 |
|
|
my $rkda = $rval[2];
|
4896 |
|
|
my $rkmr = $rval[3];
|
4897 |
|
|
my $rkcs = $rval[4];
|
4898 |
|
|
|
4899 |
|
|
my $se = $rkda & RKDA_B_SC;
|
4900 |
|
|
my $hd = ($rkda>>RKDA_V_SUR ) & RKDA_B_SUR;
|
4901 |
|
|
my $cy = ($rkda>>RKDA_V_CYL ) & RKDA_B_CYL;
|
4902 |
|
|
my $dr = ($rkda>>RKDA_V_DRSEL) & RKDA_B_DRSEL;
|
4903 |
|
|
|
4904 |
|
|
my $go = ($rkcs & RKCS_M_GO) != 0;
|
4905 |
|
|
my $fu = ($rkcs>>RKCS_V_FUNC) & RKCS_B_FUNC;
|
4906 |
|
|
my $mex = ($rkcs>>RKCS_V_MEX ) & RKCS_B_MEX;
|
4907 |
|
|
|
4908 |
|
|
my $nwrd = ((~$rkwc) & 0xffff) + 1; # transfer size in words
|
4909 |
|
|
my $nbyt = 2*$nwrd; # transfer size in bytes
|
4910 |
|
|
my $nblk = int (($nbyt+$blksize-1)/$blksize);# transfer size in blocks
|
4911 |
|
|
|
4912 |
|
|
my $addr = $mex<<16 | $rkba; # 18 bit memory address
|
4913 |
|
|
my $lbn = $se + RK11_NUMSE*$hd + RK11_NUMSE*RK11_NUMHD*$cy;
|
4914 |
|
|
|
4915 |
|
|
my $ucb = $serv11_unittbl{$ctl->{units}[$dr]};
|
4916 |
|
|
|
4917 |
|
|
my $rkds = $ucb->{rkds};
|
4918 |
|
|
if (not defined $rkds) {
|
4919 |
|
|
printf $fh_log
|
4920 |
|
|
"serv -- RK11 ERROR: no rri device init, assume ds=0 for drive %d\n", $dr;
|
4921 |
|
|
$rkds = $ucb->{rkds} = $rkds = 0;
|
4922 |
|
|
}
|
4923 |
|
|
|
4924 |
|
|
if ($go == 0) { # quit here if no go bit set
|
4925 |
|
|
if (exists $opts{tserv} && $ctl->{trace}) {
|
4926 |
|
|
if (not $force) {
|
4927 |
|
|
printf $fh_log "serv -- RK11 cs=%6.6o go=0, spurious attn\n", $rkcs;
|
4928 |
|
|
}
|
4929 |
|
|
}
|
4930 |
|
|
return;
|
4931 |
|
|
}
|
4932 |
|
|
|
4933 |
|
|
my $rker = 0;
|
4934 |
|
|
my $msg = "";
|
4935 |
|
|
|
4936 |
|
|
if ($fu != RKCS_CRESET && # function not control reset
|
4937 |
|
|
(not $ucb->{att_ok})) { # and drive not attached
|
4938 |
|
|
$rker = RKER_M_NXD; # --> abort with NXD error
|
4939 |
|
|
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
|
4940 |
|
|
if ($fu == RKCS_SEEK || $fu == RKCS_DRESET) {
|
4941 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_SBCLR) | 1<<($dr));
|
4942 |
|
|
}
|
4943 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
|
4944 |
|
|
serv11_attn_rk11_logerr($ctl, $rker);
|
4945 |
|
|
|
4946 |
|
|
} elsif ($fu != RKCS_WRITE && # function neither read
|
4947 |
|
|
$fu != RKCS_READ && # nor write
|
4948 |
|
|
($rkcs & RKCS_M_FMT)) { # and FMT set
|
4949 |
|
|
$rker = RKER_M_PGE; # --> abort with PGE error
|
4950 |
|
|
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
|
4951 |
|
|
if ($fu == RKCS_SEEK || $fu == RKCS_DRESET) {
|
4952 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_SBCLR) | 1<<($dr));
|
4953 |
|
|
}
|
4954 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
|
4955 |
|
|
serv11_attn_rk11_logerr($ctl, $rker);
|
4956 |
|
|
|
4957 |
|
|
} else {
|
4958 |
|
|
|
4959 |
|
|
if ($fu == RKCS_CRESET) { # Control reset -------------------
|
4960 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_CRESET));
|
4961 |
|
|
|
4962 |
|
|
} elsif ($fu == RKCS_WRITE) { # Write ---------------------------
|
4963 |
|
|
# Note: WRITE+FMT is just like WRITE
|
4964 |
|
|
$rker |= RKER_M_NXS if $se >= RK11_NUMSE;
|
4965 |
|
|
$rker |= RKER_M_NXC if $cy >= RK11_NUMCY;
|
4966 |
|
|
$rker |= RKER_M_WLO if $ucb->{att_wpro};
|
4967 |
|
|
$rker |= RKER_M_DRE if $rkcs & RKCS_M_IBA; # not yet supported ! FIXME !
|
4968 |
|
|
$rker |= RKER_M_DRE if $rkcs & RKCS_M_RWA; # will never be supported
|
4969 |
|
|
if ($rker) {
|
4970 |
|
|
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
|
4971 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
|
4972 |
|
|
serv11_attn_rk11_logerr($ctl, $rker);
|
4973 |
|
|
} else {
|
4974 |
|
|
my $icb = {rdmahdl => \&serv11_rdma_rk11,
|
4975 |
|
|
func => "write",
|
4976 |
|
|
ctl => $ctl,
|
4977 |
|
|
ucb => $ucb,
|
4978 |
|
|
lbn => $lbn,
|
4979 |
|
|
nblk => $nblk,
|
4980 |
|
|
nwrd => $nwrd,
|
4981 |
|
|
addr => $addr,
|
4982 |
|
|
nwdone => 0,
|
4983 |
|
|
rkcs => $rkcs, # later needed for MEX update
|
4984 |
|
|
rkda => $rkda # later needed in RKDA update
|
4985 |
|
|
};
|
4986 |
|
|
push @serv11_icbque, $icb;
|
4987 |
|
|
}
|
4988 |
|
|
|
4989 |
|
|
} elsif ($fu == RKCS_READ) { # Read ----------------------------
|
4990 |
|
|
$rker |= RKER_M_NXS if ($se >= RK11_NUMSE);
|
4991 |
|
|
$rker |= RKER_M_NXC if ($cy >= RK11_NUMCY);
|
4992 |
|
|
$rker |= RKER_M_DRE if $rkcs & RKCS_M_IBA; # not yet supported ! FIXME !
|
4993 |
|
|
$rker |= RKER_M_DRE if $rkcs & RKCS_M_RWA; # will never be supported
|
4994 |
|
|
if ($rker) {
|
4995 |
|
|
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
|
4996 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
|
4997 |
|
|
serv11_attn_rk11_logerr($ctl, $rker);
|
4998 |
|
|
} else {
|
4999 |
|
|
|
5000 |
|
|
if ($rkcs & RKCS_M_FMT) {
|
5001 |
|
|
my $icb = {rdmahdl => \&serv11_rdma_rk11,
|
5002 |
|
|
func => "rdfmt",
|
5003 |
|
|
ctl => $ctl,
|
5004 |
|
|
ucb => $ucb,
|
5005 |
|
|
lbn => $lbn,
|
5006 |
|
|
nblk => $nwrd, # #blocks == #words for RD FMT !!
|
5007 |
|
|
nwrd => $nwrd,
|
5008 |
|
|
addr => $addr,
|
5009 |
|
|
nwdone => 0,
|
5010 |
|
|
rkcs => $rkcs, # later needed for MEX update
|
5011 |
|
|
rkda => $rkda # later needed in RKDA update
|
5012 |
|
|
};
|
5013 |
|
|
push @serv11_icbque, $icb;
|
5014 |
|
|
} else {
|
5015 |
|
|
my $icb = {rdmahdl => \&serv11_rdma_rk11,
|
5016 |
|
|
func => "read",
|
5017 |
|
|
ctl => $ctl,
|
5018 |
|
|
ucb => $ucb,
|
5019 |
|
|
lbn => $lbn,
|
5020 |
|
|
nblk => $nblk,
|
5021 |
|
|
nwrd => $nwrd,
|
5022 |
|
|
addr => $addr,
|
5023 |
|
|
nwdone => 0,
|
5024 |
|
|
rkcs => $rkcs, # later needed for MEX update
|
5025 |
|
|
rkda => $rkda # later needed in RKDA update
|
5026 |
|
|
};
|
5027 |
|
|
push @serv11_icbque, $icb;
|
5028 |
|
|
}
|
5029 |
|
|
}
|
5030 |
|
|
|
5031 |
|
|
} elsif ($fu == RKCS_WCHK) { # Write Check ---------------------
|
5032 |
|
|
$rker |= RKER_M_NXS if $se >= RK11_NUMSE;
|
5033 |
|
|
$rker |= RKER_M_NXC if $cy >= RK11_NUMCY;
|
5034 |
|
|
$rker |= RKER_M_DRE if $rkcs & RKCS_M_IBA; # not yet supported ! FIXME !
|
5035 |
|
|
$rker |= RKER_M_DRE if $rkcs & RKCS_M_RWA; # will never be supported
|
5036 |
|
|
if ($rker) {
|
5037 |
|
|
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
|
5038 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
|
5039 |
|
|
serv11_attn_rk11_logerr($ctl, $rker);
|
5040 |
|
|
} else {
|
5041 |
|
|
my $icb = {rdmahdl => \&serv11_rdma_rk11,
|
5042 |
|
|
func => "wrcheck",
|
5043 |
|
|
ctl => $ctl,
|
5044 |
|
|
ucb => $ucb,
|
5045 |
|
|
lbn => $lbn,
|
5046 |
|
|
nblk => $nblk,
|
5047 |
|
|
nwrd => $nwrd,
|
5048 |
|
|
addr => $addr,
|
5049 |
|
|
nwdone => 0,
|
5050 |
|
|
rkcs => $rkcs, # later needed for MEX update
|
5051 |
|
|
rkda => $rkda # later needed in RKDA update
|
5052 |
|
|
};
|
5053 |
|
|
push @serv11_icbque, $icb;
|
5054 |
|
|
}
|
5055 |
|
|
|
5056 |
|
|
} elsif ($fu == RKCS_SEEK) { # Seek ----------------------------
|
5057 |
|
|
$rker |= RKER_M_NXS if ($se >= RK11_NUMSE);
|
5058 |
|
|
$rker |= RKER_M_NXC if ($cy >= RK11_NUMCY);
|
5059 |
|
|
if ($rker) {
|
5060 |
|
|
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
|
5061 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_SBCLR) | 1<<($dr));
|
5062 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
|
5063 |
|
|
serv11_attn_rk11_logerr($ctl, $rker);
|
5064 |
|
|
} else {
|
5065 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
|
5066 |
|
|
$rkds &= ~(RKDS_B_SC); # replace current sector number
|
5067 |
|
|
$rkds |= $se;
|
5068 |
|
|
$ucb->{rkds} = $rkds;
|
5069 |
|
|
serv11_rri_wibr("RKDS", $ctl, RK11_RKDS, $rkds);
|
5070 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<($dr)); # issue seek done
|
5071 |
|
|
}
|
5072 |
|
|
|
5073 |
|
|
} elsif ($fu == RKCS_RCHK) { # Read Check ----------------------
|
5074 |
|
|
$rker |= RKER_M_NXS if $se >= RK11_NUMSE;
|
5075 |
|
|
$rker |= RKER_M_NXC if $cy >= RK11_NUMCY;
|
5076 |
|
|
$rker |= RKER_M_DRE if $rkcs & RKCS_M_IBA; # not yet supported ! FIXME !
|
5077 |
|
|
$rker |= RKER_M_DRE if $rkcs & RKCS_M_RWA; # will never be supported
|
5078 |
|
|
if ($rker) {
|
5079 |
|
|
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker);
|
5080 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
|
5081 |
|
|
serv11_attn_rk11_logerr($ctl, $rker);
|
5082 |
|
|
} else {
|
5083 |
|
|
my $icb = {rdmahdl => \&serv11_rdma_rk11,
|
5084 |
|
|
func => "rdcheck",
|
5085 |
|
|
ctl => $ctl,
|
5086 |
|
|
ucb => $ucb,
|
5087 |
|
|
lbn => $lbn,
|
5088 |
|
|
nblk => $nblk,
|
5089 |
|
|
nwrd => $nwrd,
|
5090 |
|
|
addr => $addr,
|
5091 |
|
|
nwdone => 0,
|
5092 |
|
|
rkcs => $rkcs, # later needed for MEX update
|
5093 |
|
|
rkda => $rkda # later needed in RKDA update
|
5094 |
|
|
};
|
5095 |
|
|
push @serv11_icbque, $icb;
|
5096 |
|
|
}
|
5097 |
|
|
|
5098 |
|
|
} elsif ($fu == RKCS_DRESET) { # Drive Reset ---------------------
|
5099 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
|
5100 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<($dr)); # issue seek done
|
5101 |
|
|
|
5102 |
|
|
} elsif ($fu == RKCS_WLOCK) { # Write Lock ----------------------
|
5103 |
|
|
$ucb->{rkds} |= RKDS_M_WPS; # set RKDS write protect flag
|
5104 |
|
|
$ucb->{att_wpro} = 1; # set UCB write protect flag
|
5105 |
|
|
serv11_rri_wibr("RKDS", $ctl, RK11_RKDS, $ucb->{rkds});
|
5106 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
|
5107 |
|
|
}
|
5108 |
|
|
|
5109 |
|
|
}
|
5110 |
|
|
|
5111 |
|
|
if (exists $opts{tserv} && $ctl->{trace}) {
|
5112 |
|
|
printf $fh_log "serv -- RK11 cs=%6.6o da=%6.6o wc=%6.6o",
|
5113 |
|
|
$rkcs, $rkda, $rkwc;
|
5114 |
|
|
printf $fh_log " ad=%6.6o", $addr;
|
5115 |
|
|
printf $fh_log " fu=%d dchs=%d,%3d,%d,%2d", $fu, $dr, $cy, $hd, $se;
|
5116 |
|
|
printf $fh_log " lbn=%4d nw,nb=%5d,%2d", $lbn, $nwrd, $nblk;
|
5117 |
|
|
print $fh_log "\n";
|
5118 |
|
|
}
|
5119 |
|
|
|
5120 |
|
|
$rc = serv11_rri_exec(\@rval);
|
5121 |
|
|
|
5122 |
|
|
}
|
5123 |
|
|
|
5124 |
|
|
#-------------------------------------------------------------------------------
|
5125 |
|
|
|
5126 |
|
|
sub serv11_attn_rk11_logerr {
|
5127 |
|
|
my ($ctl,$rker) = @_;
|
5128 |
|
|
if (exists $opts{tserv}) {
|
5129 |
|
|
printf $fh_log "serv -- RK11 er=%6.6o ERROR ABORT\n", $rker;
|
5130 |
|
|
}
|
5131 |
|
|
}
|
5132 |
|
|
|
5133 |
|
|
#-------------------------------------------------------------------------------
|
5134 |
|
|
|
5135 |
|
|
sub serv11_rdma_rk11 {
|
5136 |
|
|
my ($icb) = @_;
|
5137 |
|
|
my $ctl = $icb->{ctl};
|
5138 |
|
|
my $ucb = $icb->{ucb};
|
5139 |
|
|
my $addr = $icb->{addr};
|
5140 |
|
|
my $blksize = $ctl->{blksize};
|
5141 |
|
|
my @rval;
|
5142 |
|
|
my $rc = 1; # default ok, make code below shorter FIXME
|
5143 |
|
|
my $rker = 0;
|
5144 |
|
|
|
5145 |
|
|
# printf "+++x1 func=%5s addr=%6.6o nblk=%2d nwdone=%3d\n",
|
5146 |
|
|
# $icb->{func}, $addr, $icb->{nblk}, $icb->{nwdone};
|
5147 |
|
|
|
5148 |
|
|
if ($icb->{func} eq "read") { # --- read function --------------
|
5149 |
|
|
if ($icb->{nwdone} == 0) { # new block ?
|
5150 |
|
|
$rker |= RKER_M_OVR if $icb->{lbn} >= RK11_NUMBL;
|
5151 |
|
|
$rc = serv11_icb_disk_read($icb) if not $rker;
|
5152 |
|
|
$rker |= RKER_M_CSE if not $rc; # forward disk I/O error
|
5153 |
|
|
}
|
5154 |
|
|
|
5155 |
|
|
if (not $rker) {
|
5156 |
|
|
my $nwdma = int($blksize/2) - $icb->{nwdone};
|
5157 |
|
|
$nwdma = $icb->{nwrd} if $nwdma > $icb->{nwrd};
|
5158 |
|
|
$nwdma = $serv11_rdma_chunk if $nwdma > $serv11_rdma_chunk;
|
5159 |
|
|
my $beg = $icb->{nwdone};
|
5160 |
|
|
my $end = $beg + $nwdma - 1;
|
5161 |
|
|
my $buf = $icb->{buf};
|
5162 |
|
|
|
5163 |
|
|
serv11_rri_lalh($icb->{addr}, 3);
|
5164 |
|
|
serv11_rri_wblk($nwdma, [ @$buf[$beg..$end] ]);
|
5165 |
|
|
$rc = serv11_rri_exec(\@rval); # FIXME: handle dma I/O error
|
5166 |
|
|
$stat_tab{rdisk} += 2*$nwdma;
|
5167 |
|
|
|
5168 |
|
|
$icb->{nwdone} += $nwdma;
|
5169 |
|
|
$icb->{nwrd} -= $nwdma;
|
5170 |
|
|
$icb->{addr} += 2*$nwdma;
|
5171 |
|
|
|
5172 |
|
|
if ((not $rker) && # no error and
|
5173 |
|
|
($icb->{nwdone} == int($blksize/2) || # block done or
|
5174 |
|
|
$icb->{nwrd} == 0) ) { # all done
|
5175 |
|
|
$icb->{nwdone} = 0;
|
5176 |
|
|
$icb->{lbn} += 1;
|
5177 |
|
|
$icb->{nblk} -= 1;
|
5178 |
|
|
}
|
5179 |
|
|
}
|
5180 |
|
|
|
5181 |
|
|
if ((not $rker) && $icb->{nwrd}) { # if no error found and not done yet
|
5182 |
|
|
push @serv11_icbque, $icb; # requeue
|
5183 |
|
|
return;
|
5184 |
|
|
}
|
5185 |
|
|
|
5186 |
|
|
} elsif ($icb->{func} eq "rdfmt") { # --- read format function -------
|
5187 |
|
|
$rker |= RKER_M_OVR if $icb->{lbn} >= RK11_NUMBL;
|
5188 |
|
|
|
5189 |
|
|
if (not $rker) {
|
5190 |
|
|
my $cy = $icb->{lbn}/(RK11_NUMHD*RK11_NUMSE);
|
5191 |
|
|
my $da = $cy<<(RKDA_V_CYL);
|
5192 |
|
|
my @buf = ($da);
|
5193 |
|
|
|
5194 |
|
|
serv11_rri_lalh($icb->{addr}, 3);
|
5195 |
|
|
serv11_rri_wblk(1, [ @buf ]);
|
5196 |
|
|
$rc = serv11_rri_exec(\@rval); # FIXME: handle dma I/O error
|
5197 |
|
|
$stat_tab{rdisk} += 2;
|
5198 |
|
|
|
5199 |
|
|
$icb->{nwrd} -= 1;
|
5200 |
|
|
$icb->{addr} += 2;
|
5201 |
|
|
$icb->{lbn} += 1;
|
5202 |
|
|
$icb->{nblk} -= 1;
|
5203 |
|
|
}
|
5204 |
|
|
|
5205 |
|
|
if ((not $rker) && $icb->{nwrd}) { # if no error found and not done yet
|
5206 |
|
|
push @serv11_icbque, $icb; # requeue
|
5207 |
|
|
return;
|
5208 |
|
|
}
|
5209 |
|
|
|
5210 |
|
|
} elsif ($icb->{func} eq "write") { # --- write function -------------
|
5211 |
|
|
$icb->{buf} = [] if $icb->{nwdone} == 0;
|
5212 |
|
|
my $nwdma = int($blksize/2) - $icb->{nwdone};
|
5213 |
|
|
$nwdma = $icb->{nwrd} if $nwdma > $icb->{nwrd};
|
5214 |
|
|
$nwdma = $serv11_rdma_chunk if $nwdma > $serv11_rdma_chunk;
|
5215 |
|
|
|
5216 |
|
|
serv11_rri_lalh($icb->{addr}, 3);
|
5217 |
|
|
serv11_rri_rblk($nwdma);
|
5218 |
|
|
$rc = serv11_rri_exec(\@rval); # FIXME: handle dma I/O error
|
5219 |
|
|
$stat_tab{wdisk} += 2*$nwdma;
|
5220 |
|
|
|
5221 |
|
|
$icb->{nwdone} += $nwdma;
|
5222 |
|
|
$icb->{nwrd} -= $nwdma;
|
5223 |
|
|
$icb->{addr} += 2*$nwdma;
|
5224 |
|
|
|
5225 |
|
|
push @{$icb->{buf}}, @{$rval[0]};
|
5226 |
|
|
|
5227 |
|
|
if ((not $rker) && # no error and
|
5228 |
|
|
($icb->{nwdone} == int($blksize/2) || # block done or
|
5229 |
|
|
$icb->{nwrd} == 0) ) { # all done
|
5230 |
|
|
$rc = serv11_icb_disk_write($icb); # FIXME: handle file I/O error
|
5231 |
|
|
$icb->{nwdone} = 0;
|
5232 |
|
|
$icb->{lbn} += 1;
|
5233 |
|
|
$icb->{nblk} -= 1;
|
5234 |
|
|
$rker |= RKER_M_OVR if $icb->{nblk} && $icb->{lbn} >= RK11_NUMBL;
|
5235 |
|
|
}
|
5236 |
|
|
|
5237 |
|
|
if ((not $rker) && $icb->{nwrd}) { # if no error found and not done yet
|
5238 |
|
|
push @serv11_icbque, $icb; # requeue
|
5239 |
|
|
return;
|
5240 |
|
|
}
|
5241 |
|
|
|
5242 |
|
|
} elsif ($icb->{func} eq "wrcheck") { # --- write check function -------
|
5243 |
|
|
if ($icb->{nwdone} == 0) { # new block ?
|
5244 |
|
|
$rker |= RKER_M_OVR if $icb->{lbn} >= RK11_NUMBL;
|
5245 |
|
|
$rc = serv11_icb_disk_read($icb) if not $rker;
|
5246 |
|
|
$rker |= RKER_M_CSE if not $rc; # forward disk I/O error
|
5247 |
|
|
if ((not $rker)) {
|
5248 |
|
|
$icb->{bufdsk} = $icb->{buf};
|
5249 |
|
|
$icb->{buf} = [];
|
5250 |
|
|
}
|
5251 |
|
|
}
|
5252 |
|
|
|
5253 |
|
|
my $nwdma = int($blksize/2) - $icb->{nwdone};
|
5254 |
|
|
$nwdma = $icb->{nwrd} if $nwdma > $icb->{nwrd};
|
5255 |
|
|
$nwdma = $serv11_rdma_chunk if $nwdma > $serv11_rdma_chunk;
|
5256 |
|
|
|
5257 |
|
|
serv11_rri_lalh($icb->{addr}, 3);
|
5258 |
|
|
serv11_rri_rblk($nwdma);
|
5259 |
|
|
$rc = serv11_rri_exec(\@rval); # FIXME: handle dma I/O error
|
5260 |
|
|
$stat_tab{wdisk} += 2*$nwdma;
|
5261 |
|
|
|
5262 |
|
|
$icb->{nwdone} += $nwdma;
|
5263 |
|
|
$icb->{nwrd} -= $nwdma;
|
5264 |
|
|
$icb->{addr} += 2*$nwdma;
|
5265 |
|
|
|
5266 |
|
|
push @{$icb->{buf}}, @{$rval[0]};
|
5267 |
|
|
|
5268 |
|
|
if ((not $rker) && # no error and
|
5269 |
|
|
($icb->{nwdone} == int($blksize/2) || # block done or
|
5270 |
|
|
$icb->{nwrd} == 0)) { # all done
|
5271 |
|
|
my $bufdsk = $icb->{bufdsk};
|
5272 |
|
|
my $bufmem = $icb->{buf};
|
5273 |
|
|
my $nwmem = scalar(@{$bufmem});
|
5274 |
|
|
for (my $i=0; $i<$nwmem; $i++) {
|
5275 |
|
|
$rker |= RKER_M_WCE if $bufdsk->[$i] != $bufmem->[$i];
|
5276 |
|
|
}
|
5277 |
|
|
$icb->{nwdone} = 0;
|
5278 |
|
|
$icb->{lbn} += 1;
|
5279 |
|
|
$icb->{nblk} -= 1;
|
5280 |
|
|
$rker |= RKER_M_OVR if $icb->{nblk} && $icb->{lbn} >= RK11_NUMBL;
|
5281 |
|
|
}
|
5282 |
|
|
|
5283 |
|
|
my $stop = ($rker & ~RKER_M_WCE) != 0 || # any hard error
|
5284 |
|
|
(($rker & RKER_M_WCE) && $icb->{rkcs} & RKCS_M_SSE);
|
5285 |
|
|
if ((not $stop) && $icb->{nwrd}) { # if no error found and not done yet
|
5286 |
|
|
push @serv11_icbque, $icb; # requeue
|
5287 |
|
|
return;
|
5288 |
|
|
}
|
5289 |
|
|
|
5290 |
|
|
} elsif ($icb->{func} eq "rdcheck") { # --- read check function --------
|
5291 |
|
|
$rker |= RKER_M_OVR if $icb->{lbn} >= RK11_NUMBL;
|
5292 |
|
|
|
5293 |
|
|
if (not $rker) {
|
5294 |
|
|
my $nwdma = int($blksize/2);
|
5295 |
|
|
$nwdma = $icb->{nwrd} if $nwdma > $icb->{nwrd};
|
5296 |
|
|
|
5297 |
|
|
# Note: rkwc is decremented; rkba is untouched, no DMA transfer done
|
5298 |
|
|
$icb->{nwrd} -= $nwdma;
|
5299 |
|
|
$icb->{lbn} += 1;
|
5300 |
|
|
$icb->{nblk} -= 1;
|
5301 |
|
|
}
|
5302 |
|
|
|
5303 |
|
|
if ((not $rker) && $icb->{nwrd}) { # if no error found and not done yet
|
5304 |
|
|
push @serv11_icbque, $icb; # requeue
|
5305 |
|
|
return;
|
5306 |
|
|
}
|
5307 |
|
|
|
5308 |
|
|
|
5309 |
|
|
} else { # --- unkown function ------------
|
5310 |
|
|
printf "pi_rri-E: unknown func=%s for serv11_rdma_rk11\n", $icb->{func};
|
5311 |
|
|
}
|
5312 |
|
|
|
5313 |
|
|
# common handling for dma transfer completion
|
5314 |
|
|
|
5315 |
|
|
my $ba = $icb->{addr} &0177776; # get lower 16 bits
|
5316 |
|
|
my $mex = ($icb->{addr} >> 16) & 03; # get upper 2 bits
|
5317 |
|
|
my $lbn = $icb->{lbn};
|
5318 |
|
|
my $nwrd = $icb->{nwrd};
|
5319 |
|
|
my $end = $lbn;
|
5320 |
|
|
my $se = $end % RK11_NUMSE;
|
5321 |
|
|
$end = int ($end / RK11_NUMSE);
|
5322 |
|
|
my $hd = $end % RK11_NUMHD;
|
5323 |
|
|
$end = int ($end / RK11_NUMHD);
|
5324 |
|
|
my $cy = $end;
|
5325 |
|
|
my $da = ($icb->{rkda} & RKDA_M_DRSEL) |
|
5326 |
|
|
$se | $hd<<(RKDA_V_SUR) | $cy<<(RKDA_V_CYL);
|
5327 |
|
|
my $cs = ($icb->{rkcs} & (~RKCS_M_MEX)) | ($mex << RKCS_V_MEX);
|
5328 |
|
|
|
5329 |
|
|
serv11_rri_ibrb($ctl);
|
5330 |
|
|
serv11_rri_wibr("RKER", $ctl, RK11_RKER, $rker) if $rker;
|
5331 |
|
|
serv11_rri_wibr("RKWC", $ctl, RK11_RKWC, (-$nwrd)&0177777);
|
5332 |
|
|
serv11_rri_wibr("RKBA", $ctl, RK11_RKBA, $ba);
|
5333 |
|
|
serv11_rri_wibr("RKDA", $ctl, RK11_RKDA, $da);
|
5334 |
|
|
serv11_rri_wibr("RKCS", $ctl, RK11_RKCS, $cs) if ($cs != $icb->{rkcs});
|
5335 |
|
|
serv11_rri_wibr("RKMR", $ctl, RK11_RKMR, 1<<(RKMR_V_FDONE));
|
5336 |
|
|
serv11_attn_rk11_logerr($ctl, $rker) if $rker;
|
5337 |
|
|
$rc = serv11_rri_exec(\@rval);
|
5338 |
|
|
}
|
5339 |
|
|
|
5340 |
|
|
#-------------------------------------------------------------------------------
|
5341 |
|
|
# read one disk block at lbn, returns $icb->{buf}
|
5342 |
|
|
|
5343 |
|
|
sub serv11_icb_disk_read { # read one dsk file block
|
5344 |
|
|
my ($icb) = @_;
|
5345 |
|
|
my $ucb = $icb->{ucb};
|
5346 |
|
|
my $ctl = $icb->{ctl};
|
5347 |
|
|
my $fh = $ucb->{att_fh};
|
5348 |
|
|
my $fsize = $ucb->{att_nbyt};
|
5349 |
|
|
my $lbn = $icb->{lbn};
|
5350 |
|
|
my $blksize = $ctl->{blksize};
|
5351 |
|
|
my $seekpos = $lbn*$blksize;
|
5352 |
|
|
my $sysbuf;
|
5353 |
|
|
my $msg = "";
|
5354 |
|
|
my $rc = 0;
|
5355 |
|
|
|
5356 |
|
|
$icb->{buf} = undef;
|
5357 |
|
|
|
5358 |
|
|
if ($seekpos < $fsize) {
|
5359 |
|
|
($rc,$sysbuf) = file_seek_read($fh, $seekpos, $blksize);
|
5360 |
|
|
$icb->{buf} = conv_buf2wlist($sysbuf);
|
5361 |
|
|
} else {
|
5362 |
|
|
$rc = $blksize; # setup good rc
|
5363 |
|
|
$msg = " past eof zero buf";
|
5364 |
|
|
$icb->{buf} = [];
|
5365 |
|
|
while ($blksize > 0) {
|
5366 |
|
|
push @{$icb->{buf}}, 0;
|
5367 |
|
|
$blksize -= 2;
|
5368 |
|
|
}
|
5369 |
|
|
}
|
5370 |
|
|
|
5371 |
|
|
if (exists $opts{tserv} && $ctl->{trace}) {
|
5372 |
|
|
printf $fh_log "disk -- %3s read lbn=%5d rc=%d%s\n",
|
5373 |
|
|
$ucb->{unitname}, $lbn, $rc, $msg;
|
5374 |
|
|
}
|
5375 |
|
|
|
5376 |
|
|
return $rc;
|
5377 |
|
|
}
|
5378 |
|
|
|
5379 |
|
|
#-------------------------------------------------------------------------------
|
5380 |
|
|
# write one disk block at lbn, takes data from $icb->{buf}
|
5381 |
|
|
|
5382 |
|
|
sub serv11_icb_disk_write { # write one dsk file block
|
5383 |
|
|
my ($icb) = @_;
|
5384 |
|
|
my $ucb = $icb->{ucb};
|
5385 |
|
|
my $ctl = $icb->{ctl};
|
5386 |
|
|
my $fh = $ucb->{att_fh};
|
5387 |
|
|
my $fsize = $ucb->{att_nbyt};
|
5388 |
|
|
my $lbn = $icb->{lbn};
|
5389 |
|
|
my $blksize = $ctl->{blksize};
|
5390 |
|
|
my $seekpos = $lbn*$blksize;
|
5391 |
|
|
my $sysbuf = "";
|
5392 |
|
|
my $rc;
|
5393 |
|
|
|
5394 |
|
|
if (scalar(@{$icb->{buf}}) > int($blksize/2)) {
|
5395 |
|
|
print_fatal "serv11_icb_disk_write: buf too long";
|
5396 |
|
|
}
|
5397 |
|
|
|
5398 |
|
|
while (scalar(@{$icb->{buf}}) < int($blksize/2)) { # zero pad to block size
|
5399 |
|
|
push @{$icb->{buf}}, 0;
|
5400 |
|
|
}
|
5401 |
|
|
|
5402 |
|
|
if ($fsize <= $seekpos) { # extend dsk file ?
|
5403 |
|
|
my $zerobuf = chr(0) x $blksize;
|
5404 |
|
|
my $cnt = 0;
|
5405 |
|
|
file_seek($fh, $fsize);
|
5406 |
|
|
while ($fsize <= $seekpos) {
|
5407 |
|
|
file_write($fh, $zerobuf);
|
5408 |
|
|
$fsize += $blksize;
|
5409 |
|
|
$cnt += 1;
|
5410 |
|
|
}
|
5411 |
|
|
if (exists $opts{tserv} && $ctl->{trace}) {
|
5412 |
|
|
printf $fh_log "disk -- %3s extended by %d blocks\n",
|
5413 |
|
|
$ucb->{unitname}, $cnt;
|
5414 |
|
|
}
|
5415 |
|
|
$ucb->{att_nbyt} = $fsize;
|
5416 |
|
|
}
|
5417 |
|
|
|
5418 |
|
|
$sysbuf = conv_wlist2buf($icb->{buf});
|
5419 |
|
|
$rc = file_seek_write($fh, $seekpos, $sysbuf);
|
5420 |
|
|
|
5421 |
|
|
if (exists $opts{tserv} && $ctl->{trace}) {
|
5422 |
|
|
printf $fh_log "disk -- %3s write lbn=%5d rc=%d\n",
|
5423 |
|
|
$ucb->{unitname}, $lbn, $rc;
|
5424 |
|
|
}
|
5425 |
|
|
|
5426 |
|
|
return $rc;
|
5427 |
|
|
}
|
5428 |
|
|
|
5429 |
|
|
#-------------------------------------------------------------------------------
|
5430 |
|
|
|
5431 |
|
|
sub serv11_rri_init { # issue rri init command
|
5432 |
|
|
my ($aname,$addr,$data) = @_;
|
5433 |
|
|
push @rri_cmdlist, {cname => "init",
|
5434 |
|
|
aname => $aname,
|
5435 |
|
|
addr => $addr,
|
5436 |
|
|
data => $data,
|
5437 |
|
|
ref_stat => $rri_ref_sdef,
|
5438 |
|
|
msk_stat => $rri_msk_sdef};
|
5439 |
|
|
return undef;
|
5440 |
|
|
}
|
5441 |
|
|
|
5442 |
|
|
#-------------------------------------------------------------------------------
|
5443 |
|
|
|
5444 |
|
|
sub serv11_rri_attn { # issue rri attn command
|
5445 |
|
|
my ($aname) = @_;
|
5446 |
|
|
push @rri_cmdlist, {cname => "attn",
|
5447 |
|
|
aname => $aname,
|
5448 |
|
|
ref_stat => $rri_ref_sdef,
|
5449 |
|
|
msk_stat => $rri_msk_sdef};
|
5450 |
|
|
$rri_cmdlist[$#rri_cmdlist]->{get_data} = 1;
|
5451 |
|
|
return $rri_rvalcnt++;
|
5452 |
|
|
}
|
5453 |
|
|
|
5454 |
|
|
#-------------------------------------------------------------------------------
|
5455 |
|
|
|
5456 |
|
|
sub serv11_rri_stat { # issue rri stat command
|
5457 |
|
|
my ($aname) = @_;
|
5458 |
|
|
push @rri_cmdlist, {cname => "stat",
|
5459 |
|
|
aname => $aname,
|
5460 |
|
|
ref_stat => $rri_ref_sdef,
|
5461 |
|
|
msk_stat => $rri_msk_sdef};
|
5462 |
|
|
$rri_cmdlist[$#rri_cmdlist]->{get_data} = 1;
|
5463 |
|
|
return $rri_rvalcnt++;
|
5464 |
|
|
}
|
5465 |
|
|
|
5466 |
|
|
#-------------------------------------------------------------------------------
|
5467 |
|
|
|
5468 |
|
|
sub serv11_rri_rreg { # issue rri rreg command
|
5469 |
|
|
my ($aname,$addr) = @_;
|
5470 |
|
|
push @rri_cmdlist, {cname => "rreg",
|
5471 |
|
|
aname => $aname,
|
5472 |
|
|
addr => $addr,
|
5473 |
|
|
ref_stat => $rri_ref_sdef,
|
5474 |
|
|
msk_stat => $rri_msk_sdef};
|
5475 |
|
|
$rri_cmdlist[$#rri_cmdlist]->{get_data} = 1;
|
5476 |
|
|
return $rri_rvalcnt++;
|
5477 |
|
|
}
|
5478 |
|
|
|
5479 |
|
|
#-------------------------------------------------------------------------------
|
5480 |
|
|
|
5481 |
|
|
sub serv11_rri_wreg { # issue rri wreg command
|
5482 |
|
|
my ($aname,$addr,$data) = @_;
|
5483 |
|
|
push @rri_cmdlist, {cname => "wreg",
|
5484 |
|
|
aname => $aname,
|
5485 |
|
|
addr => $addr,
|
5486 |
|
|
data => $data,
|
5487 |
|
|
ref_stat => $rri_ref_sdef,
|
5488 |
|
|
msk_stat => $rri_msk_sdef};
|
5489 |
|
|
return undef;
|
5490 |
|
|
}
|
5491 |
|
|
|
5492 |
|
|
#-------------------------------------------------------------------------------
|
5493 |
|
|
|
5494 |
|
|
sub serv11_rri_rblk { # issue rri rblk command
|
5495 |
|
|
my ($nblk) = @_;
|
5496 |
|
|
push @rri_cmdlist, {cname => "rblk",
|
5497 |
|
|
aname => "brm",
|
5498 |
|
|
addr => PDPCP_ADDR_MEMI,
|
5499 |
|
|
nblk => $nblk,
|
5500 |
|
|
ref_stat => $rri_ref_sdef,
|
5501 |
|
|
msk_stat => $rri_msk_sdef};
|
5502 |
|
|
$rri_cmdlist[$#rri_cmdlist]->{get_rblk} = 1;
|
5503 |
|
|
return $rri_rvalcnt++;
|
5504 |
|
|
}
|
5505 |
|
|
|
5506 |
|
|
#-------------------------------------------------------------------------------
|
5507 |
|
|
|
5508 |
|
|
sub serv11_rri_wblk { # issue rri wblk command
|
5509 |
|
|
my ($nblk,$dref) = @_;
|
5510 |
|
|
push @rri_cmdlist, {cname => "wblk",
|
5511 |
|
|
aname => "bwm",
|
5512 |
|
|
addr => PDPCP_ADDR_MEMI,
|
5513 |
|
|
nblk => $nblk,
|
5514 |
|
|
dat_wblk => $dref,
|
5515 |
|
|
ref_stat => $rri_ref_sdef,
|
5516 |
|
|
msk_stat => $rri_msk_sdef};
|
5517 |
|
|
return undef;
|
5518 |
|
|
}
|
5519 |
|
|
|
5520 |
|
|
#-------------------------------------------------------------------------------
|
5521 |
|
|
|
5522 |
|
|
sub serv11_rri_lalh { # issue pdpcp lal and lah commands
|
5523 |
|
|
my ($addr,$mode) = @_;
|
5524 |
|
|
|
5525 |
|
|
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr&0xffff); # lower 16 bits
|
5526 |
|
|
if ($mode>=1 and $mode<=3) {
|
5527 |
|
|
my $data = ($addr>>16)&0x3f | $mode<<6;
|
5528 |
|
|
serv11_rri_wreg("wah", PDPCP_ADDR_AH, $data); # upper 6 bits
|
5529 |
|
|
}
|
5530 |
|
|
if ($mode<0 or $mode>3) {
|
5531 |
|
|
print STDERR "pi_rri($curmode)-E: bad mode $mode in serv11_exec_rblk()\n";
|
5532 |
|
|
}
|
5533 |
|
|
}
|
5534 |
|
|
|
5535 |
|
|
#-------------------------------------------------------------------------------
|
5536 |
|
|
|
5537 |
|
|
sub serv11_rri_ibrb { # issue rbus set base address
|
5538 |
|
|
my ($ctl) = @_;
|
5539 |
|
|
serv11_rri_wreg("wibrb", PDPCP_ADDR_IBRB, $ctl->{ibrb});
|
5540 |
|
|
return undef;
|
5541 |
|
|
}
|
5542 |
|
|
|
5543 |
|
|
#-------------------------------------------------------------------------------
|
5544 |
|
|
|
5545 |
|
|
sub serv11_rri_ribr { # issue rbus read
|
5546 |
|
|
my ($aname,$ctl,$off) = @_;
|
5547 |
|
|
my $ibroff = $ctl->{base} + $off - $ctl->{ibrb};
|
5548 |
|
|
return serv11_rri_rreg($aname, PDPCP_ADDR_IBR+int($ibroff/2));
|
5549 |
|
|
}
|
5550 |
|
|
|
5551 |
|
|
#-------------------------------------------------------------------------------
|
5552 |
|
|
|
5553 |
|
|
sub serv11_rri_wibr { # issue rbus write
|
5554 |
|
|
my ($aname,$ctl,$off,$data) = @_;
|
5555 |
|
|
my $ibroff = $ctl->{base} + $off - $ctl->{ibrb};
|
5556 |
|
|
return serv11_rri_wreg($aname, PDPCP_ADDR_IBR+int($ibroff/2), $data);
|
5557 |
|
|
}
|
5558 |
|
|
|
5559 |
|
|
#-------------------------------------------------------------------------------
|
5560 |
|
|
|
5561 |
|
|
sub serv11_rri_clear {
|
5562 |
|
|
@rri_cmdlist = ();
|
5563 |
|
|
$rri_rvalcnt = 0;
|
5564 |
|
|
}
|
5565 |
|
|
|
5566 |
|
|
#-------------------------------------------------------------------------------
|
5567 |
|
|
|
5568 |
|
|
sub serv11_rri_exec {
|
5569 |
|
|
my ($dref) = @_;
|
5570 |
|
|
my $rc = 0;
|
5571 |
|
|
|
5572 |
|
|
return $rc if scalar(@rri_cmdlist) == 0;
|
5573 |
|
|
|
5574 |
|
|
rri_cmdlist_exec(\@rri_cmdlist);
|
5575 |
|
|
$rc = rri_cmdlist_check_stat(\@rri_cmdlist);
|
5576 |
|
|
|
5577 |
|
|
if ($rc) {
|
5578 |
|
|
print "pi_rri($curmode)-E: serv11_rri_exec error - dump follows\n";
|
5579 |
|
|
if (exists $opts{log} && $opts{log} ne "") {
|
5580 |
|
|
print $fh_log "pi_rri($curmode)-E: serv11_rri_exec error - dump follows\n";
|
5581 |
|
|
}
|
5582 |
|
|
}
|
5583 |
|
|
if ($rc || exists $opts{dserv}) {
|
5584 |
|
|
rri_cmdlist_dump(\@rri_cmdlist, 0, $fh_log);
|
5585 |
|
|
}
|
5586 |
|
|
|
5587 |
|
|
@{$dref} = ();
|
5588 |
|
|
foreach my $ele (@rri_cmdlist) {
|
5589 |
|
|
push @{$dref}, $ele->{rcv_data} if $ele->{get_data};
|
5590 |
|
|
push @{$dref}, $ele->{rcv_rblk} if $ele->{get_rblk};
|
5591 |
|
|
}
|
5592 |
|
|
|
5593 |
|
|
@rri_cmdlist = ();
|
5594 |
|
|
$rri_rvalcnt = 0;
|
5595 |
|
|
|
5596 |
|
|
return $rc;
|
5597 |
|
|
}
|
5598 |
|
|
|
5599 |
|
|
#-------------------------------------------------------------------------------
|
5600 |
|
|
|
5601 |
|
|
sub serv11_rri_uset { # issue rbus uset writes
|
5602 |
|
|
my $ucb = shift @_;
|
5603 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
5604 |
|
|
my $first = 1;
|
5605 |
|
|
|
5606 |
|
|
while (scalar(@_)) {
|
5607 |
|
|
my $text = shift @_;
|
5608 |
|
|
my $addr = shift @_;
|
5609 |
|
|
my $data = shift @_;
|
5610 |
|
|
my $key = "uset_" . $text;
|
5611 |
|
|
|
5612 |
|
|
if ((not defined $ctl->{$key}) || $ctl->{$key} != $data) {
|
5613 |
|
|
|
5614 |
|
|
serv11_rri_ibrb($ctl) if $first;
|
5615 |
|
|
$first = 0;
|
5616 |
|
|
|
5617 |
|
|
serv11_rri_wibr($text, $ctl, $addr, $data);
|
5618 |
|
|
$ctl->{$key} = $data;
|
5619 |
|
|
|
5620 |
|
|
if (exists $opts{tserv} && $ctl->{trace}) {
|
5621 |
|
|
printf $fh_log "uset -- %s %s %6.6o\n",
|
5622 |
|
|
$ctl->{ctltype}, $ucb->{unitname}, $data;
|
5623 |
|
|
}
|
5624 |
|
|
}
|
5625 |
|
|
}
|
5626 |
|
|
|
5627 |
|
|
}
|
5628 |
|
|
|
5629 |
|
|
#-------------------------------------------------------------------------------
|
5630 |
|
|
|
5631 |
|
|
sub serv11_exec_rblk {
|
5632 |
|
|
my ($addr,$mode,$dref,$nword) = @_;
|
5633 |
|
|
my @rval;
|
5634 |
|
|
|
5635 |
|
|
serv11_rri_lalh($addr,$mode);
|
5636 |
|
|
|
5637 |
|
|
while ($nword>0) {
|
5638 |
|
|
my $nblk = $nword;
|
5639 |
|
|
$nblk = 256 if $nblk > 256;
|
5640 |
|
|
$nword -= $nblk;
|
5641 |
|
|
|
5642 |
|
|
my $idref = serv11_rri_rblk($nblk);
|
5643 |
|
|
|
5644 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
5645 |
|
|
return $rc if $rc;
|
5646 |
|
|
|
5647 |
|
|
push @$dref, @{$rval[$idref]};
|
5648 |
|
|
}
|
5649 |
|
|
|
5650 |
|
|
return 0;
|
5651 |
|
|
}
|
5652 |
|
|
|
5653 |
|
|
#-------------------------------------------------------------------------------
|
5654 |
|
|
|
5655 |
|
|
sub serv11_exec_wblk {
|
5656 |
|
|
my ($addr,$mode,$dref) = @_;
|
5657 |
|
|
my @rval;
|
5658 |
|
|
|
5659 |
|
|
serv11_rri_lalh($addr,$mode);
|
5660 |
|
|
|
5661 |
|
|
my $nword = scalar(@$dref);
|
5662 |
|
|
my $offset = 0;
|
5663 |
|
|
|
5664 |
|
|
if ($nword == 0) {
|
5665 |
|
|
print "pi_rri($curmode)-W: spurious serv11_exec_wblk() with 0 data length\n";
|
5666 |
|
|
return;
|
5667 |
|
|
}
|
5668 |
|
|
|
5669 |
|
|
while ($nword>0) {
|
5670 |
|
|
my $nblk = $nword;
|
5671 |
|
|
$nblk = 256 if $nblk > 256;
|
5672 |
|
|
my $beg = $offset;
|
5673 |
|
|
my $end = $offset+$nblk-1;
|
5674 |
|
|
|
5675 |
|
|
serv11_rri_wblk($nblk, [ @$dref[$beg..$end] ]);
|
5676 |
|
|
|
5677 |
|
|
$nword -= $nblk;
|
5678 |
|
|
$offset += $nblk;
|
5679 |
|
|
|
5680 |
|
|
my $rc = serv11_rri_exec(\@rval);
|
5681 |
|
|
return $rc if $rc;
|
5682 |
|
|
}
|
5683 |
|
|
|
5684 |
|
|
return 0;
|
5685 |
|
|
}
|
5686 |
|
|
|
5687 |
|
|
#-------------------------------------------------------------------------------
|
5688 |
|
|
|
5689 |
|
|
sub serv11_exec_probe {
|
5690 |
|
|
my ($addr,$mode) = @_;
|
5691 |
|
|
my $iib;
|
5692 |
|
|
my $irb;
|
5693 |
|
|
|
5694 |
|
|
if ($mode =~ /i/) {
|
5695 |
|
|
serv11_rri_wreg("wal", PDPCP_ADDR_AL, $addr); # i/o page in 16 bit mode
|
5696 |
|
|
serv11_rri_rreg("rm", PDPCP_ADDR_MEM);
|
5697 |
|
|
$iib = $#rri_cmdlist;
|
5698 |
|
|
}
|
5699 |
|
|
if ($mode =~ /r/) {
|
5700 |
|
|
my $ibrbase = $addr & ~(077); # ibr-base => drop last 6 bits
|
5701 |
|
|
my $ibroff = $addr & (077); # ibr-offset => take last 6 bits
|
5702 |
|
|
|
5703 |
|
|
serv11_rri_wreg("wibrb", PDPCP_ADDR_IBRB, $ibrbase);
|
5704 |
|
|
serv11_rri_rreg("ribr", PDPCP_ADDR_IBR + int($ibroff/2));
|
5705 |
|
|
$irb = $#rri_cmdlist;
|
5706 |
|
|
}
|
5707 |
|
|
|
5708 |
|
|
rri_cmdlist_exec(\@rri_cmdlist);
|
5709 |
|
|
rri_cmdlist_dump(\@rri_cmdlist, 0) if exists $opts{dserv};
|
5710 |
|
|
|
5711 |
|
|
my $ival;
|
5712 |
|
|
my $rval;
|
5713 |
|
|
if (defined $iib) {
|
5714 |
|
|
$ival =$rri_cmdlist[$iib]->{rcv_data} if not $rri_cmdlist[$iib]->{err_stat};
|
5715 |
|
|
}
|
5716 |
|
|
if (defined $irb) {
|
5717 |
|
|
$rval =$rri_cmdlist[$irb]->{rcv_data} if not $rri_cmdlist[$irb]->{err_stat};
|
5718 |
|
|
}
|
5719 |
|
|
serv11_rri_clear();
|
5720 |
|
|
|
5721 |
|
|
return ($ival, $rval);
|
5722 |
|
|
}
|
5723 |
|
|
|
5724 |
|
|
#-------------------------------------------------------------------------------
|
5725 |
|
|
|
5726 |
|
|
sub next_nxbuf { # calculate next nxbuf value
|
5727 |
|
|
my ($ctl,$nxbuf,$nxbuf_val) = @_;
|
5728 |
|
|
|
5729 |
|
|
if ($nxbuf_val <= $nxbuf/2) {
|
5730 |
|
|
$nxbuf -= $ctl->{nxbuf_inc};
|
5731 |
|
|
} else {
|
5732 |
|
|
$nxbuf += $ctl->{nxbuf_inc};
|
5733 |
|
|
}
|
5734 |
|
|
$nxbuf = $ctl->{nxbuf_min} if $nxbuf < $ctl->{nxbuf_min};
|
5735 |
|
|
$nxbuf = $ctl->{nxbuf_max} if $nxbuf > $ctl->{nxbuf_max};
|
5736 |
|
|
|
5737 |
|
|
return $nxbuf;
|
5738 |
|
|
}
|
5739 |
|
|
|
5740 |
|
|
#-------------------------------------------------------------------------------
|
5741 |
|
|
|
5742 |
|
|
sub telnet_readhdl { # telnet: socket read handler
|
5743 |
|
|
my ($teldsc) = @_;
|
5744 |
|
|
my $ucb = $teldsc->{ucb};
|
5745 |
|
|
|
5746 |
|
|
if ($teldsc->{state} == TELNET_STATE_LISTEN) {
|
5747 |
|
|
my $fh_data = new FileHandle;
|
5748 |
|
|
if (not accept($fh_data, $teldsc->{fh_port})) {
|
5749 |
|
|
printf STDERR "pi_rri($curmode)-E: erro in accept(): $!\n";
|
5750 |
|
|
return; # FIXME: error handling ??
|
5751 |
|
|
}
|
5752 |
|
|
printf "connect on port %s for %s\n", $teldsc->{port}, $ucb->{unitname};
|
5753 |
|
|
my $buf;
|
5754 |
|
|
my $rc;
|
5755 |
|
|
$buf = pack("C3", TELNET_CODE_IAC, TELNET_CODE_WILL, TELNET_OPT_LINE);
|
5756 |
|
|
$rc = syswrite($fh_data, $buf, length($buf));
|
5757 |
|
|
$buf = pack("C3", TELNET_CODE_IAC, TELNET_CODE_WILL, TELNET_OPT_SGA);
|
5758 |
|
|
$rc = syswrite($fh_data, $buf, length($buf));
|
5759 |
|
|
$buf = pack("C3", TELNET_CODE_IAC, TELNET_CODE_WILL, TELNET_OPT_ECHO);
|
5760 |
|
|
$rc = syswrite($fh_data, $buf, length($buf));
|
5761 |
|
|
$buf = pack("C3", TELNET_CODE_IAC, TELNET_CODE_WILL, TELNET_OPT_BIN);
|
5762 |
|
|
$rc = syswrite($fh_data, $buf, length($buf));
|
5763 |
|
|
$buf = pack("C3", TELNET_CODE_IAC, TELNET_CODE_DO, TELNET_OPT_BIN);
|
5764 |
|
|
$rc = syswrite($fh_data, $buf, length($buf));
|
5765 |
|
|
|
5766 |
|
|
$teldsc->{state} = TELNET_STATE_STREAM;
|
5767 |
|
|
$teldsc->{fh_data} = $fh_data;
|
5768 |
|
|
|
5769 |
|
|
$buf = sprintf("\r\nconnect on port %s for %s\r\n\r\n",
|
5770 |
|
|
$teldsc->{port}, $ucb->{unitname});
|
5771 |
|
|
$rc = syswrite($fh_data, $buf, length($buf));
|
5772 |
|
|
|
5773 |
|
|
telnet_writehdl($ucb);
|
5774 |
|
|
|
5775 |
|
|
$serv11_fds_update = 1;
|
5776 |
|
|
|
5777 |
|
|
} else {
|
5778 |
|
|
|
5779 |
|
|
my $buf;
|
5780 |
|
|
my $rc;
|
5781 |
|
|
$rc = sysread($teldsc->{fh_data}, $buf, 64);
|
5782 |
|
|
|
5783 |
|
|
if ($rc == 0) {
|
5784 |
|
|
printf "disconnect on port %s for %s\n", $teldsc->{port}, $ucb->{unitname};
|
5785 |
|
|
close ($teldsc->{fh_data});
|
5786 |
|
|
delete $teldsc->{fh_data};
|
5787 |
|
|
$teldsc->{state} = TELNET_STATE_LISTEN;
|
5788 |
|
|
$serv11_fds_update = 1;
|
5789 |
|
|
|
5790 |
|
|
} else {
|
5791 |
|
|
my @int = unpack("C*", $buf);
|
5792 |
|
|
foreach my $byt (@int) {
|
5793 |
|
|
if ($teldsc->{state} == TELNET_STATE_STREAM) { # state: stream
|
5794 |
|
|
if ($byt == TELNET_CODE_IAC) {
|
5795 |
|
|
$teldsc->{state} = TELNET_STATE_IAC;
|
5796 |
|
|
} else {
|
5797 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
5798 |
|
|
my @bytes;
|
5799 |
|
|
push @bytes, $byt;
|
5800 |
|
|
&{$ctl->{ichrhdl}}($ucb, \@bytes); # call ichr handler
|
5801 |
|
|
}
|
5802 |
|
|
} elsif ($teldsc->{state} == TELNET_STATE_IAC) { # state: IAC seen
|
5803 |
|
|
if ($byt == TELNET_CODE_WILL ||
|
5804 |
|
|
$byt == TELNET_CODE_WONT ||
|
5805 |
|
|
$byt == TELNET_CODE_DO ||
|
5806 |
|
|
$byt == TELNET_CODE_DONT) {
|
5807 |
|
|
$teldsc->{state} = TELNET_STATE_CMD;
|
5808 |
|
|
} elsif ($byt == TELNET_CODE_SB) {
|
5809 |
|
|
$teldsc->{state} = TELNET_STATE_SUBNEG;
|
5810 |
|
|
} else {
|
5811 |
|
|
$teldsc->{state} = TELNET_STATE_STREAM;
|
5812 |
|
|
}
|
5813 |
|
|
} elsif ($teldsc->{state} == TELNET_STATE_CMD) { # state: cmd seen
|
5814 |
|
|
$teldsc->{state} = 0;
|
5815 |
|
|
} elsif ($teldsc->{state} == TELNET_STATE_SUBNEG) { # state: subneg
|
5816 |
|
|
if ($byt == TELNET_CODE_IAC) {
|
5817 |
|
|
$teldsc->{state} = TELNET_STATE_SUBIAC;
|
5818 |
|
|
}
|
5819 |
|
|
} elsif ($teldsc->{state} == TELNET_STATE_SUBIAC) { # state: subneg+IAC
|
5820 |
|
|
$teldsc->{state} = TELNET_STATE_STREAM;
|
5821 |
|
|
}
|
5822 |
|
|
}
|
5823 |
|
|
}
|
5824 |
|
|
}
|
5825 |
|
|
}
|
5826 |
|
|
|
5827 |
|
|
#-------------------------------------------------------------------------------
|
5828 |
|
|
|
5829 |
|
|
sub telnet_writehdl { # telnet: write handler
|
5830 |
|
|
my ($ucb) = @_;
|
5831 |
|
|
|
5832 |
|
|
my $teldsc = $telnettbl{$ucb->{att_port}};
|
5833 |
|
|
return if $teldsc->{state} == TELNET_STATE_LISTEN;
|
5834 |
|
|
|
5835 |
|
|
while (scalar( @{$ucb->{sndque}} )) {
|
5836 |
|
|
my $byte = shift @{$ucb->{sndque}};
|
5837 |
|
|
syswrite($teldsc->{fh_data}, pack("C1",$byte), 1);
|
5838 |
|
|
## FIXME: escape IAC !!
|
5839 |
|
|
## if ($byte == TELNET_CODE_CR) {
|
5840 |
|
|
## syswrite($teldsc->{fh_data}, pack("C1",TELNET_CODE_LF), 1);
|
5841 |
|
|
## }
|
5842 |
|
|
}
|
5843 |
|
|
|
5844 |
|
|
}
|
5845 |
|
|
|
5846 |
|
|
#-------------------------------------------------------------------------------
|
5847 |
|
|
|
5848 |
|
|
sub pdp11_disassemble {
|
5849 |
|
|
my ($pc,$d0,$d1,$d2) = @_;
|
5850 |
|
|
my @mem = ($d0,0,0);
|
5851 |
|
|
$mem[1] = $d1 if defined $d1;
|
5852 |
|
|
$mem[2] = $d2 if defined $d2;
|
5853 |
|
|
|
5854 |
|
|
my $code = shift @mem;
|
5855 |
|
|
|
5856 |
|
|
foreach my $ele (@pdp11_opcode_tbl) {
|
5857 |
|
|
if (($code & (~($ele->{mask})) ) == $ele->{code}) {
|
5858 |
|
|
my $name = $ele->{name};
|
5859 |
|
|
my $type = $ele->{type};
|
5860 |
|
|
my $str = $name;
|
5861 |
|
|
if ($type eq "0arg") {
|
5862 |
|
|
return ($name,1);
|
5863 |
|
|
|
5864 |
|
|
} elsif ($type eq "1arg" or $type eq "1fpp") {
|
5865 |
|
|
my $dst = $code & 077;
|
5866 |
|
|
my $pref = ($type eq "1fpp") ? "f" : "r";
|
5867 |
|
|
my ($dst_str,$dst_nw,$dst_ta) =
|
5868 |
|
|
pdp11_disassemble_regmod($dst, $mem[0], $pc+2, $pref);
|
5869 |
|
|
shift @mem if ($dst_nw);
|
5870 |
|
|
$str = "$name $dst_str";
|
5871 |
|
|
if ($dst_ta) {
|
5872 |
|
|
$str .= " " x (27-length($str)) if length($str)<27;
|
5873 |
|
|
$str .= "; $dst_ta";
|
5874 |
|
|
}
|
5875 |
|
|
return ($str, 1+$dst_nw);
|
5876 |
|
|
|
5877 |
|
|
} elsif ($type eq "2arg") {
|
5878 |
|
|
my $src = ($code>>6) & 077;
|
5879 |
|
|
my $dst = $code & 077;
|
5880 |
|
|
my ($src_str,$src_nw,$src_ta) =
|
5881 |
|
|
pdp11_disassemble_regmod($src, $mem[0], $pc+2);
|
5882 |
|
|
shift @mem if ($src_nw);
|
5883 |
|
|
my ($dst_str,$dst_nw,$dst_ta) =
|
5884 |
|
|
pdp11_disassemble_regmod($dst, $mem[0], $pc+2+2*$src_nw);
|
5885 |
|
|
shift @mem if ($dst_nw);
|
5886 |
|
|
$str = "$name $src_str,$dst_str";
|
5887 |
|
|
if ($src_ta or $dst_ta) {
|
5888 |
|
|
$str .= " " x (27-length($str)) if length($str)<27;
|
5889 |
|
|
$str .= ";";
|
5890 |
|
|
$str .= " $src_ta" if $src_ta;
|
5891 |
|
|
$str .= " $dst_ta" if $dst_ta;
|
5892 |
|
|
}
|
5893 |
|
|
return ($str, 1+$src_nw+$dst_nw);
|
5894 |
|
|
|
5895 |
|
|
} elsif ($type eq "rdst") {
|
5896 |
|
|
my $reg = ($code>>6) & 07;
|
5897 |
|
|
my $src = $code & 077;
|
5898 |
|
|
my ($src_str,$src_nw,$src_ta) =
|
5899 |
|
|
pdp11_disassemble_regmod($src, $mem[0], $pc+2);
|
5900 |
|
|
shift @mem if ($src_nw);
|
5901 |
|
|
$str = "$name $src_str,r$reg";
|
5902 |
|
|
if ($src_ta) {
|
5903 |
|
|
$str .= " " x (27-length($str)) if length($str)<27;
|
5904 |
|
|
$str .= "; $src_ta";
|
5905 |
|
|
}
|
5906 |
|
|
return ($str, 1+$src_nw);
|
5907 |
|
|
|
5908 |
|
|
} elsif ($type eq "1reg") {
|
5909 |
|
|
my $reg = $code & 07;
|
5910 |
|
|
my $reg_str = "r$reg";
|
5911 |
|
|
$reg_str = "sp" if $reg == 6;
|
5912 |
|
|
$reg_str = "pc" if $reg == 7;
|
5913 |
|
|
return ("$name $reg_str", 1);
|
5914 |
|
|
|
5915 |
|
|
} elsif ($type eq "br") {
|
5916 |
|
|
my $off = $code & 0177;
|
5917 |
|
|
my $sign = "+";
|
5918 |
|
|
if ($code & 0200) {
|
5919 |
|
|
$off = -(((~$off) & 0177)+1);
|
5920 |
|
|
$sign = "-";
|
5921 |
|
|
}
|
5922 |
|
|
my $str = sprintf "$name .%s%d.", $sign, abs(2*$off);
|
5923 |
|
|
$str .= " " x (27-length($str)) if length($str)<27;
|
5924 |
|
|
$str .= sprintf "; -> %6.6o", (($pc+2)+2*$off)&0177777;
|
5925 |
|
|
return ($str, 1);
|
5926 |
|
|
|
5927 |
|
|
} elsif ($type eq "sob") {
|
5928 |
|
|
my $reg = ($code>>6) & 07;
|
5929 |
|
|
my $off = $code & 077;
|
5930 |
|
|
my $str = sprintf "$name r%d,.-%d.", $reg, 2*$off;
|
5931 |
|
|
$str .= " " x (27-length($str)) if length($str)<27;
|
5932 |
|
|
$str .= sprintf "; -> %6.6o", ($pc+2)-2*$off;
|
5933 |
|
|
return ($str, 1);
|
5934 |
|
|
|
5935 |
|
|
} elsif ($type eq "trap") {
|
5936 |
|
|
my $off = $code & 0377;
|
5937 |
|
|
my $str = sprintf "$name %3.3o", $off;
|
5938 |
|
|
return ($str, 1);
|
5939 |
|
|
|
5940 |
|
|
} elsif ($type eq "spl") {
|
5941 |
|
|
my $off = $code & 07;
|
5942 |
|
|
my $str = sprintf "$name %d", $off;
|
5943 |
|
|
return ($str, 1);
|
5944 |
|
|
|
5945 |
|
|
} elsif ($type eq "ccop") {
|
5946 |
|
|
my $cc = $code & 017;
|
5947 |
|
|
return ("nop",1) if ($cc == 0);
|
5948 |
|
|
return ("ccc",1) if ($code == 0257);
|
5949 |
|
|
return ("scc",1) if ($code == 0277);
|
5950 |
|
|
my $str = "";
|
5951 |
|
|
my $del = "";
|
5952 |
|
|
if ($code & 010) { $str .= $del . $name . "n", $del = "+" }
|
5953 |
|
|
if ($code & 004) { $str .= $del . $name . "z", $del = "+" }
|
5954 |
|
|
if ($code & 002) { $str .= $del . $name . "v", $del = "+" }
|
5955 |
|
|
if ($code & 001) { $str .= $del . $name . "c", $del = "+" }
|
5956 |
|
|
return ($str, 1);
|
5957 |
|
|
|
5958 |
|
|
} elsif ($type eq "jsr") {
|
5959 |
|
|
my $reg = ($code>>6) & 07;
|
5960 |
|
|
my $dst = $code & 077;
|
5961 |
|
|
my ($dst_str,$dst_nw,$dst_ta) =
|
5962 |
|
|
pdp11_disassemble_regmod($dst, $mem[0], $pc+2);
|
5963 |
|
|
shift @mem if ($dst_nw);
|
5964 |
|
|
$str = "$name r$reg,$dst_str";
|
5965 |
|
|
if ($dst_ta) {
|
5966 |
|
|
$str .= " " x (27-length($str)) if length($str)<27;
|
5967 |
|
|
$str .= "; $dst_ta";
|
5968 |
|
|
}
|
5969 |
|
|
return ($str, 1+$dst_nw);
|
5970 |
|
|
|
5971 |
|
|
} elsif ($type eq "mark") {
|
5972 |
|
|
my $off = $code & 077;
|
5973 |
|
|
my $str = sprintf "$name %3.3o", $off;
|
5974 |
|
|
return ($str, 1);
|
5975 |
|
|
|
5976 |
|
|
} elsif ($type eq "rfpp") {
|
5977 |
|
|
my $reg = ($code>>6) & 03;
|
5978 |
|
|
my $dst = $code & 077;
|
5979 |
|
|
my ($dst_str,$dst_nw,$dst_ta) =
|
5980 |
|
|
pdp11_disassemble_regmod($dst, $mem[0], $pc+2, "f");
|
5981 |
|
|
shift @mem if ($dst_nw);
|
5982 |
|
|
$str = "$name f$reg,$dst_str";
|
5983 |
|
|
if ($dst_ta) {
|
5984 |
|
|
$str .= " " x (27-length($str)) if length($str)<27;
|
5985 |
|
|
$str .= "; $dst_ta";
|
5986 |
|
|
}
|
5987 |
|
|
return ($str, 1+$dst_nw);
|
5988 |
|
|
|
5989 |
|
|
} else {
|
5990 |
|
|
return ("?type?",1);
|
5991 |
|
|
}
|
5992 |
|
|
}
|
5993 |
|
|
}
|
5994 |
|
|
return ("=inval=",1);
|
5995 |
|
|
}
|
5996 |
|
|
|
5997 |
|
|
#-------------------------------------------------------------------------------
|
5998 |
|
|
|
5999 |
|
|
sub pdp11_disassemble_regmod {
|
6000 |
|
|
my ($regmod,$data,$pc,$pref) = @_;
|
6001 |
|
|
my $mod = ($regmod>>3) & 07;
|
6002 |
|
|
my $reg = $regmod & 07;
|
6003 |
|
|
|
6004 |
|
|
$pref = "r" if not defined $pref or $reg>5;
|
6005 |
|
|
|
6006 |
|
|
my $reg_str = "r$reg";
|
6007 |
|
|
$reg_str = "sp" if $reg == 6;
|
6008 |
|
|
$reg_str = "pc" if $reg == 7;
|
6009 |
|
|
|
6010 |
|
|
if ($mod == 0) { # mode 0: Rx { Fx for float }
|
6011 |
|
|
$reg_str = "f$reg" if defined $pref && $pref eq "f" && $reg<=5;
|
6012 |
|
|
return ($reg_str, 0, "");
|
6013 |
|
|
} elsif ($mod == 1) { # mode 1: (Rx)
|
6014 |
|
|
return ("($reg_str)", 0, "");
|
6015 |
|
|
} elsif ($mod == 2 || $mod == 3) { # mode 2/3: (Rx)+ @(Rx)+
|
6016 |
|
|
my $ind = ($mod == 3) ? "@" : "";
|
6017 |
|
|
if ($reg != 7) { # if reg != pc
|
6018 |
|
|
return ("$ind($reg_str)+", 0, "");
|
6019 |
|
|
} else { # if reg == pc
|
6020 |
|
|
my $str = sprintf "$ind#%6.6o", $data; # 27 -> #nnn; 37 -> @#nnn
|
6021 |
|
|
return ($str, 1, "");
|
6022 |
|
|
}
|
6023 |
|
|
} elsif ($mod == 4 || $mod == 5) { # mode 4/5: -(Rx) @-(Rx)
|
6024 |
|
|
my $ind = ($mod == 5) ? "@" : "";
|
6025 |
|
|
return ("$ind-($reg_str)", 0, "");
|
6026 |
|
|
} elsif ($mod == 6 || $mod == 7) { # mode 6/7: nn(Rx) @nn(Rx)
|
6027 |
|
|
my $ind = ($mod == 7) ? "@" : "";
|
6028 |
|
|
my $data_str = sprintf "%o", $data;
|
6029 |
|
|
my $ta_str = "";
|
6030 |
|
|
$ta_str = sprintf "%6.6o",($pc+2+$data)&0177777 if ($reg==7);
|
6031 |
|
|
return ("$ind$data_str($reg_str)", 1, $ta_str);
|
6032 |
|
|
}
|
6033 |
|
|
}
|
6034 |
|
|
|
6035 |
|
|
#-------------------------------------------------------------------------------
|
6036 |
|
|
|
6037 |
|
|
sub file_seek { # fseek wrapper
|
6038 |
|
|
my ($fh,$pos) = @_;
|
6039 |
|
|
my $rc;
|
6040 |
|
|
my $offset = $pos;
|
6041 |
|
|
my $whence = 0;
|
6042 |
|
|
if ($pos < 0) { # if offset<0 -> seek to EOF
|
6043 |
|
|
$offset = 0;
|
6044 |
|
|
$whence = 2;
|
6045 |
|
|
}
|
6046 |
|
|
$rc = $fh->seek($offset, $whence);
|
6047 |
|
|
if (not $rc) {
|
6048 |
|
|
print "pi_rri($curmode)-E: file_seek failed\n";
|
6049 |
|
|
$rc = 0;
|
6050 |
|
|
}
|
6051 |
|
|
return $rc;
|
6052 |
|
|
}
|
6053 |
|
|
|
6054 |
|
|
#-------------------------------------------------------------------------------
|
6055 |
|
|
|
6056 |
|
|
sub file_read { # fread wrapper
|
6057 |
|
|
my ($fh,$nbyte) = @_;
|
6058 |
|
|
my $rc;
|
6059 |
|
|
my $buf = "";
|
6060 |
|
|
|
6061 |
|
|
$rc = $fh->read($buf, $nbyte);
|
6062 |
|
|
if ($rc != $nbyte) {
|
6063 |
|
|
print "pi_rri($curmode)-E: file_read failed, got $rc, expectd $nbyte\n";
|
6064 |
|
|
$rc = 0;
|
6065 |
|
|
}
|
6066 |
|
|
return ($rc, $buf);
|
6067 |
|
|
}
|
6068 |
|
|
|
6069 |
|
|
#-------------------------------------------------------------------------------
|
6070 |
|
|
|
6071 |
|
|
sub file_seek_read { # fseek+fread wrapper
|
6072 |
|
|
my ($fh,$pos,$nbyte) = @_;
|
6073 |
|
|
my $rc;
|
6074 |
|
|
my $buf;
|
6075 |
|
|
$rc = file_seek($fh, $pos);
|
6076 |
|
|
($rc,$buf) = file_read($fh, $nbyte) if $rc;
|
6077 |
|
|
return ($rc, $buf);
|
6078 |
|
|
}
|
6079 |
|
|
|
6080 |
|
|
#-------------------------------------------------------------------------------
|
6081 |
|
|
|
6082 |
|
|
sub file_write { # fwrite wrapper
|
6083 |
|
|
my ($fh,$buf) = @_;
|
6084 |
|
|
my $rc;
|
6085 |
|
|
$rc = print $fh $buf;
|
6086 |
|
|
if (not $rc) {
|
6087 |
|
|
print "pi_rri($curmode)-E: file_write failed\n";
|
6088 |
|
|
$rc = 0;
|
6089 |
|
|
}
|
6090 |
|
|
return $rc;
|
6091 |
|
|
}
|
6092 |
|
|
|
6093 |
|
|
#-------------------------------------------------------------------------------
|
6094 |
|
|
|
6095 |
|
|
sub file_seek_write { # fseek+fwrite wrapper
|
6096 |
|
|
my ($fh,$pos,$buf) = @_;
|
6097 |
|
|
my $rc;
|
6098 |
|
|
$rc = file_seek($fh, $pos);
|
6099 |
|
|
$rc = file_write($fh, $buf) if $rc;
|
6100 |
|
|
return $rc;
|
6101 |
|
|
}
|
6102 |
|
|
|
6103 |
|
|
#-------------------------------------------------------------------------------
|
6104 |
|
|
|
6105 |
|
|
sub raw_get9_crc_16bit { # read 16 bit value
|
6106 |
|
|
my ($dref) = @_;
|
6107 |
|
|
my $idl = raw_get9_crc();
|
6108 |
|
|
my $idh = undef;
|
6109 |
|
|
$idh = raw_get9_crc() if defined $idl;
|
6110 |
|
|
|
6111 |
|
|
if (defined $idh) {
|
6112 |
|
|
my $idat = $idl | ($idh<<8);
|
6113 |
|
|
$$dref = $idat;
|
6114 |
|
|
return 1;
|
6115 |
|
|
}
|
6116 |
|
|
print "pi_rri($curmode)-E: receive time out\n";
|
6117 |
|
|
print $fh_log "ERR -- receive time out in raw_get9_crc_16bit\n";
|
6118 |
|
|
return 0;
|
6119 |
|
|
}
|
6120 |
|
|
|
6121 |
|
|
#-------------------------------------------------------------------------------
|
6122 |
|
|
|
6123 |
|
|
sub raw_get9_crc_8bit { # read 8bit value
|
6124 |
|
|
my ($dref) = @_;
|
6125 |
|
|
my $idat = raw_get9_crc();
|
6126 |
|
|
if (defined $idat) {
|
6127 |
|
|
$$dref = $idat;
|
6128 |
|
|
return 1;
|
6129 |
|
|
}
|
6130 |
|
|
return 0;
|
6131 |
|
|
}
|
6132 |
|
|
|
6133 |
|
|
#-------------------------------------------------------------------------------
|
6134 |
|
|
|
6135 |
|
|
sub raw_get9_crc_check { # get 9bit, block, crc, ref value
|
6136 |
|
|
my ($ref,$case) = @_;
|
6137 |
|
|
my $dat = raw_get9_crc();
|
6138 |
|
|
if (defined $dat) {
|
6139 |
|
|
return 1 if ($dat == $ref);
|
6140 |
|
|
printf "pi_rri($curmode)-E: receive $case mismatch" .
|
6141 |
|
|
" found=0x%3.3x expect=0x%3.3x\n",
|
6142 |
|
|
$dat, $ref;
|
6143 |
|
|
return 0;
|
6144 |
|
|
}
|
6145 |
|
|
return 0;
|
6146 |
|
|
}
|
6147 |
|
|
|
6148 |
|
|
#-------------------------------------------------------------------------------
|
6149 |
|
|
|
6150 |
|
|
sub raw_get9_check { # get 9bit, block, expect ref value
|
6151 |
|
|
my ($ref,$case) = @_;
|
6152 |
|
|
my $dat = raw_get9();
|
6153 |
|
|
if (defined $dat) {
|
6154 |
|
|
return 1 if ($dat == $ref);
|
6155 |
|
|
printf "pi_rri($curmode)-E: receive $case mismatch" .
|
6156 |
|
|
" found=0x%3.3x expect=0x%3.3x\n",
|
6157 |
|
|
$dat, $ref;
|
6158 |
|
|
return 0;
|
6159 |
|
|
}
|
6160 |
|
|
return 0;
|
6161 |
|
|
}
|
6162 |
|
|
|
6163 |
|
|
#-------------------------------------------------------------------------------
|
6164 |
|
|
|
6165 |
|
|
sub raw_get9_checksop { # get 9bit, block, expect SOP
|
6166 |
|
|
my $dat;
|
6167 |
|
|
while(1) {
|
6168 |
|
|
$dat = raw_get9();
|
6169 |
|
|
last unless defined $dat;
|
6170 |
|
|
last if ($dat != D9ATTN);
|
6171 |
|
|
if ($serv11_active) {
|
6172 |
|
|
$serv11_attn_seen = 1;
|
6173 |
|
|
} else {
|
6174 |
|
|
printf "pi_rri($curmode)-W: unexpected ATTN comma dropped\n";
|
6175 |
|
|
}
|
6176 |
|
|
}
|
6177 |
|
|
if (defined $dat) {
|
6178 |
|
|
return 1 if ($dat == D9SOP);
|
6179 |
|
|
printf "pi_rri($curmode)-E: expect sop, but found=0x%3.3x\n", $dat;
|
6180 |
|
|
}
|
6181 |
|
|
return 0;
|
6182 |
|
|
}
|
6183 |
|
|
|
6184 |
|
|
#-------------------------------------------------------------------------------
|
6185 |
|
|
|
6186 |
|
|
sub raw_get9_checkeop { # get 9bit, block, expect EOP
|
6187 |
|
|
my $dat;
|
6188 |
|
|
$dat = raw_get9();
|
6189 |
|
|
if (defined $dat) {
|
6190 |
|
|
return 1 if ($dat == D9EOP);
|
6191 |
|
|
printf "pi_rri($curmode)-E: expect eop, but found=0x%3.3x\n", $dat;
|
6192 |
|
|
}
|
6193 |
|
|
return 0;
|
6194 |
|
|
}
|
6195 |
|
|
|
6196 |
|
|
#-------------------------------------------------------------------------------
|
6197 |
|
|
|
6198 |
|
|
sub raw_get9_crc { # get 9bit, block, update crc
|
6199 |
|
|
my $dat = raw_get9();
|
6200 |
|
|
$icrc = $crc8_tbl[$icrc ^ $dat] if (defined $dat && $dat < 0x100);
|
6201 |
|
|
return $dat;
|
6202 |
|
|
}
|
6203 |
|
|
|
6204 |
|
|
#-------------------------------------------------------------------------------
|
6205 |
|
|
|
6206 |
|
|
sub raw_get9 { # get 9bit, block
|
6207 |
|
|
my $nidle = 0;
|
6208 |
|
|
my $dat = undef;
|
6209 |
|
|
while (1) {
|
6210 |
|
|
$dat = raw_rcv9_to($raw_timeout);
|
6211 |
|
|
last unless defined $dat;
|
6212 |
|
|
last if $dat != D9IDLE;
|
6213 |
|
|
$nidle += 1;
|
6214 |
|
|
}
|
6215 |
|
|
## print "pi_rri($curmode)-I: dropped $nidle idle commas\n" if $nidle;
|
6216 |
|
|
print "pi_rri($curmode)-E: receive time out\n" unless defined $dat;
|
6217 |
|
|
print $fh_log "ERR -- receive time out in raw_get9\n" unless defined $dat;
|
6218 |
|
|
return $dat;
|
6219 |
|
|
}
|
6220 |
|
|
|
6221 |
|
|
#-------------------------------------------------------------------------------
|
6222 |
|
|
|
6223 |
|
|
sub raw_snd9_crc { # put 9bit to RX, update crc
|
6224 |
|
|
my ($dat) = @_;
|
6225 |
|
|
raw_snd9($dat);
|
6226 |
|
|
$ocrc = $crc8_tbl[$ocrc ^ $dat] if ($dat < 0x100);
|
6227 |
|
|
}
|
6228 |
|
|
|
6229 |
|
|
#-------------------------------------------------------------------------------
|
6230 |
|
|
|
6231 |
|
|
sub raw_snd9 { # put 9bit to RX
|
6232 |
|
|
my ($dat) = @_;
|
6233 |
|
|
|
6234 |
|
|
if (exists $opts{tio9}) {
|
6235 |
|
|
print $fh_log conv_etime(\$tlast_tio9),
|
6236 |
|
|
"[$curchan] snd9 ", conv_dat9($dat);
|
6237 |
|
|
printf $fh_log " sndq=%3d", scalar(@que_snd);
|
6238 |
|
|
print $fh_log " -- idle" if $dat == D9IDLE;
|
6239 |
|
|
print $fh_log " -- sop " if $dat == D9SOP;
|
6240 |
|
|
print $fh_log " -- eop " if $dat == D9EOP;
|
6241 |
|
|
print $fh_log " -- nak " if $dat == D9NAK;
|
6242 |
|
|
print $fh_log " -- attn" if $dat == D9ATTN;
|
6243 |
|
|
print $fh_log "\n";
|
6244 |
|
|
}
|
6245 |
|
|
$stat_tab{osop} += 1 if $dat == D9SOP;
|
6246 |
|
|
|
6247 |
|
|
if ($dat >= 0x100) {
|
6248 |
|
|
raw_snd8(CPREF | ($dat & 0x0f));
|
6249 |
|
|
} else {
|
6250 |
|
|
if ( $dat == CESC ||
|
6251 |
|
|
($dat >= CPREF && $dat <= (CPREF+NCOMM)) ) {
|
6252 |
|
|
raw_snd8(CESC);
|
6253 |
|
|
raw_snd8(CEN1 | ($dat & 0x0f));
|
6254 |
|
|
$stat_tab{oesc} += 1;
|
6255 |
|
|
} else {
|
6256 |
|
|
raw_snd8($dat);
|
6257 |
|
|
}
|
6258 |
|
|
}
|
6259 |
|
|
}
|
6260 |
|
|
|
6261 |
|
|
#-------------------------------------------------------------------------------
|
6262 |
|
|
|
6263 |
|
|
sub raw_snd8 { # put 8bit to RX
|
6264 |
|
|
my ($dat) = @_;
|
6265 |
|
|
if (exists $opts{tio8}) {
|
6266 |
|
|
print $fh_log conv_etime(\$tlast_tio8),
|
6267 |
|
|
"[$curchan] snd8 ", conv_dat8($dat),"\n";
|
6268 |
|
|
}
|
6269 |
|
|
$stat_tab{obyte} += 1;
|
6270 |
|
|
|
6271 |
|
|
push @que_snd, int $dat;
|
6272 |
|
|
}
|
6273 |
|
|
|
6274 |
|
|
#-------------------------------------------------------------------------------
|
6275 |
|
|
|
6276 |
|
|
sub raw_rcv9 { # get 9bit from TX, non-blocking
|
6277 |
|
|
return raw_rcv9_to(0.);
|
6278 |
|
|
}
|
6279 |
|
|
|
6280 |
|
|
#-------------------------------------------------------------------------------
|
6281 |
|
|
|
6282 |
|
|
sub raw_rcv8 { # get 8bit from TX, non-blocking
|
6283 |
|
|
return raw_rcv8_to(0.);
|
6284 |
|
|
}
|
6285 |
|
|
|
6286 |
|
|
#-------------------------------------------------------------------------------
|
6287 |
|
|
|
6288 |
|
|
sub raw_rcv9_to {
|
6289 |
|
|
my ($timeout) = @_;
|
6290 |
|
|
my $dat8 = raw_rcv8_to($timeout);
|
6291 |
|
|
my $dat9 = undef;
|
6292 |
|
|
|
6293 |
|
|
if (defined $dat8) {
|
6294 |
|
|
if ($dat8 == CESC) {
|
6295 |
|
|
$stat_tab{iesc} += 1;
|
6296 |
|
|
$raw_rcv_esc = 1;
|
6297 |
|
|
$dat8 = raw_rcv8_to($timeout);
|
6298 |
|
|
return $dat8 unless defined $dat8;
|
6299 |
|
|
}
|
6300 |
|
|
if ($raw_rcv_esc) {
|
6301 |
|
|
$dat9 = CPREF | ($dat8 & 0x0f);
|
6302 |
|
|
$raw_rcv_esc = 0;
|
6303 |
|
|
} else {
|
6304 |
|
|
if ($dat8>= CPREF && $dat8<=(CPREF+NCOMM) ) {
|
6305 |
|
|
$dat9 = 0x100 | ($dat8 & 0x0f);
|
6306 |
|
|
} else {
|
6307 |
|
|
$dat9 = $dat8;
|
6308 |
|
|
}
|
6309 |
|
|
}
|
6310 |
|
|
}
|
6311 |
|
|
|
6312 |
|
|
if (defined $dat9) {
|
6313 |
|
|
$stat_tab{att} += 1 if $dat9 == D9ATTN;
|
6314 |
|
|
##print "+++9 attn seen\n" if $dat9==D9ATTN;
|
6315 |
|
|
|
6316 |
|
|
if (exists $opts{tio9}) {
|
6317 |
|
|
print $fh_log conv_etime(\$tlast_tio9),
|
6318 |
|
|
"[$curchan] rcv9 ", conv_dat9($dat9);
|
6319 |
|
|
printf $fh_log " rcvq=%3d", scalar(@que_rcv);
|
6320 |
|
|
print $fh_log " -- idle" if $dat9 == D9IDLE;
|
6321 |
|
|
print $fh_log " -- sop " if $dat9 == D9SOP;
|
6322 |
|
|
print $fh_log " -- eop " if $dat9 == D9EOP;
|
6323 |
|
|
print $fh_log " -- nak " if $dat9 == D9NAK;
|
6324 |
|
|
print $fh_log " -- attn" if $dat9 == D9ATTN;
|
6325 |
|
|
print $fh_log "\n";
|
6326 |
|
|
}
|
6327 |
|
|
}
|
6328 |
|
|
|
6329 |
|
|
return $dat9;
|
6330 |
|
|
}
|
6331 |
|
|
|
6332 |
|
|
#-------------------------------------------------------------------------------
|
6333 |
|
|
|
6334 |
|
|
sub raw_rcv8_to { # get 8bit from TX, expl. time-out
|
6335 |
|
|
my ($timeout) = @_;
|
6336 |
|
|
my $buf;
|
6337 |
|
|
my $dat;
|
6338 |
|
|
|
6339 |
|
|
&{$chan_tab{$curchan}{write}}(); # flush write queue before read
|
6340 |
|
|
|
6341 |
|
|
&{$chan_tab{$curchan}{read}}($timeout) unless @que_rcv;
|
6342 |
|
|
$dat = shift @que_rcv;
|
6343 |
|
|
|
6344 |
|
|
if (exists $opts{tio8} and defined $dat) {
|
6345 |
|
|
print $fh_log conv_etime(\$tlast_tio8),
|
6346 |
|
|
"[$curchan] rcv8 ", conv_dat8($dat),"\n";
|
6347 |
|
|
}
|
6348 |
|
|
$stat_tab{ibyte} += 1;
|
6349 |
|
|
|
6350 |
|
|
return $dat;
|
6351 |
|
|
}
|
6352 |
|
|
|
6353 |
|
|
#-------------------------------------------------------------------------------
|
6354 |
|
|
|
6355 |
|
|
sub wait_sel_filercv { # poll/wait for TX to be ready
|
6356 |
|
|
my ($timeout) = @_;
|
6357 |
|
|
my $nfound=-1;
|
6358 |
|
|
my $fds_rd;
|
6359 |
|
|
|
6360 |
|
|
while ($nfound<0) {
|
6361 |
|
|
$nfound = select($fds_rd=$fdset_filercv, undef, undef, $timeout);
|
6362 |
|
|
next if ($nfound == -1) and $! == EINTR;
|
6363 |
|
|
die "select error: $!" unless $nfound >= 0;
|
6364 |
|
|
}
|
6365 |
|
|
return $nfound;
|
6366 |
|
|
}
|
6367 |
|
|
|
6368 |
|
|
#-------------------------------------------------------------------------------
|
6369 |
|
|
|
6370 |
|
|
sub fifo_open { # chan fifo: open handler
|
6371 |
|
|
my ($arg) = @_;
|
6372 |
|
|
my ($file,$keep) = split /,/,$arg;
|
6373 |
|
|
my $file_base = $file ? $file : "tb_rriext_fifo";
|
6374 |
|
|
my $file_snd = $file_base . "_rx";
|
6375 |
|
|
my $file_rcv = $file_base . "_tx";
|
6376 |
|
|
|
6377 |
|
|
$fifo_keep = $keep;
|
6378 |
|
|
$fdset_filercv = "";
|
6379 |
|
|
|
6380 |
|
|
print_fatal("I/O mode already set to --$curchan") if ($curchan);
|
6381 |
|
|
|
6382 |
|
|
if (-e $file_snd) {
|
6383 |
|
|
print_fatal("$file_snd exists but is not a pipe") unless (-p $file_snd);
|
6384 |
|
|
} else {
|
6385 |
|
|
mkfifo($file_snd, 0666) || die "can't mkfifo $file_snd: $!";
|
6386 |
|
|
print "pi_rri[fifo]-I: created fifo $file_snd\n";
|
6387 |
|
|
}
|
6388 |
|
|
|
6389 |
|
|
if (-e $file_rcv) {
|
6390 |
|
|
print_fatal("$file_rcv exists but is not a pipe") unless (-p $file_rcv);
|
6391 |
|
|
} else {
|
6392 |
|
|
mkfifo($file_rcv, 0666) || die "can't mkfifo $file_rcv: $!";
|
6393 |
|
|
print "pi_rri[fifo]-I: created fifo $file_rcv\n";
|
6394 |
|
|
}
|
6395 |
|
|
|
6396 |
|
|
$fh_snd = new FileHandle;
|
6397 |
|
|
$fh_rcv = new FileHandle;
|
6398 |
|
|
|
6399 |
|
|
print "pi_rri[fifo]-I: wait to connect to $file_snd\n";
|
6400 |
|
|
sysopen ($fh_snd, $file_snd, O_WRONLY) || die "can't open $file_snd: $!";
|
6401 |
|
|
print "pi_rri[fifo]-I: connected to $file_snd\n";
|
6402 |
|
|
sysopen ($fh_rcv, $file_rcv, O_RDONLY) || die "can't open $file_rcv: $!";
|
6403 |
|
|
print "pi_rri[fifo]-I: connected to $file_rcv\n";
|
6404 |
|
|
vec($fdset_filercv, fileno($fh_rcv), 1) = 1;
|
6405 |
|
|
|
6406 |
|
|
$curchan = "fifo";
|
6407 |
|
|
}
|
6408 |
|
|
|
6409 |
|
|
#-------------------------------------------------------------------------------
|
6410 |
|
|
|
6411 |
|
|
sub fifo_close { # chan fifo: close handler
|
6412 |
|
|
if ($fifo_keep) {
|
6413 |
|
|
print "pi_rri[fifo]-I: signal 'keep-alive' to tb\n";
|
6414 |
|
|
raw_snd8(CESC);
|
6415 |
|
|
raw_snd8(CESC);
|
6416 |
|
|
&{$chan_tab{$curchan}{write}}();
|
6417 |
|
|
}
|
6418 |
|
|
close $fh_snd;
|
6419 |
|
|
close $fh_rcv;
|
6420 |
|
|
$fh_snd = undef;
|
6421 |
|
|
$fh_rcv = undef;
|
6422 |
|
|
$curchan = undef;
|
6423 |
|
|
}
|
6424 |
|
|
|
6425 |
|
|
#-------------------------------------------------------------------------------
|
6426 |
|
|
|
6427 |
|
|
sub term_open { # term fifo: open handler
|
6428 |
|
|
my ($arg) = @_;
|
6429 |
|
|
my ($dev,$baud,$break) = split /,/,$arg;
|
6430 |
|
|
$dev = "/dev/ttyS0" unless $dev;
|
6431 |
|
|
$baud = 115200 unless $baud;
|
6432 |
|
|
$break = 0 unless $break;
|
6433 |
|
|
|
6434 |
|
|
$fdset_filercv = "";
|
6435 |
|
|
|
6436 |
|
|
print_fatal("I/O mode already set to --$curchan") if ($curchan);
|
6437 |
|
|
|
6438 |
|
|
$fh_snd = new FileHandle;
|
6439 |
|
|
$fh_rcv = $fh_snd; # same file handle for read and write
|
6440 |
|
|
|
6441 |
|
|
sysopen ($fh_snd, $dev, O_RDWR|O_NOCTTY) || # read/write, not control TTY
|
6442 |
|
|
die "can't open $dev: $!";
|
6443 |
|
|
my $fd = fileno($fh_snd);
|
6444 |
|
|
vec($fdset_filercv, $fd, 1) = 1;
|
6445 |
|
|
$curchan = "term";
|
6446 |
|
|
|
6447 |
|
|
print_fatal("$dev is not a TTY") unless isatty($fd);
|
6448 |
|
|
|
6449 |
|
|
$term_oldtios = new POSIX::Termios;
|
6450 |
|
|
$term_oldtios->getattr($fd) || die "getattr failed: $!";
|
6451 |
|
|
|
6452 |
|
|
## term_tios_print($term_oldtios);
|
6453 |
|
|
|
6454 |
|
|
my $newtios = new POSIX::Termios;
|
6455 |
|
|
$newtios->getattr($fd) || die "getattr failed: $!"; ## hack for cygwin !!
|
6456 |
|
|
|
6457 |
|
|
my $c_iflag = &POSIX::BRKINT; # ignore parity errors
|
6458 |
|
|
my $c_oflag = 0;
|
6459 |
|
|
my $c_cflag = &POSIX::CS8 | # 8 bit chars
|
6460 |
|
|
&POSIX::CSTOPB | # 2 stop bits
|
6461 |
|
|
&POSIX::CREAD | # enable receiver
|
6462 |
|
|
&POSIX::CLOCAL | # ignore modem control
|
6463 |
|
|
LINUX_CRTSCTS; # enable hardware flow control
|
6464 |
|
|
my $c_lflag = 0;
|
6465 |
|
|
my $speed = 0;
|
6466 |
|
|
|
6467 |
|
|
$speed = &POSIX::B9600 if $baud == 9600;
|
6468 |
|
|
$speed = &POSIX::B19200 if $baud == 19200;
|
6469 |
|
|
$speed = &POSIX::B38400 if $baud == 38400;
|
6470 |
|
|
$speed = LINUX_B57600 if $baud == 57600; # hack, only for linux
|
6471 |
|
|
$speed = LINUX_B115200 if $baud == 115200; # hack, only for linux
|
6472 |
|
|
$speed = LINUX_B230400 if $baud == 230400; # hack, only for linux
|
6473 |
|
|
$speed = LINUX_B460800 if $baud == 460800; # hack, only for linux
|
6474 |
|
|
$speed = LINUX_B500000 if $baud == 500000; # hack, only for linux
|
6475 |
|
|
$speed = LINUX_B921600 if $baud == 921600; # hack, only for linux
|
6476 |
|
|
$speed = LINUX_B1000000 if $baud ==1000000; # hack, only for linux
|
6477 |
|
|
$speed = LINUX_B2000000 if $baud ==2000000; # hack, only for linux
|
6478 |
|
|
$speed = LINUX_B3000000 if $baud ==3000000; # hack, only for linux
|
6479 |
|
|
|
6480 |
|
|
print_fatal("speed $baud not supported") unless $speed != 0;
|
6481 |
|
|
|
6482 |
|
|
$c_cflag |= $speed;
|
6483 |
|
|
|
6484 |
|
|
$newtios->setiflag($c_iflag);
|
6485 |
|
|
$newtios->setoflag($c_oflag);
|
6486 |
|
|
$newtios->setcflag($c_cflag);
|
6487 |
|
|
$newtios->setlflag($c_lflag);
|
6488 |
|
|
$newtios->setcc(&POSIX::VEOF, 0); # undef
|
6489 |
|
|
$newtios->setcc(&POSIX::VEOL, 0); # undef
|
6490 |
|
|
$newtios->setcc(&POSIX::VERASE, 0); # undef
|
6491 |
|
|
$newtios->setcc(&POSIX::VINTR, 0); # undef
|
6492 |
|
|
$newtios->setcc(&POSIX::VKILL, 0); # undef
|
6493 |
|
|
$newtios->setcc(&POSIX::VQUIT, 0); # undef
|
6494 |
|
|
$newtios->setcc(&POSIX::VSUSP, 0); # undef
|
6495 |
|
|
$newtios->setcc(&POSIX::VSTART, 0); # undef
|
6496 |
|
|
$newtios->setcc(&POSIX::VSTOP, 0); # undef
|
6497 |
|
|
$newtios->setcc(&POSIX::VMIN, 1); # wait for 1 char
|
6498 |
|
|
$newtios->setcc(&POSIX::VTIME, 0); #
|
6499 |
|
|
|
6500 |
|
|
## term_tios_print($newtios);
|
6501 |
|
|
|
6502 |
|
|
$newtios->setattr($fd) || die "setattr failed: $!";
|
6503 |
|
|
|
6504 |
|
|
if ($break) {
|
6505 |
|
|
tcsendbreak($fd, 0) || die "tcsendbreak failed: $!";
|
6506 |
|
|
raw_snd8 (0x80);
|
6507 |
|
|
&{$chan_tab{$curchan}{write}}(); # write 10000000 for autobaud
|
6508 |
|
|
}
|
6509 |
|
|
|
6510 |
|
|
}
|
6511 |
|
|
|
6512 |
|
|
#-------------------------------------------------------------------------------
|
6513 |
|
|
|
6514 |
|
|
sub term_close { # chan term: close handler
|
6515 |
|
|
$term_oldtios->setattr(fileno($fh_snd)) || die "setattr failed: $!";
|
6516 |
|
|
close $fh_snd;
|
6517 |
|
|
$fh_snd = undef;
|
6518 |
|
|
$fh_rcv = undef;
|
6519 |
|
|
$curchan = undef;
|
6520 |
|
|
}
|
6521 |
|
|
|
6522 |
|
|
#-------------------------------------------------------------------------------
|
6523 |
|
|
|
6524 |
|
|
sub term_tios_print {
|
6525 |
|
|
my ($tios) = @_;
|
6526 |
|
|
|
6527 |
|
|
my $iflag = $tios->getiflag;
|
6528 |
|
|
my $oflag = $tios->getoflag;
|
6529 |
|
|
my $cflag = $tios->getcflag;
|
6530 |
|
|
my $lflag = $tios->getlflag;
|
6531 |
|
|
|
6532 |
|
|
printf "iflag = %8.8x:", $iflag;
|
6533 |
|
|
print " BRKINT" if $iflag & &POSIX::BRKINT;
|
6534 |
|
|
print " ICRNL " if $iflag & &POSIX::ICRNL;
|
6535 |
|
|
print " IGNBRK" if $iflag & &POSIX::IGNBRK;
|
6536 |
|
|
print " IGNCR " if $iflag & &POSIX::IGNCR;
|
6537 |
|
|
print " IGNPAR" if $iflag & &POSIX::IGNPAR;
|
6538 |
|
|
print " INLCR " if $iflag & &POSIX::INLCR;
|
6539 |
|
|
print " INPCK " if $iflag & &POSIX::INPCK;
|
6540 |
|
|
print " ISTRIP" if $iflag & &POSIX::ISTRIP;
|
6541 |
|
|
print " IXOFF " if $iflag & &POSIX::IXOFF;
|
6542 |
|
|
print " IXON " if $iflag & &POSIX::IXON;
|
6543 |
|
|
print " PARMRK" if $iflag & &POSIX::PARMRK;
|
6544 |
|
|
print "\n";
|
6545 |
|
|
printf "oflag = %8.8x:", $oflag;
|
6546 |
|
|
print " OPOST " if $oflag & &POSIX::OPOST;
|
6547 |
|
|
print "\n";
|
6548 |
|
|
|
6549 |
|
|
printf "cflag = %8.8x:", $cflag;
|
6550 |
|
|
print " CLOCAL" if $cflag & &POSIX::CLOCAL;
|
6551 |
|
|
print " CREAD " if $cflag & &POSIX::CREAD;
|
6552 |
|
|
print " CS5 " if ($cflag & &POSIX::CSIZE) == &POSIX::CS5;
|
6553 |
|
|
print " CS6 " if ($cflag & &POSIX::CSIZE) == &POSIX::CS6;
|
6554 |
|
|
print " CS7 " if ($cflag & &POSIX::CSIZE) == &POSIX::CS7;
|
6555 |
|
|
print " CS8 " if ($cflag & &POSIX::CSIZE) == &POSIX::CS8;
|
6556 |
|
|
print " CSTOPB" if $cflag & &POSIX::CSTOPB;
|
6557 |
|
|
print " HUPCL " if $cflag & &POSIX::HUPCL;
|
6558 |
|
|
print " PARENB" if $cflag & &POSIX::PARENB;
|
6559 |
|
|
print " PARODD" if $cflag & &POSIX::PARODD;
|
6560 |
|
|
|
6561 |
|
|
my $sbits = &POSIX::B50 | &POSIX::B75 | &POSIX::B110 | &POSIX::B134 |
|
6562 |
|
|
&POSIX::B150 | &POSIX::B200 | &POSIX::B300 | &POSIX::B600 |
|
6563 |
|
|
&POSIX::B1200 | &POSIX::B1800 | &POSIX::B2400 | &POSIX::B4800 |
|
6564 |
|
|
&POSIX::B9600 | &POSIX::B19200 | &POSIX::B38400;
|
6565 |
|
|
print " B0 " if ($cflag & $sbits) == &POSIX::B0;
|
6566 |
|
|
print " B50 " if ($cflag & $sbits) == &POSIX::B50;
|
6567 |
|
|
print " B75 " if ($cflag & $sbits) == &POSIX::B75;
|
6568 |
|
|
print " B110 " if ($cflag & $sbits) == &POSIX::B110;
|
6569 |
|
|
print " B134 " if ($cflag & $sbits) == &POSIX::B134;
|
6570 |
|
|
print " B150 " if ($cflag & $sbits) == &POSIX::B150;
|
6571 |
|
|
print " B200 " if ($cflag & $sbits) == &POSIX::B200;
|
6572 |
|
|
print " B300 " if ($cflag & $sbits) == &POSIX::B300;
|
6573 |
|
|
print " B600 " if ($cflag & $sbits) == &POSIX::B600;
|
6574 |
|
|
print " B1200 " if ($cflag & $sbits) == &POSIX::B1200;
|
6575 |
|
|
print " B1800 " if ($cflag & $sbits) == &POSIX::B1800;
|
6576 |
|
|
print " B2400 " if ($cflag & $sbits) == &POSIX::B2400;
|
6577 |
|
|
print " B4800 " if ($cflag & $sbits) == &POSIX::B4800;
|
6578 |
|
|
print " B9600 " if ($cflag & $sbits) == &POSIX::B9600;
|
6579 |
|
|
print " B19200" if ($cflag & $sbits) == &POSIX::B19200;
|
6580 |
|
|
print " B38400" if ($cflag & $sbits) == &POSIX::B38400;
|
6581 |
|
|
print "\n";
|
6582 |
|
|
|
6583 |
|
|
printf "lflag = %8.8x:", $lflag;
|
6584 |
|
|
print " ECHO " if $lflag & &POSIX::ECHO;
|
6585 |
|
|
print " ECHOE " if $lflag & &POSIX::ECHOE;
|
6586 |
|
|
print " ECHOK " if $lflag & &POSIX::ECHOK;
|
6587 |
|
|
print " ECHONL" if $lflag & &POSIX::ECHONL;
|
6588 |
|
|
print " ICANON" if $lflag & &POSIX::ICANON;
|
6589 |
|
|
print " IEXTEN" if $lflag & &POSIX::IEXTEN;
|
6590 |
|
|
print " ISIG " if $lflag & &POSIX::ISIG;
|
6591 |
|
|
print " NOFLSH" if $lflag & &POSIX::NOFLSH;
|
6592 |
|
|
print " TOSTOP" if $lflag & &POSIX::TOSTOP;
|
6593 |
|
|
print "\n";
|
6594 |
|
|
|
6595 |
|
|
printf "cc(VEOF) = %3.3o\n", $tios->getcc(&POSIX::VEOF);
|
6596 |
|
|
printf "cc(VEOL) = %3.3o\n", $tios->getcc(&POSIX::VEOL);
|
6597 |
|
|
printf "cc(VERASE)= %3.3o\n", $tios->getcc(&POSIX::VERASE);
|
6598 |
|
|
printf "cc(VINTR) = %3.3o\n", $tios->getcc(&POSIX::VINTR);
|
6599 |
|
|
printf "cc(VKILL) = %3.3o\n", $tios->getcc(&POSIX::VKILL);
|
6600 |
|
|
printf "cc(VQUIT) = %3.3o\n", $tios->getcc(&POSIX::VQUIT);
|
6601 |
|
|
printf "cc(VSUSP) = %3.3o\n", $tios->getcc(&POSIX::VSUSP);
|
6602 |
|
|
printf "cc(VSTART)= %3.3o\n", $tios->getcc(&POSIX::VSTART);
|
6603 |
|
|
printf "cc(VSTOP) = %3.3o\n", $tios->getcc(&POSIX::VSTOP);
|
6604 |
|
|
printf "cc(VMIN) = %3.3o\n", $tios->getcc(&POSIX::VMIN);
|
6605 |
|
|
printf "cc(VTIME) = %3.3o\n", $tios->getcc(&POSIX::VTIME);
|
6606 |
|
|
# printf "cc(NCCS) = %3.3o\n", $tios->getcc(&POSIX::NCCS);
|
6607 |
|
|
}
|
6608 |
|
|
|
6609 |
|
|
#-------------------------------------------------------------------------------
|
6610 |
|
|
|
6611 |
|
|
sub genio_read { # generic io: read handler
|
6612 |
|
|
my ($timeout) = @_;
|
6613 |
|
|
my $tstart;
|
6614 |
|
|
my $rc;
|
6615 |
|
|
|
6616 |
|
|
$tstart = get_time() if exists $opts{tiob};
|
6617 |
|
|
if (wait_sel_filercv($timeout)) {
|
6618 |
|
|
my $buf;
|
6619 |
|
|
|
6620 |
|
|
while (not defined $rc) {
|
6621 |
|
|
$rc = sysread($fh_rcv, $buf, 64);
|
6622 |
|
|
next if (not defined $rc) and $! == EINTR;
|
6623 |
|
|
die "sysread fifo error: $!" unless defined $rc;
|
6624 |
|
|
}
|
6625 |
|
|
|
6626 |
|
|
if (exists $opts{tiob}) {
|
6627 |
|
|
printf $fh_log "%s[$curchan] read %3d bytes in %8.6f sec\n",
|
6628 |
|
|
conv_etime(\$tlast_tiob), $rc, get_time()-$tstart;
|
6629 |
|
|
}
|
6630 |
|
|
if ($rc) {
|
6631 |
|
|
push @que_rcv, unpack("C*", $buf);
|
6632 |
|
|
}
|
6633 |
|
|
}
|
6634 |
|
|
### if (defined $rc) {
|
6635 |
|
|
### printf "+++1 _read $timeout rc=%d\n", $rc;
|
6636 |
|
|
### } else {
|
6637 |
|
|
### printf "+++1 _read $timeout rc=undef\n";
|
6638 |
|
|
### }
|
6639 |
|
|
return $rc;
|
6640 |
|
|
}
|
6641 |
|
|
|
6642 |
|
|
#-------------------------------------------------------------------------------
|
6643 |
|
|
|
6644 |
|
|
sub genio_write { # generic io: write handler
|
6645 |
|
|
## printf "+++2 _write q=%d\n", scalar @que_snd;
|
6646 |
|
|
if (scalar @que_snd) {
|
6647 |
|
|
|
6648 |
|
|
my $buf = pack("C*", @que_snd);
|
6649 |
|
|
while (length($buf)) {
|
6650 |
|
|
while(1) { # read rcv fifo before writing
|
6651 |
|
|
my $rc = genio_read(0.); # to avoid blocking under cygwin
|
6652 |
|
|
last unless defined $rc and $rc > 0;
|
6653 |
|
|
}
|
6654 |
|
|
my $nwrite = length($buf);
|
6655 |
|
|
### $nwrite = 1; # <-- when is this really needed ???
|
6656 |
|
|
### printf "+++2a _write nw=%d\n", $nwrite;
|
6657 |
|
|
my $rc = syswrite($fh_snd, $buf, $nwrite);
|
6658 |
|
|
next if (not defined $rc) and $! == EINTR;
|
6659 |
|
|
die "syswrite fifo error: $!" unless defined $rc;
|
6660 |
|
|
if (exists $opts{tiob}) {
|
6661 |
|
|
printf $fh_log "%s[$curchan] write %3d bytes", conv_etime(\$tlast_tiob), $rc;
|
6662 |
|
|
printf $fh_log " of %3d in queue", length($buf) if $rc < length($buf);
|
6663 |
|
|
print $fh_log "\n";
|
6664 |
|
|
}
|
6665 |
|
|
last if $rc == length($buf);
|
6666 |
|
|
$buf = substr($buf, $rc);
|
6667 |
|
|
}
|
6668 |
|
|
|
6669 |
|
|
@que_snd = ();
|
6670 |
|
|
}
|
6671 |
|
|
}
|
6672 |
|
|
|
6673 |
|
|
#-------------------------------------------------------------------------------
|
6674 |
|
|
|
6675 |
|
|
sub cget_chkblank { # check for unused chars in cmd line
|
6676 |
|
|
$cmd_rest =~ s/^\s*//;
|
6677 |
|
|
if ($cmd_rest ne "") {
|
6678 |
|
|
print "pi_rri($curmode)-E: extra data ignored: \"$cmd_rest\"\n";
|
6679 |
|
|
print " for command: \"$cmd_line\"\n";
|
6680 |
|
|
$cmd_bad = 1;
|
6681 |
|
|
}
|
6682 |
|
|
return $cmd_bad;
|
6683 |
|
|
}
|
6684 |
|
|
|
6685 |
|
|
#-------------------------------------------------------------------------------
|
6686 |
|
|
|
6687 |
|
|
sub cget_tagval2_gdat { # get tag=v1[,v2], generic base
|
6688 |
|
|
my ($tag,$nbit,$dbase) = @_;
|
6689 |
|
|
my $dat;
|
6690 |
|
|
my $msk = undef;
|
6691 |
|
|
$cmd_rest =~ s/^\s*//;
|
6692 |
|
|
### print "+++2 |$cmd_rest|$tag|$nbit|$dbase|\n";
|
6693 |
|
|
if ($cmd_rest =~ /^$tag=/) {
|
6694 |
|
|
$cmd_rest = $';
|
6695 |
|
|
if ($cmd_rest =~ /^-/) {
|
6696 |
|
|
$cmd_rest = $';
|
6697 |
|
|
return (0,0xffff);
|
6698 |
|
|
} else {
|
6699 |
|
|
$dat = cget_gdat($nbit, $dbase);
|
6700 |
|
|
if ($cmd_rest =~ /^,/) {
|
6701 |
|
|
$cmd_rest = $';
|
6702 |
|
|
$msk = cget_gdat($nbit, $dbase);
|
6703 |
|
|
}
|
6704 |
|
|
return ($dat, $msk);
|
6705 |
|
|
}
|
6706 |
|
|
}
|
6707 |
|
|
return (undef, undef);
|
6708 |
|
|
}
|
6709 |
|
|
|
6710 |
|
|
#-------------------------------------------------------------------------------
|
6711 |
|
|
|
6712 |
|
|
sub cget_tagval_gdat { # get tag=val, generic base
|
6713 |
|
|
my ($tag,$nbit,$dbase,$min,$max) = @_;
|
6714 |
|
|
$cmd_rest =~ s/^\s*//;
|
6715 |
|
|
if ($cmd_rest =~ /^$tag=/) {
|
6716 |
|
|
$cmd_rest = $';
|
6717 |
|
|
return cget_gdat($nbit, $dbase,$min,$max);
|
6718 |
|
|
}
|
6719 |
|
|
return undef;
|
6720 |
|
|
}
|
6721 |
|
|
|
6722 |
|
|
#-------------------------------------------------------------------------------
|
6723 |
|
|
|
6724 |
|
|
sub cget_gdat { # get generic base value
|
6725 |
|
|
my ($nbit,$dbase,$min,$max) = @_;
|
6726 |
|
|
my $dat;
|
6727 |
|
|
|
6728 |
|
|
$cmd_rest =~ s/^\s*//;
|
6729 |
|
|
### print "+++1 |$nbit|$dbase|$cmd_rest|\n";
|
6730 |
|
|
if ($cmd_rest =~ /^[xXoObBdD]"/) {
|
6731 |
|
|
if ($cmd_rest =~ /^[xX]"([0-9a-fA-F]+)"/) {
|
6732 |
|
|
$cmd_rest = $';
|
6733 |
|
|
$dat = hex $1;
|
6734 |
|
|
} elsif ($cmd_rest =~ /^[oO]"([0-7]+)"/) {
|
6735 |
|
|
$cmd_rest = $';
|
6736 |
|
|
$dat = oct $1;
|
6737 |
|
|
} elsif ($cmd_rest =~ /^[bB]"([01]+)"/) {
|
6738 |
|
|
$cmd_rest = $';
|
6739 |
|
|
my $odat = sget_bdat($nbit, $1);
|
6740 |
|
|
$dat = $odat if defined $odat;
|
6741 |
|
|
} elsif ($cmd_rest =~ /^[dD]"([+-]?[0-9]+)"/) {
|
6742 |
|
|
$cmd_rest = $';
|
6743 |
|
|
my $odat = (int $1) & ((1<<$nbit)-1);
|
6744 |
|
|
$dat = $odat;
|
6745 |
|
|
}
|
6746 |
|
|
} else {
|
6747 |
|
|
if ($cmd_rest =~ /^([+-]?[0-9]+)\./) {
|
6748 |
|
|
$cmd_rest = $';
|
6749 |
|
|
my $odat = (int $1) & ((1<<$nbit)-1);
|
6750 |
|
|
$dat = $odat;
|
6751 |
|
|
} elsif ($dbase == 16 && $cmd_rest =~ /^([0-9a-fA-F]+)/) {
|
6752 |
|
|
$cmd_rest = $';
|
6753 |
|
|
$dat = hex $1;
|
6754 |
|
|
} elsif ($dbase == 8 && $cmd_rest =~ /^([0-7]+)/) {
|
6755 |
|
|
$cmd_rest = $';
|
6756 |
|
|
$dat = oct $1;
|
6757 |
|
|
} elsif ($dbase == 2 && $cmd_rest =~ /^([01]+)/) {
|
6758 |
|
|
$cmd_rest = $';
|
6759 |
|
|
my $odat = sget_bdat($nbit, $1);
|
6760 |
|
|
$dat = $odat if defined $odat;
|
6761 |
|
|
} elsif ($dbase == 10 && $cmd_rest =~ /^([0-9]+)/) {
|
6762 |
|
|
$cmd_rest = $';
|
6763 |
|
|
$dat = int $1;
|
6764 |
|
|
}
|
6765 |
|
|
}
|
6766 |
|
|
|
6767 |
|
|
if (not defined $dat) {
|
6768 |
|
|
$cmd_bad = 1;
|
6769 |
|
|
print "pi_rri($curmode)-E: cget_gdat error in \"$cmd_rest\" (base=$dbase)\n";
|
6770 |
|
|
return undef;
|
6771 |
|
|
}
|
6772 |
|
|
|
6773 |
|
|
if (defined $min && $dat < $min) {
|
6774 |
|
|
$cmd_bad = 1;
|
6775 |
|
|
print "pi_rri($curmode)-E: cget_gdat range error, $dat < $min\n";
|
6776 |
|
|
return undef;
|
6777 |
|
|
}
|
6778 |
|
|
if (defined $max && $dat > $max) {
|
6779 |
|
|
$cmd_bad = 1;
|
6780 |
|
|
print "pi_rri($curmode)-E: cget_gdat range error, $dat > $max\n";
|
6781 |
|
|
return undef;
|
6782 |
|
|
}
|
6783 |
|
|
|
6784 |
|
|
return $dat;
|
6785 |
|
|
}
|
6786 |
|
|
|
6787 |
|
|
#-------------------------------------------------------------------------------
|
6788 |
|
|
|
6789 |
|
|
sub cget_name { # get name \w+
|
6790 |
|
|
|
6791 |
|
|
$cmd_rest =~ s/^\s*//;
|
6792 |
|
|
if ($cmd_rest =~ /^(\w+)/) {
|
6793 |
|
|
$cmd_rest = $';
|
6794 |
|
|
return $1;
|
6795 |
|
|
}
|
6796 |
|
|
|
6797 |
|
|
$cmd_bad = 1;
|
6798 |
|
|
print "pi_rri($curmode)-E: cget_name error in \"$cmd_rest\"\n";
|
6799 |
|
|
return undef;
|
6800 |
|
|
}
|
6801 |
|
|
|
6802 |
|
|
#-------------------------------------------------------------------------------
|
6803 |
|
|
|
6804 |
|
|
sub cget_bool { # get boolean [01]
|
6805 |
|
|
$cmd_rest =~ s/^\s*//;
|
6806 |
|
|
if ($cmd_rest =~ /^([01])/) {
|
6807 |
|
|
$cmd_rest = $';
|
6808 |
|
|
return int($1);
|
6809 |
|
|
}
|
6810 |
|
|
|
6811 |
|
|
$cmd_bad = 1;
|
6812 |
|
|
print "pi_rri($curmode)-E: cget_name error in \"$cmd_rest\"\n";
|
6813 |
|
|
return undef;
|
6814 |
|
|
}
|
6815 |
|
|
|
6816 |
|
|
#-------------------------------------------------------------------------------
|
6817 |
|
|
|
6818 |
|
|
sub cget_file { # get filename [\w\/.]+
|
6819 |
|
|
|
6820 |
|
|
$cmd_rest =~ s/^\s*//;
|
6821 |
|
|
if ($cmd_rest =~ /^([\w\/.-]+)/) {
|
6822 |
|
|
$cmd_rest = $';
|
6823 |
|
|
return $1;
|
6824 |
|
|
}
|
6825 |
|
|
|
6826 |
|
|
$cmd_bad = 1;
|
6827 |
|
|
print "pi_rri($curmode)-E: cget_file error in \"$cmd_rest\"\n";
|
6828 |
|
|
return undef;
|
6829 |
|
|
}
|
6830 |
|
|
|
6831 |
|
|
#-------------------------------------------------------------------------------
|
6832 |
|
|
|
6833 |
|
|
sub cget_ucb { # get ucb (read name, return ucb)
|
6834 |
|
|
my ($type,$name) = @_;
|
6835 |
|
|
|
6836 |
|
|
$name = cget_name() unless defined $name;
|
6837 |
|
|
return undef if not defined $name;
|
6838 |
|
|
|
6839 |
|
|
$name = uc($name);
|
6840 |
|
|
$name .= "0" if length($name)==2;
|
6841 |
|
|
if (not exists $serv11_unittbl{$name}) {
|
6842 |
|
|
$cmd_bad = 1;
|
6843 |
|
|
print "pi_rri($curmode)-E: unknown device unit $name\n";
|
6844 |
|
|
return undef;
|
6845 |
|
|
}
|
6846 |
|
|
|
6847 |
|
|
my $ucb = $serv11_unittbl{$name};
|
6848 |
|
|
my $ctl = $serv11_ctltbl{$ucb->{ctlname}};
|
6849 |
|
|
|
6850 |
|
|
if (not $ctl->{probe_ok}) {
|
6851 |
|
|
$cmd_bad = 1;
|
6852 |
|
|
print "pi_rri($curmode)-E: device controller $name not available\n";
|
6853 |
|
|
return undef;
|
6854 |
|
|
}
|
6855 |
|
|
|
6856 |
|
|
if (defined $type) {
|
6857 |
|
|
if ($ctl->{type} ne $type) {
|
6858 |
|
|
$cmd_bad = 1;
|
6859 |
|
|
print "pi_rri($curmode)-E: $name is not type=$type\n";
|
6860 |
|
|
return undef;
|
6861 |
|
|
}
|
6862 |
|
|
}
|
6863 |
|
|
|
6864 |
|
|
return $ucb;
|
6865 |
|
|
}
|
6866 |
|
|
|
6867 |
|
|
#-------------------------------------------------------------------------------
|
6868 |
|
|
|
6869 |
|
|
sub cget_opt { # get option
|
6870 |
|
|
my ($opt) = @_;
|
6871 |
|
|
if ($cmd_rest =~ /^\s*$opt\b/) { # opt found, followed by non \w
|
6872 |
|
|
$cmd_rest = $';
|
6873 |
|
|
return 1;
|
6874 |
|
|
}
|
6875 |
|
|
return 0;
|
6876 |
|
|
}
|
6877 |
|
|
|
6878 |
|
|
#-------------------------------------------------------------------------------
|
6879 |
|
|
|
6880 |
|
|
sub cget_optset { # get option set
|
6881 |
|
|
my ($optset) = @_;
|
6882 |
|
|
my $optout = "";
|
6883 |
|
|
while ($cmd_rest =~ /\s*-([a-zA-Z])\b/) { # any -x found
|
6884 |
|
|
$cmd_rest = $';
|
6885 |
|
|
my $optchar = $1;
|
6886 |
|
|
if ($optset =~ /$optchar/) { # char in optset ?
|
6887 |
|
|
$optout .= $optchar;
|
6888 |
|
|
} else {
|
6889 |
|
|
$cmd_bad = 1;
|
6890 |
|
|
print "pi_rri($curmode)-E: unexpected option -$optchar\n";
|
6891 |
|
|
}
|
6892 |
|
|
}
|
6893 |
|
|
return $optout;
|
6894 |
|
|
}
|
6895 |
|
|
|
6896 |
|
|
#-------------------------------------------------------------------------------
|
6897 |
|
|
sub cget_regrange { # get register/memory range
|
6898 |
|
|
my $ctl;
|
6899 |
|
|
my $beg;
|
6900 |
|
|
my $end;
|
6901 |
|
|
|
6902 |
|
|
if (cchk_number()) { # numerical address
|
6903 |
|
|
$beg = cget_gdat(22,8);
|
6904 |
|
|
$end = $beg;
|
6905 |
|
|
if ($cmd_rest =~ m{^:}) {
|
6906 |
|
|
$cmd_rest =~ s{^:}{};
|
6907 |
|
|
$end = cget_gdat(22,8);
|
6908 |
|
|
} elsif ($cmd_rest =~ m{^/}) {
|
6909 |
|
|
$cmd_rest =~ s{^/}{};
|
6910 |
|
|
$end = $beg + cget_gdat(22,8) - 2;
|
6911 |
|
|
}
|
6912 |
|
|
|
6913 |
|
|
} else { # symbolical address
|
6914 |
|
|
my $regtbl;
|
6915 |
|
|
my $ctlnam = uc(cget_name());
|
6916 |
|
|
my $begnam = lc($ctlnam);
|
6917 |
|
|
my $endnam;
|
6918 |
|
|
if (exists $serv11_ctltbl{CPU}->{regtbl}->{$begnam}) {
|
6919 |
|
|
$ctlnam = "CPU";
|
6920 |
|
|
$regtbl = $serv11_ctltbl{CPU}->{regtbl};
|
6921 |
|
|
} elsif (exists $serv11_ctltbl{$ctlnam}->{regtbl}) {
|
6922 |
|
|
$regtbl = $serv11_ctltbl{$ctlnam}->{regtbl};
|
6923 |
|
|
$begnam = lc(cget_name());
|
6924 |
|
|
} else {
|
6925 |
|
|
print "pi_rri($curmode)-E: '$begnam' neither controller nor" .
|
6926 |
|
|
" cpu register name\n";
|
6927 |
|
|
$cmd_bad = 1;
|
6928 |
|
|
return (undef, undef, undef);
|
6929 |
|
|
}
|
6930 |
|
|
|
6931 |
|
|
$ctl = $serv11_ctltbl{$ctlnam};
|
6932 |
|
|
|
6933 |
|
|
if (not $ctl->{probe_ok}) {
|
6934 |
|
|
print "pi_rri($curmode)-E: '$ctlnam' not available\n";
|
6935 |
|
|
$cmd_bad = 1;
|
6936 |
|
|
return (undef, undef, undef);
|
6937 |
|
|
}
|
6938 |
|
|
|
6939 |
|
|
my $reglist = $ctl->{reglist};
|
6940 |
|
|
$beg = 0;
|
6941 |
|
|
$end = scalar @{$reglist}-1;
|
6942 |
|
|
|
6943 |
|
|
if ($begnam ne "state") {
|
6944 |
|
|
|
6945 |
|
|
$endnam = $begnam;
|
6946 |
|
|
if ($cmd_rest =~ m{^:}) {
|
6947 |
|
|
$cmd_rest =~ s{^:}{};
|
6948 |
|
|
$endnam = lc(cget_name());
|
6949 |
|
|
}
|
6950 |
|
|
|
6951 |
|
|
if (not exists $regtbl->{$begnam}) {
|
6952 |
|
|
print "pi_rri($curmode)-E: '$begnam' not register in '$ctlnam'\n";
|
6953 |
|
|
$cmd_bad = 1;
|
6954 |
|
|
return (undef, undef, undef);
|
6955 |
|
|
}
|
6956 |
|
|
if (not exists $regtbl->{$endnam}) {
|
6957 |
|
|
print "pi_rri($curmode)-E: '$endnam' not register in '$ctlnam'\n";
|
6958 |
|
|
$cmd_bad = 1;
|
6959 |
|
|
return (undef, undef, undef);
|
6960 |
|
|
}
|
6961 |
|
|
|
6962 |
|
|
$beg = $regtbl->{$begnam};
|
6963 |
|
|
$end = $regtbl->{$endnam};
|
6964 |
|
|
}
|
6965 |
|
|
}
|
6966 |
|
|
|
6967 |
|
|
if (defined $beg && defined $end && $beg > $end) {
|
6968 |
|
|
my $tmp = $beg;
|
6969 |
|
|
$beg = $end;
|
6970 |
|
|
$end = $tmp;
|
6971 |
|
|
}
|
6972 |
|
|
|
6973 |
|
|
return ($ctl, $beg, $end);
|
6974 |
|
|
}
|
6975 |
|
|
|
6976 |
|
|
#-------------------------------------------------------------------------------
|
6977 |
|
|
|
6978 |
|
|
sub cchk_number { # check for number. any gdat value
|
6979 |
|
|
# except for plain hex (e.g. 'dead')
|
6980 |
|
|
return 1 if $cmd_rest =~ /^\s*([0-9]+)/;
|
6981 |
|
|
return 1 if $cmd_rest =~ /^\s*([+-]?[0-9]+)\./;
|
6982 |
|
|
return 1 if $cmd_rest =~ /^\s*[xX]"([0-9a-fA-F]+)"/;
|
6983 |
|
|
return 1 if $cmd_rest =~ /^\s*[oO]"([0-9]+)"/;
|
6984 |
|
|
return 1 if $cmd_rest =~ /^\s*[bB]"([01]+)"/;
|
6985 |
|
|
return 1 if $cmd_rest =~ /^\s*[dD]"([+-]?[0-9]+)"/;
|
6986 |
|
|
return 0;
|
6987 |
|
|
}
|
6988 |
|
|
|
6989 |
|
|
#-------------------------------------------------------------------------------
|
6990 |
|
|
|
6991 |
|
|
sub sget_bdat { # convert 01 string -> binary value
|
6992 |
|
|
my ($nbit,$str) = @_;
|
6993 |
|
|
my $nchar = length($str);
|
6994 |
|
|
my $odat = 0;
|
6995 |
|
|
my $i;
|
6996 |
|
|
|
6997 |
|
|
return undef if ($nchar != $nbit);
|
6998 |
|
|
|
6999 |
|
|
for ($i = 0; $i < $nchar; $i++) {
|
7000 |
|
|
$odat *= 2;
|
7001 |
|
|
$odat += 1 if substr($str, $i, 1) eq "1";
|
7002 |
|
|
}
|
7003 |
|
|
return $odat;
|
7004 |
|
|
}
|
7005 |
|
|
|
7006 |
|
|
#-------------------------------------------------------------------------------
|
7007 |
|
|
|
7008 |
|
|
sub conv_etime { # generate timestamp string
|
7009 |
|
|
my ($ref_elast) = @_;
|
7010 |
|
|
my $etime = get_time()-$time0;
|
7011 |
|
|
my $str = sprintf "%12.6f ", $etime;
|
7012 |
|
|
if (defined $ref_elast) {
|
7013 |
|
|
my $dt = $etime - $$ref_elast;
|
7014 |
|
|
$$ref_elast = $etime;
|
7015 |
|
|
$str .= sprintf "(%10.6f) ", $dt;
|
7016 |
|
|
}
|
7017 |
|
|
return $str;
|
7018 |
|
|
}
|
7019 |
|
|
|
7020 |
|
|
#-------------------------------------------------------------------------------
|
7021 |
|
|
|
7022 |
|
|
sub conv_dat9 {
|
7023 |
|
|
my ($dat9) = @_;
|
7024 |
|
|
return (($dat9 & 0x100) ? "1" : "0") . " " . conv_dat8($dat9);
|
7025 |
|
|
}
|
7026 |
|
|
|
7027 |
|
|
#-------------------------------------------------------------------------------
|
7028 |
|
|
|
7029 |
|
|
sub conv_dat8 {
|
7030 |
|
|
my ($dat8) = @_;
|
7031 |
|
|
my $buf = "";
|
7032 |
|
|
vec($buf,0,8) = int $dat8;
|
7033 |
|
|
return unpack("B8",$buf);
|
7034 |
|
|
}
|
7035 |
|
|
|
7036 |
|
|
#-------------------------------------------------------------------------------
|
7037 |
|
|
|
7038 |
|
|
sub conv_str2bytes { # string to bytelist; handle \n\r
|
7039 |
|
|
my ($str,$dref,$esc) = @_;
|
7040 |
|
|
|
7041 |
|
|
while (length($str)) {
|
7042 |
|
|
if ($esc && $str =~ /^\\n/) {
|
7043 |
|
|
push @{$dref}, 0015; # send CR
|
7044 |
|
|
$str = $';
|
7045 |
|
|
} elsif ($esc && $str =~ /^\\r/) {
|
7046 |
|
|
push @{$dref}, 0013; # send LF
|
7047 |
|
|
$str = $';
|
7048 |
|
|
} else {
|
7049 |
|
|
my $chr = substr($str,0,1);
|
7050 |
|
|
push @{$dref}, ord($chr);
|
7051 |
|
|
$str = substr($str,1);
|
7052 |
|
|
}
|
7053 |
|
|
}
|
7054 |
|
|
}
|
7055 |
|
|
|
7056 |
|
|
#-------------------------------------------------------------------------------
|
7057 |
|
|
|
7058 |
|
|
sub conv_buf2wlist { # string buffer -> word list
|
7059 |
|
|
my ($buf) = @_;
|
7060 |
|
|
my @sysbyt;
|
7061 |
|
|
my $nw = int(length($buf)/2);
|
7062 |
|
|
my $dref = [];
|
7063 |
|
|
my $i;
|
7064 |
|
|
|
7065 |
|
|
push @sysbyt, unpack("C*", $buf);
|
7066 |
|
|
for ($i=0; $i<$nw; $i++) {
|
7067 |
|
|
my $bl = shift @sysbyt; # lsb is first
|
7068 |
|
|
my $bh = shift @sysbyt;
|
7069 |
|
|
push @{$dref}, 256*$bh + $bl;
|
7070 |
|
|
}
|
7071 |
|
|
return $dref;
|
7072 |
|
|
}
|
7073 |
|
|
|
7074 |
|
|
#-------------------------------------------------------------------------------
|
7075 |
|
|
|
7076 |
|
|
sub conv_wlist2buf { # word list -> string buffer
|
7077 |
|
|
my ($dref) = @_;
|
7078 |
|
|
my @sysbyt;
|
7079 |
|
|
my $buf;
|
7080 |
|
|
|
7081 |
|
|
foreach my $word (@{$dref}) {
|
7082 |
|
|
my $bl = $word & 0xff;
|
7083 |
|
|
my $bh = ($word>>8) & 0xff;
|
7084 |
|
|
push @sysbyt, $bl; # lsb is first
|
7085 |
|
|
push @sysbyt, $bh;
|
7086 |
|
|
}
|
7087 |
|
|
|
7088 |
|
|
$buf = pack("C*", @sysbyt);
|
7089 |
|
|
return $buf;
|
7090 |
|
|
}
|
7091 |
|
|
|
7092 |
|
|
#-------------------------------------------------------------------------------
|
7093 |
|
|
|
7094 |
|
|
sub conv_byte2ascii2 { # byte -> 2 charcter ASCII display
|
7095 |
|
|
my ($byte) = @_;
|
7096 |
|
|
if ($byte >= 32 && $byte < 128) {
|
7097 |
|
|
return chr($byte) . " ";
|
7098 |
|
|
} else {
|
7099 |
|
|
my $str = "..";
|
7100 |
|
|
$str = "\\0" if $byte == 000; # NUL 000 -> \0
|
7101 |
|
|
$str = "\\a" if $byte == 007; # BEL 007 -> \a
|
7102 |
|
|
$str = "\\b" if $byte == 010; # BS 010 -> \b
|
7103 |
|
|
$str = "\\t" if $byte == 011; # TAB 011 -> \t
|
7104 |
|
|
$str = "\\n" if $byte == 012; # LF 012 -> \n
|
7105 |
|
|
$str = "\\v" if $byte == 013; # VT 013 -> \v
|
7106 |
|
|
$str = "\\f" if $byte == 014; # FF 014 -> \f
|
7107 |
|
|
$str = "\\r" if $byte == 015; # CR 015 -> \r
|
7108 |
|
|
return $str;
|
7109 |
|
|
}
|
7110 |
|
|
}
|
7111 |
|
|
|
7112 |
|
|
#-------------------------------------------------------------------------------
|
7113 |
|
|
|
7114 |
|
|
sub gconv_dat16 {
|
7115 |
|
|
my ($dat,$dbase) = @_;
|
7116 |
|
|
if ($dbase == 2) {
|
7117 |
|
|
my $bufl = "";
|
7118 |
|
|
my $bufh = "";
|
7119 |
|
|
vec($bufl,0,8) = int ($dat & 0xff);
|
7120 |
|
|
vec($bufh,0,8) = int (($dat>>8) & 0xff);
|
7121 |
|
|
return unpack("B8",$bufh) . unpack("B8",$bufl);
|
7122 |
|
|
} elsif ($dbase == 8) {
|
7123 |
|
|
return sprintf "%6.6o", int $dat;
|
7124 |
|
|
} elsif ($dbase == 16) {
|
7125 |
|
|
return sprintf "%4.4x", int $dat;
|
7126 |
|
|
} else {
|
7127 |
|
|
return "??dbase??";
|
7128 |
|
|
}
|
7129 |
|
|
}
|
7130 |
|
|
#-------------------------------------------------------------------------------
|
7131 |
|
|
|
7132 |
|
|
sub hdl_sigint { # SIGINT handler
|
7133 |
|
|
if ($sigint_count == 1) {
|
7134 |
|
|
print STDERR "\a"; # send beep
|
7135 |
|
|
} elsif ($sigint_count == 2) {
|
7136 |
|
|
print STDERR "pi_rri($curmode)-W: not responding on ^C, next will abort\n";
|
7137 |
|
|
} elsif ($sigint_count == 3) {
|
7138 |
|
|
print STDERR "pi_rri($curmode)-E: ^C abort\n";
|
7139 |
|
|
exit(1);
|
7140 |
|
|
}
|
7141 |
|
|
$sigint_count += 1;
|
7142 |
|
|
}
|
7143 |
|
|
|
7144 |
|
|
#-------------------------------------------------------------------------------
|
7145 |
|
|
|
7146 |
|
|
sub get_time {
|
7147 |
|
|
my ($sec, $usec) = gettimeofday();
|
7148 |
|
|
return $sec + 1.e-6 * $usec;
|
7149 |
|
|
}
|
7150 |
|
|
|
7151 |
|
|
#-------------------------------------------------------------------------------
|
7152 |
|
|
|
7153 |
|
|
sub get_timestamp {
|
7154 |
|
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
|
7155 |
|
|
return sprintf "%2.2d:%2.2d:%2.2d", $hour, $min, $sec;
|
7156 |
|
|
}
|
7157 |
|
|
|
7158 |
|
|
#-------------------------------------------------------------------------------
|
7159 |
|
|
|
7160 |
|
|
sub filename_expand { # expand $nnn in name
|
7161 |
|
|
my ($file) = @_;
|
7162 |
|
|
my $fileexp = $file;
|
7163 |
|
|
|
7164 |
|
|
while($fileexp =~ /\$(\w+)/) {
|
7165 |
|
|
if (exists $ENV{$1}) {
|
7166 |
|
|
$fileexp = $` . $ENV{$1} . $';
|
7167 |
|
|
} else {
|
7168 |
|
|
printf "pi_rri-E: environment variable \$%s not defined\n", $1;
|
7169 |
|
|
$fileexp = $` . "\$?" . $1 . "?" . $';
|
7170 |
|
|
}
|
7171 |
|
|
}
|
7172 |
|
|
|
7173 |
|
|
return $fileexp;
|
7174 |
|
|
}
|
7175 |
|
|
|
7176 |
|
|
#-------------------------------------------------------------------------------
|
7177 |
|
|
|
7178 |
|
|
sub print_fatal {
|
7179 |
|
|
my ($msg) = @_;
|
7180 |
|
|
print STDERR "pi_rri($curmode)-F: $msg\n";
|
7181 |
|
|
exit 1;
|
7182 |
|
|
}
|
7183 |
|
|
|
7184 |
|
|
#-------------------------------------------------------------------------------
|
7185 |
|
|
|
7186 |
|
|
sub print_help {
|
7187 |
|
|
print "usage: pi_rri\n";
|
7188 |
|
|
print " --help this message\n";
|
7189 |
|
|
print " --int force interactive mode\n";
|
7190 |
|
|
print " --trace trace\n";
|
7191 |
|
|
|
7192 |
|
|
printf "CPREF %2.2x\n", CPREF;
|
7193 |
|
|
printf "NCOMM %2.2x\n", NCOMM;
|
7194 |
|
|
printf "CESC %2.2x\n", CESC;
|
7195 |
|
|
printf "CEN1 %2.2x\n", CEN1;
|
7196 |
|
|
|
7197 |
|
|
}
|