This is a cross-referenced version of writeecma.plan, to download the unmodified
source try writeecma.plan.
#PROGRAM /GFWRITEECMA(15AM,22AM,DBM,EBM)
#PAGE
#INCLUDE IOHEAD(/DEFS)
#INCLUDE STACK(/DEFS)
#INCLUDE ECMA(/DEFS)
#PROGRAM
# Write 7 bit characters in ECMA character set.
# If buffer fills up must force a WRITEBUF
# ERR = WRITEECMA(FD, BUF, POS, LEN)
# BUF must be a array or array element, not a
# simple variable
# ECMA characters are stored one per word.
# *NOTE* Fortran program must be compiled with
# COMPRESS INTEGER AND LOGICAL
# We could work around this by redefining to pass
# array instead of array element and using the
# stride, but that would require using GETAH and
# needing one more register in main loop to hold
# the stride.
# How would that work with ALGOL?
# Conversion between ECMA and ICL 6 bit:
# Zone 0:
# 0x00 .. 0x0f (#000 .. #017, NUL .. SI)
# => DELTA, #20 .. #37
# 0x10 .. 0x1f (#020 .. #037, DLE .. US)
# => DELTA, #00 .. #17
# So 6bit = DELTA, 7bit XOR #20
#
# Zone 1:
# 0x20 .. 0x2f (#040 .. #057, " " .. "/")
# => #20 .. #37
# 0x30 .. 0x3f (#060 .. #077, "0" .. "?")
# => #00 .. #17
# so 6bit = 7bit XOR #60
#
# Zone 2:
# 0x40 .. 0x5b (#100 .. #133, "@" .. "[" )
# => ALPHA, #40 .. #73
# so 6bit = ALPHA, (7bit OR #40) AND #77
# 0x5c .. 0x5f (#134 .. #137, "$" .. "<-")
# => DELTA, #64 .. #67
# so 6bit = DELTA, (7bit XOR #50) AND #77
#
# Zone 3:
# 0x60 .. 0x7b (#140 .. #173, "ul" .. "lbrace" )
# => BETA, #40 .. #73
# so 6bit = BETA, 7bit AND #77
# 0x7c .. 0x7f (#134 .. #137, "N2" .. "DEL")
# => DELTA, #70 .. #73
# so 6bit = DELTA, (7bit XOR #04) AND #77
# integer procedure writeecma (fd, buf, len);
# value fd, len;
# integer fd, len;
# integer array buf [len];
# buf is passed by call-by-name, assumed to be
# array element.
# CALL 1 WRITEECMA
# LDN 3 FD
# LDN 3 BUF [ 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 ARGLEN=ARGS
#SET ARGS=ARGS+1
# 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 STLEN=SXPAR3 [ LEN
#SET STFRAME=STFRAME+1
# Now local vars:
#DEFINE STDESC=STFRAME [ saved file descrtiptor
#SET STFRAME=STFRAME+1
# Pick up call by value parameters
STACK 2
OBEY ARGFD(1)
LDX 0 0(3) [ get FD
STO 0 STFD(2)
OBEY ARGLEN(1) [ get len
LDX 0 0(3)
STO 0 STLEN(2)
# Pick up call by name parameeters
OBEY ARGBUF(1) [ get @buf to X3
ARRAY 3
STACK 2 [ restore stack top
STO 3 STBUF(2)
ADN 1 ARGS
# Now Pascal entry point
#CUE GPWRITEECMA
BEGIN 2 3,1,STFRAME
# Check if FD is open
LDX 0 STFD(2)
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
CONT LDX 6 STLEN(2) [ how much to write
BZE 6 BYE
LDX 5 FDSHIFT(3) [ get current shift
BPZ 5 *+2
LDN 5 0 [ cope with -ve = amor hack
LDX 7 FDBUFLEN(3) [ get buffer len in 6bit chars
SBX 7 FDCHARS(3) [ work out space avail
LDX 1 FDNEXT(3)
LDX 3 STBUF(2)
# X0 = input char
# X1 = output buffer
# X2 = base
# X3 = input buffer
# X4 = scratch
# X5 = current shift
# X6 = ECMA bytes to write
# X7 = space avail in output buffer
MORE BZE 7 FLUSH
LDX 0 0(3) [ get char from input
LDX 4 0
SBN 4 #140
BPZ 4 Z3 [ 0x60..0x7f, BETA
ADN 4 #40
BPZ 4 Z2 [ 0x40..0x5f, ALPHA
ADN 4 #40
BPZ 4 Z1 [ 0x20..0x3f, shiftless
# Zone 0, 0x00 .. 0x1f
# control chars
BNZ 5 Z0 [ shifty, output DELTA, CH
SBN 0 ECMAHT [ is it TAB?
BNZ 0 IGN [ if not, just ignore it
# Convert TAB to space. Maybe should expand?
LDN 0 #20 [ output a space
BRN OUTCH
Z0 SBN 7 1
BZE 7 FILL [ jif not enough space for DELTA
LDN 4 #76 [ output delta
DCH 4 0(1)
BCHX 1 *+1
ERN 0 #20 [ flip 010 000
OUTCH DCH 0 0(1) [ output character
BCHX 1 *+1
SBN 7 1
IGN ADN 3 1 [ consume input char
BCT 6 MORE [ loop if not finished
LDX 3 STDESC(2) [ get back FDESC
STO 1 FDNEXT(3) [ update next pointer
BZE 5 *+2
STO 5 FDSHIFT(3) [ update current shift
LDX 0 FDBUFLEN(3)
SBX 0 7
STO 0 FDCHARS(3) [ chars = len - avail
STOZ 6 [ return 0, it worked
BYE END 2 1,0
# Zone 1, 0x20 .. 0x3f
# unshifted
Z1 ERN 0 #60
BRN OUTCH
# Zone 2, 0x40 .. 0x5f
# ALPHA shift
# if outputting to shift file then 0x5c..0x5f
# go out as DELTA shifted
Z2 STO 0 4 [ save ECMA char in X4
ORN 0 #40 [ #100 -> #040
BNZ 5 Z2S [ shifty?
BRN OUTCH
Z2S SBN 4 #134 [ does it need delta?
BPZ 4 Z2DEL
LDN 4 #74 [ is current shift ALPHA?
SHFT BXE 5 4,OUTCH [ if it is just output char
SBN 7 1 [ need space for ALPHA
BZE 7 FILL
LDX 5 4 [ set current shift
DCH 5 0(1)
BCHX 1 *+1
BRN OUTCH
Z2DEL ERN 0 #10+#20 [ get in range
BRN Z0 [ (already ored in 040)
# Zone 3, 0x60 .. 0x7f
# BETA shift
# if outputing to shift file then 0x7c .. 0x7f
# go out as DELTA shifted
Z3 BNZ 5 Z3S [ shifty?
BRN OUTCH [ no, just output
Z3S LDX 4 0
SBN 4 #174 [ does it need delta?
BPZ 4 Z3DEL
LDN 4 #75 [ is current shift BETA?
BRN SHFT [ rest same as ALPHA
Z3DEL ERN 0 #04+#20 [ get in range
BRN Z0 [ (#24 xor #20 = #04)
# While writing to a shift file we found we
# didn't have enough space for a shift:
FILL LDN 0 #77 [ output filler char
DCH 0 0(1)
BCHX 1 *+1
# Get here if buffer is full, we have to flush it
FLUSH STO 3 STBUF(2) [ save input buffer
STO 6 STLEN(2) [ and length left to process
LDX 3 STDESC(2) [ get back FDESC
LDX 0 FDBUFLEN(3) [ Buffer is full
STO 0 FDCHARS(3)
STACK 3
LDX 0 STFD(2) [ pass FD to writebuf
STO 0 SXPAR1(3)
CALL 1 GPWRITEBUF
BNZ 6 BYE
LDX 3 STDESC(2)
BRN CONT
#END
#FINISH