This is a cross-referenced version of write6.plan, to download the unmodified
source try write6.plan.
#PROGRAM /GFWRITE6(15AM,22AM,DBM,EBM)
#PAGE
#INCLUDE IOHEAD(/DEFS)
#INCLUDE STACK(/DEFS)
#PROGRAM
# Write 6 bit characters. If buffer fills up must
# force a WRITEBUF
# If output files is not graphic we must do shift
# conversion
# integer procedure write6 (fd, buf, pos, len);
# value fd, pos, len;
# integer fd, pos, len;
# integer array buf [];
# ERR = WRITE6(FD, BUF, POS, LEN)
# BUF must be an array or array element, not a
# simple variable. (In Fortran a holerith constant
# is treated as an array element).
# CALL 1 WRITE6
# LDN 3 FD
# LDN 3 BUF [ buffer
# LDN 3 POS [ start pos in buffer
# LDN 3 LEN [ # of chars to write
#SET ARGS=0
#DEFINE ARGFD=ARGS
#SET ARGS=ARGS+1
#DEFINE ARGBUF=ARGS
#SET ARGS=ARGS+1
#DEFINE ARGPOS=ARGS
#SET ARGS=ARGS+1
#DEFINE ARGLEN=ARGS
#SET ARGS=ARGS+1
# Define stack frame:
#SET STFRAME=SXFRAME
# First the arguments
#DEFINE STFD=SXPAR1 [ fd
#SET STFRAME=STFRAME+1
#DEFINE STBUF=SXPAR2 [ BUF
#SET STFRAME=STFRAME+1
#DEFINE STPOS=SXPAR3 [ offset in buf
#SET STFRAME=STFRAME+1
#DEFINE STLEN=SXPAR4 [ len
#SET STFRAME=STFRAME+1
# Then the local variables
#DEFINE STDESC=STFRAME [ saveed FDESC
#SET STFRAME=STFRAME+1
# Fortran entry point, copy args to stack
STACK 2
OBEY ARGFD(1)
LDX 0 0(3) [ get FD
STO 0 STFD(2)
OBEY ARGPOS(1) [ get offset
LDX 0 0(3)
STO 0 STPOS(2) [ save
OBEY ARGLEN(1) [ get len
LDX 0 0(3)
STO 0 STLEN(2)
# Now potential call-by-name args
OBEY 1(1) [ get addr of buf to X3
ARRAY 3
STACK 2 [ restore base
STO 3 STBUF(2) [ save
ADN 1 ARGS [ fix return addr
# Pascal convention entry point
#CUE GPWRITE6
BEGIN 2 3,1,STFRAME
# Now do the work
LDX 0 STFD(2) [ is FD open?
STO 0 SXPAR1(3)
LDN 0 1 [ in write mode
STO 0 SXPAR2(3)
CALL 1 GPIOCHECK
BNG 6 BYE [ fd is not open
STO 6 STDESC(2)
STO 6 3
# Calculate start pos in buffer
LDX 0 STPOS(2)
SLC 0 2 [ convert to char pointer
ADS 0 STBUF(2) [ add to buffer addr
# Are we doing shift conversion?
OUT LDX 0 FDSHIFT(3)
BNG 0 GRAP [ actualy AMORPHOUS
BZE 0 GRAP
# We are doing shift conversion, must move one
# char at a time
NORM LDX 6 STLEN(2) [ Amount we want to write
BZE 6 DONE
LDX 7 FDBUFLEN(3) [ get buffer len in chars
SBX 7 FDCHARS(3) [ subtract used to get avail
LDX 1 FDNEXT(3)
LDX 3 STBUF(2)
MORE BZE 7 NFLSH [ jif output buffer is full
LDCH 5 0(3) [ get char from buf
LDX 4 5
SBN 4 #74 [ does it need delta shift?
BNG 4 NOTDL
SBN 7 1 [ do we have space for delta
BZE 7 FILL
LDN 5 #76 [ output DELTA
DCH 5 0(1)
BCHX 1 *+1
ADN 4 #64 [ Dollar -> DELTA T
STO 4 5
BRN NSHFT
NOTDL LDX 4 5
SBN 4 #40 [ chars below "@" in either shift
BNG 4 NSHFT
SBN 0 #74 [ are we in ALPHA?
BZE 0 ALPHA
SBN 7 1 [ need space for alpha shift
BZE 7 FILL
LDN 0 #74
DCH 0 0(1)
BCHX 1 *+1
ALPHA LDN 0 #74 [ now in alpha shift
NSHFT DCH 5 0(1) [ save char
BCHX 1 *+1
SBN 7 1 [ decrement space available
BCHX 3 *+1 [ increment input pointer
BCT 6 MORE [ loop back if more to handle
NDON LDX 3 STDESC(2)
STO 1 FDNEXT(3)
STO 0 FDSHIFT(3)
LDX 0 FDBUFLEN(3) [ avail = buflen - chars
SBX 0 7 [ so
STO 0 FDCHARS(3) [ chars = buflen - avail
DONE LDN 6 0 [ zero = success
BYE END 2 1,0
# We are outputing to a GRAPHIC file, use MVCH to
# maximum advantage
GRAP LDX 6 STLEN(2) [ Amount we want to write
BZE 6 DONE
LDX 0 FDBUFLEN(3) [ get buffer len in chars
SBX 0 FDCHARS(3) [ subtract used to get avail
BZE 0 FLSH [ jif output buffer is full
BXGE 0 6,FITS [ jif avail >= len
STO 0 6 [ X6 = amount to move this time
FITS SBS 6 STLEN(2) [ decrement amount left to move
ADS 6 FDCHARS(3) [ increment chars written to buf
LDX 4 STBUF(2) [ get input buffer address to X4
LDX 5 FDNEXT(3) [ get destination buffer to X5
CALL 1 MVCH [ Move X6 chars from X4 to X5
BASE 2 [ get base pointer back
LDX 3 STDESC(2) [ get FDESC back
STO 5 FDNEXT(3) [ update next char pointer
STO 4 STBUF(2) [ update buffer pointer
BRN GRAP [ and go do the rest
# While writing to a shift file we found we
# didn't have enough space for a shift:
FILL LDN 5 #77 [ output filler char
DCH 5 0(1)
BCHX 1 *+1
NFLSH STO 3 STBUF(2) [ save input buffer
STO 6 STLEN(2) [ and length left to process
LDX 3 STDESC(2) [ get back FDESC
STO 1 FDNEXT(3) [ save NEXT (shouldn't matter)
STO 0 FDSHIFT(3) [ save shift (shouldn't matter)
LDX 0 FDBUFLEN(3) [ avail = buflen - chars
SBX 0 7 [ so chars = buflen - avail
STO 0 FDCHARS(3) [ but 7 should be zero
# Get here if buffer is full, we have to flush it
FLSH STACK 3
LDX 4 STFD(2)
STO 4 SXPAR1(3)
CALL 1 GPWRITEBUF
BNZ 6 BYE
LDX 3 STDESC(2)
BRN OUT
#END
#FINISH