RECORDFORMAT C
FRF(INTEGER CONAD, FILETYPE, DATASTART, DATEND, SIZE, RUP,
EEP, MODE, USERS, ARCH, STRING (6)TRAN, STRING (8)DATE, TIME,
INTEGER COUNT, SPARE1, SPARE2)
CONSTINTEGER TOP = 100
RECORDFORMAT C
HF(INTEGER END, START, SIZE, TYPE, SUM, DATETIME, ADR, RECS,
TOPFILE,
STRING (31)ARRAY FILE(1 : TOP),
STRING (31)ARRAY TOPIC(1 : TOP),
INTEGERARRAY KEY(1 : TOP),
INTEGER KEYAREA)
RECORDFORMAT C
MF(INTEGER PDT, REFERENCES, STRING (6) USER, STRING (20) CALL)
RECORDFORMAT C
REFF(STRING (31)SECTION NAME, SECTION NO, INTEGER FILENO)
RECORDFORMAT C
RF(INTEGER CONAD, FILETYPE, DATASTART, DATAEND)
!
!
!
SYSTEMROUTINESPEC C
CONNECT(STRING (31)FILE, INTEGER MODE, HOLE, PROTECT,
RECORD (RF)NAME R, INTEGERNAME FLAG)
SYSTEMROUTINESPEC C
DISCONNECT(STRING (31)FILE, INTEGERNAME FLAG)
EXTERNALINTEGERFNSPEC C
DSFI(STRING (31)INDEX, INTEGER FSYS, TYPE, SET, ADR)
SYSTEMINTEGERFNSPEC C
DTWORD(INTEGER DT)
SYSTEMSTRINGFNSPEC C
FAILUREMESSAGE(INTEGER FLAG)
SYSTEMROUTINESPEC C
FINFO(STRING (31)FILE, INTEGER MODE, RECORD (FRF)NAME R, INTEGERNAME FLAG)
SYSTEMSTRINGFNSPEC C
ITOS(INTEGER N)
EXTERNALSTRING (255)FUNCTIONSPEC C
MODESTR
SYSTEMROUTINESPEC C
MOVE(INTEGER LEN, FROM, TO)
EXTERNALROUTINESPEC C
PROMPT(STRING (255)S)
SYSTEMINTEGERFNSPEC C
PSTOI(STRING (63)S)
SYSTEMINTEGERFUNCTIONSPEC C
QUERYMODE(INTEGER N)
EXTERNALROUTINESPEC C
SET RETURN CODE(INTEGER I)
SYSTEMROUTINESPEC C
SETFNAME(STRING (63) S)
EXTERNALROUTINESPEC C
SETMODE(STRING (255) S)
EXTERNALSTRINGFNSPEC C
UINFS(INTEGER ENTRY)
EXTERNALINTEGERFNSPEC C
VDUB(INTEGER N)
EXTERNALINTEGERFNSPEC C
VDUI(INTEGER N)
EXTERNALSTRINGFNSPEC C
VDUS(INTEGER N)
SYSTEMROUTINESPEC C
ZVIEW2(STRING (255)PARMS, STRINGNAME RETURN)
SYSTEMROUTINESPEC C
UCTRANSLATE(INTEGER AD, LEN)
SYSTEMINTEGERFNSPEC C
CURRENT PACKED DT
!
!
!
OWNINTEGER DTEXTRACT
OWNINTEGER TOPIC FILE
OWNINTEGER QUERY
OWNINTEGER PTRNS0
OWNINTEGER OCP0
CONSTSTRINGNAME TIME = X'80C0004B'
CONSTINTEGER YES= 1
CONSTINTEGER NO = 0
CONSTINTEGER REF LIMIT= 10
CONSTINTEGER MAX REFS= 100
CONSTINTEGER RECLENGTH= 36
CONSTSTRING (31) MONFILE= "SUBSYS.HELPMON"
OWNBYTEINTEGERARRAY P(1 : 160); ! see LAYOUT and DISPLAY
OWNINTEGER TOPMOD = 0
OWNBYTEINTEGERARRAY MODIFIED(1 : TOP)
OWNSTRING (31) START STANDOUT, END STANDOUT
!
!
OWNINTEGER REF COUNT, RED REF COUNT
OWNRECORD (REFF) ARRAY REFS(1:MAXREFS)
OWNRECORD (REFF) ARRAY RED REFS(1:MAX REFS)
CONSTINTEGER TOP KEY = 8
OWNSTRING (63)ARRAY KEY(1:TOPKEY)
OWNSTRING (63)ARRAY REDKEY(1:TOP KEY)
OWNBYTEINTEGERARRAY STAR(1:TOPKEY)
OWNBYTEINTEGERARRAY REDSTAR(1:TOP KEY)
OWNINTEGER KEYCOUNT, REDKEYFLAG
!
!
!
!
!
!
ROUTINE Q(STRING (255)S)
INTEGER J, PTRNS, OCP
RETURN IF QUERY = NO
J = DSFI("", -1, 24, 0, ADDR(PTRNS))
J = DSFI("", -1, 28, 0, ADDR(OCP))
PRINTSTRING(TIME)
PRINTSTRING(" PTRNS"); WRITE(PTRNS - PTRNS0, 3)
PRINTSTRING(" OCP"); WRITE(OCP - OCP0, 3)
SPACE
PRINTSTRING(S)
NEWLINE
END ; ! Q
!
!
!
ROUTINE PRINTCHS(STRING (255)S)
INTEGER J
CYCLE J = 1, 1, LENGTH(S)
PRINTCH(CHARNO(S, J))
REPEAT
END ; ! PRINTCHS
!
!
!
ROUTINE RSTRG(STRINGNAME S)
INTEGER J
S = ""
CYCLE
READ SYMBOL(J)
RETURN IF J = NL
S = S . TOSTRING(J)
REPEAT
END
!
!
!
ROUTINE W(STRING (255)S)
PRINTCHS(S)
NEWLINE
END ; ! W
!
!
!
RECORDFORMAT C
DIRF(STRING (30)SEC, BYTEINTEGER B, STRING (31)NAME,
INTEGER I1, I2, I3, I4)
OWNRECORD (DIRF)ARRAYFORMAT C
VDIRAF(-1 : 32768)
RECORDFORMAT C
PDF(INTEGER START, STRING (11) NAME, INTEGER HOLE, S5, S6, S7)
RECORDFORMAT C
PDHF(INTEGER DATAEND, DATASTART, SIZE, FILETYPE, SUM,
DATETIME, ADIR, COUNT)
OWNRECORD (PDF)ARRAYFORMAT C
DIRAF(0:4095)
!
!
!
!
!
!
SYSTEMROUTINESPEC C
OUTFILE(STRING (31) FILE, INTEGER SIZE, HOLE, PROT,
INTEGERNAME CONAD, FLAG)
!
!
!***********************************************************************
!*
!* Service routines
!*
!***********************************************************************
!
CONSTINTEGER SILENT = NO
!
!-----------------------------------------------------------------------
!
ROUTINE CONNECT2(STRING (63)FILE, INTEGER MODE, HOLE, PROT,
RECORD (RF) NAME RR, INTEGERNAME FLAG)
! This is a generalised version of CONNECT.
INTEGER BASE, NEWBASE, I
STRING (31)MEM
STRING (255) FILEF, FULL, REM
RECORD (RF) R1
RECORD (PDHF) NAME H
RECORD (PDF) ARRAYNAME DIR
IF FILE = "" START
SETFNAME(FILE)
FLAG = 220; ! Invalid filename
RETURN
FINISH
!
!
FILEF = FILE."_"
FILEF -> FULL.("_").REM
CONNECT(FULL, MODE, HOLE, PROT, R1, FLAG)
RETURNIF FLAG # 0
!
BASE = R1_CONAD
!
CYCLE
H == RECORD(BASE)
EXITIF REM = ""
IF H_FILETYPE # 6 {SSPDFILETYPE} START
FULL <- FULL." is not a PD file"
IF LENGTH(FULL) > 40 START
FULL = SUBSTRING(FULL, LENGTH(FULL) - 36, LENGTH(FULL))
FULL = "...".FULL
FINISH
SETFNAME(FULL)
FLAG = 233; ! General flag
RETURN
FINISH
!
DIR == ARRAY(BASE + H_ADIR, DIRAF)
UNLESS REM - > MEM.("_").REM START
IF LENGTH(FILE) > 40 START
LENGTH(FILE) = 37
FILE = FILE."..."
FINISH
SETFNAME(FILE)
FLAG = 220; ! Invalid filename
RETURN
FINISH
!
NEWBASE = 0
FOR I = 0, 1, H_COUNT - 1 CYCLE
IF DIR(I)_NAME = MEM START
NEWBASE = BASE + DIR(I)_START
EXIT
FINISH
REPEAT
!
IF NEWBASE = 0 START
SETFNAME(MEM)
FLAG = 288; ! Member does not exist
RETURN
FINISH
!
BASE = NEWBASE
FULL = FULL."_".MEM
REPEAT
!
RR_CONAD = BASE
RR_FILETYPE = H_FILETYPE
RR_DATASTART = H_DATASTART
RR_DATAEND = H_DATAEND
END ; ! connect2
!
!------------------------------------------------------------
!
INTEGERFN EXTRACT(RECORD (HF)NAME H, STRING (255)FILE)
INTEGER J, K, F, CFLAG, CH, DIRA, KEYA
INTEGER K1, N, L
RECORD (RF)R, KR, VR
BYTEINTEGERARRAYNAME KEYS
BYTEINTEGERARRAYFORMAT KEYSF(0 : 1000000)
RECORD (DIRF)ARRAY NAME DIR
STRING (255)NAME
RECORD (PDHF)NAME HDR
H_TYPE = 4; ! Data
H_ADR = 3; ! Structure not specified
K = ADDR(H_KEYAREA)
BYTEINTEGER(K) = 10
K = K + 1
!
H_TOPFILE = 1
H_FILE(1) = FILE
!
F = 1
Q("Subfile: " . H_FILE(F))
H_KEY(F) = K - ADDR(H)
CONNECT2(H_FILE(F), 1, 0, 0, R, CFLAG)
-> NEXT UNLESS CFLAG = 0
!
HDR == RECORD(R_CONAD)
IF HDR_FILETYPE = 3 START
IF HDR_COUNT = 2 START
DIRA = R_CONAD + 96
KEYA = DIRA + INTEGER(DIRA) + 32
DIRA = DIRA + 32
FINISH ELSE -> NEXT
FINISH ELSE START
CONNECT2(H_FILE(F) . "_VIEWKEYS", 1, 0, 0, KR, CFLAG)
-> NEXT UNLESS CFLAG = 0
!
CONNECT2(H_FILE(F) . "_VIEWDIR2", 1, 0, 0, VR, CFLAG)
-> NEXT UNLESS CFLAG = 0
!
DIRA = VR_CONAD+VR_DATASTART
KEYA = KR_CONAD+KR_DATASTART
FINISH
!
DIR == ARRAY(DIRA, VDIRAF)
KEYS == ARRAY(KEYA, KEYSF)
!
H_TOPIC(F) = DIR(-1)_SEC
K1 = INTEGER(KEYA-32) - 34; ! end of Viewkeys file
J = 0
LOOP:
-> NEXT IF J >= K1
J = J + 1 AND -> LOOP UNLESS KEYS(J) = NL
N = 0
WHILE '0' <= KEYS(J+1) <= '9' CYCLE
J = J + 1
N = N * 10 + KEYS(J) - '0'
REPEAT
!
IF LENGTH(DIR(N)_NAME) < 32 C
THEN NAME = DIR(N)_NAME C
ELSE START
LENGTH(NAME) = 31
MOVE(31, R_CONAD+INTEGER(ADDR(DIR(N)_NAME)+4)-X'40000', ADDR(NAME)+1)
FINISH
!
NAME = NAME . "¬" . DIR(N)_SEC
L = LENGTH(NAME)
MOVE(L, ADDR(NAME)+1, K)
K = K + L
!
CYCLE
J = J + 1
CH = KEYS(J)
BYTEINTEGER(K) = CH AND K = K + 1 UNLESS CH = ' '
REPEAT UNTIL CH = NL
-> LOOP
NEXT:
Q(H_FILE(F) . FAILUREMESSAGE(CFLAG)) UNLESS CFLAG = 0
!
H_END = K - ADDR(H)
Q("End: " . ITOS(H_END))
RESULT = CFLAG
END ; ! EXTRACT
!
!-----------------------------------------------------------------------
!
INTEGERFN KWDSCAN(INTEGERNAME XLENGTH, XADDR, ORIGINAL,
INTEGER KWDCT, RED KEY FLAG,
STRINGARRAYNAME RED KEY, KEY,
BYTEINTEGERARRAYNAME RED STAR, STAR)
! This routine is coded in IMP80 with embedded machine code for the 2900.
!
! This routine searches a 'keyword index' for a section which includes all
! of a set of keywords nominated by the caller. Successive calls will
! discover all such sections in the index.
!
! The index must be laid out as follows:
! Each section consists of a section name (any sequence of bytes not
! including NL, space or colon - they need not all be printable
! characters - there are no rules about the first character being
! alphabetic - the name may, but need not, be an IMP string starting
! with a 'length byte'), and the section name is immediately followed
! by a colon and a space. That is followed by one or more keywords, separated
! by single spaces. Keywords should consist of printable characters, i.e.,
! format effectors and length bytes should NOT be included, and the
! three characters NL, space and colon are not permitted in keywords.
! There are no other restrictions on keywords. The last keyword of a
! section must be followed by a space and NL. The next section, if any,
! follows immediately, with no intervening characters. The first section
! in an index may, but need not, be preceded by a NL charcter. The index
! should contain no characters after the NL terminating the last section.
!
! The caller supplies the number of bytes in the index as the parameter
! XLENGTH, and the address of the first byte of the index as the
! parameter XADDR. The number of keywords to be sought is given as KWDCT,
! and the keywords themselves are supplied in IMP strings as KEYS(1:KWDCT).
!
! If a section is found whose keywords include all those nominated by the
! caller, then KWDSCAN will return the address of the first byte of the
! title of that section. If no such section is found, the result will be
! zero. In either case, XLENGTH and XADDR will be updated to specify that
! part of the index which should be scanned at the next call of KWDSCAN.
! That is, if KWDSCAN returns the address of a section title, then
! XADDR will point to the next section (if any) and XLENGTH will be
! correspondingly reduced. Thus a further call of KWDSCAN, using the
! new values of XLENGTH and XADDR, will find another section which satisfies
! the caller's keyword specification (if there is another such section).
! If there are no more sections, or if KWDSCAN returned zero after an
! unsuccessful search, then XLENGTH will be zero and XADDR will point
! to the first byte after the end of the index.
!
! The KEYS may use the same characters as are permitted for the keywords
! in the index. It is also permissible for the first and/or last
! character of any of the KEYS to be a space. If one of the KEYS starts
! with a space, then it can only be matched by a keyword in the index
! which starts with the non-space characters of the KEY. If a KEY ends
! with a space, then it is matched only by keywords which end with the
! non-space characters of the KEY. If it begins and ends with a space,
! then only keywords which exactly match all the non-space characters
! of the KEY will be acceptable. A KEY which contains no spaces can
! be matched by any keyword which includes the KEY.
!
! None of KEYS(1:KWDCT) may be a null string. KWDCT must be >0.
!
! Every occurrence of SECT MARK 1 in the data area must be followed
! by an instance of SECT MARK 2.
INTEGER ARRAY CHECKTAB (0:7)
INTEGER SECTPTR
INTEGER ARRAY SEEN (1:KWDCT)
INTEGER PREVIOUS CH
INTEGER I, L, UNSEENCT
LONG INTEGER ARRAY REDKEYDESCR, KEYDESCR (1:KWDCT)
LONG INTEGER SDESCR, XDESCR, KDESCR, DRH
CONST INTEGER SECT MARK 1 = NL
! %CONST %INTEGER SECT MARK 2 = ':'
! Bit vector descriptor to the table for TCH:
KDESCR = X'0000010000000000' ! ADDR(CHECKTAB(0))
! Pointer to the start of the section data:
SECTPTR = XADDR
! Set up descriptors to the texts of the keywords:
CYCLE I = KWDCT, -1, 1
REDKEYDESCR(I) = (LENGTHENI(X'18000000'!LENGTH(REDKEY(I)))<<32) C
! (ADDR(RED KEY(I)) + 1)
IF RED KEY FLAG = 1 START
KEYDESCR(I) = (LENGTHENI(X'18000000'!LENGTH(KEY(I)))<<32) C
! (ADDR(KEY(I))+1)
FINISH
REPEAT
! Descriptor to the data area supplied by the caller:
XDESCR = (LENGTHENI(X'18000000'!XLENGTH)<<32) ! XADDR
! Set up the check table:
CYCLE I = 0, 1, 7
CHECKTAB (I) = 0
REPEAT
!
CYCLE I = KWDCT, -1, 1
DRH = REDKEYDESCR (I)
*LB_(DRH); ! Get the first character of KEYS (I).
*LSS_1; ! reduced keys have the same initial letter
*ST_(KDESCR+B ); ! Set the corresponding bit in the table.
REPEAT
*LSS_1
*LD_KDESCR
*ST_(DR +SECT MARK 1); ! Set a bit for SECT MARK 1.
ORIGINAL = 1; ! assume found original keys unless proved wrong
NEW SECT:
! When we come to a new section, we forget all about any
! KEYS that we may have seen before.
CYCLE I = KWDCT, -1, 1
SEEN (I) = 0
REPEAT
!
UNSEENCT = KWDCT
!
CYCLE
*LSD_KDESCR; ! Descriptor to the check table (for TCH).
*LD_XDESCR; ! Descriptor to the data area - more
! accurately, to that part of it which we
! have not yet scanned.
*TCH_L =DR ; ! Scan for any interesting character -
! viz., the start-of-section marker, or the
! first character of any of the KEYS.
*JCC_8,<XSD>;! Go if no interesting characters have been
! found in the residue of the data area.
!
! If some interesting character has been found:
*LSS_(DR +0); ! Fetch the interesting character.
*UCP_SECT MARK 1; ! Is it a start-of-section marker?
*JCC_8,<SOS>; ! Go if it is a start-of-section marker.
! %EXIT %IF we have found a start-of-section marker.
!
! Can we match any of the requested RED KEYS?
*STD_XDESCR
L = INTEGER(ADDR(XDESCR)) & X'00FFFFFF'; ! Length of residue of data.
PREVIOUS CH = BYTEINTEGER(INTEGER(ADDR(XDESCR)+4)-1)
CYCLE I = KWDCT, -1, 1
IF SEEN(I) = 0 AND LENGTH(RED KEY(I)) <= L START
DRH = REDKEYDESCR(I)
*LD_DRH
*LSD_XDESCR
*CPS_L =DR
*JCC_7,<TRY NEXT>
-> TRY NEXT IF REDSTAR(I) = 0 AND PREVIOUS CH # ','
-> ORIG MATCH IF RED KEY FLAG = 0; ! only one set of keys
IF LENGTH(KEY(I)) <= L START ; ! possible
DRH = KEYDESCR(I)
*LD_DRH
*LSD_XDESCR
*CPS_L =DR
*JCC_7,<NOTORIG>
-> ORIG MATCH IF STAR(I) = 1 OR PREVIOUS CH = ','
FINISH
NOT ORIG:
ORIGINAL = 0
ORIG MATCH:
SEEN (I) = -1
UNSEENCT = UNSEENCT - 1
IF UNSEENCT = 0 START
*LD_SDESCR
*MODD_1
*CYD_0
*STUH_B
*ST_SECTPTR
*SWNE_L =DR ,0,10; ! %MASK=0, %REF=SECT MARK 1.
*STD_SDESCR
XLENGTH = INTEGER(ADDR(SDESCR)) & X'00FFFFFF'
XADDR = INTEGER(ADDR(SDESCR)+4)
RESULT = SECTPTR
FINISH
TRY NEXT:
FINISH
REPEAT
IF L<2 THEN -> XSD; ! Data exhausted.
*LD_XDESCR
*MODD_1
*STD_XDESCR; ! Skip past the 'interesting character'.
REPEAT
SOS:
! Handle a start-of-section marker:
*STD_SDESCR; ! Save a pointer to the new section.
! *SWNE_%L=%DR,0,SECT MARK 2; ! Skip to the end of the section identifier.
! But that will not compile at the present, so -
*SWNE_L =DR ,0,58
*STD_XDESCR; ! Save that descriptor for future reference.
*J_<NEW SECT>; ! Go back to process the new section.
!
XSD:
XADDR = XADDR + XLENGTH
XLENGTH = 0
RESULT = 0
!
END ; ! KWDSCAN
!
!-----------------------------------------------------------------------
!
INTEGERFN FINDREFS(RECORD (HF)NAME H, STRINGARRAYNAME REDKEY, KEY,
BYTEINTEGERARRAYNAME REDSTAR, STAR,
RECORD (REFF)ARRAYNAME RED REF, REF,
INTEGER MAXREF, KEY COUNT, RED KEY FLAG, INTEGERNAME REF COUNT)
!
INTEGER J, RED REF COUNT, A, F, ADR, LEN, ORIGINAL
STRING (63)SNAME, SNO
INTEGERNAME COUNT
RECORD (REFF)ARRAYNAME R
!
ROUTINE GET(STRINGNAME S, INTEGERNAME J, INTEGER STOP)
INTEGER A0, A, CH
A0 = ADDR(S) + 1
A = A0
CYCLE
CH = BYTEINTEGER(J)
J = J + 1
EXIT IF CH = STOP
BYTEINTEGER(A) = CH
A = A + 1
REPEAT
LENGTH(S) = A - A0
END ; ! GET
!
ROUTINE SAVE REF(RECORD (REFF)ARRAYNAME REF, INTEGERNAME COUNT,
STRINGNAME SNAME, SNO, INTEGER FILE, MAX)
STRING (31)BEFORE
STRING (255)W
W = SNO . "."
COUNT = COUNT + 1
IF COUNT <= MAX START
IF COUNT > 1 ANDC
FILE = REF(COUNT-1)_FILE NO ANDC
W -> BEFORE . (REF(COUNT-1)_SECTION NO . ".") AND BEFORE = "" C
THEN COUNT = COUNT - 1 C
ELSE START
REF(COUNT)_SECTION NAME = SNAME
REF(COUNT)_SECTION NO = SNO
REF(COUNT)_FILE NO = FILE
FINISH
FINISH
END ; ! SAVE REF
!
ADR = ADDR(H_KEYAREA)
LEN = ADDR(H) + H_END - ADR
RED REF COUNT = 0
REF COUNT = 0
!
CYCLE
J = KWDSCAN(LEN, ADR, ORIGINAL, KEY COUNT, RED KEY FLAG, RED KEY, KEY,
RED STAR, STAR)
EXIT IF J = 0
!
GET(SNAME, J, '¬')
GET(SNO, J, ':')
!
A = J - ADDR(H)
CYCLE F = H_TOPFILE, -1, 1
EXIT IF A > H_KEY(F)
REPEAT
!
IF ORIGINAL = 0 C
THEN COUNT == RED REF COUNT AND R == RED REF C
ELSE COUNT == REF COUNT AND R == REF
SAVE REF(R, COUNT, SNAME, SNO, F, MAXREF)
!
REPEAT
Q("Red ref count " . ITOS(RED REF COUNT))
Q(" Ref count " . ITOS(REF COUNT))
RESULT = RED REF COUNT
END ; ! FINDREFS
!
!-----------------------------------------------------------------------
!
ROUTINE SYMBOLS(INTEGER N, SYMBOL)
WHILE N > 0 CYCLE
PRINTSYMBOL(SYMBOL)
N = N - 1
REPEAT
END ; ! SYMBOLS
!
!-----------------------------------------------------------------------
!
INTEGERFN LAYOUT(INTEGER A, B, LPPAGE)
INTEGER L, I, THIS L
P(1) = 205; ! header lines
P(2) = 206
P(3) = 207
P(4) = 200
L = 4; ! number of lines so far
!
IF A > 0 START
IF A = 1 THEN P(5) = 201 ELSE P(5) = 202
P(6) = 200
L = 6
CYCLE I = 1, 1, A
L = L + 1
P(L) = I
REPEAT
!
-> TIDY IF B = 0
!
THIS L = L
THIS L = THIS L - LPPAGE WHILE THIS L > LPPAGE
IF THIS L > LPPAGE - 4 C
{ (THIS L + 3 + B > LPPAGE %AND B < LPPAGE - 2) %C }
START
CYCLE I = 1, 1, LPPAGE - THIS L
L = L + 1
P(L) = 200
REPEAT
FINISH ELSE START
L = L + 1
P(L) = 200
FINISH
FINISH
!
IF B > 0 START
L = L + 1
IF B = 1 THEN P(L) = 203 ELSE P(L) = 204
L = L + 1
P(L) = 200
CYCLE I = 1, 1, B
L = L + 1
P(L) = 100 + I
REPEAT
FINISH
TIDY:
THIS L = L
THIS L = THIS L - LPPAGE WHILE THIS L > LPPAGE
CYCLE I = 1, 1, LPPAGE - THIS L
L = L + 1
P(L) = 200
REPEAT
!
RESULT = L // LPPAGE
END ; ! LAYOUT
!
!-----------------------------------------------------------------------
!
ROUTINE DISPLAY(RECORD (HF)NAME H, STRING (255)KEYS, RED KEYS,
RECORD (REFF)ARRAYNAME REFS, RED REFS,
INTEGER PAGE, MAXPAGE, LPPAGE, A)
INTEGER I, J, L, WW, N
STRING (63)WORK
RECORD (REFF)NAME REF
SWITCH SW(200:207)
PRINTCHS(VDUS(1)); ! could do this a bit better for hardcopy devices
PRINTSTRING(" References found")
IF PAGE > 1 START
SPACES(44)
PRINTSTRING("/" . ITOS(PAGE))
FINISH
NEWLINE
SYMBOLS(72, '-'); NEWLINE
!
I = (PAGE - 1) * LPPAGE + 1
J = I + LPPAGE - 1
CYCLE L = I, 1, J
WW = P(L)
-> SW(WW) IF WW >= 200
IF WW < 100 START
N = WW
REF == REFS(WW)
FINISH ELSE START
WW = WW - 100
N = WW + A
REF == RED REFS(WW)
FINISH
WORK = ITOS(N) . " "
LENGTH(WORK) = 4
WORK = WORK . REF_SECTION NAME . " "
LENGTH(WORK) = LENGTH(WORK) & (-4)
WORK = WORK . " . " WHILE LENGTH(WORK) < 40
LENGTH(WORK) = 40
W(WORK . H_TOPIC(REF_FILE NO))
-> NEXT
SW(200):
NEWLINE; -> NEXT
SW(201):
W("Reference to " . KEYS); -> NEXT
SW(202):
W("References to " . KEYS); -> NEXT
SW(203):
W("Reference to " . RED KEYS); -> NEXT
SW(204):
W("References to " . RED KEYS); -> NEXT
SW(205):
W("To examine a reference type its number and press 'return'. To return to")
W("this page, type R and press 'return' in response to the View: prompt")
W("(you may have to do this more than once). Q returns to command level.")
SW(206):
SW(207):
NEXT:
REPEAT
IF PAGE < MAXPAGE C
THEN W(START STANDOUT."...more".END STANDOUT) C
ELSE W(START STANDOUT."End of section".END STANDOUT)
PROMPT("Help: ")
END ; ! DISPLAY
!
!-----------------------------------------------------------------------
!
ROUTINE MONITOR CALL(STRING (255)PARMS, INTEGER REFCOUNT)
RECORD (MF) NAME M
INTEGERNAME COUNT
INTEGER BASE, MAX
INTEGER FLAG, HOLDCOUNT
RECORD (RF) RR
RECORD (FRF) FR
CONNECT(MONFILE, 11, 0, 0, RR, FLAG); ! Connect write shared
RETURN UNLESS FLAG = 0
FINFO(MONFILE, 0, FR, FLAG)
RETURN UNLESS FLAG = 0
MAX = (FR_SIZE - 36) // RECLENGTH; !Maximum of records it can hold
BASE = RR_CONAD + 36
COUNT == INTEGER(RR_CONAD + RR_DATASTART)
*INCT_(COUNT)
*ST_HOLDCOUNT
RETURN UNLESS 0 <= HOLDCOUNT <= MAX; ! FILE FULL
!
M == RECORD(BASE + HOLDCOUNT * RECLENGTH)
M_PDT = CURRENT PACKED DT
M_REFERENCES = REFCOUNT
M_USER = UINFS(1)
M_CALL <- PARMS
!
DISCONNECT(MONFILE, FLAG)
END ; ! MONITOR CALL
!
!-----------------------------------------------------------------------
!
STRINGFN REDUCED(STRING (80)S)
! This FN attempts to reduce compound forms of words to
! more simple forms by removing common suffixes and
! truncating words to a meaningful length, ie. meaningful w.r.t.
! any common prefix that the word may have. The known suffixes
! and prefixes are normally no longer than four characters long
! and sometimes less and so they are held in a form that can be
! be used to exploit the full-word logical operator AND.
! Note that the order in which the suffixes are stored is
! very important and should not be altered. The prefixes are
! not affected by the order in which they are stored and thus
! can be added to as the need arrises, something that is quite
! likely to happen in a specialised environment.
!
INTEGER I, WORD END, WE ADDR, OPTION, SADDR
INTEGER TRUNCATION, WORD START, MINIMUM
BYTEINTEGERNAME L
STRING (80) ORIGINAL S
!
! MASKS FOR USE WITH THE SUFFIX OPTION VALUES
!
CONSTBYTEINTEGER COMPLETED= 1,REMOVE = 2,DOUBLE CHECK = 4
CONSTINTEGER VOWEL TRUNC= 8
!
! VARIOUS IMPORTANT CONST LENGTHS
!
CONSTINTEGER VT MIN= 5 ; ! WORDS LESS THAN THIS DON'T HAVE VOWELS TRUNCATED
!
!********************************************************************************
!*
!* SPECIFICATION OF THE SUFFIXES - ORDER VERY IMPORTANT
!*
!********************************************************************************
!
CONSTINTEGER MAX SUFFIX= 22
CONSTBYTEINTEGERARRAY SUFFIX BYTES(0:11, 0:MAX SUFFIX)= C
{ }
{ S U F F I X M A S K LEN OPTION SPARE }
0 , 0 , 0 , 0 , x'00',x'00',x'00',x'00', 0, 1, 0, 0,
0 , 0 ,'L','Y', x'00',x'00',x'FF',x'FF', 2, 2, 0, 0,
'L','E','S','S', x'FF',x'FF',x'FF',x'FF', 4, 2, 0, 0,
'N','E','S','S', x'FF',x'FF',x'FF',x'FF', 4, 2, 0, 0,
0 , 0 ,'S','S', x'00',x'00',x'FF',x'FF', 2, 1, 0, 0,
0 ,'I','E','S', x'00',x'FF',x'FF',x'FF', 3, 2, 0, 0,
0 , 0 ,'E','S', x'00',x'00',x'FF',x'FF', 2, 2, 0, 0,
0 , 0 , 0 ,'S', x'00',x'00',x'00',x'FF', 1, 2, 0, 0,
0 ,'I','O','N', x'00',x'FF',x'FF',x'FF', 3, 2, 0, 0,
0 , 0 ,'E','D', x'00',x'00',x'FF',x'FF', 2, 7, 0, 0,
0 ,'I','N','G', x'00',x'FF',x'FF',x'FF', 3, 7, 0, 0,
0 , 0 ,'A','Y', x'00',x'00',x'FF',x'FF', 2, 1, 0, 0,
0 , 0 ,'E','Y', x'00',x'00',x'FF',x'FF', 2, 1, 0, 0,
0 , 0 ,'I','Y', x'00',x'00',x'FF',x'FF', 2, 1, 0, 0,
0 , 0 ,'O','Y', x'00',x'00',x'FF',x'FF', 2, 1, 0, 0,
0 , 0 ,'U','Y', x'00',x'00',x'FF',x'FF', 2, 1, 0, 0,
0 , 0 , 0 ,'Y', x'00',x'00',x'00',x'FF', 1, 9, 0, 0,
0 , 0 , 0 ,'A', x'00',x'00',x'00',x'FF', 1, 9, 0, 0,
0 , 0 , 0 ,'E', x'00',x'00',x'00',x'FF', 1, 9, 0, 0,
0 , 0 , 0 ,'I', x'00',x'00',x'00',x'FF', 1, 9, 0, 0,
0 , 0 , 0 ,'O', x'00',x'00',x'00',x'FF', 1, 9, 0, 0,
0 , 0 , 0 ,'U', x'00',x'00',x'00',x'FF', 1, 9, 0, 0,
0 , 0 , 0 , 0, x'00',x'00',x'00',x'00', 0, 1, 0, 0
INTEGERARRAYNAME SUFFIX WORDS
INTEGERARRAYFORMAT SW FORMAT(0:2, 0:MAX SUFFIX)
!
!********************************************************************************
!*
!* A SIMPLE SET OF SUFFIXES TO BE REMOVED IN THE EVENT OF THE
!* FULL REDUCTION HAVING REDUCED A WORD TO LESS THAN THE
!* MINIMUM SUITABLE BEARING IN MIND ANY PREFIX
!*
!********************************************************************************
!
CONSTINTEGER MAX SIMPLE= 6
CONSTBYTEINTEGERARRAY SIMPLE BYTES(0:11, 0:MAX SIMPLE)= C
{ }
{ S U F F I X M A S K LEN SPARE SPARE }
0 , 0 , 0 , 0 , x'00',x'00',x'00',x'00', 0, 0, 0, 0,
0 , 0 ,'L','Y', x'00',x'00',x'FF',x'FF', 2, 0, 0, 0,
0 ,'I','E','S', x'00',x'FF',x'FF',x'FF', 3, 0, 0, 0,
0 , 0 ,'E','S', x'00',x'00',x'FF',x'FF', 2, 0, 0, 0,
0 , 0 , 0 ,'S', x'00',x'00',x'00',x'FF', 1, 0, 0, 0,
0 , 0 , 0 ,'Y', x'00',x'00',x'00',x'FF', 1, 0, 0, 0,
0 , 0 , 0 , 0 , x'00',x'00',x'00',x'00', 0, 0, 0, 0
INTEGERARRAYNAME SIMPLE WORDS
INTEGERARRAYFORMAT SIMPLE FORMAT(0:2, 0:MAX SIMPLE)
!
!********************************************************************************
!*
!* PREFIXES - ORDER NOT IMPORTANT - STORED IN ALPHABETICAL ORDER
!* FOR LACK OF ANY BETTER IDEA.
!*
!********************************************************************************
!
CONSTINTEGER MAX PREFIX= 16
CONSTBYTEINTEGERARRAY PREFIX BYTES(0:11, 0:MAX PREFIX)= C
{ }
{ P R E F I X M A S K MIN TRUNC SPARE }
0 , 0 , 0 , 0 , x'00',x'00',x'00',x'00', 3, 5, 0, 0,
'A','R','C', 0 , x'FF',x'FF',x'FF',x'00', 5, 7, 0, 0,
'C','O','M', 0 , x'FF',x'FF',x'FF',x'00', 6, 7, 0, 0,
'C','O','N', 0 , x'FF',x'FF',x'FF',x'00', 6, 7, 0, 0,
'C','O','R','R', x'FF',x'FF',x'FF',x'FF', 6, 7, 0, 0,
'D','I','F','F', x'FF',x'FF',x'FF',x'FF', 7, 10, 0, 0,
'D','I','R','E', x'FF',x'FF',x'FF',x'FF', 8, 8, 0, 0,
'E','I','G', 0 , x'FF',x'FF',x'FF',x'00', 5, 7, 0, 0,
'G','R','A','P', x'FF',x'FF',x'FF',x'FF', 7, 9, 0, 0,
'I','N','T', 0 , x'FF',x'FF',x'FF',x'00', 5, 7, 0, 0,
'M','U','L','T', x'FF',x'FF',x'FF',x'FF', 6, 6, 0, 0,
'O','P','T', 0 , x'FF',x'FF',x'FF',x'00', 5, 5, 0, 0,
'P','R','O', 0 , x'FF',x'FF',x'FF',x'00', 5, 7, 0, 0,
'S','T','A', 0 , x'FF',x'FF',x'FF',x'00', 5, 7, 0, 0,
'S','T','R', 0 , x'FF',x'FF',x'FF',x'00', 6, 7, 0, 0,
'T','R','A','N', x'FF',x'FF',x'FF',x'FF', 6, 8, 0, 0,
0 , 0 , 0 , 0 , x'00',x'00',x'00',x'00', 3, 5, 0, 0
INTEGERARRAYNAME PREFIX WORDS
INTEGERARRAYFORMAT PW FORMAT(0:2, 0:MAX PREFIX)
!
! OTHER PREFIXES THAT MIGHT NEED TO BE INCLUDED IN THE ABOVE TABLE ARE
! OPEN,CLOS(E),READ,WRIT(E),PRIN(T),COPY,OUT,IN
! GET,SET,SUB,NEW,OLD,LOG,ALG,PRE,DIS,UN,DE,RE
!
!********************************************************************************
!
!
ORIGINAL S = S
SADDR = ADDR(S) + 1
L == BYTEINTEGER(SADDR - 1)
FOR I = SADDR, 1, SADDR + L - 1 CYCLE
IF '0' <= BYTEINTEGER(I) <= '9' THENRESULT = S
REPEAT
SUFFIX WORDS == ARRAY(ADDR(SUFFIX BYTES(0, 0)), SW FORMAT)
PREFIX WORDS == ARRAY(ADDR(PREFIX BYTES(0, 0)), PW FORMAT)
SIMPLEWORDS == ARRAY(ADDR(SIMPLE BYTES(0, 0)), SIMPLE FORMAT)
WE ADDR = ADDR(WORD END)
!
MOVE(4, SADDR, ADDR(WORD START))
FOR I = 1, 1, MAX PREFIX CYCLE
IF WORD START & PREFIX WORDS(1, I) = PREFIX WORDS(0, I) START
TRUNCATION = PREFIX BYTES(9, I)
MINIMUM = PREFIX BYTES(8, I)
EXIT
FINISH
REPEAT
!
CYCLE
MOVE(4, SADDR + L - 4, WE ADDR)
FOR I = 1, 1, MAX SUFFIX CYCLE
IF WORD END & SUFFIX WORDS(1, I) = SUFFIX WORDS(0, I) THEN C
OPTION = SUFFIX BYTES(9, I) ANDEXIT
REPEAT
!
IF OPTION & REMOVE > 0 START
L = L - SUFFIX BYTES(8, I)
IF L <= MINIMUM THENEXIT
FINISH
!
IF OPTION & DOUBLE CHECK > 0 START
IF CHARNO(S, L - 1) = CHARNO(S, L) THEN L = L - 1
FINISH
!
IF OPTION & VOWEL TRUNC > 0 START
! %IF L > VT MIN %THEN
L = L - SUFFIX BYTES(8, I)
FINISH
!
IF OPTION & COMPLETED > 0 THENEXIT
REPEAT
!
IF L > TRUNCATION THEN L = TRUNCATION
!
IF L < MINIMUM START
! MAIN REDUCTION HAS SHORTENED WORD TO SOMETNING
! LESS THAN USEFUL EG "SING" TO "S". THE ONLY
! THING TO DO NOW IS TO REINSTATE THE ORIGINAL WORD
! AND SIMPLY REMOVE PLURALS AND "LY"'S
S = ORIGINAL S
MOVE(4, SADDR + L - 4, WE ADDR)
FOR I = 1, 1, MAX SIMPLE CYCLE
IF WORD END & SIMPLE WORDS(1, I) = SIMPLE WORDS(0, I) THEN C
L = L - SIMPLE BYTES(8, I) ANDEXIT
REPEAT
FINISH
IF L < MINIMUM THEN S = ORIGINAL S
!
RESULT = S
!
END ; ! REDUCED
!
!-----------------------------------------------------------------------
!
INTEGERFN MODIFY(INTEGER F, MAX, INTEGERNAME N1, N2,
RECORD (REFF)ARRAYNAME R1, R2)
INTEGER I, J, I0, I1, FNO, OLD, N, NEWCOUNT
I0 = 0
I1 = 0
IF N1 > 0 START ; ! locate old refs to the file
CYCLE I = 1, 1, N1
FNO = R1(I)_FILENO
I0 = I IF I0 = 0 AND FNO >= F
I1 = I IF FNO = F
EXIT IF FNO > F
REPEAT
FINISH
I0 = N1 + 1 IF I0 = 0; ! where refs are or should be put
OLD = 0
OLD = I1 - I0 + 1 IF I1 > 0; ! number of old refs
!
-> DIFF UNLESS OLD = N2
I = I0
CYCLE J = 1, 1, OLD
-> DIFF UNLESS R1(I)_SECTION NO = R2(J)_SECTION NO
-> DIFF UNLESS R1(I)_SECTION NAME = R2(J)_SECTION NAME
I = I + 1
REPEAT
RESULT = 0; ! same number of refs with same values
DIFF:
J = N1 + N2 - OLD; ! new last
N2 = 0 AND J = N1 - OLD IF J > MAX; ! most unlikely
NEWCOUNT = J
!
IF N2 < OLD START ; ! now have fewer so close the gap
I = I1
J = I0 + N2
CYCLE
I = I + 1
EXIT IF I > N1
R1(J) = R1(I)
J = J + 1
REPEAT
FINISH
!
IF N2 > OLD AND I0 + OLD <= N1 START ; ! need (bigger) gap
I = N1
N = N1 - I0 + 1 - OLD
CYCLE
R1(J) = R1(I)
J = J - 1
I = I - 1
N = N - 1
REPEAT UNTIL N = 0
FINISH
!
I = 0
J = I0
WHILE I < N2 CYCLE
I = I + 1
R2(I)_FILENO = F
R1(J) = R2(I)
J = J + 1
REPEAT
!
N1 = NEWCOUNT
RESULT = 1; ! refs radically altered
END ; ! MODIFY
!
!-----------------------------------------------------------------------
!
INTEGERFN CHANGED(RECORD (HF)NAME H0, INTEGER F)
INTEGER HA, J, RC, RRC, RC0, RRC0
STRING (255)JUNK
RECORD (HF)NAME H
RECORD (REFF)ARRAY R, RR(1:MAXREFS)
RC0 = REFCOUNT
RRC0 = REDREFCOUNT
RC = 0
RRC = 0
! J = MAILSUPPORT("ERCC04@2972", H0_FILE(F) . " changed?")
OUTFILE("T#EXTRACT", 1 << 17, 0, 0, HA, J)
IF J = 0 START
H == RECORD(HA)
J = EXTRACT(H, H0_FILE(F))
RRC = FINDREFS(H, REDKEY, KEY, REDSTAR, STAR, RR, R,
MAXREFS, KEYCOUNT, REDKEYFLAG, RC) IF J = 0
FINISH
!
J = MODIFY(F, MAXREFS, REDREFCOUNT, RRC, REDREFS, RR) ! C
MODIFY(F, MAXREFS, REFCOUNT, RC, REFS, R)
RESULT = 0 IF J = 0; ! no apparent change
!
RESULT = 1 IF RC0 = 1 > RRC0; ! there wasn't a menu on display
W("File '" . H0_TOPIC(F) . "', which contained the reference, has been changed")
IF REF COUNT = 0 = RED REF COUNT START
W("and the reference no longer exists")
RESULT = 2
FINISH
!
W("Please press 'return' for a revised menu")
PROMPT("Revision: ")
RSTRG(JUNK)
RESULT = 3
END ; ! CHANGED
!
!-----------------------------------------------------------------------
!
INTEGERFN DISPLAY REF(RECORD (HF)NAME H, RECORD (REFF)NAME REF,
STRINGNAME RETURN)
INTEGER F, J, DONE
STRING (31)FILE
RECORD (RF)R
J = 0
F = REF_FILENO
FILE = H_FILE(F)
CONNECT(FILE, 1, 0, 0, R, J)
IF J # 0 OR DTWORD(INTEGER(R_CONAD+20)) > DTEXTRACT START
DONE = 0
J = 0
WHILE J < TOPMOD CYCLE
DONE = 1 AND EXIT IF MODIFIED(J) = F; ! already done this file
J = J + 1
REPEAT
!
J = 0
J = CHANGED(H, F) IF DONE = 0
FINISH
ZVIEW2(H_FILE(F) . "," . REF_SECTION NO, RETURN) IF J = 0
PROMPT("Help: ")
RESULT = J; ! non zero if changed and ref not displayed
END ; ! DISPLAY REF
!
!-----------------------------------------------------------------------
!
SYSTEMROUTINE ZHELP(STRING (255)EXTRACT, HELPINFO, KEYS)
!
INTEGER J, PAGE, MAXPAGE, VDUI2, VDUI3, LPPAGE
INTEGER A, B, L
INTEGER MENU ON DISPLAY
STRING (255)RED KEYS, WORK, K, KEY AS GIVEN
STRING (255)BEFORE, AFTER, VDUS1
RECORD (RF)R
RECORD (HF)NAME H
CONNECT(EXTRACT, 1, 0, 0, R, J)
RETURN UNLESS J = 0
H == RECORD(R_CONAD)
DTEXTRACT = DTWORD(H_DATETIME)
!
KEYS = BEFORE.AFTER WHILE KEYS -> BEFORE.(" ").AFTER; ! remove blanks
UCTRANSLATE(ADDR(KEYS) + 1, LENGTH(KEYS)); ! upper case translate
!
QUERY = NO
IF LENGTH(KEYS) > 1 AND CHARNO(KEYS, LENGTH(KEYS)) = '?' START
QUERY = YES
LENGTH(KEYS) = LENGTH(KEYS) - 1
J = DSFI("", -1, 24, 0, ADDR(PTRNS0)); ! get initial values
J = DSFI("", -1, 28, 0, ADDR(OCP0))
FINISH
!
TOPIC FILE = 0
IF KEYS -> KEYS . ("/") .AFTER START
CYCLE J = 1, 1, H_TOPFILE
IF H_TOPIC(J) = AFTER START
TOPIC FILE = J
Q("Topic file: ".ITOS(TOPIC FILE))
EXIT
FINISH
REPEAT
FINISH
!-----------------------------------------------------------------------
IF KEYS -> (".ALL") OR KEYS="" OR KEYS="?" OR KEYS="HELP" OR LENGTH(KEYS)>128 START
CYCLE J = 1, 1, H_TOPFILE
Q(H_FILE(J) . " - " . H_TOPIC(J))
REPEAT
ZVIEW2(HELPINFO, AFTER)
-> RETURN
FINISH
!-----------------------------------------------------------------------
IF KEYS -> (",") START
W("Commas (,) are not permitted in keys")
W("To send output to a printer or a file, get to the section")
W("you want, then type")
W(" F<.LP>")
W("or F<filename>")
W("or F<filename/W> if the file already exists")
W("or F<filename-MOD> to add to an existing file")
SETFNAME(KEYS)
SET RETURN CODE(202)
RETURN
FINISH
!
!-----------------------------------------------------------------------
! Each key is examined to see if it can be 'reduced' ie
! some common suffix (and prefix?) removed. This is done
! if the length of the key is > 2 (excluding *'s) and does
! not have a trailing *. The reduced key - RED key - is
! then enclosed in *'s.
RED KEY FLAG = NO
RED KEYS = ""
WORK = KEYS."&"
KEY COUNT = 0
WHILE WORK -> KEY AS GIVEN.("&").WORK CYCLE
KEY COUNT = KEY COUNT + 1
IF KEY COUNT > TOP KEY START
W("Too many keys!!!")
-> FAIL
FINISH
L = LENGTH(KEY AS GIVEN); ! examine each key
A = 0
B = 0
IF L > 0 START
A = 1 IF CHARNO(KEY AS GIVEN, 1) = '*'
B = 1 IF CHARNO(KEY AS GIVEN, L) = '*'
FINISH
IF L - A - B < 2 START
W("Keys must be at least 2 characters long")
FAIL:
SETFNAME(KEYS)
SET RETURN CODE(202)
RETURN
FINISH
BEFORE = KEY AS GIVEN
BEFORE -> ("*") . BEFORE IF A = 1
L = L - A - B
LENGTH(BEFORE) = L IF B = 1
K = BEFORE; ! original key
K = K . "," IF B = 0
KEY(KEY COUNT) = K
RED KEY(KEY COUNT) = K
STAR(KEYCOUNT) = A
REDSTAR(KEYCOUNT) = A
!
REDKEYS = REDKEYS . "&" UNLESS REDKEYS = ""
!
IF L > 2 AND B = 0 START ; ! make a 'reduced' version
RED KEY FLAG = 1
K = REDUCED(BEFORE)
REDKEY(KEYCOUNT) = K
REDKEYS = REDKEYS . "*" . K . "*"
REDSTAR(KEYCOUNT) = 1
FINISH ELSE REDKEYS = REDKEYS . KEY AS GIVEN
REPEAT
!
IF QUERY = YES START
CYCLE J = 1, 1, KEY COUNT
IF RED KEY FLAG = 1 START
IF REDSTAR(J) = 0 THEN SPACE ELSE PRINTSYMBOL('*')
PRINTSTRING(RED KEY(J))
SPACES(2)
FINISH
IF STAR(J) = 0 THEN SPACE ELSE PRINTSYMBOL('*')
PRINTSTRING(KEY(J))
NEWLINE
REPEAT
FINISH
!
!-----------------------------------------------------------------------
RED REF COUNT = FINDREFS(H, RED KEY, KEY, REDSTAR, STAR,
RED REFS, REFS, MAX REFS, KEY COUNT, RED KEY FLAG, REF COUNT)
!
UNLESS TOPIC FILE = 0 START
A = 0
J = 0
WHILE J < REF COUNT CYCLE
J = J + 1
Q("sec: ".REFS(J)_SECTION NAME." file: ".ITOS(REFS(J)_FILENO))
IF REFS(J)_FILENO = TOPIC FILE START
A = A + 1
REFS(A) = REFS(J) UNLESS A = J
FINISH
REPEAT
REF COUNT = A
!
A = 0
J = 0
WHILE J < RED REF COUNT CYCLE
J = J + 1
IF RED REFS(J)_FILENO = TOPIC FILE START
A = A + 1
RED REFS(A) = RED REFS(J) UNLESS A = J
FINISH
REPEAT
RED REF COUNT = A
FINISH
!
-> NONE IF RED REF COUNT = 0 = REF COUNT
!
-> TOO MANY IF REF COUNT > MAXREFS
!
RED REF COUNT = 0 IF RED REF COUNT > MAX REFS
!
-> TOO MANY IF REF COUNT = 0 = RED REF COUNT
!
!-----------------------------------------------------------------------
! Now that we have finished processing the keys and refs
! monitor this successful call.
MONITOR CALL(KEYS, REF COUNT + RED REF COUNT)
!-----------------------------------------------------------------------
!
!
REPEAT:
-> NONE IF RED REF COUNT = 0 = REF COUNT
!
IF REF COUNT = 1 > RED REF COUNT START
J = DISPLAY REF(H, REFS(1), AFTER)
-> RETURN IF J = 0 OR J = 2
-> REPEAT
FINISH
!-----------------------------------------------------------------------
!
! If more than one, construct a View like display of
! the references found.
VDUI2 = 72; ! width
VDUI3 = 0; ! lines per page, 0=hardcopy
LPPAGE = 20; ! value to use for same
VDUS1 = ""; ! clear screen sequence
!
IF VDUI(1) > 0 START ; ! terminal type is set
VDUI2 = VDUI(2)
VDUI2 = VDUI2 - 1 IF VDUB(4) # 0
START STANDOUT = VDUS(17)
END STANDOUT = VDUS(18)
VDUI3 = VDUI(3)
LPPAGE = VDUI3 - 4 IF VDUI3 > 0
LPPAGE = 20 IF LPPAGE > 20
VDUS1 = VDUS(1) . "
"
FINISH
!
PAGE = 1
!
! The LAYOUT procedure figures out how the references
! are to laid out on the page(s) in an attractive
! manner.
MAXPAGE = LAYOUT(REF COUNT, RED REF COUNT, LPPAGE)
Q("REFS ".ITOS(REFCOUNT)." REDREFS ".ITOS(REDREFCOUNT))
D:
DISPLAY(H, KEYS, RED KEYS, REFS, RED REFS, PAGE, MAXPAGE, LPPAGE, REF COUNT)
MENU ON DISPLAY = YES
R:
-> D IF MENU ON DISPLAY = NO
RSTRG(AFTER)
UNLESS AFTER = "" START
AFTER -> (" ") . AFTER WHILE AFTER # "" AND CHARNO(AFTER, 1) = ' '
-> R IF AFTER = ""
FINISH
!
UCTRANSLATE(ADDR(AFTER)+1, LENGTH(AFTER)) UNLESS AFTER = ""
!
IF AFTER = "Q" OR AFTER = "QUIT" START
-> RETURN
FINISH
R1:
IF AFTER = "-" START
-> R IF PAGE = 1
PAGE = PAGE - 1
-> D
FINISH
!
IF AFTER = "" START
PAGE = PAGE + 1 AND -> D IF PAGE < MAXPAGE
J = 1
FINISH ELSE START
J = PSTOI(AFTER)
-> R UNLESS 1 <= J <= REF COUNT + RED REF COUNT
FINISH
!
IF J > REF COUNT START
J = J - REF COUNT
J = DISPLAY REF(H, RED REFS(J), AFTER)
FINISH ELSE START
J = DISPLAY REF(H, REFS(J), AFTER)
FINISH
MENU ON DISPLAY = NO
-> REPEAT IF J = 3
-> RETURN IF J = 2
!
! Ideally at this point, we would like to know if the user
! said Q to get out of VIEW and, if so, return.
-> RETURN IF AFTER = "Q"
-> D IF AFTER = ""
-> R1
NONE:
W("No references found")
MONITOR CALL(KEYS, 0)
-> RETURN
TOO MANY:
PRINTSTRING("Too many references found, ")
W("please give more specific request")
RETURN:
SET RETURN CODE(0)
END ; ! ZHELP
!
!
!
EXTERNALROUTINE HELP(STRING (255)PARMS)
STRING (255) SAVEMODE
SAVEMODE = ""
UNLESS QUERY MODE(2) = 0 C
THEN SAVEMODE = MODESTR AND SETMODE("H=0")
ZHELP("SUBSYS.EXTRACT", "SUBSYS.VD_CMNDS,K<HELP>", PARMS)
SETMODE(SAVEMODE) UNLESS SAVEMODE = ""
END ; ! HELP
!
!
!
ENDOFFILE