This is a cross-referenced version of iocheck.plan, to download the unmodified
source try iocheck.plan.
#PROGRAM /GPIOCHECK(15AM,22AM,DBM,EBM)
#PAGE
#INCLUDE IOHEAD(/DEFS)
#INCLUDE STACK(/DEFS)
#PUPPER
ASFWB 7HAS *FW1
ASFW 60/1,0,6,/ASFWB
ASFW1 60/1,0,7,/ASFWB
ASFRB 6HAS *FR
ASFR 60/1,0,6,/ASFRB
OLTPB 15HOL *TP(ALLCHAR)
OLTP 60/1,0,15,/OLTPB
OLTP1B 16HOL *TP1(ALLCHAR)
OLTP1 60/1,0,16,/OLTP1B
OLTRB 15HOL *TR(ALLCHAR)
OLTR 60/1,0,15,/OLTRB
#UPPER
MEND501 -1 [ mop flag
CMDASFW /ASFW [ pointer to ASSIGN/ONLINE
CMDASFW1 /ASFW1 [ pointer to ASSIGN/ONLINE
CMDASFR /ASFR [ ...
CMDOLTP /OLTP [ ...
CMDOLTP1 /OLTP1 [ ...
CMDOLTR /OLTR [ ...
# Offsets from start of #UPPER
#DEFINE UPPER=MEND501
#DEFINE DOOLTR=CMDOLTR-UPPER
#DEFINE DOOLTP=CMDOLTP-UPPER
#DEFINE DOASFW=CMDASFW-UPPER
#DEFINE DOASFR=CMDASFR-UPPER
#PROGRAM
# Work out whether a file is open or not.
# fdesc = iocheck (fd, write)
# integer procedure (fd, write);
# value fd, write;
# integer fd;
# boolean write;
#SET STFRAME=SXFRAME
#DEFINE STFD=SXPAR1
#SET STFRAME=STFRAME+1
#DEFINE STWRITE=SXPAR2
#SET STFRAME=STFRAME+1
#DEFINE STUNIT=STFRAME
#SET STFRAME=STFRAME+1
#DEFINE STRET=STFRAME
#SET STFRAME=STFRAME+1
#DEFINE STFDESC=STFRAME
#SET STFRAME=STFRAME+1
BEGIN 2 3,1,STFRAME
LDXC 3 STFD(2) [ get FD
BCS BADF [ jump if negative
STO 3 4 [ save FD for later
LDX 1 PFTABLE [ get file table
BZE 1 NFILE [ not yet allocated
BXGE 3 0(1),NFILE [ too big
ADX 3 1
LDX 3 1(3) [ get file entry
BZE 3 NFILE [ not allocated
BRN GOT
# Auto-allocated units:
# Unit 0 (STDIN), *FR0 if already assigned
# if not, OL *TR0(NORMAL) in MOP
# jobs or AS *FR0 in background
# Unit 1 (STDOUT), *FW0 if already assigned
# if not, OL *TP0(ALLCHAR) in MOP
# jobs or AS *FW0 in background
# Unit 2 (STDERR), *FW1 if already assigned
# if not OL *TP1(ALLCHAR) in MOP
# or as *FW1 in background
NFILE SBN 4 3
BPZ 4 BADF
ADN 4 1
BZE 4 STDOT [ stderr
ADN 4 1
BZE 4 STDOT [ stdout
# STDIN
LDXC 0 STWRITE(2)
BCS BADF [ don't open from CLOSE
BNZ 0 INVAL [ can't write to STDIN
# fhalloc (fd, unit, type, readmode, writemode)
STACK 3
STOZ SXPAR1(3) [ FD 0
STOZ SXPAR2(3) [ want *FR0
LDN 0 DEVFR [ device type 50 = FR
STO 0 SXPAR3(3)
LDN 0 #22 [ block reads
STO 0 SXPAR4(3)
NGN 0 1 [ no write command
STO 0 SXPAR5(3)
CALL 1 GPFHALLOC [ allocate FD 0 = *FR0
BPZ 6 GOT
# Ok, we couldn't allocate the FR, let's try to
# issue an OL *TR(ALLCHAR) or AS *FR as appropriate.
CALL 1 MOP [ check if MOP, leaves /UPPER in X3
BZE 6 FR
# Looks like MOP, let's OL *TR(ALLCHAR)
LDX 0 DOOLTR(3)
CALL 1 DOCMD
BNG 6 FR
TR STACK 3
STOZ SXPAR1(3) [ allocate FD 0
STOZ SXPAR2(3) [ unit0
STOZ SXPAR3(3) [ device type 0 = *TR
CALL 1 GPTPALLOC [ allocate fd 0 = *TR0
BPZ 6 GOT
LDX 3 '/UPPER'
FR LDX 0 DOASFR(3)
CALL 1 DOCMD
BNG 6 BADF
STACK 3
STOZ SXPAR1(3) [ FD 0
STOZ SXPAR2(3) [ want *FR0
LDN 0 DEVFR [ device type 50 = FR
STO 0 SXPAR3(3)
LDN 0 #2 [ Simple reads
STO 0 SXPAR4(3)
NGN 0 1 [ no writes
STO 0 SXPAR5(3)
CALL 1 GPFHALLOC [ allocate FD 0 = *FR0
BPZ 6 GOT
BRN BADF
# STDOUT/STDERR
STDOT LDXC 0 STWRITE(2)
BCS BADF [ don't open from CLOSE
BZE 0 INVAL [ can't read from STDOUT/STDERR
LDX 0 STFD(2) [ 1 or 2
LDX 1 0 [ FD1 -> FW0
SBN 1 1
STO 1 STUNIT(2)
STACK 3
STO 0 SXPAR1(3)
STO 1 SXPAR2(3) [ want *FW0
LDN 0 DEVFW [ device type 51 = FW
STO 0 SXPAR3(3)
NGN 0 1 [ no reads
STO 0 SXPAR4(3)
LDN 0 #1 [ append to EOF
STO 0 SXPAR5(3)
CALL 1 GPFHALLOC [ allocate UNIT 1 = *FW0
BPZ 6 GOT
# Ok, we couldn't allocate the FW, let's try to
# issue an OL *TP(ALLCHAR) or AS *FW as appropriate
CALL 1 MOP [ check if MOP, leaves /UPPER in X3
BZE 6 FW
# Looks like MOP, let's OL *TP(ALLCHAR)
LDN 1 DOOLTP(3)
ADX 1 STUNIT(2)
LDX 0 0(1)
CALL 1 DOCMD
BNG 6 FW
# Must be a MOP job
STACK 3
LDX 0 STFD(2) [ Allocate FD 1 or 2
STO 0 SXPAR1(3)
LDX 0 STUNIT(2)
STO 0 SXPAR2(3) [ unit#, *TP0 or *TP1
LDN 0 DEVTP
STO 0 SXPAR3(3) [ device type 1 = *TP
CALL 1 GPTPALLOC
BPZ 6 GOT
LDX 3 '/UPPER'
FW LDN 1 DOASFW(3)
ADX 1 STUNIT(2)
LDX 0 0(1)
CALL 1 DOCMD
BNG 6 BADF
STACK 3
LDX 0 STFD(2) [ Allocate FD 1 or 2
STO 0 SXPAR1(3)
LDX 0 STUNIT(2)
STO 0 SXPAR2(3) [ want *FW0 or *FW1
LDN 0 DEVFW [ device type 51 = FW
STO 0 SXPAR3(3)
NGN 0 1 [ no read command
STO 0 SXPAR4(3)
LDN 0 #1 [ append to EOF
STO 0 SXPAR5(3)
CALL 1 GPFHALLOC [ allocate UNIT 1 = *FW0
BPZ 6 GOT
# Fall into BADF
BADF NGN 6 EBADF
BRN BYE
INVAL NGN 6 EINVAL
BRN BYE
# Found FDESC wanted by user. Is it in the
# correct mode?
GOT LDXC 0 STWRITE(2)
BCS CLOS [ Special processing for close
BNZ 0 WRIT [ go check if in write mode
# User wants to be in read mode. Is it possible?
LDX 0 FDREAD(3)
BZE 0 INVAL [ this FD can't read
CLOS LDN 0 FLAGWRITE
ANDX 0 FDFLAGS(3) [ already reading?
BZE 0 RET [ easy if we are.
LDXC 0 FDTYPE(3) [ is this a string stream?
BCS READS [ no flush if it is
LDX 0 FDCHARS(3) [ how much in buffer
LDX 4 FDREDTAPE(3) [ do we want red tape?
BZE 4 *+2 [ skip if do
SBN 0 4 [ ignore red tape
BZE 0 SETR [ no flush if buffer empty
STO 3 STFDESC(2) [ save FDESC
LDX 0 STFD(2) [ get FD
STACK 3
STO 0 SXPAR1(3) [ save in args for GPWRITEBUF
CALL 1 FLUSH [ flush
BNG 6 BYE
LDX 3 STFDESC(2) [ get back FDESC
SETR STOZ FDCHARS(3) [ buffer empty
LDX 0 FDREAD(3) [ get read PERI
STO 0 FDPERI(3) [ and set as current
READS LDN 4 #7777-FLAGWRITE [ turn off write flag
ANDS 4 FDFLAGS(3)
LDX 4 FDADDR(3) [ set next char at start of buf
STO 4 FDNEXT(3)
BRN RET
# User wants write mode. Is it possible?
WRIT LDN 0 FLAGWRITE
ANDX 0 FDFLAGS(3) [ write flag set?
BNZ 0 RET
LDX 0 FDWRITE(3) [ can we write?
BZE 0 INVAL [ bad if we can't
STO 0 FDPERI(3) [ set write PERI
LDX 0 FDSHIFT(3) [ get shift
BNG 0 *+4 [ ignore if amorphous
BZE 0 *+3 [ ignore if graphic
LDN 0 #74
STO 0 FDSHIFT(3) [ set current shift
STOZ 4 [ buffer empty
LDX 0 FDADDR(3)
BXE 4 FDREDTAPE(3),*+3
ADX 0 1 [ leave space for red tape
ADN 4 4
STO 0 FDNEXT(3)
STO 4 FDCHARS(3)
LDN 0 FLAGWRITE
ORS 0 FDFLAGS(3) [ set write flag
RET LDX 6 3 [ get return value to X6
BYE END 2 1,0 [ finished
# Internal routine to check if MOP
MOP LDX 3 '/MEND501' [ get pointer to MOP flag
LDX 6 0(3) [ get MOP flag
BPZ 6 MOPEX [ jump if already set
STO 1 STRET(2) [ save link across call
CALL 1 GFISMOP [ Go check if MOP
LDX 3 '/MEND501' [ save MOP flag
STO 6 0(3)
LDX 1 STRET(2)
MOPEX EXIT 1 0
# Internal routine to issue a command
# Enter with X0 pointing to PERI area, X3 MOP flag
# On exit X6 -ve means error in command,
# MOP flag unset
DOCMD STO 1 STRET(2) [ save link, need reg
LDX 1 0
PERI 0 0(1)
LDX 6 1(1) [ get reply, assume command finished
SLA 6 4 [ Did we get an error?
BVCR DOOUT [ all is good if it isn't
STOZ 0(3) [ clear MOP flag
NGN 6 1 [ set error return
DOOUT LDX 1 STRET(2)
EXIT 1 0
#PAGE
# We include WRITEBUF in the same segment to deal with
# the IOCHECK/WRITEBUF dependancy
#PROGRAM
# Write out the current buffer
# We need two cases, either we're writing to a TP
# device (type 1) or a file writer/file handler.
# TP's use a character count in the PERI instruction
# FW/FH use a word count in the PERI instruction and
# set the number of characters used in the last word
# in the red tape word.
#SET ARGS=0
#DEFINE ARGFD=ARGS
#SET ARGS=ARGS+1
#SET STFRAME=SXFRAME
# STFD=SXPAR1
#SET STFRAME=STFRAME+1
#DEFINE STDESC=STFRAME
#SET STFRAME=STFRAME+1
# Fortran entry, copy args to stack
#CUE GFWRITEBUF
OBEY ARGFD(1)
LDX 3 0(3)
STACK 2
STO 3 STFD(2)
ADN 1 ARGS
# Pascal entry
#CUE GPWRITEBUF
FLUSH BEGIN 2 3,1,STFRAME
LDX 5 STFD(2) [ See if fd is open
STO 5 SXPAR1(3)
LDN 4 1 [ in write mode
STO 4 SXPAR2(3)
CALL 1 GPIOCHECK
BNG 6 OUT
STO 6 STDESC(2)
STO 6 1
LDX 6 FDCHARS(1) [ get chars to write
LDN 0 DEVTP [ is this a TP?
BXE 0 FDTYPE(1),TP
LDN 0 DEVCI [ or a *CI?
BXE 0 FDTYPE(1),TP
LDX 7 6
ANDN 7 3 [ How many chars used in last wd?
BZE 7 FULL [ jump if last word full
LDN 5 4
SBX 5 7 [ work out spaces needed
LDX 3 FDNEXT(1) [ space fill last word
LDN 4 #20
DCH 4 0(3)
BCHX 3 *+1
BCT 5 *-2
FULL LDX 5 FDREDTAPE(1) [ get red tape word
BZE 5 AMOR [ skip if amorphous
SRC 7 2 [ move chars in last word
ORX 5 7 [ move to red tape
LDX 3 FDADDR(1) [ get addr of 1st word of buf
STO 5 0(3) [ save red tape
AMOR ADN 6 3 [ round chars to words
SRL 6 2 [ work out words to write
TP BZE 6 DONE [ don't do zero length PERI
STO 6 FDCOUNT(1) [ save count in PERI area
LDX 6 FDUNIT(1) [ get unit#
PERI 6 FDPERI(1) [ start peripheral transfer
LDXC 4 FDREPLY(1) [ is transfer finished?
BCC CHECK
LDX 3 FDTYPE(1) [ get periperal type
SUSBY 6 256(3) [ wait till finished
LDX 4 FDREPLY(1) [ get reply word
# In general the reply word looks like this:
# B6..23 = unexpired character or word count
# B0 = 0 if transfer complete
# B3 = 1 if error, B5 = 1 if EOF
# For *CI B4 is 1 if the command failed
CHECK LDN 0 DEVCI
BXU 0 FDTYPE(1),GEN
LDX 0 4
SLA 0 4 [ is B4 set?
BRN TEST [ go check
GEN LDX 0 4
SLA 0 3 [ is B3 set?
TEST BVCR DONE [ jif not
# Should check diff between error and eof
NGN 6 EIO
BRN *+2
DONE LDN 6 0 [ set OK status
STOZ FDCHARS(1) [ empty buffer
LDX 0 FDADDR(1)
STO 0 FDNEXT(1)
LDXC 0 FDSHIFT(1) [ get shift
BCS OUT [ do nothing if AMOR
BZE 0 RED [ GRAP: cope with red tape
LDN 0 #74 [ start in ALPHA
STO 0 FDSHIFT(1)
RED LDX 0 FDREDTAPE(1) [ do we want red tape
BZE 0 OUT
LDN 4 4 [ if we do must adjust
ADS 4 FDCHARS(1)
LDN 4 1 [ count and pointer
ADS 4 FDNEXT(1)
OUT END 2 1,0
#END
#FINISH