CONSTINTEGER TOP = 100
!
!
RECORDFORMAT C
HF(INTEGER END, START, SIZE, TYPE, SUM, DT, ADR, COUNT)
RECORDFORMAT C
MF(INTEGER START, STRING (11)NAME, STRING (15)JUNK)
RECORDFORMAT C
RF(INTEGER ADR, TYPE, START, END)
!
!
EXTERNALROUTINESPEC C
CLEAR(STRING (255)S)
SYSTEMROUTINESPEC C
CONNECT(STRING (31)FILE, INTEGER MODE, HOLE, PROT, RECORD (RF)NAME R,
INTEGERNAME J)
EXTERNALROUTINESPEC C
DEFINE(STRING (255)S)
SYSTEMROUTINESPEC C
DESTROY(STRING (31)FILE, INTEGERNAME FILE)
SYSTEMINTEGERFNSPEC C
DEVCODE(STRING (16)DEVICE)
EXTERNALINTEGERFNSPEC C
EXIST(STRING (255)S)
SYSTEMINTEGERFNSPEC C
IOCP(INTEGER A, B)
SYSTEMSTRINGFNSPEC C
ITOS(INTEGER I)
SYSTEMROUTINESPEC C
NEWGEN(STRING (31)FROM, TO, INTEGERNAME J)
SYSTEMROUTINESPEC C
PRINTMESS(INTEGER N)
SYSTEMINTEGERFNSPEC C
PSTOI(STRING (63)S)
SYSTEMROUTINESPEC C
RENAME(STRING (31)FROM, TO, INTEGERNAME J)
SYSTEMROUTINESPEC C
SENDFILE(STRING (31)FILE, STRING (16)DEVICE, STRING (11)NAME,
INTEGER COPIES, FORMS, INTEGERNAME J)
EXTERNALINTEGERFNSPEC C
UINFI(INTEGER N)
SYSTEMROUTINESPEC C
ZCOPY2(STRING (255)S, INTEGER SILENT, INTEGERNAME J)
!
!
ROUTINE W(STRING (255)S)
PRINTSTRING(S)
NEWLINE
END ; ! W
!
!
INTEGERFN VALID OUTFILE(STRINGNAME GIVEN)
INTEGER J, WR
STRING (255)Z, TRIMMED
!
! 1: don't know, give to COPY2
! 2: .OUT
! 3: good device
! 4: file does not exist
! 5: file exists and can be overwritten
! 0: .NULL
! -1: bad device
! -2: file exists and cannot be overwritten
!
TRIMMED = GIVEN
!
RESULT = 0 IF TRIMMED = ""
!
IF CHARNO(TRIMMED, 1) = '.' START
RESULT = 0 IF TRIMMED = ".NULL"
RESULT = 2 IF TRIMMED = ".OUT"
J = DEVCODE(TRIMMED)
RESULT = 3 IF J > 0
RESULT = -1
FINISH
!
WR = 0
WR = 1 IF TRIMMED -> TRIMMED . ("/W") . Z AND Z = ""
RESULT = 0 IF TRIMMED = ""
RESULT = 1 IF TRIMMED -> TRIMMED . ("-MOD") . Z AND Z = ""
RESULT = 1 IF TRIMMED -> Z . ("_")
J = EXIST(TRIMMED)
RESULT = 4 IF J = 0; ! file does not exist
RESULT = 5 IF WR = 1; ! can overwrite file
RESULT = -2
END ; ! VALID OUTFILE
!
!
!
ROUTINE DISPOSE OF(STRING (255) FILE, TO, INTEGER VFLAG)
INTEGER J, DR0, DR1
STRING (255)OUTFILE, Z
RECORD (RF)R
SWITCH SW(1:5)
!
CONSTINTEGER TOP = -13
CONSTSTRING (80)ARRAY TXT(TOP : -1) = C
{-13} "Too complicated!",
{-12} "SEND FILE fails",
{-11} "Output parameter not recognised",
{-10} "Attempt to copy to an existing member without setting /W",
{-9} "Not a PD file",
{-8} "Invalid filename format",
{-7} "Attempt to copy to an existing file without setting /W",
{-6} "Null operation",
{-5} "Attempt to connect non-existent member of PD file",
{-4} "Invalid filename format",
{-3} "Attempt to reference member of non-PD file",
{-2} "Attempt to concatenate non-character files",
{-1} "Attempt to write to concatenated files"
!
!
OUTFILE = TO UNLESS TO -> OUTFILE . ("/") . Z
-> SW(VFLAG)
SW(1): ! tricky, let COPY2 do it
ZCOPY2(FILE . "," . TO, 0, J)
PRINTMESS(J) IF J > 0
W(TXT(J)) IF 0 > J >= TOP
W("???") IF J < TOP
SW1:
DESTROY(FILE, J)
RETURN
SW(2): ! .OUT, here goes:
CONNECT(FILE, 0, 0, 0, R, J)
DR0 = R_END - R_START
DR1 = R_ADR + R_START
J = IOCP(19, ADDR(DR0))
-> SW1
SW(3): ! Good device
SENDFILE(FILE, OUTFILE, FILE, 0, 0, J)
PRINTMESS(J) UNLESS J = 0
RETURN
SW(4): ! OUTFILE does not exist
RENAME(FILE, OUTFILE, J)
PRINTMESS(J) UNLESS J = 0
RETURN
SW(5): ! OUTFILE does exist
NEWGEN(FILE, OUTFILE, J)
PRINTMESS(J) UNLESS J = 0
END ; ! DISPOSE OF
!
!
!
EXTERNALROUTINE CUT AND PASTE(STRING (255)S)
RECORD (MF)ARRAYFORMAT MAF(0 : 32767)
INTEGER J, BASE, MBASE, N, I, K, LINE COUNT, CH
INTEGER NONCH, WRONG, WIDTH, VFLAG, LEN, TRUNC
SWITCH SW(-2 : 0)
INTEGERNAME T
STRING (255)IN, OUT, LINE
RECORD (RF)R
RECORD (HF)NAME H
RECORD (MF)ARRAYNAME M
RECORD (HF)NAME MH
BYTEINTEGERARRAY X, C(1 : TOP)
INTEGERARRAY L, START, END(1 : TOP)
STRING (8)ARRAY STEM(1 : TOP)
!
!
ROUTINE WS(INTEGER N, STRING (255)S1, S2)
RETURN IF N < 1
WRITE(N, 1)
SPACE
PRINTSTRING(S1)
PRINTSTRING("s") IF N > 1
SPACE
W(S2)
END ; ! WS
!
!
INTEGERFN OK(STRING (255)S, INTEGERNAME L, BYTEINTEGERNAME C)
INTEGER J
STRING (11)STEM, LL, CC
RESULT = 1 UNLESS 3 < LENGTH(S) < 12
CYCLE J = 1, 1, LENGTH(S)
EXIT IF '0' <= CHARNO(S, J) <= '9'
REPEAT
STEM = S
LENGTH(STEM) = J - 1
S -> (STEM) . S
RESULT = 1 UNLESS S -> LL . ("C") . CC
RESULT = 1 IF STEM = ""
L = PSTOI(LL)
J = PSTOI(CC)
RESULT = 1 IF L < 1 OR J < 1 OR J > 255
C = J
RESULT = 0
END
!
!
ROUTINE SORT INTO ORDER
INTEGER I, J, S, P, Q, R
S = 1
S = S << 1 WHILE S <= N
S = S - 1
!
CYCLE
S = S >> 1
EXIT IF S = 0
CYCLE P = 1, 1, N-S
R = P
WHILE R > 0 CYCLE
Q = R + S
I = X(R)
J = X(Q)
EXIT IF STEM(I) < STEM(J)
X(R) = J
X(Q) = I
R = R - S
REPEAT
REPEAT
REPEAT
END
!
!
IF S = "" OR S = "?" OR S = "HELP" START
W("The format of the command is")
W("CUTANDPASTE( input-file, output)")
W("The input file must be a PD file with one or more")
-> HELP
FINISH
!
IN = S AND OUT = ".OUT" UNLESS S -> IN . (",") . OUT
!
CONNECT(IN, 1, 0, 0, R, J)
PRINTMESS(J) AND RETURN UNLESS J = 0
!
UNLESS R_TYPE = 6 START
W("Input file - " . IN . " - must be PD file")
RETURN
FINISH
!
VFLAG = VALID OUTFILE(OUT)
-> SW(VFLAG) IF VFLAG < 1
!
BASE = R_ADR
H == RECORD(BASE)
M == ARRAY(BASE+H_ADR, MAF)
N = H_COUNT
I = 0
J = 1
NONCH = 0
WRONG = 0
!
CYCLE
EXIT IF I = N
MBASE = BASE + M(I)_START
MH == RECORD(MBASE)
IF MH_TYPE = 3 START
IF OK(M(I)_NAME, L(J), C(J)) = 0 START
START(J) = MBASE + MH_START
END(J) = MBASE + MH_END
STEM(J) <- M(I)_NAME
X(J) = J
J = J + 1
IF J = TOP START
W("Too many members given!")
RETURN
FINISH
FINISH ELSE WRONG = WRONG + 1
FINISH ELSE NONCH = NONCH + 1
I = I + 1
REPEAT
J = J - 1
N = J
!
WS(NONCH, "non character member", "found")
WS(WRONG, "unsuitable character member", "found")
!
IF N = 0 START
W("No suitable members found!")
W("CUTANDPASTE requires the PD file to have one or more")
HELP:
W("character members with names of the form:")
W(" stem m C n")
W("These members are then positioned on the output in")
W("alphabetic order of 'stem' and starting at line m column n")
W("m and n > 0")
RETURN
FINISH
!
SORT INTO ORDER
!
DEFINE("61,T#OUT," . ITOS(UINFI(6)))
SELECT OUTPUT(61)
!
CYCLE LINE COUNT = 1, 1, 10000000
LEN = 0
CYCLE I = 1, 1, J
K = X(I)
IF LINE COUNT >= L(K) START
TRUNC = 0
T == START(K)
CYCLE
IF T >= END(K) START
L(K) = 10000001
N = N - 1
EXIT
FINISH
IF TRUNC = 0 START
TRUNC = 1
WIDTH = C(K) - 1
LEN = LEN + 1 AND CHARNO(LINE, LEN) = ' ' WHILE LEN < WIDTH
FINISH
CH = BYTEINTEGER(T)
T = T + 1
EXIT IF CH = NL
IF WIDTH < 255 START
WIDTH = WIDTH + 1
CHARNO(LINE, WIDTH) = CH
LEN = WIDTH IF LEN < WIDTH
FINISH
REPEAT
FINISH
REPEAT
!
LENGTH(LINE) = LEN
W(LINE) IF N > 0 OR LINE # ""
EXIT IF N = 0
REPEAT
!
SELECT OUTPUT(0)
CLOSE STREAM(61)
CLEAR("61")
DISPOSE OF("T#OUT", OUT, VFLAG)
RETURN
SW(-2):
W("Output file already exists")
RETURN
SW(-1):
W("Invalid output device specified")
RETURN
SW(0):
W("No suitable output specified")
END
ENDOFFILE