!TITLE View source code
! This is the source code of VIEW
!
!
!<System routine ZVIEW
!%SYSTEMROUTINE ZVIEW(%STRING(255)S)
! VIEW(S)
!%END
!
! This is simply a call on VIEW which can be used by a program
! to ensure that it does actually call the 'system' version of
! VIEW.
!>
!
!
!
!<System integer fn ZVIEWREFS
!%SYSTEMINTEGERFN ZVIEWREFS(%STRING(31)FILE, %STRING(255)KEYS, %C
! %INTEGER MAXREF, %RECORDARRAYNAME REF, %INTEGER SUBFILES)
!
! This function uses VIEW to scan the file FILE for the keys
! given in KEYS. Any 'hits' are returned in the record array
! REF up to a maximum of MAXREF. All the subsidiary files of
! FILE are examined automatically unless SUBFILES = 0. The number
! of 'hits' is returned as the result and may be greater than
! MAXREF.
!
! KEYS has the form
! key1 & key2 & ...
! where keyi may have an asterisk before and/or after
!
! REF is an array (1:MAXREF) of records whose format is
! %string(31)SECTION NAME, TOPIC, FILE, SECTION NUMBER
! To view a reference, call
! ZVIEW(FILE, SECTION NUMBER)
! If KEYS is null, the name and topic of the file, and each
! subfile if requested, are returned in REF.
!>
!
!
!
CONSTSTRINGNAME DATE = X'80C0003F'
CONSTSTRINGNAME TIME = X'80C0004B'
CONSTSTRING (10)NLS10 = "
"
CONSTSTRING (15)DEFAULT FILE = "SUBSYS.VIEWBASE"
CONSTSTRING (8)VIEWDIR = "VIEWDIR2"
CONSTSTRING (8)VIEWKEY = "VIEWKEYS"
!
!
!
CONSTINTEGER KENT = 0
CONSTINTEGER ERCC = 1
CONSTINTEGER SITE = KENT
!
CONSTINTEGER NO = 0
CONSTINTEGER YES = 1
CONSTINTEGER TOP FT = 60
CONSTINTEGER TOP PAD = 6
CONSTBYTEINTEGERARRAY PAD(1 : TOP PAD) = 35,23,17,13,11,1
!
!
!
!
RECORDFORMAT C
BNF(BYTEINTEGER LEN, S1, S2, S3, INTEGER ADR)
RECORDFORMAT C
DIRF(STRING (30)SEC, BYTEINTEGER PER,
STRING (31)NAME, INTEGER P1, P2, SUBS, LINK)
OWNRECORD (DIRF)ARRAYFORMAT C
DIRAF(-1:130000)
RECORDFORMAT C
FDF(INTEGER LINK, DSNUM, {CUR, below, is addr of next byte to be written}
BYTEINTEGER STATUS, ACCESSROUTE, VALID ACTION, CUR STATE,
BYTEINTEGER MODE OF USE, MODE, FILE ORG, DEV CODE,
BYTEINTEGER REC TYPE, FLAGS, LM, RM,
INTEGER ASVAR, AREC, RECSIZE, MINREC, MAXREC, MAXSIZE,
LASTREC, CONAD, CURREC, CUR, END, TRANSFERS, DARECNUM,
CURSIZE, DATASTART, STRING (31) IDEN,
INTEGER KEYDESC0, KEYDESC1, RECSIZEDESC0, RECSIZEDESC1,
BYTE INTEGER F77FLAG, F77FORM, F77ACCESS, F77STATUS,
INTEGER F77RECL, F77NREC, IDADDR,
BYTE INTEGER F77BLANK, F77UFD, SPARE1, SPARE2)
RECORDFORMAT C
FHDRF(INTEGER NFB, TXTST, MAX, TYPE,
CHKSUM, TIMESTAMP, ADR, COUNT)
RECORDFORMAT C
FRAMEF(INTEGER I, T, CJ, STATE)
RECORDFORMAT C
MEMF(INTEGER START, STRING (11)NAME, INTEGER S1, S2, S3, S4)
OWNRECORD (MEMF)ARRAYFORMAT C
MEMAF(0:4095)
RECORDFORMAT C
FTF(STRING (46)FILE, BYTEINTEGER SSW,
STRING (71)PROMPT,
INTEGER CONRES, TIMESTAMP, CONBASE, DIRA, KEYA)
RECORDFORMAT C
REFF(STRING (31)NAME, TOPIC, FILE, SEC)
OWNSTRING (31)ARRAYFORMAT C
S31AF(1 : 100)
RECORDFORMAT C
RF(INTEGER ADR, TYPE, START, END)
!
!
!
DYNAMICROUTINESPEC C
CALL(STRING (31)COMMAND, STRING (255)PARAMETER)
SYSTEMROUTINESPEC C
CASTOUT(STRINGNAME S)
DYNAMICROUTINESPEC C
CLEAR(STRING (255)S)
SYSTEMROUTINESPEC C
CONNECT(STRING (31)FILE, INTEGER MODE, HOLE, PROT, RECORD (RF)NAME R,
INTEGERNAME FLAG)
SYSTEMROUTINESPEC C
CONSOLE(INTEGER TYPE, INTEGERNAME START, LENGTH); ! TYPE=7 : KILL OUTPUT
DYNAMICROUTINESPEC C
DEFINE(STRING (255)S)
SYSTEMROUTINESPEC C
DESTROY(STRING (31)FILE, INTEGERNAME FLAG)
SYSTEMROUTINESPEC C
DISCONNECT(STRING (31)FILE, INTEGERNAME FLAG)
EXTERNALINTEGERFNSPEC C
DRESUME(INTEGER C, B, A)
EXTERNALINTEGERFNSPEC C
DSFI(STRING (31)INDEX, INTEGER FSYS, TYPE, SET, ADR)
SYSTEMINTEGERFNSPEC C
DTWORD(INTEGER X)
SYSTEMSTRINGFNSPEC C
FAILURE MESSAGE(INTEGER FLAG)
SYSTEMINTEGERFNSPEC C
FDMAP(INTEGER CHAN)
SYSTEMSTRINGFNSPEC C
HTOS(INTEGER VALUE, PLACES)
SYSTEMINTEGERFNSPEC C
IOCP(INTEGER EP, PARM)
ROUTINESPEC C
LAYNEWPAGE
SYSTEMROUTINESPEC C
LOAD(STRING (31)COMMAND, INTEGER I, INTEGERNAME FLAG)
EXTERNALSTRING (255)FNSPEC C
MODESTR
SYSTEMROUTINESPEC C
MODPDFILE(INTEGER ACT, STRING (31)PDFILE, STRING (11)MEMBER,
STRING (31)INFILE, INTEGERNAME FLAG)
! ACT 1 INSERT
! 2 REMOVE
! 3 RENAME
! 4 CREATE PD FILE
SYSTEMROUTINESPEC C
NEWGEN(STRING (31)FROM, TO, INTEGERNAME FLAG)
SYSTEMROUTINESPEC C
OUTFILE(STRING (31)S, INTEGER LEN, MAX, PRM, INTEGERNAME ADR, RES)
DYNAMICROUTINESPEC C
PROMPT(STRING (255)S)
SYSTEMINTEGERFNSPEC C
QUERY MODE(INTEGER N)
EXTERNALINTEGERFNSPEC C
READID(INTEGER A)
SYSTEMROUTINESPEC C
REROUTECONTINGENCY(INTEGER EP, CLASS, LONGINTEGER MASK,
ROUTINE STRAP(INTEGER CLASS, SUBCLASS), INTEGERNAME FLAG)
EXTERNALROUTINESPEC C
SETMODE(STRING (255)S)
SYSTEMROUTINESPEC C
SIGNAL(INTEGER EP, P1, P2, INTEGERNAME FLAG)
DYNAMICROUTINESPEC C
TERMINALTYPE(STRING (255)S)
EXTERNALROUTINESPEC C
TERMINATE
SYSTEMROUTINESPEC C
UCTRANSLATE(INTEGER ADR, LEN)
EXTERNALINTEGERFNSPEC C
UINFI(INTEGER N)
EXTERNALSTRINGFNSPEC C
UINFS(INTEGER N)
SYSTEMSTRING (8)FNSPEC C
UNPACKDATE(INTEGER P)
SYSTEMSTRING (8)FNSPEC C
UNPACKTIME(INTEGER P)
EXTERNALINTEGERFNSPEC C
VDUB(INTEGER N)
EXTERNALINTEGERFNSPEC C
VDUI(INTEGER N)
EXTERNALSTRINGFNSPEC C
VDUS(INTEGER N)
STRINGFNSPEC C
VIEWFN(STRING (255)S, LINE)
DYNAMICROUTINESPEC C
ZCOPY2 ALIAS "S#ZCOPY2" (STRING (255)S, INTEGER SILENT, INTEGERNAME FLAG)
!
!
!
OWNINTEGER KK TOP REF; ! max the user can accept
OWNINTEGER KK REF ADDR; ! address of REF(1)
OWNINTEGER KK TOP KEY; ! number of keys (in array KKEY)
OWNINTEGER KK REFI; ! number of references found
OWNINTEGER KKEYPT; ! address of next avail byte in T#KEYWRK
OWNINTEGER KK TOP KEYPT; ! address of max avail byte...
OWNSTRING (63)ARRAY KKEY(1 : 10)
!
!
!
OWNINTEGER LEVEL = 0
OWNINTEGER LAST SCREEN ID; ! previous value of SCREEN ID
OWNINTEGER LIBRAR = 0; ! SET TO 1 IF USER IS LIBRAR
OWNINTEGER LINT; ! set non zero on receipt of INT: K
OWNINTEGER LPPAGE = 20
OWNINTEGER MAXDIR = 13000 { so need up to 17 bits and 13 bits for the 'frame' in contents }
OWNINTEGER PARTIAL DISPLAY = 0; ! set non zero to get heading only
OWNINTEGER RESTRICTED = 0; ! set non zero for VIEWER, LIBRAR etc
OWNINTEGER SCREEN ID; ! used to record what is on display
OWNINTEGER VDUI3; ! LINES/PAGE, 0=HARDCOPY
OWNINTEGER VIEWMON = 0
OWNINTEGER WIDTH = 72
!
!
!
CONSTINTEGER TOP PARAMETER = 115
OWNSTRING (31)ARRAY PARAMETER(100 : TOP PARAMETER)
OWNBYTEINTEGERARRAY PARAMETER USED(100 : TOP PARAMETER)
OWNINTEGER SOME PARAMETER USED
!
!
!
OWNINTEGER EFFING STYLE = 1
OWNSTRING (31)EFFING FILE = ""
OWNSTRING (11)OUTPUT FILE
!
!
!
OWNSTRING (6)PROCUSER
OWNSTRING (255)SAVEMODE
OWNSTRING (31)VDUS1 = ""; ! CLEAR SCREEN SEQUENCE
OWNSTRING (31) START STANDOUT, END STANDOUT
!
!
OWNINTEGER KSUPSUBFILES
!
!
OWNRECORD (FTF)ARRAY FTS(1 : TOP FT)
CONSTINTEGER TOP LEVEL = 99
OWNBYTEINTEGERARRAY FTI(1 : TOP LEVEL)
!
!
!
CONSTINTEGER TOP STRIP = 100
OWNINTEGERARRAY STRIP(0 : TOP STRIP)
OWNINTEGER STRIPJ
!
!
!
ROUTINE MON(STRING (255)S1, S2)
UNLESS VIEWMON = 0 START
PRINTSTRING(S1.": ")
PRINTSTRING(S2)
NEWLINE
FINISH
END
!
!
!
STRING (255)FN ITOS(INTEGER N0)
STRING (11)S
INTEGER I, N
N = N0
N = -N IF N < 0
S = ""
CYCLE
I = N
N = N // 10
I = I - 10 * N + '0'
S = TOSTRING(I) . S
EXIT UNLESS N > 0
REPEAT
S = "-" . S IF N0 < 0
RESULT = S
END ; ! ITOS
!
!
!
ROUTINE PRINTCHS(STRING (255)S)
INTEGER LEN, ADR, RES; ! KEEP IN THIS ORDER !!!!
RETURN IF LENGTH(S) = 0
LEN = LENGTH(S)
ADR = ADDR(S) + 1
RES = IOCP(19, ADDR(LEN))
END
!
!
!
ROUTINE W(STRING (255)S)
STRING (1)NP
STRING (255)S1, S2
NP = TOSTRING(12)
S = S1 . S2 WHILE S -> S1 . (NP) . S2
PRINTCHS(S)
NEWLINE
END
!
!
!
ROUTINE RSTRG(STRINGNAME S)
INTEGER I
S = ""
CYCLE
READSYMBOL(I)
RETURN IF I = NL
S = S . TOSTRING(I)
REPEAT
END ; ! OF RSTRG
!
!
!
INTEGERFN STOI2(STRING (255) P, INTEGERNAME I2)
INTEGER TOTAL, AD, I, J
STRING (255) WORK
TOTAL = 0
AD = ADDR(P)
A: IF P -> WORK.(" ").P THEN START
-> A IF WORK = ""
P = WORK." ".P
FINISH
I = 1
WHILE I <= BYTEINTEGER(AD) CYCLE
J = BYTE INTEGER(I+AD)
-> FAULT UNLESS '0' <= J <= '9'
TOTAL = 10*TOTAL + J&15
I = I+1
REPEAT
IF I > 1 THEN I2 = TOTAL AND RESULT = 0
FAULT:
I2 = 0
RESULT = 1
END ; ! STOI2
!
!
!
ROUTINE READ VALUE(STRINGNAME S)
INTEGER J, N, FAIL
STRING (255)NUM, PROMPTTEXT, DEFAULT, HELP, TEMPLATE, VALUE
FAIL = 1
IF S -> NUM . ("¬") . PROMPT TEXT.("¬").DEFAULT.("¬").HELP START
TEMPLATE = "" UNLESS HELP -> HELP . ("¬") . TEMPLATE
!
J = STOI2(NUM, N)
IF J = 0 AND 100 <= N <= TOP PARAMETER START
PROMPT(PROMPT TEXT . ": ")
L:
RSTRG(VALUE)
VALUE = DEFAULT IF VALUE = ""
W(HELP) AND -> L IF VALUE = "?"
FAIL = 0
PARAMETER(N) = VALUE
PARAMETER USED(N) = 1
SOME PARAMETER USED = 1
FINISH
FINISH
!
W("Incorrect use: !READ " . S) IF FAIL = 1
END ; ! READ VALUE
!
!
!
ROUTINE DRAWLINE
INTEGER N
NEWLINE
RETURN IF VDUI3 = 0; ! Not a Video
CYCLE N = 1, 1, WIDTH
PRINTSTRING("-")
REPEAT
NEWLINE
END ; ! DRAWLINE
!
!
!
ROUTINE BLANKLINES(INTEGER N)
UNLESS VDUI3 = 0 OR N < 1 C
THEN NEWLINES(N)
END
!
!
!
ROUTINE WRITEN(INTEGER N)
PRINTSTRING(ITOS(N))
END ; ! OF WRITEN
!
!
!
ROUTINE DESPACE(STRINGNAME S)
INTEGER I, J, K, CH
J = LENGTH(S)
RETURN IF J = 0
K = 0
!
CYCLE I = 1, 1, J
CH = CHARNO(S, I)
UNLESS CH = ' ' START
K = K + 1
CHARNO(S, K) = CH IF I > K
FINISH
REPEAT
!
LENGTH(S) = K IF J > K
END ; ! DESPACE
!
!
!
STRINGFN JUST(STRING (255)S)
INTEGER A, I, J
I = 1
J = LENGTH(S)
I = I + 1 WHILE I < J AND CHARNO(S, I) = ' '
J = J - 1 WHILE I < J AND CHARNO(S, J) = ' '
I = I - 1
A = ADDR(S) + I
BYTEINTEGER(A) = J - I
RESULT = STRING(A)
END
!
!
!
ROUTINE MOVE(INTEGER LEN, FROM, TO)
*LDTB_X'18000000'
*LDB_LEN
*LDA_FROM
*CYD_0
*LDA_TO
*MV_L =DR
END
!
!
!
integerfn MAIL SUPPORT(string (255)s, fsubject)
!!
!! Offers the TELL interface, with extensions, to send a message
!! via MAILER. Parameters are <address>,<file>,<subject>
!! - if <file> is omitted, text is read from the console
!! until nl*nl sequence.
!! Various forms for address:
!! usernumber (at this host assumed) ERCC27 (at 2972)
!! directory name S.Shaw
!! name@other host ERCC99@2980
record format frf(integer a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, string (6) a11, string (8) a12, a13,
integer a14, a15, a16)
record format rf(integer conad, filetype, datastart, dataend)
record format paf(integer dest, srce, flag, message count, secs, ident, bad bitcomp, p6)
system routine spec finfo(string (31) file, integer mode, record (frf) name fr, integer name flag)
system routine spec setfname(string (40) name)
system routine spec psysmes(integer root, mess)
external routine spec prompt(string (15) s)
external string fn spec derrs(integer flag)
external routine spec setreturncode(integer flag)
system routine spec connect(string (31) file, integer mode, hole, prot, record (rf) name r,
integer name flag)
system routine spec destroy(string (31) file, integer name flag)
system routine spec disconnect(string (31) file, integer name flag)
external integer fn spec dmail(record (paf) name p, integer len, adr)
external integer fn spec dpermission(string (6) owner, user, string (8) date, string (11) file,
integer fsys, type, adrprm)
system string fn spec itos(integer n)
system routine spec outfile(string (31) file, integer size, hole, prot, integer name conad, flag)
system routine spec move(integer len, from, to)
system routine spec uctranslate(integer addr, length)
external string fn spec uinfs(integer entry)
external integer fn spec uinfi(integer entry)
record (paf) pa
record (rf) r
record (frf) fr
integer len, flag, conad, i, j, nlsw, query, lines
string (255) to, file, name, server, subject
const integer invalid user= 201; !SS FLAG
const integer tempfile= x'40000000'; !CREATE MODE
const integer sscharfiletype= 3
const integer general= 233
const integer max mflag= 529
const string (28) array mailer mess(501:max mflag)= c
"Invalid parameters",
"Duplicate component:",
"Unknown component",
"Invalid command",
"No valid recipients",
"Too many recipients",
"Addr table full",
"Name table full",
"Illegal name",
"Mail service closed",
"Recipient offline",
"Message too long",
"MAILER fault",
"Missing component:",
"No free message descriptors",
"Invalid component:",
"Total message kb exceeded",
"Cannot return report file",
"Message stored",
"Forbidden component",
"Create file fails",
"User not accredited",
"Invalid password",
"Name not accredited",
"Name already accredited",
"Name belongs to another user",
"Uncollected mail for R-name",
"Invalid date/time after",
"Not allowed in student procs"
const string (1) snl= "
"
const string (12) config file="FTRANS.CFILE"; !"MANAGR.MFILE"
const integer this auth flag= 8
const integer this host flag=16
const integer max fsys=99
const integer hash length= 1023
const integer station entry size= 512
own integer config conad=0
record format pointers f(integer link list displ, ftp table displ, queues, queue entry size, queue displ,
queue name displ, streams, stream entry size, stream displ, remotes, remote entry size, remote displ,
hash len, station, station entry size, station displ, station name displ, station addresses displ,
guest no, byte integer array discs(0:max fsys), string (63) dead letters, this full host,
integer expanded address displ, integer array hash t(0:hash length))
record format station f((byte integer max lines or c
byte integer max ftp lines), byte integer status, (byte integer service or c
byte integer ftp service), byte integer connect retry ptr, fep, address type, accounting,
(byte integer q lines or byte integer ftp q lines), (integer limit or c
integer ftp limit), integer last call, last response, system loaded, connect attempts, connect retry time,
integer array ispare(0:4), integer seconds, bytes, integer last q response by us, p transfers,
q transfers, p kb, q kb, p mail, q mail, integer name, shortest name, integer array address(1:4),
integer pss entry, integer mail, integer ftp, integer description, (integer queue or c
integer route), integer flags,
byte integer array string space(0:375) {decrement this if more fields added, keep to 512 total})
record (pointers f) name pointers
record (station f) name station
integer fn connect configfile
record (rf) rr
integer flag
connect(config file, 1!8 {read shared}, 0, 0, rr, flag)
if flag#0 then printstring(" - configuration file not currently available".snl) and result = -2
config conad = rr_conad
pointers == record(config conad+rr_datastart)
result = 0
end ; !of connect config
integer fn lookup hasht(string (127) name)
const integer station entry size= 512
record format hname f(integer link, host entry, string (255) name)
record (hname f) name hname entry
integer i, pt, n, h
byte integer array x(0:15)
const byte integer array prime(1:7)= 23, 19, 11, 7, 5, 13, 17
pt = (addr(x(7))>>3)<<3
longinteger(pt) = 0
n = addr(name)
byteinteger(pt+i&7) = byteinteger(pt+i&7)!!byteinteger(n+i) for i = 0, 1, length(name)
h = length(name)*29
h = h+prime(i)*byteinteger(pt+i) for i = 1, 1, 7
h = h&hash length
if pointers_hasht(h)#-1 start
hname entry == record(config conad+pointers_hasht(h))
cycle
if name=hname entry_name start ; !found it
station == record(config conad+pointers_station displ+(hname entry_host entry-1)*station entry size)
result = hname entry_host entry
finish
exit if hname entry_link=-1
hname entry == record(config conad+hname entry_link)
repeat
finish
result = 0
end ; !of lookup hasht
integer fn lookup host(string (127) name)
integer res
string (31) this ukac
string (127) s1, s2
if connect configfile#0 then result = -1
name = s1.s2 while name->s1.(" ").s2
res = lookup hasht(name)
if res#0 then result = res
this ukac = uinfs(15)
! %monitor
unless name->(this ukac).s1 start
res = lookup hasht(this ukac.".".name); !prefix uk.ac
if res#0 then result = res
if name->name.(".").s1 then result = lookup hasht(name); !for arpa.
finish
result = -1
end ; !of lookup host
routine error(integer flag, string (255) text)
destroy("M#MSG", i)
setreturncode(flag)
if length(text)>40 then length(text) = 40
setfname(text)
if flag#0 then psysmes(2, flag)
end ; !OF ERROR
!!
routine remove end spaces(string name s)
length(s) = length(s)-1 while length(s)>0 and charno(s, length(s))=' '
s = substring(s, 2, length(s)) while length(s)>0 and charno(s, 1)=' '
end
integer fn check rname
s = ""
cycle i = 1, 1, length(to)
j = charno(to, i)
if 'A'<=j<='Z' or '0'<=j<='9' then s = s.tostring(j)
repeat
s = "NAMESERVER INQUIRE ".s.",FULL,M#DREPORT"
pa = 0
flag = dmail(pa, length(s), addr(s)+1)
destroy("M#DREPORT", i)
if flag=0 then result = invalid user
result = 0
end ; !of check rname
lines = 2
to = s and subject = fsubject unless s -> to . (",") . subject
query = 0
len = length(subject)
query = 1 and length(subject) = len - 1 if len > 1 and charno(subject,len) = '?'
if to="" then error(263, "") and -> return; !NO PARAMS
uctranslate(addr(to)+1, length(to))
to = name.server while to->name.(" ").server
if to->name.("@").server start
i = lookup host(server)
if i<=0 then error(general, "invalid host") and -> return
if station_flags&this host flag#0 start
if length(name)=6 then finfo(name.".A", 0, fr, flag) else flag = invalid user
if flag=invalid user then error(invalid user, to) and -> return
else
if station_flags&this auth flag#0 start
to = name
if check rname#0 then error(invalid user, to) and -> return
finish
finish
else
if length(to)=6 then finfo(to.".A", 0, fr, flag) else flag = invalid user
if flag=invalid user then flag = check rname else flag=0
if flag#0 then error(invalid user, to) and -> return
finish
outfile("M#MSG", 4096, 0, tempfile, conad, flag)
if flag#0 then error(flag, "M#MSG") and -> return
string(conad+31) = "To: ".to.snl."Subject: ".subject.snl.SNL.SNL
i = conad+byteinteger(conad+31)+32
j = i and -> send if query = 1
printstring("Terminate your comments with an asterisk on a line by itself. ie:".snl)
printstring(" Comments: *" . snl)
prompt("Comments:")
nlsw = nextch; !FORCE PROMPT EARLY
nlsw = 1
cycle j = i, 1, i+4000
readsymbol(byteinteger(j))
if nlsw=1 and byteinteger(j)='*' and nextsymbol=nl then skipsymbol and exit
if byteinteger(j)=nl then lines = lines + 1 and nlsw = 1 else nlsw = 0
repeat
if j=i then error(0, "") and -> return
send:
len = j-conad-32
s = "MAILSERVER POST M#MSG,32,".itos(len).",M#DREPORT"
disconnect("M#MSG", flag)
flag = dpermission(uinfs(1), "MAILER", "", "M#MSG", uinfi(1), 2, 3)
pa = 0
flag = dmail(pa, length(s), addr(s)+1)
if pa_flag#0 start
if pa_flag<500 then s = derrs(pa_flag) else start
if pa_flag>max mflag then pa_flag = 513
s = mailer mess(pa_flag)
finish
error(general, s)
finish else error(0, "")
return:
result = lines
end ; ! MAIL SUPPORT
!
!
!
INTEGERFN KWDSCAN(INTEGERNAME XLENGTH,XADDR, INTEGER KWDCT, C
STRINGARRAYNAME KEYS)
! 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 I, L, UNSEENCT
LONG INTEGER ARRAY 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
KEYDESCR(I) = (LENGTHENI(X'18000000'!LENGTH(KEYS(I)))<<32) C
! (ADDR(KEYS(I))+1)
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 = KEYDESCR (I)
*LB_(DRH); ! Get the first character of KEYS (I).
*LSS_1
*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.
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 KEYS?
*STD_XDESCR
L = INTEGER(ADDR(XDESCR)) & X'00FFFFFF'; ! Length of residue of data.
CYCLE I = KWDCT, -1, 1
IF SEEN(I)=0 AND LENGTH(KEYS(I))<=L THEN START
DRH = KEYDESCR (I)
*LD_DRH
*LSD_XDESCR
*CPS_L =DR
*JCC_7,<TRY NEXT>
! %IF the text we have found matches KEYS(I) %THEN %START
SEEN (I) = -1
UNSEENCT = UNSEENCT - 1
IF UNSEENCT=0 THEN 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
! %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
!
LIST
END ; ! KWDSCAN
!
!
!
ROUTINE GETLINE(STRINGNAME LINE, INTEGERNAME T0, T1, INTEGER BASE, EOF)
INTEGER L, LMAX, CH, T
L = 0
LMAX = 0
LENGTH(LINE) = 255
T = T0
LOOP:
CH = BYTEINTEGER(T + BASE)
T = T + 1
UNLESS CH = NL START
IF CH = 13 START ; ! CR
LMAX = L IF L > LMAX
L = 0
FINISH ELSE START
IF L < 140 START
L = L + 1
CHARNO(LINE, L) = CH IFC
L > LMAX OR (CH # 95 AND CHARNO(LINE, L) = ' ')
FINISH
FINISH
-> LOOP UNLESS T >= EOF
FINISH
!
L = LMAX IF LMAX > L
LENGTH(LINE) = L
T1 = T
END ; ! GETLINE
!
!
!
STRINGFN GETNAME(INTEGER I, DIRA, CONBASE)
INTEGER T0, T1
STRING (255)LINE
RECORD (DIRF)ARRAYNAME DIR
RECORD (BNF)NAME BIGNAME
DIR == ARRAY(DIRA+32, DIRAF)
IF LENGTH(DIR(I)_NAME) < 32 C
THEN RESULT = DIR(I)_NAME
!
BIGNAME == RECORD(ADDR(DIR(I)_NAME))
T0 = BIGNAME_ADR
GETLINE(LINE, T0, T1, CONBASE, X'70000000') {should be DIR(I)_P2}
LENGTH(LINE) = BIGNAME_LEN
RESULT = LINE
END ; ! GETNAME
!
!
!
ROUTINE DELETE FILE(STRING (255)FILE)
INTEGER J
STRING (255)U, F, FULL
UNLESS FILE -> U . (".") . F C
THEN U = PROCUSER AND F = FILE
!
F = F . "_"
F -> FULL . ("_") . F
FULL = U . "." . FULL
!
CYCLE J = 1, 1, TOPFT
IF FTS(J)_FILE = FULL C
THEN FTS(J) = 0 AND RETURN
REPEAT
END ; ! DELETE FILE
!
!
!
INTEGERFN VCONNECT(STRING (255)FILE,
INTEGERNAME FTINDEX,
STRINGNAME MSG)
!
!
!
INTEGER CONBASE, DIRA, KEYA
INTEGER BASE, SUBFILEA, KEYPOINT, KEYSAVE, KEYSAVE1, KEYSTATE
INTEGER CL, DL, HL, KL, SIZE, ADR, A
INTEGER I, J, K, M, IMAX, CONRES
STRING (255)MNAME
RECORD (RF) CONR
STRING (255)USER, FULL, FULLFILE, DFILE, R, LINE
STRING (31)VDIR, VKEY
!
!
!
RECORD (FTF)NAME FT
RECORD (FHDRF)NAME H
RECORD (MEMF)NAME MH
RECORD (FHDRF)NAME TXT
RECORD (MEMF)ARRAYNAME MEM
RECORD (DIRF)ARRAYNAME DIR
STRINGARRAYNAME SUBFILE
!
!
!
INTEGERFN FINFO(STRING (6)USER, STRING (11)FILE)
INTEGER J
STRING (11)W
RECORDFORMAT RF(INTEGER A,B,C,D,E,F,FSYS,SEG,G,H,I,J,STRING (6)OFF)
RECORD (RF) R
EXTERNALINTEGERFNSPEC DFINFO(STRING (6)USER, STRING (11)FILE, C
INTEGER FSYS, ADR)
W = FILE
LENGTH(FILE) = 2 IF LENGTH(FILE) > 2
W = W . ITOS(UINFI(13)) IF FILE = "T#"
J = DFINFO(USER, W, -1, ADDR(R))
IF J = 0 AND R_SEG > 0 C
THEN RESULT = 1 C
ELSE RESULT = 0; ! 0 = not already connected
END
!
!
!
INTEGERFN DIFF(INTEGER TA, TB)
RESULT = IMOD(DTWORD(TA) - DTWORD(TB))
END
!
!
!
INTEGERFN FIND(STRING (255)M)
INTEGER I
CYCLE I = 0, 1, TXT_COUNT - 1
RESULT = BASE + MEM(I)_START IF MEM(I)_NAME = M
REPEAT
RESULT = 0
END ; ! OF FIND
!
!
!
STRINGFN DIRFILE
INTEGER I, J, MAXDEFINE
RECORD (FHDRF)NAME H
MAXDEFINE = UINFI(6) << 10
!
J = 80 * (MAXDIR + 2) + 3200
IF J > MAXDEFINE START
MAXDIR = ((MAXDEFINE - 3200)//80) - 2
J = 80 * (MAXDIR + 2) + 3200
FINISH
!
OUTFILE(VDIR, J, 0, 0, DIRA, J)
UNLESS J = 0 START
RESULT = "OUTFILE" . VDIR . FAILURE MESSAGE(J)
FINISH
!
H == RECORD(DIRA)
H_TYPE = 4; ! TYPE = DATA
H_ADR = 3; ! STRUCTURE UNSPECIFIED
DIR == ARRAY(DIRA+32, DIRAF)
!
CYCLE I = -1, 1, 1
DIR(I) = 0
REPEAT
DIR(-1)_SEC <- DFILE; ! default 'topic'
!
J = MAXDIR * 128
J = MAXDEFINE IF J > MAXDEFINE
OUTFILE(VKEY, J, 0, 0, KEYA, J)
UNLESS J = 0 START
RESULT = "OUTFILE ".VKEY . FAILURE MESSAGE(J)
FINISH
!
H == RECORD(KEYA)
H_TYPE = 4
H_ADR = 3
KEYPOINT = KEYA + 32
!
SUBFILEA = ADDR(DIR(MAXDIR)) + 80
SUBFILE == ARRAY(SUBFILEA, S31AF)
!
RESULT = ""
END
!
!
!
ROUTINE WRITE KEYS(INTEGER ACT, I, STRING (255)T)
!
! ACT = 0 New section
! 1 Title
! 2 Key
!
! KEY STATE = 0 new section started, KEYSAVE set
! -1 !KEY, ie no keys, KEYPOINT reset
! 1 explicit keys set
STRING (255)A, B
SWITCH SW(0:2)
!
!
!
CONSTSTRING (255)OMIT = C
",AND,SINCE,THE,FROM,WITH,
,EXAMPLES,DESCRIPTION,INTRODUCTION,"
!
!
!
-> SW(ACT)
SW(0): ! New section
KEY SAVE = KEY POINT
A = ITOS(I) . ":,"
STRING(KEY POINT) = A
BYTEINTEGER(KEYPOINT) = NL
KEY POINT = KEY POINT + LENGTH(A) + 1
KEY SAVE1 = KEYPOINT
KEY STATE = 0
-> SW1
SW(1): ! Alternative title
RETURN UNLESS KEY STATE = 0; ! ignore if some keys have been specified
KEY POINT = KEY SAVE1
SW1:
T = A . B WHILE T -> A . (":") . B; ! remove colons
T = A . " " . B WHILE T -> A . (",") . B; ! turn commas into spaces
T = A . " " . B WHILE T -> A . (" ") . B; ! multiple spces to single ones
T = A . "," . B WHILE T -> A . (" ") . B; ! turn spaces into commas!
UCTRANSLATE(ADDR(T)+1, LENGTH(T)) UNLESS T = ""
B = T . ","; ! append a comma
T = ""
WHILE B -> A . (",") . B CYCLE
IF A # "" AND ( LENGTH(A) > 2 OR T = "" = B) START
A = A . ","
T = T.A UNLESS OMIT -> (",".A)
FINISH
REPEAT
IF T = "" START {what's this bit for?????}
KEYSTATE = -1
KEYPOINT = KEYSAVE
RETURN
FINISH
MOVE(LENGTH(T), ADDR(T)+1, KEY POINT)
KEY POINT = KEY POINT + LENGTH(T)
RETURN
SW(2):
UCTRANSLATE(ADDR(T)+1, LENGTH(T))
B = T . ","
WHILE B -> A . (",") . B CYCLE
A = JUST(A)
UNLESS A = "" OR A = " " START
A = A . ","
MOVE(LENGTH(A), ADDR(A)+1, KEYPOINT)
KEYPOINT = KEYPOINT + LENGTH(A)
FINISH
REPEAT
END
!
!
!
STRINGFN SHORTEN(INTEGER T0, I, TYPE)
! Type = 0 !<
! 1 title
! 2 subfile
! 3 topic
CONSTSTRING (7)ARRAY S(0:3) = C
"title", "title", "subfile", "topic"
CONSTBYTEINTEGERARRAY JS(0:3) = 3, 8, 4, 8
INTEGER J, K, L, TRUNC
STRING (255)Z
STRINGNAME R
RECORD (BNF)NAME BIGNAME
Z = LINE
J = JS(TYPE)
K = LENGTH(Z)
IF TYPE = 3 C
THEN L = 29 C
ELSE L = WIDTH - 2 - LENGTH(DIR(I)_SEC)
!
J = J + 1 WHILE J < K AND CHARNO(Z, J) = ' '
K = K - 1 WHILE J < K AND CHARNO(Z, K) = ' '
R == STRING(ADDR(Z) + J - 1)
TRUNC = YES
L = K - J AND TRUNC = NO UNLESS K > J + L
LENGTH(R) = L + 1
IF TRUNC = YES C
THEN W(DIR(I)_SEC." Warning: ".S(TYPE)." truncated to ".R)
!
IF TYPE = 3 START
DIR(-1)_SEC = R
FINISH ELSE START
IF LENGTH(R) < 32 C
THEN DIR(I)_NAME = R C
ELSE START
BIGNAME == RECORD(ADDR(DIR(I)_NAME))
BIGNAME_LEN = L + 1
BIGNAME_ADR = T0 + J - 1
FINISH
WRITEKEYS(TYPE, I, R) IF TYPE < 2
FINISH
RESULT = R
END
!
!
!
ROUTINE SCAN FILE(STRING (31)STEM, NAME, INTEGERNAME I, INTEGER BASE)
! Used to determine the structure of a character
! file. 'stem' is the prefix to use, without any
! trailing dots ie
! null, 1, 1.2, 1.2.3 etc
INTEGER LEVEL, IX, S, J, K, T0, T, TXTEOF, I0
STRING (31)ARRAY SECS(-1:15)
INTEGERARRAY PER, F, SUBS(0:15)
STRING (31)SEC
RECORD (FHDRF)NAME H
STRING (255)Z, Z0, NULL
CONSTINTEGER TOP = 10
CONSTSTRING (8)ARRAY WORD(1:TOP) = C
"!TITLE ", "!SKIP", "!KEY ", "!KEY", "!TOPIC ", "!<>", "!<", "!>",
"!ADDKEY ", "!HELP"
SWITCH SW(1:TOP)
H == RECORD(BASE)
T = BASE + H_TXTST - CONBASE
TXTEOF = BASE + H_NFB - CONBASE
F(0) = I
I0 = I
DIR(I)_SEC = STEM
STEM = STEM . "." UNLESS STEM = ""
SECS(-1) = STEM
DIR(I)_NAME = NAME
WRITE KEYS(0, I, NAME)
DIR(I)_P1 = T
DIR(I)_P2 = 0
I = I + 1
RETURN IF I > MAXDIR
DIR(I) = 0
LEVEL = 0
SUBS(0) = 0
PER(0) = 0; ! use first to get max title, then no/line
L1:
T0 = T; ! remember start of line
GETLINE(LINE, T, T, CONBASE, TXTEOF)
IX = F(LEVEL)
!
IF LENGTH(LINE) > 1 AND CHARNO(LINE, 1) = '!' START
CYCLE J = 1, 1, TOP
-> SW(J) IF LINE -> NULL . (WORD(J)) . Z AND NULL = ""
REPEAT
FINISH
-> L1 IF T < TXTEOF
L2:
IX = F(LEVEL)
DIR(IX)_SUBS = SUBS(LEVEL)
J = PER(LEVEL) + 5 + LENGTH(SECS(LEVEL-1))
CYCLE K = 1, 1, TOP PAD
EXIT IF J > PAD(K)
REPEAT
K = DIR(IX)_SUBS IF K > DIR(IX)_SUBS
DIR(IX)_PER = K
DIR(IX)_LINK = I
DIR(IX)_P2 = T IF DIR(IX)_P2 = 0; ! CLOSE PREFACE IF NECESSARY
LEVEL = LEVEL - 1
-> L2 UNLESS LEVEL < 0
RETURN
SW(1): ! TITLE
Z = SHORTEN(T0, IX, 1)
IF LEVEL > 0 START
PER(LEVEL-1) = LENGTH(Z) IF LENGTH(Z) > PER(LEVEL-1)
FINISH
SW1:
DIR(IX)_P1 = T IF DIR(IX)_P1 = T0; ! Adjust start of preface if no text yet
-> L1
SW(2): ! SKIP
DIR(IX)_P1 = -1
DIR(IX)_P2 = -1
-> L1
SW(3): ! KEY word1,word2,...
SW(9): ! ADDKEY word1, word2, ...
IF KEY STATE = 0 START
KEY STATE = 1
KEY POINT = KEY SAVE1 IF J = 3
FINISH
WRITE KEYS(2, I, Z) IF KEY STATE = 1
-> SW1
SW(4): ! KEY
KEY STATE = -1
KEY POINT = KEY SAVE
-> SW1
SW(5): ! TOPIC
Z = SHORTEN(T0, 0, 3) IF F(0) = 0
-> SW1
SW(6): ! <>
S = SUBS(LEVEL) + 1
SUBS(LEVEL) = S
SEC = SECS(LEVEL-1) . ITOS(S)
DIR(I)_SEC = SEC
SECS(LEVEL) = SEC . "."
DIR(IX)_P2 = T0 IF DIR(IX)_P2 <= 0
Z = SHORTEN(T0, I, 2)
PER(LEVEL) = LENGTH(Z) IF LENGTH(Z) > PER(LEVEL)
WHILE Z -> Z . (",") . Z0 CYCLE ; REPEAT
-> IGNORE IF LENGTH(Z) > 31
SEC = Z
-> IGNORE UNLESS SEC = Z
J = DIR(-1)_P1 + 1
K = 1
WHILE K < J CYCLE
-> IGNORE IF SUBFILE(K) = SEC; ! already in
K = K + 1
REPEAT
SUBFILE(J) = SEC
DIR(-1)_P1 = J; ! increment count
IGNORE:
DIR(I)_LINK = I + 1
I = I + 1
RETURN IF I > MAXDIR
-> L1
SW(7): ! < fails if more than 100 subfiles
S = SUBS(LEVEL) + 1; ! also get cap exceeded
SUBS(LEVEL) = S
SEC = SECS(LEVEL-1) . ITOS(S)
DIR(I)_SEC = SEC
SECS(LEVEL) = SEC . "."
DIR(IX)_P2 = T0 IF DIR(IX)_P2 = 0; ! CLOSE PREF
Z = SHORTEN(T0, I, 0)
PER(LEVEL) = LENGTH(Z) IF LENGTH(Z) > PER(LEVEL)
LEVEL = LEVEL + 1
SUBS(LEVEL) = 0
PER(LEVEL) = 0
F(LEVEL) = I
DIR(I)_P1 = T
I = I + 1
RETURN IF I > MAXDIR
DIR(I) = 0
-> L1
SW(8): ! >
DIR(IX)_P2 = T0 IF DIR(IX)_P2 = 0
-> L1 IF I = I0+1; ! just terminate preface part
!
IF LEVEL > 0 START
DIR(IX)_SUBS = SUBS(LEVEL)
J = PER(LEVEL) + 5 + LENGTH(SECS(LEVEL-1))
CYCLE K = 1, 1, TOP PAD
EXIT IF J > PAD(K)
REPEAT
K = DIR(IX)_SUBS IF K > DIR(IX)_SUBS
DIR(IX)_PER = K
DIR(IX)_LINK = I
LEVEL = LEVEL - 1
FINISH
-> L1
SW(10): ! HELP
DIR(-1)_P2 = I - 1
-> L1
END ; ! SCAN FILE
!
!
!
ROUTINE DO DIR(INTEGER BASE, STRING (31)STEM, NAME)
! Given a PD file NAME starting
! at BASE, constructs a VIEW
! directory for it in DIR(I)
! onwards
INTEGER IM, MEMS, I0, M, T0, T, TXTEOF, L
RECORD (FHDRF)NAME H, MH
RECORD (MEMF)ARRAYFORMAT MEMAF(0:2047)
RECORD (MEMF)ARRAYNAME MEM
STRING (11)MNAME
STRING (255)Z, NULL
INTEGER P,Q,R,S,N,XW
INTEGERARRAY X(0:2047)
H == RECORD(BASE)
MEM == ARRAY(BASE + H_ADR, MEMAF)
DIR(I)_SEC = STEM
STEM = STEM . "." UNLESS STEM = ""
DIR(I)_NAME = NAME; ! name of file
IM = 0
MEMS = 0
DIR(I)_SUBS = 0
DIR(I)_LINK = -1
DIR(I)_P1 = 1
DIR(I)_P2 = 0
DIR(I)_PER = 0
I0 = I
I = I + 1
RETURN IF I > MAXDIR
DIR(I) = 0
!
!
!
N = H_COUNT
RETURN IF N < 1
!
CYCLE S = 0, 1, N-1; X(S) = S; REPEAT ; ! sort member names into alpha order
!
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
EXIT IF MEM(X(R-1))_NAME <= MEM(X(Q-1))_NAME
XW = X(Q-1)
X(Q-1) = X(R-1)
X(R-1) = XW
R = R - S
REPEAT
REPEAT
REPEAT
!
Q = -1; ! Its convenient to have the 'preface' member, if any,
! first so that its keys, if any, come first in VIEWKEYS
CYCLE P = 0, 1, N-1
Q = P AND EXIT IF MEM(X(P))_NAME = "PREFACE"
REPEAT
!
IF Q > 0 START ; ! there is a preface and its not the first member
XW = X(Q)
CYCLE P = Q-1, -1, 0; ! make it the first
X(P+1) = X(P)
REPEAT
X(0) = XW
FINISH
!
CYCLE P = 0, 1, N - 1; ! process each member
M = X(P)
MNAME = MEM(M)_NAME
MH == RECORD(BASE + MEM(M)_START)
!
IF MH_TYPE = 6 START ; ! another PD file
DIR(IM)_LINK = I IF IM > 0
IM = I
MEMS = MEMS + 1
DODIR(ADDR(MH), STEM . ITOS(MEMS), MNAME)
RETURN IF I > MAXDIR
IF LENGTH(DIR(IM)_NAME) > DIR(I0)_PER C
THEN DIR(I0)_PER = LENGTH(DIR(IM)_NAME)
FINISH ELSE START
IF MH_TYPE = 3 START
IF MNAME = "PREFACE" START
T = ADDR(MH)+MH_TXTST-CONBASE
DIR(I0)_P1 = T
WRITE KEYS(0, I0, NAME)
TXTEOF = ADDR(MH)+MH_NFB-CONBASE
DIR(I0)_P2 = TXTEOF; ! -1 ?
LOOP:
CONTINUE UNLESS T < TXTEOF
T0 = T
GETLINE(LINE, T, T, CONBASE, TXTEOF)
!
L = LENGTH(LINE)
L = L - 1 IF L > 0 AND CHARNO(LINE, L) = ' '
-> LOOP IF L < 4
!
IF LINE -> NULL . ("!TITLE ") . Z AND NULL = "" START
Z = SHORTEN(T0, I0, 1)
-> L
FINISH
IF LINE -> NULL . ("!TOPIC ") . Z AND NULL = "" START
Z = SHORTEN(T0, 0, 3) IF I0 = 0
-> L
FINISH
IF LINE = "!KEY" START
KEY STATE = -1
KEY POINT = KEY SAVE
-> L
FINISH
IF LINE -> NULL . ("!KEY ") . Z AND NULL = "" START
IF KEY STATE = 0 START
KEY STATE = 1
KEY POINT = KEY SAVE1
FINISH
WRITEKEYS(2, I0, Z) IF KEY STATE = 1
-> L
FINISH
!
IF LINE -> NULL . ("!ADDKEY ") . Z AND NULL = "" START
KEY STATE = 1 IF KEY STATE = 0
WRITE KEYS(2, I0, Z) IF KEY STATE = 1
L:
DIR(I0)_P1 = T IF DIR(I0)_P1 = T0; ! adjust start of preface if no text yet
-> LOOP
FINISH
!
IF LINE = "!SKIP" START
DIR(I0)_P1 = -1
DIR(I0)_P2 = -1
CONTINUE
FINISH
-> LOOP
FINISH ELSE START
DIR(IM)_LINK = I IF IM > 0
IM = I
MEMS = MEMS + 1
SCAN FILE(STEM.ITOS(MEMS), MNAME, I, ADDR(MH))
RETURN IF I > MAXDIR
IF LENGTH(DIR(IM)_NAME) > DIR(I0)_PER C
THEN DIR(I0)_PER = LENGTH(DIR(IM)_NAME)
FINISH
FINISH
FINISH
REPEAT
DIR(I0)_SUBS = MEMS
P = DIR(I0)_PER + 5 + LENGTH(STEM)
CYCLE Q = 1, 1, TOP PAD
EXIT IF P > PAD(Q)
REPEAT
Q = MEMS IF Q > MEMS
DIR(I0)_PER = Q
DIR(I0)_LINK = I
END ; ! DODIR
!
!
STRINGFN PICKUP(INTEGER BASE)
INTEGER ADR, LEN, J, K, CH
STRING (255)WK, FILE, SEC, TITLE, TOPIC
RECORD (REFF)ARRAYFORMAT REFAF(1:KKTOPREF)
RECORD (REFF)ARRAYNAME REF
REF == ARRAY(KKREFADDR, REFAF)
ADR = BASE + 32
LEN = INTEGER(BASE) - 32
!
CYCLE
J = KWDSCAN(LEN, ADR, KKTOPKEY, KKEY)
EXIT IF J = 0
KKREFI = KKREFI + 1
UNLESS KKREFI > KKTOPREF START
K = 0
CYCLE
CH = BYTEINTEGER(J)
EXIT IF CH = ':'
J = J + 1
K = K + 1
CHARNO(WK, K) = CH
REPEAT
LENGTH(WK) = K
WK -> FILE.("¬").SEC.("¬").TITLE.("¬").TOPIC
REF(KKREFI)_NAME <- TITLE
REF(KKREFI)_TOPIC <- TOPIC
REF(KKREFI)_FILE <- FILE
REF(KKREFI)_SEC <- SEC
FINISH
REPEAT
RESULT = ""
END ; ! PICKUP
!
!-----------------------------------------------------------------------
!
MSG = ""
UNLESS FILE -> USER . (".") . FULLFILE C
THEN USER = PROCUSER AND FULLFILE = FILE; ! FULL is something like USER.FRED
! while FULLFILE is USER.FRED_JIM_JOE
!
DFILE = FULLFILE . "_"
DFILE -> DFILE . ("_") . R
!
FULL <- USER . "." . DFILE
FULLFILE = USER . "." . FULLFILE
!
IF LENGTH(USER) > 6 OR LENGTH(DFILE) > 11 START
MSG = FULLFILE . " is an invalid file name"
RESULT = 1
FINISH
!
FTINDEX = 1
CYCLE
FT == FTS(FTINDEX)
RESULT = 0 IF FT_FILE = FULLFILE
-> CONNECT IF FT_FILE = ""
FTINDEX = FTINDEX + 1
EXIT IF FTINDEX > TOPFT
REPEAT
!
MSG = "Too many files for VIEW"
RESULT = 1
CONNECT:
FT_PROMPT = "View: "
FT_FILE = FULLFILE
VDIR = "T#VDIR" . ITOS(FTINDEX)
VKEY = "T#VKEY" . ITOS(FTINDEX)
!
CONNECT(FULL, 0,0,0,CONR,CONRES); ! connect outermost file
FT_CONRES = CONRES
UNLESS CONRES = 0 START
MSG = FAILURE MESSAGE(CONRES)
-> OUT
FINISH
BASE = CONR_ADR
!
IF DFILE = "T#KEYWRK" START ; ! UGH
MSG = PICKUP(BASE)
-> OUT
FINISH
!
FT_CONBASE = BASE - X'40000'
H == RECORD(BASE)
FT_TIMESTAMP = H_TIMESTAMP
CONBASE = BASE - X'40000'
MNAME = DFILE
CYCLE ; ! unwind down to required member
TXT == RECORD(BASE)
EXIT IF LENGTH(R) = 0
UNLESS TXT_TYPE = 6 START ; ! PD FILE
MSG = MNAME . " not a PD file"
-> OUT
FINISH
MEM == ARRAY(BASE + TXT_ADR, MEMAF)
UNLESS R -> MNAME . ("_") . R START
!
MSG = R
LENGTH(MSG) = LENGTH(MSG) - 1
MSG = MSG ." is not a valid name"
-> OUT
FINISH
BASE = FIND(MNAME)
IF BASE = 0 START
MSG = "Member ".MNAME." does not exist"
-> OUT
FINISH
REPEAT
!
CONBASE = BASE - X'40000'
UNLESS TXT_TYPE = 6 OR TXT_TYPE = 3 START ; ! PD
MSG = MNAME." is not a PD or a character file"
-> OUT
FINISH
!
IF TXT_TYPE = 3 AND TXT_COUNT = 2 START ; ! appears to have directories
DIRA = BASE + 96
KEYA = DIRA + INTEGER(DIRA)
CONBASE = BASE + INTEGER(BASE + 4) - X'40000' - TXT_CHKSUM
-> SETUPDONE
FINISH
!
IF TXT_TXTST >= TXT_NFB ORC
(TXT_TYPE = 6 AND TXT_COUNT < 1) START
MSG = "File ".MNAME." empty"
-> OUT
FINISH
!
I = 0
MSG = ""
IF TXT_TYPE = 6 START ; ! PDFILE
KEYSTATE = 0; ! no VIEWKEY member encountered
MEM == ARRAY(BASE+TXT_ADR, MEMAF)
CYCLE M = 0, 1, TXT_COUNT - 1
!
IF MEM(M)_NAME = VIEWKEY START
KEYSTATE = 1
KEYA = BASE + MEM(M)_START
FINISH
!
IF MEM(M)_NAME = VIEWDIR START
DIRA = BASE + MEM(M)_START
DIR == ARRAY(DIRA + 32, DIRAF)
!
H == RECORD(DIRA)
CONBASE = BASE - X'40000'
FT_TIMESTAMP = H_TIMESTAMP
-> SET UP DONE IF DIFF(TXT_TIMESTAMP, H_TIMESTAMP) < 5
!
CONRES = 1; ! to avoid the DISCONNECT
MODPDFILE(2, FULLFILE, VIEWKEY, "", J)
UNLESS J = 0 START
MSG = "Cannot delete " . VIEWKEY . " in " . FULLFILE
-> OUT
FINISH
MODPDFILE(2, FULLFILE, VIEWDIR, "", J)
IF J = 0 START
W("Out of date " . VIEWDIR ." deleted OK")
-> CONNECT
FINISH
W(VIEWDIR . " in " . FULLFILE . " out of date")
-> OUT
FINISH
REPEAT
IF KEYSTATE = 1 START
CONRES = 1
MODPDFILE(2, FULLFILE, VIEWKEY, "", J)
UNLESS J = 0 START
W("Cannot delete " . VIEWKEY . " in " . FULLFILE)
-> OUT
FINISH
-> CONNECT
FINISH
UNLESS USER = PROCUSER START ; ! ******************* AND SEND A MESSAGE **********
MSG = "There is no " . VIEWDIR . " in " . FULLFILE
-> OUT
FINISH
MSG = DIRFILE; ! create temporary files
-> OUT UNLESS MSG = ""
DODIR(BASE, "", FULL FILE)
-> TOO BIG IF I > MAXDIR
J = DIR(-1)_P1; ! number of sub_files
INTEGER(DIRA) = 32 + 80 * (I+1) + 32*J; ! 80 IS SIZE OF DIR RECORD
IF J > 0 START
IMAX = DIR(0)_LINK
K = ADDR(DIR(IMAX))
CYCLE I = 1, 1, J
STRING(K) = SUBFILE(I)
K = K + 32
REPEAT
FINISH
BYTEINTEGER(KEYPOINT) = NL
INTEGER(KEYA) = KEY POINT - KEYA + 1
CONRES = 1
MODPDFILE(1, FULL FILE, VIEWKEY, VKEY, J)
DESTROY(VKEY, K)
CONNECT(VDIR, 3, 0, 0, CONR, J); ! CONNECT IN WRITE MODE
! TO GET TIMESTAMP AS RECENT AS POSS
UNLESS J = 0 START
MSG = FAILURE MESSAGE(J)
-> OUT
FINISH
MOD PD FILE(1, FULL FILE, VIEWDIR, VDIR, J)
DESTROY(VDIR, K)
IF J = 0 START
W("New " . VIEWDIR . " inserted")
-> CONNECT
FINISH
MSG = FAILURE MESSAGE(J)
-> OUT
FINISH
!
! Do character file
!
MSG = DIRFILE
-> OUT UNLESS MSG = ""
SCAN FILE("", FULLFILE, I, BASE)
-> TOO BIG IF I > MAXDIR
BYTEINTEGER(KEYPOINT) = NL
INTEGER(KEYA) = KEY POINT - KEYA + 1
! { go to SET UP DONE if can't insert directories? }
J = DIR(-1)_P1
INTEGER(DIRA) = 32 + 80*(I+1) + 32*J
IF J > 0 START
IMAX = DIR(0)_LINK
K = ADDR(DIR(IMAX))
CYCLE I = 1, 1, J
STRING(K) = SUBFILE(I)
K = K + 32
REPEAT
FINISH
!
DL = INTEGER(DIRA); ! size of VIEWDIR
KL = INTEGER(KEYA)
CL = TXT_NFB - TXT_TXTST
HL = (32 + 64 + DL + KL + 31) & (-32)
SIZE = HL + CL
OUTFILE(OUTPUT FILE, SIZE, 0, 0, ADR, J)
UNLESS J = 0 START
MSG = FAILUREMESSAGE(J)
-> OUT
FINISH
!
H == RECORD(ADR)
H_NFB = SIZE
H_TXTST = HL
H_TYPE = 3
H_CHKSUM = TXT_TXTST
H_ADR = 32
H_COUNT = 2
A = ADR + 32
MH == RECORD(A)
MH = 0
MH_START = 96
MH_NAME = VIEWDIR
A = A + 32
MH == RECORD(A)
MH = 0
MH_START = 96 + DL
MH_NAME = VIEWKEY
!
A = A + 32
MOVE(DL, DIRA, A)
!
A = A + DL
MOVE(KL, KEYA, A)
!
A = ADR + HL
MOVE(CL, BASE+TXT_TXTST, A)
!
IF FULL = FULL FILE C
THEN NEWGEN(OUTPUT FILE, FULL, J) C
ELSE START
ZCOPY2(OUTPUT FILE . "," . FULL FILE . "/W", 0, J)
J = 219 IF J = -7 OR J = -10
FINISH
DESTROY(VKEY, K)
DESTROY(VDIR, K)
!
UNLESS J = 0 START
MSG = FAILUREMESSAGE(J)
-> OUT
FINISH
!
LINE = FULLFILE . "_"
LINE -> LINE . ("_") . R; ! to reconstruct 'R'
!
-> CONNECT
SET UP DONE:
FT_CONBASE = CONBASE
FT_DIRA = DIRA
FT_KEYA = KEYA
RESULT = 0
OUT:
FT_FILE = ""
RESULT = 1
TOO BIG:
FT_FILE = ""
RESULT = 2
LIST
END ; ! VCONNECT
!
!
!
INTEGERFN CHECKWORD(STRING (255)LINE, STRING (255)LOOKFOR,
STRINGNAME REST)
! Looks for lines starting with words given in LOOKFOR which
! should have the form: !WORD1&!WORD2& etc
INTEGER J
STRING (255)NULL, WORD
J = 0
WHILE LOOKFOR -> WORD . ("&") . LOOKFOR CYCLE
J = J + 1
RESULT = J IF LINE -> NULL . (WORD) . REST AND NULL = ""
REPEAT
RESULT = 0
END ; ! CHECKWORD
!
!
!
CONSTINTEGER TOPLVI = 10
CONSTINTEGER TOPLVS = 4
CONSTINTEGER TOPLV = TOPLVI + TOPLVS
!
OWNINTEGERARRAY LAYI(1 : TOPLVI)
OWNSTRING (63)ARRAY LAYS(1 : TOPLVS)
!
CONSTBYTEINTEGERARRAY LAYI DEF(1 : TOPLVI) = C
54, 1, 2, 3, 0, 0, 72, 0, 0, 0
CONSTSTRING (15)ARRAY LAYS DEF(1 : TOPLVS) = C
"C",
"C",
"ADF",
"ADF"
!
OWNINTEGER LAYLINES
OWNINTEGER UNDERLINE
!
!
! LAYI1 = PAGE(54)
! LAYI2 = PAGENO(1)
! LAYI3 = TOP(2)
! LAYI4 = BOTTOM(3)
! LAYI5
! LAYI6 = LEVEL(0)
! LAYI7 = WIDTH(72)
! LAYI8
! LAYI9
! LAYI10
!
! LAYS1 = TEVEN (NL)
! LAYS2 = TODD (NL)
! LAYS3 = BEVEN (HALF.MID.PAGENO)
! LAYS4 = BODD (HALF.MID.PAGENO)
!
! A = HALF D = MID
! B = LAST E = RHM
! C = NL F = PAGENO
! G = string
!
!-----------------------------------------------------------------------
!
INTEGERFN QUOTATION(STRING (63)FROM, INTEGERNAME Q0, Q1, QL, C
INTEGER DIRA, CONBASE)
! Examines the section whose number is in FROM and returns
! the text pointers in Q0 and Q1
! the number of lines in QL
INTEGER I, J, N
STRING (63)W
RECORD (DIRF)ARRAYNAME DIR
DIR == ARRAY(DIRA+32, DIRAF)
I = 0
FROM = FROM . "."
WHILE FROM -> W . (".") . FROM CYCLE
J = STOI2(W, N)
I = I + 1
I = DIR(I)_LINK AND N = N - 1 WHILE N > 1
REPEAT
Q0 = DIR(I)_P1 + CONBASE
Q1 = DIR(I)_P2 + CONBASE
J = Q0
QL = 0
WHILE J < Q1 CYCLE
QL = QL + 1 IF BYTEINTEGER(J) = NL
J = J + 1
REPEAT
RESULT = 0
END
!
!
!
!
!
!
STRINGFN VSTRING(INTEGER N)
CONSTINTEGER TOP = 7
SWITCH L(1:TOP)
-> L(N) IF 1 <= N <= TOP
!
IF 100 <= N <= TOP PARAMETER START
RESULT = PARAMETER(N) UNLESS PARAMETER USED(N) = 0
FINISH
!
RESULT = "{" . ITOS(N) . "}"
!
L(1): RESULT = DATE
L(2): RESULT = TIME
L(3): RESULT = PROCUSER; ! user number
L(4): RESULT = UINFS(2); ! delivery information
L(5): RESULT = UINFS(7); ! surname
L(6): RESULT = UINFS(10); ! OCP
L(7): RESULT = VDUS(0); ! terminal type
END ; ! VSTRING
!
!
!
ROUTINE UNCURL(STRING (255)LINE, INTEGERNAME L, INTEGER TYPE)
!
! REMOVES CURLY BRACKETS
! a line count is maintained in L
! TYPE is set as follows:
! 0 on line, dont print but do count lines
! 1 on line, print and count
! 2 X<----->
! 3 F<----->
INTEGER J, N, K, I, FOUND, PAD
INTEGER DP15, ORD, CNTRL
STRING (255)R, X, Y, Z, A, B, C
CONSTSTRING (6)ARRAY LAYOUTVAR(1 : TOPLV) = C
"PAGE", "PAGENO", "TOP", "BOTTOM", "LEFT",
"LEVEL", "WIDTH", "X", "Y", "Z",
"TEVEN", "TODD", "BEVEN", "BODD"
!
CONSTSTRING (5)ARRAY FONT(0 : 17) = C
"[2;2x", "[2;1x", "[2;4x",
"[5;2x", "[5;1x", "[5;4x",
"[6;2x", "[6;1x", "[6;4x",
"[4;2x", "[4;1x", "[4;3x",
"[3;2x", "[3;1x", "[3;4x",
"[1;2x", "[1;1x", "[1;3x"
!
!
!
!
!
STRINGFN CLEAN(STRINGNAME S)
INTEGER C, J, K
J = 0
K = 0
WHILE J < LENGTH(S) CYCLE
J = J + 1
C = CHARNO(S, J)
UNLESS C = ' ' START
C = C - 32 IF 'a' <= C <= 'z'
K = K + 1
CHARNO(S, K) = C
FINISH
REPEAT
LENGTH(S) = K
RESULT = S
END
!
!
!
DP15 = 0
IF TYPE = 3 ANDC
EFFING FILE -> X . (".DP") AND X = "" C
THEN DP15 = 1
ORD = 0
CNTRL = 0
R = ""
ORD = 1 AND -> PRINT IF LINE = ""
!
WHILE LINE # "" CYCLE
IF LINE -> X . ("{") . Y . ("}") . LINE START
R = R . X AND ORD = 1 UNLESS X = ""
!
IF Y = "" START
R = R . "{}"
ORD = 1
CONTINUE
FINISH
!
IF CHARNO(Y, 1) = '{' START
R = R . Y . "}"
ORD = 1
CONTINUE
FINISH
!
IF STOI2(Y, N) = 0 START
R = R . VSTRING(N)
ORD = 1
CONTINUE
FINISH
!
IF Y = "_" START
IF DP15 = 1 START
UNDERLINE = 1 - UNDERLINE
R = R . TOSTRING(27)
R = R . TOSTRING(91)
R = R . TOSTRING(52) IF UNDERLINE = 1
R = R . TOSTRING(109)
CNTRL = 1
FINISH
CONTINUE
FINISH
!
IF CHARNO(Y, 1) = '!' START ; ! special directive **********
CONTINUE UNLESS TYPE = 3; ! relevant only to F<...>
Y -> ("!") . Y
Y -> (" ") . Y WHILE Y # "" AND CHARNO(Y, 1) = ' '
J = CHARNO(Y, 1); ! first non-blank character
K = J & (-33); ! convert to upper case
Y -> (TOSTRING(J)) . Y
!
IF K = 'N' START { !N }
LAYNEWPAGE IF LAYLINES > 0
RETURN
FINISH
!
IF K = 'A' START ; ! assign { !A }
CYCLE
X = Y AND Y = "" UNLESS Y -> X . (";") . Y
C = ""
C = C . CLEAN(A) . "'" . B . "'" WHILEC
X -> A . ("'") . B . ("'") . X
C = C . CLEAN(X)
!
IF C -> X . ("=") . Z START ; ! plausible
FOUND = 0
CYCLE I = 1, 1, TOPLV
FOUND = 1 AND EXIT IF X = LAYOUTVAR(I)
REPEAT
IF I > TOPLVI START ; ! codify 'page-turn' parameter
!
A = ""
CYCLE
B = Z AND Z = "" UNLESS Z -> B . (".") . Z
EXIT IF B = ""
C = ""
C = "A" IF B = "HALF"
C = "B" IF B = "LAST"
C = "C" IF B = "NL"
C = "D" IF B = "MID"
C = "E" IF B = "RHM"
C = "F" IF B = "PAGENO"
IF CHARNO(B, 1) = '''' = CHARNO(B, LENGTH(B)) START
CHARNO(B, 1) = 'G'
CHARNO(B, LENGTH(B)) = 0
C = B
FINISH
C = LAYS(1) IF B = "TEVEN"
C = LAYS(2) IF B = "TODD"
C = LAYS(3) IF B = "BEVEN"
C = LAYS(4) IF B = "BODD"
A = A . C UNLESS C = ""
REPEAT
!
LAYS(I - TOPLVI) = A UNLESS A = ""
FINISH ELSE START
J = STOI2(Z, N)
IF J = 0 START
N = 1 << 30 IF I=1 AND N=0
LAYI(I) = N
FINISH
FINISH
FINISH
EXIT IF Y = ""
REPEAT
RETURN
FINISH
!
IF K = 'F' START { !Fn }
J = STOI2(Y, N)
IF DP15 = 1 AND J=0 AND 0<=N<=17 START
R = R . TOSTRING(27) . FONT(N)
CNTRL = 1
FINISH
CONTINUE
FINISH
!
! %IF K = 'V' %START; ! set vertical spacing (default is 6)
! J = STOI2(Y, N)
! %IF DP15 = 1 %AND J = 0 %AND (X'7A880000'<<N) < 0 %START
! R = R.TOSTRING(27)."[".Y . "{"
! CNTRL = 1
! %FINISH
! %CONTINUE
! %FINISH
!
R = R . "{!" . TOSTRING(J) . Y . "}"
CONTINUE
FINISH ; ! ***************
R = R . "{" . Y . "}"
ORD = 1
FINISH ELSE START
R = R . LINE
ORD = 1
EXIT
FINISH
REPEAT
RETURN IF ORD = 0 = CNTRL
PRINT:
IF TYPE > 0 START ; ! print required
IF TYPE = 3 START
PAD = LAYI(5)
N = 0
J = 0
WHILE J < LENGTH(R) CYCLE
J = J + 1
SPACES(PAD) IF N = 0
K = CHARNO(R, J)
PRINTCH(K)
N = 1
N = 0 IF K = 13; ! a CR
REPEAT
NEWLINE IF ORD = 1
FINISH ELSE W(R)
FINISH
L = L + 1
END ; ! OF UNCURL
!
!
!
ROUTINE LAYGETLINE(STRINGNAME LINE, INTEGERNAME T0, T1, INTEGER BASE, EOF)
INTEGER L, CH, T
L = 0
LENGTH(LINE) = 255
T = T0
LOOP:
CH = BYTEINTEGER(T + BASE)
T = T + 1
UNLESS CH = NL START
IF L < 255 START
L = L + 1
CHARNO(LINE, L) = CH
FINISH
-> LOOP UNLESS T >= EOF
FINISH
!
LENGTH(LINE) = L
T1 = T
END ; ! LAYGETLINE
!
!
!
!
!
!-----------------------------------------------------------------------
!
!
ROUTINE LAYNEWPAGE
ROUTINE PAGE TURN(INTEGER PLACE)
! PLACE = 0 TOP
! 1 BOTTOM
INTEGER C, MAXC, L, MAXL, MID, RHM, J, PARITY, PAGENO, K
STRING (63)S, PIECE
STRING (127)TEXT
SWITCH SW('A':'G')
!
!
!
ROUTINE CLEAR LINE
C = -1
MID = 0
RHM = 0
END
!
!
!
ROUTINE PRINT TEXT
INTEGER J
UNLESS TEXT = "" START
IF C < 0 START
J = LAYI(5); ! LEFT
SPACES(J) IF J > 0
C = 0
FINISH
!
IF RHM > 0 START ; ! text to go at RHS
J = MAXC - C - LENGTH(TEXT)
IF J > 0 START
SPACES(J)
FINISH
FINISH
!
IF MID > 0 START ; ! text to go in centre of line
J = ((MAXC - LENGTH(TEXT)) >> 1) - C
IF J > 0 START
SPACES(J)
C = C + J
FINISH
FINISH
!
PRINTSTRING(TEXT)
C = C + LENGTH(TEXT)
TEXT = ""
FINISH
END ; ! PRINT TEXT
!
!
!
PAGENO = LAYI(2)
PARITY = PAGENO & 1; ! obtained from pageno
S = LAYS(1 + PLACE << 1 + PARITY)
MAXC = LAYI(7)
MAXL = LAYI(3 + PLACE)
L = 0
CLEAR LINE
TEXT = ""
!
WHILE S # "" CYCLE
K = CHARNO(S, 1)
S -> (TOSTRING(K)) . S
-> SW(K)
SW('A'): ! HALF
PRINT TEXT
J = MAXL >> 1
NEWLINE AND L = L + 1 WHILE L < J
CLEARLINE
CONTINUE
SW('B'): ! LAST
PRINT TEXT
NEWLINE AND L = L + 1 WHILE L < MAXL - 1
CLEARLINE
CONTINUE
SW('C'): ! NL
PRINT TEXT
NEWLINE
L = L + 1
RETURN IF L >= MAXL
CLEARLINE
CONTINUE
SW('D'): ! MID
IF MID = 0 START
PRINT TEXT
MID = 1
FINISH
CONTINUE
SW('E'): ! RHM
IF RHM = 0 START
PRINT TEXT
RHM = 1
MID = -1; ! inhibit
FINISH
CONTINUE
SW('F'): ! PAGENO
IF PAGENO > 0 START
TEXT = TEXT . ITOS(PAGENO)
FINISH
CONTINUE
SW('G'): ! text
S -> PIECE . (TOSTRING(0)) . S
TEXT = TEXT . PIECE
CONTINUE
REPEAT
!
PRINT TEXT
J = MAXL - L
NEWLINES(J) IF J > 0
END ; ! PAGE TURN
!
!-----------------------------------------------------------------------
!
RETURN IF LAYI(1) = 1 << 30
IF LAYLINES > 0 START ; ! initialised to -1
NEWLINES(LAYI(1) - LAYLINES) IF LAYI(1) > LAYLINES; ! page
PAGE TURN(1)
LAYI(2) = LAYI(2) + 1 IF LAYI(2) > 0; ! pageno
FINISH
!
NEWPAGE
!
PAGE TURN(0)
LAYLINES = 0
END ; ! LAYNEWPAGE
!
!-----------------------------------------------------------------------
!
ROUTINE LAYLINE(STRING (255)S)
LAYNEWPAGE IF LAYLINES >= LAYI(1); ! page
!
SPACES(LAYI(5)) IF LAYI(5) > 0; ! left
!
PRINTSTRING(S)
NEWLINE
LAYLINES = LAYLINES + 1
END ; ! LAYLINE
!
!-----------------------------------------------------------------------
!
ROUTINE F1SUPPORT(INTEGER DIRA, CONBASE, BASEI)
INTEGER FIRST I
STRING (255)LINE
STRING (31)BSEC
RECORD (DIRF)ARRAYNAME DIR
CONSTINTEGER TOP PNO = 31
INTEGERARRAY PNO(0 : TOP PNO)
!
!
!
ROUTINE LAYHEADING(INTEGER I, DOTS)
INTEGER P, L, S, J
STRING (80)W, A
J = DIR(I)_P1
!
IF J > 0 START ; ! real section - ie not a subsid file
IF LAYI(1) = 1 << 30 START ; ! no 'page turns'
NEWLINES(2) IF LAYLINES >= 0
FINISH ELSE START
IF LAYLINES < 0 ORC
(DOTS < LAYI(6) AND LAYLINES > 0) ORC
LAYLINES + 6 > LAYI(1) C
THEN LAYNEWPAGE C
ELSE START
NEWLINES(2)
LAYLINES = LAYLINES + 2
FINISH
FINISH
FINISH
!
IF I > FIRST I AND LAYI(2) > 0 AND LAYI(1) # 1 << 30 START ; ! put PAGENO into earlier contents
! list if pagenos on
P = PNO(DOTS); ! pointer to relevant entry
UNLESS P = 0 START
PNO(DOTS) = INTEGER(P)
W = ITOS(LAYI(2)); ! pageno
W = " " . W WHILE LENGTH(W) < 4
W = " *" UNLESS J > 0
MOVE(4, ADDR(W) + 1, P)
FINISH
FINISH
!
RETURN UNLESS J > 0
!
W = ""
W = "*" IF DIR(I)_P1 = 0
W <- W . DIR(I)_SEC . " " . GETNAME(I, DIRA, CONBASE)
W -> (" ") . W WHILE CHARNO(W, 1) = ' '
L = LENGTH(W)
S = 0
S = (LAYI(7) - L) >> 1 IF LAYI(7) > L AND DOTS < LAYI(6)
SPACES(S) UNLESS S = 0
LAYLINE(W)
A = ""
A = A . "-" WHILE LENGTH(A) < L
SPACES(S) UNLESS S = 0
LAYLINE(A)
NEWLINE; LAYLINES = LAYLINES + 1
END ; ! LAYHEADING
!
!-----------------------------------------------------------------------
!
ROUTINE LAYCONTENTS(INTEGER I, DOTS)
INTEGER COUNT, PER, SUBS, L, J, P, IW
INTEGERNAME CUR
STRING (255)SEC, Z
RECORD (FDF)NAME FD
BYTEINTEGERARRAY PAD(1 : 3)
J = LAYI(7) {width}
PAD(1) = (J) & (-4)
PAD(2) = ((J - 4) // 2) & (-4)
PAD(3) = ((J - 8) // 3) & (-4)
!
SEC = DIR(I)_SEC
SUBS = DIR(I)_SUBS; ! how many there are
!
L = 0; ! max title size encountered
IW = I + 1
J = 1
WHILE J <= SUBS CYCLE
Z <- GETNAME(IW, DIRA, CONBASE)
L = LENGTH(Z) IF LENGTH(Z) > L
IW = DIR(IW)_LINK
J = J + 1
REPEAT
!
L = L + 8; ! format of line is sp [sec.] ddd L dddd
L = L + LENGTH(SEC) + 1 UNLESS SEC = ""
!
PER = 3
PER = 2 IF L > PAD(3)
PER = 1 IF L > PAD(2)
!
L = (SUBS + PER - 1) // PER + 4; ! total number of lines reqd
IF LAYLINES + 4 > LAYI(1) ORC
(LAYLINES + L > LAYI(1) AND L < LAYI(1)) C
THEN LAYNEWPAGE C
ELSE START
IF LAYLINES > 0 START
NEWLINES(2)
LAYLINES = LAYLINES + 2
FINISH
FINISH
!
L = PAD(PER) - 4
LAYLINE("Contents")
CYCLE J = 1, 1, PER
EXIT IF J > SUBS
IF LAYI(1) # 1 << 30 AND LAYI(2) > 0 START
SPACES(L)
PRINTSTRING("Page")
SPACES(4) IF J < PER
FINISH
REPEAT
NEWLINE; LAYLINES = LAYLINES + 1
!
P = ADDR(PNO(DOTS)); ! relevant list head
FD == RECORD(FDMAP(61))
CUR == FD_CUR
PRINTCH(13) WHILE CUR & 3 # 0; ! get alignment right
I = I + 1
COUNT = 0; ! number of things on line
J = 1
WHILE J <= SUBS CYCLE
Z = " "
Z = "*" IF DIR(I)_P1 = 0
Z = Z . SEC . "." UNLESS SEC = ""
Z = Z . ITOS(J)
Z = Z . " " IF J < 100
Z = Z . " " IF J < 10
Z <- Z . GETNAME(I, DIRA, CONBASE)
LENGTH(Z) = L IF LENGTH(Z) > L
Z = Z . " " WHILE LENGTH(Z) < L
!
SPACES(4) IF COUNT > 0
PRINTSTRING(Z)
!
IF LAYI(1) # 1 << 30 AND LAYI(2) > 0 START
PRINTSTRING(" ")
INTEGER(P) = CUR - 4
P = INTEGER(P)
FINISH
!
COUNT = COUNT + 1
IF COUNT = PER START
COUNT = 0
LAYLINE("")
PRINTCH(13) WHILE CUR & 3 # 0; ! because we may have page-turned
FINISH
!
J = J + 1
I = DIR(I)_LINK
REPEAT
!
LAYLINE("") UNLESS COUNT = 0
END ; ! LAYCONTENTS
!
!-----------------------------------------------------------------------
!
ROUTINE LAYITEM(INTEGER I); ! called recursively
INTEGER NI, J, Q0, Q1, QL, T, TXTEOF, DOTS
STRING (31)WQ0, WQ1, WQL
STRING (80)W, A
STRING (255)NULL, REST
DOTS = 0
W = DIR(I)_SEC
DOTS = DOTS + 1 WHILE W -> A . (".") . W
!
LAYHEADING(I, DOTS)
NI = DIR(I)_SUBS; ! number of items
T = DIR(I)_P1
TXTEOF = DIR(I)_P2
DOTS = DOTS + 1
DOTS = 0 IF I = 0
PNO(DOTS) = 0; ! because !STOP prevents LAYCONTENTS being called
!
RETURN UNLESS T > 0
!
WHILE T < TXTEOF CYCLE ; ! preface part
LAYGETLINE(LINE, T, T, CONBASE, TXTEOF)
-> STOP IF LINE -> NULL . ("!STOP") . REST AND NULL = ""
-> L1 IF CHECKWORD(LINE,
"!PAGE&!PROMPT&!MAIL&!TITLE&!TOPIC&!KEY&!ADDKEY&!HELP&", REST) > 0
!
IF LINE -> NULL . ("!QUOTE ") . REST AND NULL = "" START
J = QUOTATION(REST, Q0, Q1, QL, DIRA, CONBASE)
-> Q
FINISH
!
IF LINE -> NULL . ("!XQUOTE ") . WQ0 . (",") . WQ1 . (",") . WQL AND NULL = "" START
J = STOI2(WQ0, Q0)
J = STOI2(WQ1, Q1)
J = STOI2(WQL, QL)
Q:
LAYNEWPAGE IF QL < LAYI(1) < LAYLINES + QL
LAYLINES = LAYLINES + QL
!
WHILE Q0 < Q1 CYCLE
PRINTSYMBOL(BYTEINTEGER(Q0))
Q0 = Q0 + 1
REPEAT
-> L1
FINISH
!
LINE -> ("!") . LINE IF LINE # "" AND CHARNO(LINE, 1) = '!'
UNCURL(LINE, LAYLINES, 3)
LAYNEWPAGE UNLESS LAYLINES < LAYI(1); ! page
L1:
REPEAT
!
RETURN IF NI < 1; ! no subsections
LAYCONTENTS(I, DOTS)
STOP:
RETURN IF NI < 1
!
I = I + 1
CYCLE J = 1, 1, NI
LAYITEM(I)
I = DIR(I)_LINK
REPEAT
END ; ! LAYITEM
!
!-------------------------LAYOUT------------------------------------------
!
ROUTINE FCONTENTS
INTEGER I, IMAX
STRING (80)T, JUNK
LAYNEWPAGE
IMAX = DIR(BASEI)_LINK
T = "Contents of "
T = T . "Sect " . BSEC . " of " UNLESS BSEC = ""
T <- T . GETNAME(0, DIRA, CONBASE)
LAYLINE(T)
!
I = BASEI
I = 1 IF I = 0
WHILE I < IMAX CYCLE
T = DIR(I)_SEC
RETURN UNLESS T -> (BSEC) . JUNK
!
IF DIR(I)_P1 = 0 C
THEN T = "*" . T C
ELSE T = " " . T
!
T = T . " " AND LENGTH(T) = 12 IF LENGTH(T)<12
T = T . " "
T <- T . GETNAME(I, DIRA, CONBASE)
LAYLINE(T)
I = I + 1
REPEAT
END
!
INTEGER J
!
!
!
!
!
!
!
!
!
!
!
!
!
DIR == ARRAY(DIRA + 32, DIRAF)
BSEC = DIR(BASEI)_SEC
!
!
!
CYCLE J = 1, 1, TOPLVI; ! set defaults
LAYI(J) = LAYIDEF(J)
REPEAT
!
CYCLE J = 1, 1, TOPLVS
LAYS(J) = LAYSDEF(J)
REPEAT
!
LAYLINES = -1
!
IF LAST SCREEN ID < 0 C
THEN FCONTENTS C
ELSE START
W("Extract from ".GETNAME(0, DIRA, CONBASE))
FIRSTI = BASEI
LAY ITEM(BASEI)
FINISH
!
LAYNEWPAGE
!
!
!
!
!
!
!
END ; ! F1SUPPORT
!
!
!
ROUTINE F2SUPPORT(INTEGER DIRA, CONBASE, BASEI)
INTEGER T1, T2, J, Q0, Q1, QL, CH
STRING (31)WQ0, WQ1, WQL
STRING (255)LINE, NULL, REST
RECORD (DIRF)ARRAYNAME DIR
DIR == ARRAY(DIRA+32, DIRAF)
T1 = DIR(BASEI)_P1
T2 = DIR(BASEI)_P2
RETURN UNLESS T1 > 0
!
QL = 0
!
WHILE T1 < T2 CYCLE
J = 0
WHILE T1 < T2 CYCLE
CH = BYTEINTEGER(CONBASE + T1)
T1 = T1 + 1
EXIT IF CH = NL
J = J + 1 AND CHARNO(LINE, J) = CH IF J < 255
REPEAT
LENGTH(LINE) = J
!
IF J > 3 AND CHARNO(LINE, 1) = '!' START
IF LINE -> NULL . ("!QUOTE ") . REST AND NULL = "" START
J = QUOTATION(REST, Q0, Q1, QL, DIRA, CONBASE)
-> L0
FINISH
!
IF LINE -> NULL . ("!XQUOTE ").WQ0.(",").WQ1.(",").WQL AND NULL = "" START
J = STOI2(WQ0, Q0)
J = STOI2(WQ1, Q1)
L0:
WHILE Q0 < Q1 CYCLE
PRINTSYMBOL(BYTEINTEGER(Q0))
Q0 = Q0 + 1
REPEAT
-> L1
FINISH
!
-> L1 IF CHECKWORD(LINE,
"!PAGE&!PROMPT&!MAIL&!TITLE&!TOPIC&!KEY&!ADDKEY&!HELP&", REST) > 0
RETURN IF LINE -> NULL . ("!STOP") . REST AND NULL = ""
FINISH
!
LINE -> ("!") . LINE IF LINE # "" AND CHARNO(LINE, 1) = '!'
UNCURL(LINE, QL, 3)
L1:
REPEAT
END ; ! F2SUPPORT
!
!
!
ROUTINE CLIST(INTEGER CONBASE, DIRA, BASEI, LPPAGE, PRINT,
INTEGERNAME I, CJ, LINES)
INTEGER COUNT, MAX, CN
STRING (255)Z, BSEC, LINE
RECORD (DIRF)ARRAYNAME DIR
DIR == ARRAY(DIRA+32, DIRAF)
BSEC = DIR(BASEI)_SEC
COUNT = 0; ! number of things on line so far
MAX = DIR(BASEI)_PER
MAX = 1 IF MAX > 6; ! number allowed per line
CN = DIR(BASEI)_SUBS; ! number of subsections
LINE = ""; ! empty to start with
WHILE CJ <= CN AND LINES < LPPAGE CYCLE
Z = " "
Z = "*" IF DIR(I)_P1 = 0
Z = Z.BSEC."." UNLESS BSEC = ""
Z = Z.ITOS(CJ)
Z = Z." " IF CJ<100
Z = Z." " IF CJ<10
Z = Z." ".GETNAME(I, DIRA, CONBASE)
!
IF MAX > 1 START
Z = Z . " "
LENGTH(Z) = PAD(MAX - 1)
FINISH
!
LINE = LINE . " " IF COUNT > 0
LINE = LINE . Z
COUNT = COUNT + 1
!
IF COUNT = MAX START
COUNT = 0
W(LINE) IF PRINT > 0
LINE = ""
LINES = LINES + 1
FINISH
!
CJ = CJ + 1
I = DIR(I)_LINK
REPEAT
UNLESS LINE = "" START
W(LINE) IF PRINT > 0
LINES = LINES + 1
FINISH
END ; ! CLIST
!
!
!
ROUTINE F3SUPPORT(INTEGER DIRA, CONBASE, BASEI)
! produces a file of material as seen on the screen except
! 1. before each screen full is written a marker
! !sec/frame or
! !C sec/frame
! 2. no little messages or prompts at the end of a screen full
INTEGER I, J, L, IMAX, FR, STATE, P, PMAX, Q, QMAX, CH, IX
INTEGER P0, Q0, Q1, QL
STRING (31)WQ0, WQ1, WQL
SWITCH SW(0:2)
STRING (31)BSEC, T1
STRING (255)T, NULL, REST
RECORD (DIRF)ARRAYNAME DIR
!
!
!
!
!
!
!
!
!
!
DIR == ARRAY(DIRA+32, DIRAF)
!
!
!
!
!
IMAX = DIR(BASEI)_LINK
BSEC = DIR(BASEI)_SEC
FR = 0
STATE = 0
I = BASEI
I = I + 1 IF LAST SCREEN ID < 0
!
WHILE I < IMAX CYCLE
FR = FR + 1
!
T = "!".DIR(I)_SEC
T = "!C ".BSEC IF LAST SCREEN ID < 0
W(T."/".ITOS(FR)); ! marker
!
T = GETNAME(I, DIRA, CONBASE)
T1 = DIR(I)_SEC
IF LAST SCREEN ID < 0 START ; ! contents mode
T = "Contents of "
T = T . "Sect ".BSEC." of " UNLESS BSEC = ""
T = T . GETNAME(0, DIRA, CONBASE)
T1 = ""
FINISH
T1 = T1 . "/" . ITOS(FR) IF FR > 1
T = " " . T IF LENGTH(T)+LENGTH(T1) < WIDTH - 10
J = WIDTH - 1 - LENGTH(T1)
LENGTH(T) = J IF LENGTH(T) > J
PRINTSTRING(T)
SPACES(J - LENGTH(T) + 1)
W(T1)
!
CYCLE J = 1, 1, WIDTH
PRINTSTRING("-")
REPEAT
NEWLINE
!
L = 0; ! lines on 'page'
IF LAST SCREEN ID < 0 START ; ! contents mode
WHILE L < 20 AND I < IMAX CYCLE
T = " "
T = "*" IF DIR(I)_P1 = 0; ! subfile
T = T . DIR(I)_SEC
PRINTSTRING(T)
J = 8 - LENGTH(T)
SPACES(J) UNLESS J < 0
SPACE
W(GETNAME(I, DIRA, CONBASE))
I = I + 1
L = L + 1
REPEAT
FINISH ELSE START ; ! text mode
-> SW(STATE)
SW(0):
P = DIR(I)_P1; ! initialise things at the start of a section
PMAX = DIR(I)_P2
PMAX = -1 IF P = -1; ! a '!SKIP' section
Q = 1
QMAX = DIR(I)_SUBS
IX = I + 1
STATE = 1
SW(1):
WHILE P < PMAX AND L < 20 CYCLE ; ! text part
J = 0
P0 = P
WHILE P < PMAX CYCLE ; ! get next line into T
CH = BYTEINTEGER(CONBASE + P)
P = P + 1
EXIT IF CH = NL
J = J + 1 AND CHARNO(T, J) = CH IF J < 255
REPEAT
LENGTH(T) = J
!
IF J > 4 AND CHARNO(T, 1) = '!' START
!
IF T -> NULL . ("!QUOTE ") . REST AND NULL = "" START
J = QUOTATION(REST, Q0, Q1, QL, DIRA, CONBASE)
P = P0 AND -> STOP IF L > 0 AND L + QL > 20
-> L0
FINISH
!
IF T -> NULL . ("!XQUOTE ") . WQ0 . (",") . WQ1 . (",") . WQL AND NULL = "" START
J = STOI2(WQL, QL)
P = P0 AND -> STOP IF L > 0 AND L + QL > 20
J = STOI2(WQ0, Q0)
J = STOI2(WQ1, Q1)
L0:
WHILE Q0 < Q1 CYCLE
PRINTSYMBOL(BYTEINTEGER(Q0))
Q0 = Q0 + 1
REPEAT
L = L + QL
-> L1
FINISH
!
-> L1 IF CHECKWORD(T,
"!PROMPT&!MAIL&!TITLE&!TOPIC&!KEY&!ADDKEY&!HELP&", REST) > 0
!
IF T -> NULL . ("!STOP") . REST AND NULL = "" START
STATE = 2
Q = QMAX + 1
-> STOP
FINISH
!
IF T -> NULL . ("!PAGE") . REST AND NULL = "" START
-> SW(1) IF L = 0
-> STOP
FINISH
!
FINISH
!
T -> ("!") . T IF T # "" AND CHARNO(T, 1) = '!'
UNCURL(T, L, 2)
L1:
REPEAT
STATE = 2 UNLESS P < PMAX
SW(2):
CLIST(CONBASE, DIRA, I, 20, 1, IX, Q, L); ! contents part
STOP:
IF STATE = 2 AND Q > QMAX START
STATE = 0
I = I + 1
FR = 0
FINISH
FINISH
!
L = 20 - L
NEWLINES(L) IF L > 0
REPEAT
!
!
!
!
!
!
!
END ; ! F3SUPPORT
!
!
!
ROUTINE FSUPPORT(STRING (255)Z, INTEGER DIRA, CONBASE, BASEI)
INTEGER STYLE, J
STRING (255)DEST, W
CONSTINTEGER TOPSTYLE = 3
SWITCH SW(1 : TOPSTYLE)
RETURN IF RESTRICTED = 1
!
IF Z = "" START
RETURN IF EFFING FILE = ""
DEST = EFFING FILE
DEST = DEST . "-MOD" UNLESS CHARNO(DEST, 1) = '.'
FINISH ELSE START
STYLE = 1
IF Z -> Z . (",") . W START
STYLE = J IF STOI2(W, J) = 0 AND J > 0 AND J <= TOPSTYLE
FINISH
EFFING STYLE = STYLE
!
DEST = Z
EFFING FILE = Z UNLESS Z -> EFFING FILE . ("/W") ORC
Z -> EFFING FILE . ("-MOD")
FINISH
!
j = uinfi(6)
j = 1024 if j > 1024 { limit to 1 meg }
DEFINE("61," . OUTPUT FILE . "," . ITOS(j))
SELECT OUTPUT(61)
!
!
UNDERLINE = 0
IF EFFING FILE -> W . (".DP") AND W = "" START
PRINTCH(27)
PRINTSTRING("[6;2x") { select font 6 for default }
FINISH
!
-> SW(EFFING STYLE)
SW(1): F1SUPPORT(DIRA, CONBASE, BASEI); -> CLOSE
SW(2): F2SUPPORT(DIRA, CONBASE, BASEI); -> CLOSE
SW(3): F3SUPPORT(DIRA, CONBASE, BASEI)
CLOSE:
SELECT OUTPUT(0)
CLOSE STREAM(61)
CLEAR("61")
ZCOPY2(OUTPUT FILE . "," . DEST, 0, J)
J = 219 IF J = -7 OR J = -10
UNLESS J = 0 START
PRINTSTRING(FAILURE MESSAGE(J))
PRINTSTRING("Output saved in " . OUTPUT FILE . "
")
FINISH
END ; ! FSUPPORT
!
!
!
OWNINTEGER SEARCHFILEI, TOPSEARCHFILE, SEARCHFILEA
!
!
!
!
!
!
!
INTEGERFN ALPHA(STRING (255)Z, INTEGER I, DIRA, CONBASE)
INTEGER N, B, J
STRING (31)UCNAME
OWNINTEGER ALPHAI = -1
RECORD (DIRF)ARRAYNAME DIR
DIR == ARRAY(DIRA+32, DIRAF)
N = DIR(I)_SUBS; ! number of sub-sections
IF N < 1 START
-> L UNLESS ALPHAI < 0; ! life saver
-> L2 IF LIBRAR = 1
W("There are no subsections")
RESULT = 0
FINISH
UNLESS I+N+1 = DIR(I)_LINK START
-> L UNLESS ALPHAI < 0; ! life saver
-> L2 IF LIBRAR = 1
W("Section not suitably structured")
RESULT = 0
FINISH
ALPHAI = I
L:
I = ALPHAI
N = DIR(I)_SUBS
!
B = 1
B = B << 1 WHILE B <= N
B = B >> 1
J = B
!
WHILE B > 1 CYCLE
B = B >> 1
UCNAME <- GETNAME(I+J, DIRA, CONBASE)
UCTRANSLATE(ADDR(UCNAME)+1, LENGTH(UCNAME)) UNLESS UCNAME = ""
IF UCNAME >= Z C
THEN J = J - B C
ELSE START
J = J + B IF J + B <= N
FINISH
REPEAT
!
UCNAME <- GETNAME(I+J, DIRA, CONBASE)
UCTRANSLATE(ADDR(UCNAME)+1, LENGTH(UCNAME)) UNLESS UCNAME = ""
J = J - 1 IF UCNAME >= Z AND J > 1
!
RESULT = I + J
L2:
W("You cannot use '?' in this section, check the instructions")
RESULT = 0
END ; ! ALPHA
!
!
!
ROUTINE PICK UP REFS(STRINGNAME FULL, INTEGER CONBASE, DIRA, KEYA)
!
! 1. Copy the names of any subfiles of this file to the
! SEARCHFILE array, unless already present or SEARCHFILE array full.
!
! 2. If no keys, just put filename and topic into REF array.
!
! 3. Else, locate as many keys as possible in current file.
!
INTEGER CH, J, K, LEN, ADR, L1, L2
STRING (31)Z
STRING (255)WK,A,B
RECORD (DIRF)ARRAYNAME DIR
RECORD (REFF)ARRAYFORMAT REFAF(1:KKTOPREF)
RECORD (REFF)ARRAYNAME REF
STRINGARRAYNAME SUBFILE, SEARCHFILE
REF == ARRAY(KKREFADDR, REFAF)
DIR == ARRAY(DIRA+32, DIRAF)
!
IF SEARCHFILEI > 0 START
SEARCHFILE == ARRAY(SEARCHFILEA, S31AF)
SUBFILE == ARRAY(ADDR(DIR(DIR(0)_LINK)), S31AF)
! copy names of subfiles of this file to the
! SEARCHFILE array unless they are there already
J = 1
WHILE J <= DIR(-1)_P1 CYCLE
Z = SUBFILE(J)
CYCLE K = 1, 1, SEARCHFILEI
-> NEXT IF Z = SEARCHFILE(K)
REPEAT
IF SEARCHFILEI < TOPSEARCHFILE START
SEARCHFILEI = SEARCHFILEI + 1
SEARCHFILE(SEARCHFILEI) = Z
FINISH
NEXT:
J = J + 1
REPEAT
FINISH
! if just checking subfiles then put filename
! and topic into REF array
IF KKTOPKEY = 0 START
KKREFI = KKREFI + 1
UNLESS KKREFI > KKTOPREF START
REF(KKREFI)_TOPIC = DIR(-1)_SEC
REF(KKREFI)_FILE = FULL
FINISH
RETURN
FINISH
!
LEN = INTEGER(KEYA) - 32
ADR = KEYA + 32
UNTIL J = 0 CYCLE
J = KWDSCAN(LEN, ADR, KKTOPKEY, KKEY)
UNLESS J = 0 START
KKREFI = KKREFI + 1
K = 0
CYCLE
CH = BYTEINTEGER(J)
EXIT UNLESS '0' <= CH <= '9'
K = 10 * K + CH - '0'
J = J + 1
REPEAT
WK = GETNAME(K, DIRA, CONBASE)
UNLESS KKREFI > KKTOPREF START
REF(KKREFI)_NAME <- WK
REF(KKREFI)_TOPIC = DIR(-1)_SEC
REF(KKREFI)_FILE = FULL
REF(KKREFI)_SEC = DIR(K)_SEC
FINISH
!
UNLESS KKEYPT = 0 START
WK = A.";".B WHILE WK -> A.(":").B
WK = A.B WHILE WK -> A.("¬").B
WK = FULL."¬".DIR(K)_SEC."¬".WK."¬".DIR(-1)_SEC
L1 = LENGTH(WK)
K = J
CYCLE
CH = BYTEINTEGER(J); ! expect : to be first ch
EXIT IF CH = NL
J = J + 1
REPEAT
!
! now need to add WK and these J-K+1 bytes to KKEYPT
! onwards, PROVIDED there is enough space
L2 = J - K + 1
IF KKEYPT + L1 + L2 < KKTOP KEYPT START
MOVE(L1, ADDR(WK)+1, KKEYPT)
MOVE(L2, K, KKEYPT + L1)
KKEYPT = KKEYPT + L1 + L2
FINISH
FINISH
FINISH
REPEAT
END ; ! PICK UP REFS
!
!
!
ROUTINE SPLUS
STRING (31)ARRAY FILE(1:100)
INTEGER J
STRING (63)Z
RECORD (FTF)NAME FT
FT == FTS(FTI(LEVEL))
PRINTCHS(VDUS1)
KKREF ADDR = ADDR(FILE(1))
KKTOP REF = 1
FILE(1) = FT_FILE
J = 0
UNTIL J = KKTOPREF CYCLE
J = J + 1
Z = VIEWFN(FILE(J), "S+,S!*!")
REPEAT
END ; ! SPLUS
!
!
!
ROUTINE SPLUSA
INTEGER X, I, J, IMAX
STRING (127)Z, F, U
STRINGARRAYNAME FILE
RECORD (FTF)NAME FT
RECORD (DIRF)ARRAYNAME DIR
INTEGER DIRA, CONBASE
FT == FTS(FTI(LEVEL))
DIRA = FT_DIRA
CONBASE = FT_CONBASE
DIR == ARRAY(DIRA+32, DIRAF)
IMAX = DIR(0)_LINK
FILE == ARRAY(KKREF ADDR, S31AF)
W("Detailed structure of ".FT_FILE." (".DIR(-1)_SEC.")")
W(" last changed on ". C
UNPACKDATE(FT_TIME STAMP) . " at " . C
UNPACKTIME(FT_TIME STAMP))
X = 0
I = 0
WHILE I < IMAX CYCLE
I = I + 1
IF DIR(I)_P1 = 0 START ; ! subfile marker
X = 1
Z = GETNAME(I, DIRA, CONBASE)
W(DIR(I)_SEC . " " . Z)
F = Z UNLESS Z -> F . (",") . Z
U = PROCUSER UNLESS F -> U . (".") . F
F = U . "." . F
CYCLE J = 1, 1, KKTOPREF
-> IN IF F = FILE(J)
REPEAT
KKTOPREF = KKTOPREF + 1
FILE(KKTOPREF) = F
IN:
FINISH
REPEAT
W("--- No external references ---") IF X = 0
END ; ! SPLUSA
!
!-----------------------------------------------------------------------
!
ROUTINE HELP(INTEGER FTINDEX)
INTEGER H, P1, P2, LINES
STRING (255)LINE, REST
RECORD (FTF)NAME FT
RECORD (DIRF)ARRAYNAME DIR
PRINTCHS(VDUS1); ! CLEAR SCREEN
!
FT == FTS(FTINDEX)
DIR == ARRAY(FT_DIRA+32, DIRAF)
H = DIR(-1)_P2
IF H > 0 START { private HELP section nominated }
LINES = 0
P1 = DIR(H)_P1
P2 = DIR(H)_P2
CYCLE
RETURN UNLESS P1 < P2
GETLINE(LINE, P1, P1, FT_CONBASE, P2)
IF CHECKWORD(LINE, "!TITLE&!TOPIC&!KEY&!ADDKEY&!HELP&", REST) = 0 C
THEN UNCURL(LINE, LINES, 1)
REPEAT
FINISH
!
!
IF LIBRAR = 1 START
W("I didn't recognise your last command. Here is a")
W("short description of what you can do.")
W(" ")
W("= repeats the current page")
W("- gives the previous page in the file, unless")
W(" you are already looking at the first page")
W("T goes back to the first page (Top) of the file")
W("'return' by itself gives the next page, unless you")
W(" are already looking at the last page")
W("3.5 gives section 3.5 etc")
W("name? gives the 'best' page in which to find your")
W(" entry, provided you are in a suitable section")
W(" DONT FORGET THE '?' !!!")
W("R returns you to a higher level, eg from SERIALS")
W(" to the initial page")
W("QUIT leaves the system ready for the next user")
W(" ")
W("remember to press 'return' when you have typed your command")
W(" ")
W(" ")
RETURN
FINISH
!
!
!
W("= repeat current frame, eg after reading this.")
W("< re-displays the previous frame that you viewed")
W("- previous frame in this file")
W("/n continuation frame n in this section / alone goes to end")
W("!com obey com, any single EMAS command")
W("m.n section m.n .n subsection n")
W("name section of that name name? alphabetic search")
W("Bn set a bookmark, n in range 1 - 9 ")
W("C lists the contents of this section ")
W("F< > output to file or device ")
W("Gn go to frame where you set Bn (in the same file)")
W("K< > key search")
W("Q exit from VIEW")
W("R return from subfile and re-display previous frame")
W("S give structure ie subfiles of current file ")
W("T top of current file")
W("V file VIEW file V alone for VIEW spec")
W("W where am I? - files traversed -------------------------")
W(" ")
W("*** Int: K kills output and goes to View:")
W("*** VIEW thinks your terminal is a " . VDUS(0))
W("*** use command TERMINALTYPE, outside VIEW, to change it")
RETURN
END ; ! HELP
!
!
!
ROUTINE CONTENTS(INTEGER F, INC, FTINDEX, I)
INTEGER L, IMAX, CONBASE, DIRA
STRING (72)T, BSEC, T1
RECORD (FTF)NAME FT
RECORD (DIRF)ARRAYNAME DIR
OWNINTEGER FR
! FR is used in this routine only to keep track of which
! contents frame is on display.
IF INC = 0 C
THEN FR = F C
ELSE FR = FR + INC
FR = 0 IF FR < 0
!
FT == FTS(FTINDEX)
DIRA = FT_DIRA
CONBASE = FT_CONBASE
DIR == ARRAY(DIRA+32, DIRAF)
IMAX = DIR(I)_LINK
FR = (IMAX-2-I)//LPPAGE UNLESS I+1+FR*LPPAGE < IMAX
!
SCREEN ID = (1<<31) ! (I<<13) ! FR; ! id of screen to be displayed
RETURN IF SCREEN ID = LAST SCREEN ID
BSEC = DIR(I)_SEC
!
I = I + 1 + FR * LPPAGE
!
LINT = 0; ! no INT K so far
PRINTCHS(VDUS1); ! CLEAR SCREEN
!
IF LINT = 0 START
SPACES(10) UNLESS VDUI3 = 0
T = "Contents of "
T = T . "Sect ".BSEC." of " UNLESS BSEC = ""
T <- T . GETNAME(0, DIRA, CONBASE)
PRINTSTRING(T)
T1 = ""
T1 = " /" . ITOS(FR+1) IF FR > 0
SPACES(WIDTH - 10 - LENGTH(T) - LENGTH(T1)) UNLESS VDUI3 = 0; ! hardcopy
PRINTSTRING(T1)
DRAWLINE
FINISH
L = 0
WHILE L < LPPAGE AND I < IMAX CYCLE
T = " "
T = "*" IF DIR(I)_P1 = 0
T = T . DIR(I)_SEC
T = T . " " AND LENGTH(T) = 8 IF LENGTH(T) < 8
T <- T . " " . GETNAME(I, DIRA, CONBASE)
W(T) IF LINT = 0
I = I + 1
L = L + 1
REPEAT
L = LPPAGE - L
RETURN UNLESS LINT = 0
BLANKLINES(L) IF L > 0
!
IF I < IMAX C
THEN W(START STANDOUT."...more".END STANDOUT) C
ELSE W(START STANDOUT."End of contents".END STANDOUT)
END ; ! CONTENTS
!
!
!
STRINGFN LOCATE(STRING (255)STEM, INTEGER FTINDEX)
!
! Searches the keys and the section names in the current file looking
! for some kind of match.
!
INTEGER DIRA, KEYA, CONBASE, LEN, ADR, J, K, N, CH, IMAX, I, P,
EXACT, EXACTI, L, H, X
!
CONSTINTEGER TOP = 64
CONSTINTEGER TOP ON SCREEN = 15
!
!
INTEGERARRAY R(1 : TOP)
STRING (255)NAME, NULL
STRING (255)ARRAY KEYS(1 : 1)
RECORD (FTF)NAME FT
RECORD (DIRF)ARRAYNAME DIR
!
!
!
KEYS(1) = STEM
KEYS(1) = "," . STEM . "," UNLESS LENGTH(STEM) > 2
FT == FTS(FTINDEX)
DIRA = FT_DIRA
KEYA = FT_KEYA
CONBASE = FT_CONBASE
DIR == ARRAY(DIRA+32, DIRAF)
!
LEN = INTEGER(KEYA) - 32
ADR = KEYA + 32
K = 0
UNTIL J = 0 CYCLE
J = KWDSCAN(LEN, ADR, 1, KEYS)
UNLESS J = 0 START
K = K + 1
EXIT IF K > TOP
N = 0
CYCLE
CH = BYTEINTEGER(J)
EXIT UNLESS '0' <= CH <= '9'
N = 10 * N + CH - '0'
J = J + 1
REPEAT
R(K) = N
FINISH
REPEAT
!
IF K <= TOP START { not swamped with keys, so look at sec names }
IMAX = DIR(0)_LINK
EXACT = 0
P = 1
I = 1
WHILE I < IMAX CYCLE
NAME = GETNAME(I, DIRA, CONBASE)
L = LENGTH(NAME)
I = I + 1 AND CONTINUE IF L = 0
UCTRANSLATE(ADDR(NAME)+1, L)
H = 0
IF NAME = STEM START
EXACT = EXACT + 1
EXACTI = I
H = 1
FINISH ELSE START
H = 1 IF LENGTH(STEM) > 2 AND NAME -> (STEM)
FINISH
!
IF H = 1 START { insert into array of hits }
P = P + 1 WHILE P <= K AND R(P) < I
IF P > K START { add to end }
K = K + 1
EXIT IF K > TOP
R(K) = I
FINISH ELSE START
IF R(P) > I START { need to insert }
K = K + 1
EXIT IF K > TOP
CYCLE X = K, -1, P+1
R(X) =R(X-1)
REPEAT
R(P) = I
FINISH
FINISH
FINISH
I = I + 1
REPEAT
FINISH
!
IF 1 < K <= TOP AND EXACT # 1 START { remove any refs which are subsids}
I = 1
J = 1
WHILE I < K CYCLE
I = I + 1
UNLESS DIR(R(I))_SEC -> NULL . (DIR(R(J))_SEC . ".") AND NULL = "" START
J = J + 1
R(J) = R(I) IF I > J
FINISH
REPEAT
K = J
FINISH
!
IF K = 0 START
W("No match found")
RESULT = ""
FINISH
!
I = 0
I = R(1) IF K = 1
I = EXACTI IF EXACT = 1
RESULT = DIR(I)_SEC IF I > 0
!
P = 1
CYCLE
NAME = DIR(R(P))_SEC
IF LENGTH(NAME) > 9 START
LENGTH(NAME) = 9
NAME = NAME . "... "
FINISH ELSE START
NAME = NAME . " "
LENGTH(NAME) = 13
FINISH
W(NAME . GETNAME(R(P), DIRA, CONBASE))
P = P + 1
REPEAT UNTIL P > K OR P > TOP ON SCREEN
!
W("etc, etc") IF K > TOP ON SCREEN
RESULT = ""
END ; ! LOCATE
!
!-----------------------------------------------------------------------
!
STRINGFN LOCATE2(STRING (31)STEM, INTEGER CONBASE, DIRA)
INTEGER L, H, I, HITS, EXACT, EXACTI, IMAX
STRING (72)NAME, J1
CONSTINTEGER TOPHIT = 16
INTEGERARRAY HIT(1:TOPHIT)
RECORD (DIRF)ARRAYNAME DIR
DIR == ARRAY(DIRA+32, DIRAF)
IMAX = DIR(0)_LINK
HITS = 0
EXACT = 0
I = 1
WHILE I < IMAX CYCLE
NAME <- GETNAME(I, DIRA, CONBASE)
L = LENGTH(NAME)
UCTRANSLATE(ADDR(NAME)+1, L) IF L > 0
H = 0
IF NAME = STEM START ; ! exact
EXACT = EXACT + 1
EXACTI = I IF EXACT = 1; ! first exact hit
H = 1
FINISH ELSE START
H = 1 IF LENGTH(STEM) > 2 AND NAME -> (STEM)
FINISH
IF H = 1 START
HITS = HITS + 1
HIT(HITS) = I IF HITS <= TOPHIT
FINISH
I = I + 1
REPEAT
!
I = 0
I = EXACTI IF EXACT = 1
I = HIT(1) IF HITS = 1
RESULT = DIR(I)_SEC IF I > 0
!
IF HITS > 0 START { make a file ??? }
H = HITS
H = TOPHIT IF H > TOPHIT
CYCLE I = 1, 1, H
J1 = DIR(HIT(I))_SEC . " "
LENGTH(J1) = 8 IF LENGTH(J1) > 8
W(J1." ".GETNAME(HIT(I), DIRA, CONBASE))
REPEAT
W("etc etc") IF HITS > TOPHIT
RESULT = ""
FINISH
!
W("No match found for ".STEM)
!
RESULT = ""
END ; ! LOCATE
!
!
!
ROUTINE WD(STRINGNAME NEXTBIT, INTEGER DIRA, CONBASE)
INTEGER I, J, L, IMAX
RECORD (DIRF)ARRAYNAME DIR
STRINGARRAYNAME SUBFILE
!
!
!
ROUTINE W(STRING (255)S)
PRINTSTRING(S)
NEWLINE
IF L < 20 C
THEN L = L + 1 C
ELSE START
L = 0
RSTRG(NEXTBIT)
FINISH
END ; ! W
!
!
!
DIR == ARRAY(DIRA+32, DIRAF)
IMAX = DIR(0)_LINK
SUBFILE == ARRAY(ADDR(DIR(IMAX)), S31AF)
L = 0
NEXTBIT = ""
W("Topic: ".DIR(-1)_SEC)
PRINTSTRING("Help sec: "); WRITE(DIR(-1)_P2, 1)
PRINTSTRING(DIR(DIR(-1)_P2)_SEC) IF DIR(-1)_P2 > 0
W(" ")
I = DIR(-1)_P1
IF I = 0 C
THEN W("No subfiles") C
ELSE START
W("Subfiles:")
CYCLE J = 1, 1, I
W(SUBFILE(J))
REPEAT
FINISH
CYCLE I = 0, 1, IMAX - 1
WRITEN(I)
PRINTSTRING("/".DIR(I)_SEC)
PRINTSTRING("/")
WRITE(DIR(I)_PER, 1)
PRINTSTRING("/".GETNAME(I, DIRA, CONBASE)."/")
WRITE(DIR(I)_P1,1)
PRINTSTRING("/")
WRITE(DIR(I)_P2,1)
PRINTSTRING("/")
WRITE(DIR(I)_SUBS, 1)
PRINTSTRING("/")
WRITE(DIR(I)_LINK, 1)
W(" ")
RETURN UNLESS NEXTBIT = ""
REPEAT
END ; ! WD
!
!
STRINGFN FIND SUPPORT(STRINGNAME Z0, FULLFILE, INTEGER DIRA, CONBASE)
INTEGER N, J, Q0, Q1, QL
STRING (63)K
STRING (255)KEYS, W1, W2
CONSTINTEGER TOPLKREF = 256
RECORD (REFF)ARRAY REF(1:TOPLKREF)
KKREFI = 0; ! No of refs found
KKTOPREF = TOPLKREF
KKREFADDR = ADDR(REF(1))
Z0 = W1 . W2 WHILE Z0 -> W1 . (" ") . W2
!
KKTOPKEY = 0
KEYS = Z0 . "&"
WHILE KEYS -> K . ("&") . KEYS CYCLE
IF K # "" AND CHARNO(K, 1) = '*' C
THEN K -> ("*") . K C
ELSE K = "," . K
!
IF K # "" AND CHARNO(K, LENGTH(K)) = '*' C
THEN LENGTH(K) = LENGTH(K) - 1 C
ELSE K = K . ","
!
KKTOPKEY = KKTOPKEY + 1
KKEY(KKTOPKEY) = K
EXIT IF KKTOPKEY = 10
REPEAT
SEARCHFILEI = 1
!
K = VIEWFN(FULLFILE, "K!*!")
!
IF KKREFI = 0 START
W("No references found")
RESULT = ""
FINISH
!
IF KKREFI > TOPLKREF START
W(ITOS(KKREFI) . " references found, please be more specific")
RESULT = ""
FINISH
!
DEFINE("61," . OUTPUT FILE . "," . ITOS(UINFI(6)))
SELECT OUTPUT(61)
W1 = GETNAME(0, DIRA, CONBASE)
K = ""
K = "s" IF KKREFI > 1
W("!TITLE " . ITOS(KKREFI) . " reference" . K . " to " . Z0 . " extracted from " . W1)
CYCLE N = 1, 1, KKREFI
NEWLINE IF N > 1
J = QUOTATION(REF(N)_SEC, Q0, Q1, QL, DIRA, CONBASE)
K = "!XQUOTE " . ITOS(Q0)
K = K . "," . ITOS(Q1)
W(K . "," . ITOS(QL))
! W("!QUOTE " . REF(N)_SEC)
REPEAT
SELECT OUTPUT(0)
CLOSE STREAM(61)
CLEAR("61")
DELETE FILE(OUTPUT FILE)
RESULT = VIEWFN(OUTPUT FILE, "")
END ; ! FIND SUPPORT
!
!
!
STRINGFN KSUPPORT(STRINGNAME KEYS, FILE)
!
!
!
STRING (63)K, Z
STRING (255)KEYSW
STRING (31)ARRAY SEARCHFILE(1:100)
INTEGER F, I, J, N
CONSTINTEGER TOPLSUPREF = 200
RECORD (REFF)ARRAY REF(1:TOPLSUPREF)
KKEYPT = 0
KEYSW = KEYS
KSUPSUBFILES = 0; ! this file only
IF CHARNO(KEYSW, LENGTH(KEYSW)) = '+' START
LENGTH(KEYSW) = LENGTH(KEYSW) - 1
KEYS = KEYSW
KSUPSUBFILES = 1; ! look at subfiles
FINISH
KKREFI = 0; ! number of refs found
KKTOPREF = TOPLSUPREF
KKREFADDR = ADDR(REF(1))
!
SEARCHFILEI = 1; ! number of searchfiles
TOPSEARCHFILE = 100
TOPSEARCHFILE = 1 IF KSUPSUBFILES = 0; ! don't look in subfiles
SEARCHFILEA = ADDR(SEARCHFILE(1))
SEARCHFILE(1) = FILE
!
KKTOPKEY = 0
KEYSW = KEYSW . "&"
WHILE KEYSW -> K . ("&") . KEYSW CYCLE
IF K # "" AND CHARNO(K, 1) = '*' C
THEN K -> ("*") . K C
ELSE K = "," . K
!
IF K # "" AND CHARNO(K, LENGTH(K)) = '*' C
THEN LENGTH(K) = LENGTH(K) - 1 C
ELSE K = K . ","
!
KKTOPKEY = KKTOPKEY + 1
KKEY(KKTOPKEY) = K
EXIT IF KKTOPKEY = 10
REPEAT
!
F = 0
UNTIL F = SEARCHFILEI CYCLE
F = F + 1
K = VIEWFN(SEARCHFILE(F), "K!*!")
REPEAT
!
IF KKREFI > TOPLSUPREF START ; ! far too many
W("far too many references")
RESULT = ""
FINISH
!
IF KKREFI = 0 START ; ! none
W("No references found")
RESULT = ""
FINISH
!
!
J = 1
N = 0
CYCLE I = 1, 1, KKREFI
IF KEYS = REF(I)_NAME START ; ! look for exact hits
N = N + 1; ! count
J = I IF N = 1; ! remember the first
FINISH
REPEAT
!
IF KKREFI = 1 OR N = 1 START ; ! only one or one exact hit
RESULT = REF(J)_SEC IF REF(J)_FILE = FILE
RESULT = VIEWFN(REF(J)_FILE, REF(J)_SEC)
FINISH
!
DELETE FILE(OUTPUT FILE)
DEFINE("61," . OUTPUT FILE . ",".ITOS(UINFI(6)))
SELECT OUTPUT(61)
W("!TITLE " . KEYS)
W(ITOS(KKREFI) . " references found")
CYCLE N = 1, 1, KKREFI
Z = ITOS(N) . " "
LENGTH(Z) = 5
W(Z.REF(N)_NAME." - ".REF(N)_TOPIC)
REPEAT
W("!STOP")
CYCLE N = 1, 1, KKREFI
W("!<>".REF(N)_FILE.",".REF(N)_SEC)
REPEAT
SELECT OUTPUT(0)
CLOSE STREAM(61)
CLEAR("61")
RESULT = VIEWFN(OUTPUT FILE, "")
END ; ! KSUPPORT
!
!
!
STRINGFN UNTRANSLATE(INTEGER ID, FTINDEX)
INTEGER I, FR
STRING (255)S
RECORD (FTF)NAME FT
RECORD (DIRF)ARRAYNAME DIR
FT == FTS(FTINDEX)
DIR == ARRAY(FT_DIRA + 32, DIRAF)
!
I = ID >> 13
S = "T"
S = DIR(I)_SEC IF I > 0
FR = ID & X'1FFF'
S = S . "/" . ITOS(FR) IF FR > 1
RESULT = S
END
!
!
ROUTINE PRINTC(RECORD (FRAMEF)ARRAYNAME FRAME, C
INTEGER PRINT, FR, BASEI, FTINDEX)
! Goes through the motions of displaying frame FR of section BASEI.
! Displays only if PRINT = 1
SWITCH STSW(0:1)
INTEGER T0, TXTEOF, CN, I, T, CJ, STATE
INTEGER DIRA, CONBASE
RECORD (FTF)NAME FT
RECORD (DIRF)ARRAYNAME DIR
INTEGER LINES, J, Q0, Q1, QL
STRING (31)BSEC, WQ0, WQ1, WQL
STRING (255)Z, LINE, L0, NULL, REST
STRING (6)OWNER
!
!
!
ROUTINE PRINTH(INTEGER I, STRING (255)SEC, INTEGER FR)
INTEGER SP
STRING (255)X
X = GETNAME(I, DIRA, CONBASE)
SEC = SEC . "/" . ITOS(FR+1) IF FR > 0
IF STRIPJ < TOP STRIP START
STRIPJ = STRIPJ + 1
STRIP(STRIPJ) = SCREEN ID
FINISH
!
IF VDUI3 = 0 START ; ! hardcopy
PRINTSTRING(SEC)
SPACES(3)
PRINTSTRING(X)
FINISH ELSE START
PRINTCHS(VDUS1); ! CLEAR SCREEN
X = " " . X IF LENGTH(X)+LENGTH(SEC) < WIDTH - 10
SP = WIDTH - LENGTH(SEC) - 1
LENGTH(X) = SP IF LENGTH(X) > SP
PRINTSTRING(X)
SPACES(SP + 1 - LENGTH(X))
PRINTSTRING(SEC)
FINISH
!
IF PARTIAL DISPLAY = 0 C
THEN DRAWLINE C
ELSE NEWLINE
END ; ! PRINTH
!
!
!
MON("PRINTC PRINT=".ITOS(PRINT), ",FR=".ITOS(FR))
FT == FTS(FTINDEX)
DIRA = FT_DIRA
CONBASE = FT_CONBASE
DIR == ARRAY(DIRA+32, DIRAF)
TXTEOF = DIR(BASEI)_P2
CN = DIR(BASEI)_SUBS
LINT = 0; ! no interrupts received so far
LINES = 0
BSEC = DIR(BASEI)_SEC
SCREEN ID = (BASEI << 13) ! FR + 1; ! screen requested
RETURN IF SCREEN ID = LAST SCREEN ID; ! already on display
!
IF FR = 0 AND SOME PARAMETER USED = 1 START
SOME PARAMETER USED = 0
CYCLE J = 100, 1, TOP PARAMETER
PARAMETER USED(J) = 0
REPEAT
FINISH
!
IF PRINT = 1 START
PRINTH(BASEI, BSEC, FR)
PARTIAL DISPLAY = 0 AND PRINT = -1 UNLESS PARTIAL DISPLAY = 0
FINISH ELSE SCREEN ID = 0
!
!
I = FRAME(FR)_I
T = FRAME(FR)_T
CJ = FRAME(FR)_CJ
STATE = FRAME(FR)_STATE
-> STSW(STATE)
STSW(0):
WHILE T < TXTEOF AND LINES < LPPAGE CYCLE
T0 = T
GETLINE(LINE, T0, T, CONBASE, TXTEOF)
IF LENGTH(LINE) > 3 AND CHARNO(LINE, 1) = '!' START
!
-> L1 IF CHECKWORD(LINE, "!TITLE&!TOPIC&!KEY&!ADDKEY&!HELP&", REST) > 0
!
IF LINE -> NULL . ("!QUOTE ") . REST AND NULL = "" START
J = QUOTATION(REST, Q0, Q1, QL, DIRA, CONBASE)
T = T0 AND -> STOP IF LINES > 0 AND LINES + QL > LPPAGE
-> L0
FINISH
!
IF LINE -> NULL . ("!XQUOTE ").WQ0.(",").WQ1.(",").WQL AND NULL = "" START
J = STOI2(WQL, QL)
T = T0 AND -> STOP IF LINES > 0 AND LINES + QL > LPPAGE
J = STOI2(WQ0, Q0)
J = STOI2(WQ1, Q1)
L0:
IF PRINT > 0 = LINT START
WHILE Q0 < Q1 CYCLE
PRINTSYMBOL(BYTEINTEGER(Q0))
Q0 = Q0 + 1
REPEAT
FINISH
LINES = LINES + QL
-> L1
FINISH
!
IF LINE -> NULL . ("!READ ") . REST AND NULL = "" START
READ VALUE(REST) IF PRINT > 0 = LINT
-> L1
FINISH
!
IF LINE -> NULL . ("!MAIL ").REST AND NULL = "" START
IF PRINT > 0 = LINT START
QL = LENGTH(REST)
J = 0
J = 1 IF QL > 0 AND CHARNO(REST, QL) = '?'
!
FT_FILE -> OWNER . (".") . Z
-> L1 IF OWNER = PROCUSER AND J = 1
!
LINES = LINES + MAIL SUPPORT(REST, DIR(-1)_SEC)
FINISH
-> L1
FINISH
!
IF LINE -> NULL . ("!PROMPT ") . REST AND NULL = "" START
FT_PROMPT <- REST . " "
-> L1
FINISH
!
IF LINE -> NULL . ("!STOP").REST AND NULL = "" START
STATE = 1
CJ = CN + 1
-> STOP
FINISH
!
IF LINE -> NULL . ("!PAGE") . REST AND NULL = "" START
-> L1 IF LINES = 0; ! ignore 'page' at start of page
-> STOP
FINISH
!
IF LINE -> NULL . ("!#").REST AND NULL = "" START
REST -> (" ").REST WHILE CHARNO(REST, 1) = ' '; ! remove leading spaces
LINES = LPPAGE
IF PRINT > 0 = LINT START
LINE = ""
WHILE REST -> WQ0 . ("{") . WQ1 . ("}") . REST CYCLE
LINE = LINE . WQ0
J = STOI2(WQ1, Q1)
IF J = 0 C
THEN LINE = LINE . VSTRING(Q1) C
ELSE LINE = LINE . "{" . WQ1 . "}"
REPEAT
LINE = LINE . REST
UCTRANSLATE(ADDR(LINE)+1, LENGTH(LINE)) UNLESS LINE = ""
Z = "" UNLESS LINE -> LINE . (" ") . Z
CALL(LINE, Z)
FINISH
-> L1
FINISH
FINISH
!
IF PRINT > 0 = LINT START
LINE -> ("!").LINE IF LINE # "" AND CHARNO(LINE, 1) = '!'
FINISH
UNCURL(LINE, LINES, PRINT)
L1:
REPEAT
!
STATE = 1 UNLESS T < TXTEOF
STSW(1):
PRINT = 0 IF LINT > 0
CLIST(CONBASE, DIRA, BASEI, LPPAGE, PRINT, I, CJ, LINES)
STOP:
STATE = 2 IF STATE = 1 AND CJ > CN
!
FRAME(FR+1)_I = I; ! FRAME has only 128 elements
FRAME(FR+1)_T = T
FRAME(FR+1)_CJ = CJ
FRAME(FR+1)_STATE = STATE
!
RETURN IF PRINT = 0 OR LINT > 0
!
LINES = -1 IF PRINT = -1
J = LPPAGE - LINES
BLANKLINES(J) IF J > 0
!
IF PRINT = -1 START
W("If you want this frame, type = and press 'return'")
RETURN
FINISH
!
IF STATE < 2 C
THEN W(START STANDOUT."...more".END STANDOUT) C
ELSE START
IF BASEI < DIR(0)_LINK - 1 C
THEN W(START STANDOUT."End of section".END STANDOUT) C
ELSE W(START STANDOUT."End of file".END STANDOUT)
FINISH
RETURN
END ; ! PRINTC
!
!
!
ROUTINE STRAP(INTEGER CLASS, SUBCLASS)
! On receipt of an INT:A, C, K or Q
INTEGER A, J
INTEGERARRAY ENV(0:20)
SUBCLASS = SUBCLASS - 'a' + 'A' IF 'a'<=SUBCLASS<='z'
UNLESS SUBCLASS = 'K' START
SETMODE(SAVEMODE) UNLESS SAVEMODE = ""
SIGNAL(3, CLASS, SUBCLASS, J)
FINISH
A = ADDR(ENV(0))
J = READID(A)
LINT = 1; ! set switch
CONSOLE(7, J, J); ! discard output
PRINTSTRING(UINFS(4)); ! repeat current prompt
TERMINATE
J = DRESUME(0, 0, A)
END ; ! STRAP
!
!
!
ROUTINE KEYS(INTEGER LEN, ADR, N)
INTEGER I, J, L, P
STRING (63)KEY
BYTEINTEGERARRAYNAME K
BYTEINTEGERARRAYFORMAT KAF(0 : 1000000)
! This procedure searches VIEWKEYS for the keys for section N
! It is not very efficient. It would be better to
! 1 do some kind of binary chop
! 2 use machine code
K == ARRAY(ADR, KAF)
KEY = ITOS(N) . ":"
L = LENGTH(KEY)
LEN = LEN - L
!
CYCLE J = 0, 1, LEN
IF K(J) = NL START
CYCLE P = L, -1, 1
-> NO UNLESS K(J+P) = CHARNO(KEY, P)
REPEAT
!
J = J + L + 2
I = 0
CYCLE
IF K(J) = ',' AND K(J+1) = NL START
NEWLINE IF I > 0
RETURN
FINISH
PRINTSYMBOL(K(J))
IF K(J) = ',' AND I > 50 C
THEN I = -1 AND NEWLINE
I = I + 1
J = J + 1
REPEAT
FINISH
NO:
REPEAT
END ; ! KEYS
!
!
!
ROUTINE CPLUS(INTEGER FTINDEX)
INTEGER KLEN, J, N, I
STRING (80)LINE
RECORD (FTF)NAME FT
BYTEINTEGERARRAYNAME K
BYTEINTEGERARRAYFORMAT KAF(0 : 1000000)
RECORD (DIRF)ARRAYNAME DIR
! Scans through VIEWKEYS and for each line gives the
! section number and name and associated keys
FT == FTS(FTINDEX)
K == ARRAY(FT_KEYA + 32, KAF)
KLEN = INTEGER(FT_KEYA) - 34
DIR == ARRAY(FT_DIRA+32, DIRAF)
J = 0
LOOP:
RETURN IF J >= KLEN
IF K(J) # NL START
J = J + 1
-> LOOP
FINISH
!
N = 0
WHILE '0' <= K(J+1) <= '9' CYCLE
J = J + 1
N = 10 * N + K(J) - '0'
REPEAT
!
LINE = DIR(N)_SEC
LINE = LINE . " " WHILE LENGTH(LINE) < 7
LINE <- LINE . " " . GETNAME(N, FT_DIRA, FT_CONBASE)
W(LINE)
!
J = J + 3
I = 0
SPACES(3)
CYCLE
IF K(J) = ',' AND K(J+1) = NL START
NEWLINE IF I > 0
-> LOOP
FINISH
PRINTSYMBOL(K(J))
IF K(J) = ',' AND I > 50 C
THEN NEWLINE AND SPACES(3) AND I = -1
I = I + 1
J = J + 1
REPEAT
END ; ! CPLUS
!
!
!
ROUTINE PACKHELP SUPPORT(STRING (255)S)
!
RECORDFORMAT FINDF(STRING (31)FILE, INTEGER DIRNO, TYPE, STATUS)
!
SYSTEMINTEGERFNSPEC FIND(STRING (31)ENTRY, INTEGERNAME NREC,
INTEGER ADR, TYPE)
DYNAMICROUTINESPEC PACKHELP(STRING (255)S)
INTEGER J, NREC
RECORD (FINDF)ARRAY FOUND(1 : 4)
!
!
!
DELETE FILE(OUTPUT FILE)
DEFINE("61," . OUTPUT FILE . "," . ITOS(UINFI(6)))
SELECT OUTPUT(61)
!
PRINTSTRING("!TITLE HELP Information on ")
IF S = "" C
THEN PRINTSTRING("Packages") C
ELSE PRINTSTRING(S)
NEWLINE
!
NREC = 4
J = FIND("PACKHELP", NREC, ADDR(FOUND(1)), 2)
IF J = 0 START
IF NREC = 0 START
CALL("OPTION", "SEARCHDIR=PLULIB.PACKDIR")
FINISH
FINISH
PACKHELP(S)
SELECT OUTPUT(0)
CLOSE STREAM(61)
CLEAR("61")
!
IF NREC = 0 START
CALL("OPTION", "REMOVEDIR=PLULIB.PACKDIR")
FINISH
!
DESTROY("T#PLUOPT", J)
DISCONNECT("PLULIB.HELP", J)
DISCONNECT("PLULIB.PARAMS", J)
DISCONNECT("PLULIB.PLUROUTINEY", J)
END
!
!
!
STRINGFN ANALYSE LINE(STRINGNAME LINE, INTEGER FTINDEX)
!
!
!
INTEGER CONBASE, DIRA, KEYA
INTEGER BASEI, FR, FRX, I, J, K, L, N, T
INTEGER STRIP0; ! Initial pointer in 'strip' at this level
STRING (6)FILE OWNER
STRING (31)TAG
STRING (63)JUNK1, JUNK2, FULLFILE
STRING (255)NEXT BIT, L0, Z, R, NULL
!
STRINGARRAYNAME SUBFILE
RECORD (FTF)NAME FT
RECORD (FRAMEF)ARRAY FRAME(0 : 127)
!
RECORD (DIRF)ARRAYNAME DIR
!
! DIR(-1)_SEC : topic
! _PER
! _NAME
! _P1 : number of subfiles
! _P2 : number of 'help' section if nominated (>0)
! _SUBS
! _LINK
!
!
CONSTINTEGER TOPMARK = 9
INTEGERARRAY SPECIFIC MARKS(1 : TOPMARK)
!
!
SWITCH SW(0:16)
CONSTINTEGER TOPSTR = 10
CONSTSTRING (4)ARRAY STR(1:TOPSTR) = C
"????", "S-", "K!*!", "QUIT", "STOP", "END", "HELP",
"KEYS", "C+", "B?"
SWITCH STRSW(1:TOPSTR)
!
!
FT == FTS(FTINDEX)
CONBASE = FT_CONBASE
DIRA = FT_DIRA
KEYA = FT_KEYA
FULLFILE = FT_FILE
FULLFILE -> FILE OWNER . (".") . JUNK1
!
STRIP0 = STRIPJ
!
CYCLE J = 1, 1, TOPMARK
SPECIFIC MARKS(J) = -1
REPEAT
!
FRX = 0
BASEI = 0
DIR == ARRAY(DIRA+32, DIRAF)
SUBFILE == ARRAY(ADDR(DIR(DIR(0)_LINK)), S31AF)
T = DIR(0)_P1
I = 1
FR = -1
FRAME(0)_I = 1
FRAME(0)_T = T
FRAME(0)_CJ = 1
FRAME(0)_STATE = 0
ANALYSE:
MON("Analyse, length", ITOS(LENGTH(LINE)))
MON("and LINE", LINE)
IF LENGTH(LINE) > 1 AND CHARNO(LINE, 1) = '!' START
-> READLINE IF RESTRICTED = 1; ! Viewer etc
LINE -> ("!") . LINE
IF STOI2(LINE, J) = 0 START ; ! purely numeric
VIEWMON = J
-> READLINE
FINISH
!
Z = ""
IF UINFI(16) = 1 START ; ! brackets ON
IF LINE -> LINE . ("(") . Z START
J = LENGTH(Z)
LENGTH(Z) = J - 1 IF J > 0 AND CHARNO(Z, J) = ')'
FINISH
FINISH ELSE START
Z = "" UNLESS LINE -> LINE . (" ") . Z
FINISH
!
LAST SCREEN ID = 0
CASTOUT(LINE); ! command
-> READLINE IF LINE = ""
CASTOUT(Z) UNLESS Z = ""; ! parameters
!
IF UINFI(26) = 0 START ; ! old loader
LOAD(LINE, 0, J)
W("?") AND -> READLINE UNLESS J = 0
FINISH
CALL(LINE, Z)
REROUTECONTINGENCY(0, 65, X'2080A0002080A', STRAP, J)
REROUTECONTINGENCY(3, 65, X'2080A0002080A', STRAP, J)
! does Q K C A
-> READLINE
FINISH
!
UCTRANSLATE(ADDR(LINE)+1, LENGTH(LINE)) UNLESS LINE = ""
!
IF LINE -> L0 . ("F<") . Z . (">") . R START
IF L0 -> (",") START
LINE -> LINE . (",") . NEXT BIT
FINISH ELSE START
IF L0 = "" AND (R="" OR CHARNO(R,1) = ',') START
FSUPPORT(Z, DIRA, CONBASE, BASEI)
-> READ LINE IF R = ""
R -> (",") . LINE
-> ANALYSE
FINISH
W("???")
-> READ LINE
FINISH
FINISH ELSE START
NEXT BIT = "" UNLESS LINE -> LINE . (",") . NEXT BIT
FINISH
!
LAST SCREEN ID = SCREEN ID
SCREEN ID = 0
! The logic here is as follows.
! In CONTENTS, the SID reqd is computed. If its
! the same as LAST SID then don't do anything
!
!
DECODE:
MON("Decode line", LINE)
MON("and NEXT BIT", NEXT BIT)
!
!
!
IF LINE = "" START ; ! null line - go to next continuation page
IF LAST SCREEN ID < 0 START ; ! in contents mode
CONTENTS(0, 1, FTINDEX, BASEI)
-> NEXT PART
FINISH
!
FRX = FR + 1
-> FINDFRAME IF FRAME(FRX)_STATE < 2; ! not yet at end of current section
J = BASEI + 1
-> NEXT PART IF J >= DIR(0)_LINK
LINE = DIR(J)_SEC
FINISH
!
LINE -> (" ").LINE WHILE LINE # "" AND CHARNO(LINE, 1) = ' '
-> NEXTPART IF LINE = ""; ! ignore lines which are only spaces
!
J = LENGTH(LINE)
J = J - 1 WHILE CHARNO(LINE, J) = 32; ! strip trailing spaces
LENGTH(LINE) = J
!
LINE = DIR(BASEI)_SEC.LINE IF CHARNO(LINE, 1) = '.'; ! If LINE starts with '.', prefix LINE with BSEC
!
FRX = 0
TAG = ""
IF LINE -> LINE . ("/") . Z START ; ! This section sets FRX if user has included a '/'
TAG = "/" . Z
FRX = 32767 { a very big number }
UNLESS Z = "" START
UNLESS STOI2(Z, FRX) = 0 START
W("Format is /number NOT " . LINE . "/" . Z)
-> READLINE
FINISH
FINISH
FRX = FRX - 1
FRX = 0 IF FRX < 0
IF LINE = "" START
-> FINDFRAME IF LAST SCREEN ID >= 0
CONTENTS(FRX, 0, FTINDEX, BASEI)
-> NEXTPART
FINISH
FINISH
!
!
!
-> NOT SINGLE IF LENGTH(LINE) > 1; ! ************* single character commands ***************
Z = "-BEQRSVW?=UCT-F-<"
Z = "---QR----=--T---<" IF LIBRAR = 1
-> SW(LENGTH(Z)) IF Z -> Z . (LINE) . JUNK1
-> L1
!
!
SW(0): ! - go to previous page
IF LAST SCREEN ID < 0 START ; ! in contents mode
CONTENTS(0, -1, FTINDEX, BASEI)
-> NEXT PART
FINISH
!
FRX = FR - 1
-> FINDFRAME UNLESS FRX < 0; ! previous page in current section
-> NEXT PART IF BASEI = 0; ! already at the top
LINE = DIR(BASEI-1)_SEC
LINE = "T" IF LINE = ""
LINE = LINE . "/"
-> DECODE
!
SW(1): ! B set a 'bookmark'
W("The 'B' facility, as such, has been withdrawn and")
W("replaced by 'Bn' and '<'")
-> READLINE
!
SW(2): ! E
SW(3): ! Q
-> OUT1
!
SW(4): ! R 'return' from file
STRIPJ = STRIP0 + 1
-> SW(16); ! ie do an '<'
!
SW(5): ! S give 'structure'
L = LENGTH(LINE); ! ie 1 for S, 2 for S-
UNLESS NEXT BIT = "S!*!" START
IF DIR(-1)_P1 = 0 START
W("there are no subsidiary files")
-> NEXT PART
FINISH
!
J = 1 { zero SSW byte in each used FT record }
CYCLE
FT == FTS(J)
EXIT IF FT_FILE = "" { all done }
FT_SSW = 0
J = J + 1
REPEAT
!
PRINTCHS(VDUS1)
IF L = 1 C
THEN W("file - topic") AND PRINTSTRING(FULLFILE." - ") C
ELSE W("The 'topic' tree")
FINISH
PRINTSTRING(DIR(-1)_SEC) { the topic }
IF FTS(FTINDEX)_SSW = 1 START
IF L = 1 C
THEN W(" circular structure!") C
ELSE NEWLINE
Z = ""
-> RETURN
FINISH
!
NEWLINE
FTS(FTINDEX)_SSW = 1
J = 1
WHILE J <= DIR(-1)_P1 CYCLE
SPACES((LEVEL-KKTOPKEY) * 3)
Z = SUBFILE(J)
PRINTSTRING(Z." - ") IF L = 1
Z = VIEWFN(Z, LINE.",S!*!")
J = J + 1
REPEAT
IF NEXT BIT = "S!*!" C
THEN Z = "" AND -> RETURN C
ELSE -> NEXT PART
SW(6): ! V equivalent to V default-file
LINE = "V " . DEFAULT FILE
-> DECODE
SW(7): ! W where am I?
PRINTCHS(VDUS1)
CYCLE J = 1, 1, LEVEL
FT == FTS(FTI(J))
W(FT_FILE." (".UNPACKDATE(FT_TIME STAMP). C
" at ".UNPACKTIME(FT_TIME STAMP).")")
REPEAT
-> NEXT PART
SW(8): ! ?
HELP(FTINDEX)
PROMPT("View (= to get last frame again): ")
RSTRG(LINE)
-> ANALYSE
SW(9): ! =
LAST SCREEN ID = 0
IF NEXT BIT = "" START { really want to display }
J = 1
Z = "="
FINISH ELSE START
J = 0
Z = "=," . NEXT BIT
FINISH
!
IF STRIPJ > STRIP0 START ; ! we have displayed something in the file
LINE = UNTRANSLATE(STRIP(STRIPJ), FTINDEX)
STRIPJ = STRIPJ - J
-> DECODE
FINISH
RESULT = Z
SW(10): ! U
W("The 'U' command has been withdrawn")
W("Can you use < instead?")
-> READLINE
SW(11): ! C
CONTENTS(0, 0, FTINDEX, BASEI)
->NEXTPART
SW(12): ! T
I = 0
-> L2
SW(13):
SW(14): ! F
FSUPPORT("", DIRA, CONBASE, BASEI)
-> NEXT PART
SW(15):
SW(16): ! <
IF NEXT BIT = "" START { want to return to previous frame}
{ and give a partial display }
PARTIAL DISPLAY = 1
J = 2
Z = "<"
FINISH ELSE START { dont want to display }
J = 1
Z = "<," . NEXT BIT
FINISH
!
IF STRIPJ >= STRIP0 + 2 START ; ! there is a previous frame in this file
LINE = UNTRANSLATE(STRIP(STRIPJ - 1), FTINDEX)
STRIPJ = STRIPJ - J
-> DECODE
FINISH
RESULT = Z
!
!-----------------------------------------------------------------------
NOT SINGLE:
!
!
CYCLE J = 1, 1, TOPSTR
-> STRSW(J) IF LINE = STR(J)
REPEAT
-> NOT STR
STRSW(1): ! ????
WD(NEXTBIT, DIRA, CONBASE) IF LIBRAR = 0
-> NEXT PART
STRSW(2): ! S-
-> NEXT PART IF LIBRAR = 1
-> SW(5)
STRSW(3): ! K!*!
PICKUPREFS(FULLFILE, CONBASE, DIRA, KEYA)
Z = ""
-> RETURN
STRSW(4): ! QUIT
STRSW(5): ! STOP
STRSW(6): ! END
-> OUT1
STRSW(7): ! HELP
-> SW(8) { as for ? }
STRSW(8): ! KEYS
KEYS(INTEGER(KEYA)-32, KEYA+32, BASEI)
-> NEXT PART
STRSW(9): ! C+
CPLUS(FTINDEX)
-> NEXT PART
STRSW(10): ! B?
L = 0
CYCLE J = 1, 1, TOPMARK
IF SPECIFIC MARKS(J) # -1 START
L = 1
PRINTSYMBOL('B')
PRINTSTRING(ITOS(J))
IF J < 10 C
THEN PRINTSTRING(": ") C
ELSE PRINTSTRING(": ")
W(UNTRANSLATE(SPECIFIC MARKS(J), FTINDEX))
FINISH
REPEAT
W("No bookmarks set") IF L = 0
-> NEXT PART
!
!-----------------------------------------------------------------------
!
NOT STR:
!
IF LINE -> NULL . ("B") . Z AND NULL = "" AND STOI2(Z, J) = 0 START ; ! Bn
IF STRIPJ > STRIP0 START
IF 1 <= J <= TOPMARK C
THEN SPECIFIC MARKS(J) = STRIP(STRIPJ) C
ELSE W("n must be in range 1-" . ITOS(TOPMARK) . " for Bn")
FINISH ELSE W("Need a frame on display for the bookmark")
-> NEXT PART
FINISH
!
IF LINE -> NULL . ("G") . Z AND NULL = "" AND STOI2(Z, J) = 0 START ; ! Gn
IF 1 <= J <= TOPMARK AND SPECIFIC MARKS(J) # -1 C
THEN LINE = UNTRANSLATE(SPECIFIC MARKS(J), FTINDEX) AND -> DECODE
W("G" . Z . " not set")
-> NEXTPART
FINISH
!
IF LINE = "S+" AND LIBRAR = 0 START
IF NEXTBIT = "" C
THEN SPLUS C
ELSE SPLUSA AND -> OUT1
-> READLINE
FINISH
!
IF LINE -> Z . ("?") . JUNK1 AND JUNK1 = "" START ; ! alphabetic search
-> SW(8) IF Z = ""; ! turn nulls into call on Help
J = ALPHA(Z, BASEI, DIRA, CONBASE)
-> READLINE IF J = 0; ! error result
I = J
-> L2
FINISH
!
!
!
-> LIBSKIP IF LIBRAR = 1
IF LINE -> NULL . ("V ") . Z AND NULL = "" START ; ! recursive call
LINE = VIEWFN(Z, NEXT BIT)
-> READ LINE IF LINE = ""
-> ANALYSE
FINISH
!
IF LINE -> NULL . ("K<") . Z . (">") AND NULL = "" START ; ! key search
LINE = KSUPPORT(Z, FULLFILE)
-> READ LINE IF LINE = ""
-> ANALYSE
FINISH
!
LIBSKIP:
IF LINE -> NULL . ("FIND ") . Z AND NULL = "" START
LINE = FIND SUPPORT(Z, FULLFILE, DIRA, CONBASE)
-> READ LINE IF LINE = ""; ! error exit
-> ANALYSE
FINISH
!
! %IF LINE -> NULL . ("U").Z %AND NULL = "" %START; ! UP A LEVEL OR MORE
! J = 1
! %UNLESS Z = "" %START
! -> KEYWORD %UNLESS STOI2(Z, J) = 0
! %FINISH
! -> KEYWORD %UNLESS J > 0
!!
! Z = DIR(BASEI)_SEC . "."
! P = 0
! P = P + 1 %WHILE Z -> PART(P) . (".") . Z
! P = P - J
! LINE = "T"
! %WHILE P > 0 %CYCLE
! P = P - 1
! %IF LINE = "T" %C
! %THEN LINE = "" %C
! %ELSE LINE = "." . LINE
! LINE = PART(P) . LINE
! %REPEAT
! LINE = LINE . TAG
! -> DECODE
! %FINISH
!-----------------------------------------------------------------------
!
! get here with line = A.B.C...
! go to KEYWORD if A, B, C, ... not all numeric
L1:
K = 0
L0 = LINE . "."
WHILE L0 -> Z . (".") . L0 CYCLE
-> KEYWORD UNLESS STOI2(Z,N)=0
-> NS UNLESS 1 <= N <= DIR(K)_SUBS
K = K + 1
K = DIR(K)_LINK AND N = N - 1 WHILE N > 1
IF DIR(K)_P1 <= 0 START
LENGTH(L0) = LENGTH(L0) - 1 IF LENGTH(L0) > 0
I = K
-> SUBFILE
FINISH
REPEAT
I = K
!
!
!
!
!
L2:
! at this point want frame FRX of section I
-> NEXT PART IF LAST SCREEN ID = (I << 13) ! FRX+1; ! already on display
FR = -1
BASEI = I
T = DIR(I)_P1
IF T <= 0 START
L0 = ""
-> SUBFILE
FINISH
FRAME(0)_I = BASEI + 1
FRAME(0)_T = T
FRAME(0)_CJ = 1
FRAME(0)_STATE = 0
FINDFRAME:
MON("FINDFRAME, FRX=".ITOS(FRX), ",FR=".ITOS(FR))
! find frame FRX of current (text) section
IF FRX <= FR START
FR = FRX
FRX = -1
-> BACK
FINISH
!
FRXLOOP:
-> NEXTPART IF FRX < 0
!
IF FRAME(FR+1)_STATE < 2 START
FR = FR + 1
FRX = -1 IF FRX = FR
BACK:
J = 0; ! print not required
J = 1 IF FRX < 0 AND NEXTBIT = ""; ! is
PRINTC(FRAME, J, FR, BASEI, FTINDEX)
-> FRXLOOP
FINISH
FRX = -1
-> BACK
KEYWORD:
! LINE = LOCATE(LINE, CONBASE, DIRA)
LINE = LOCATE(LINE, FTINDEX)
-> READ LINE IF LINE = ""; ! nothing or multiple
-> L1
!
NS:
I = 0 AND -> L2 IF LIBRAR = 1; ! ie go to top
W("No such section as " . LINE)
-> READLINE
!
!-----------------------------------------------------------------------
!
SUBFILE:
! come here with I, L0 and TAG
I = I + 1 IF DIR(I)_P1 < 0
Z = GETNAME(I, DIRA, CONBASE)
!
IF Z -> Z . (",") . JUNK2 START
NEXT BIT = JUNK2
FINISH ELSE START
L0 = L0 . TAG
IF L0 # "" START
IF NEXT BIT = "" C
THEN NEXT BIT = L0 C
ELSE NEXT BIT = L0 . "," . NEXT BIT
FINISH
FINISH
!
IF Z = "#PACKHELP" START
PACKHELP SUPPORT(NEXT BIT)
Z = OUTPUT FILE
NEXT BIT = ""
FINISH
!
LINE = VIEWFN(Z, NEXT BIT)
-> READ LINE IF LINE = ""
-> ANALYSE
NEXT PART:
UNLESS NEXT BIT = "" START
LINE = NEXT BIT
-> ANALYSE
FINISH
READLINE:
PROMPT(FT_PROMPT)
RSTRG(LINE)
-> ANALYSE
OUT1:
RESULT = "Q"
RETURN:
RESULT = Z
END ; ! ANALYSE LINE
!
!
!
STRING (63)FN VIEWFN(STRING (255)FILE, FIRST LINE)
INTEGER J, FTINDEX, SPECIALCALL
STRING (255)LINE
SWITCH SPOUT(0:3)
!
! VIEWFN is called
! either to display a frame
! or to check keys or something
!
! Result is
! either "" which is essentially an error
! or a VIEW command line, <, = or Q possibly followed by something
!
! Result is relevant only when displaying things. ZVIEW2 is the only
! higher level caller of VIEWFN to use the result.
!
J = LENGTH(FIRST LINE)
IF J > 1 AND CHARNO(FIRST LINE, J) = '?' AND CHARNO(FIRST LINE, J-1) = ',' C
THEN VIEW MON = 1 AND LENGTH(FIRST LINE) = J - 2
MON("VIEWFN, FIRST LINE", FIRST LINE)
!
SPECIAL CALL = 0
SPECIAL CALL = 1 IF FIRSTLINE = "K!*!"
SPECIAL CALL = 2 IF FIRSTLINE = "S,S!*!"
SPECIAL CALL = 3 IF FIRSTLINE = "S-,S!*!"
!
LEVEL = LEVEL + 1
IF LEVEL > TOP LEVEL START
LINE = "Too many levels of recursion"
-> OUT
FINISH
!
OUTPUT FILE = "T#VIEWOUT" . ITOS(LEVEL)
!
DESPACE(FILE)
UCTRANSLATE(ADDR(FILE)+1, LENGTH(FILE))
UCTRANSLATE(ADDR(FIRST LINE)+1, LENGTH(FIRST LINE))
J = VCONNECT(FILE, FTINDEX, LINE)
-> OUT IF J = 1
-> TOO BIG IF J = 2
!
FTI(LEVEL) = FTINDEX
LINE = FIRST LINE
LINE = "T" IF LINE = ""
!
LINE = ANALYSE LINE(LINE, FTINDEX)
-> RETURN
TOO BIG:
LINE = "More than ".ITOS(MAXDIR)." sections"
OUT:
-> SPOUT(SPECIAL CALL)
SPOUT(0):
! not a special call
W("VIEW fails " . LINE)
LINE = ""
-> RETURN
SPOUT(1):
! scanning keys, ignore failure messages
-> RETURN
SPOUT(2):
! structure determination
W(LINE)
-> RETURN
SPOUT(3):
W("faulty file found")
RETURN:
LEVEL = LEVEL - 1
OUTPUT FILE = "T#VIEWOUT" . ITOS(LEVEL)
MON("VIEWFN returns to level", ITOS(LEVEL))
RESULT = LINE
END ; ! VIEWFN
!
!-----------------------------------------------------------------------
!
ROUTINE VIEW INIT
INTEGER J
CYCLE J = 1, 1, TOPFT
FTS(J) = 0
REPEAT
!
LAST SCREEN ID = 0
LEVEL = 0
PARTIAL DISPLAY = 0
PROCUSER = UINFS(1)
SCREEN ID = 0
VIEWMON = 0
END ; ! VIEW INIT
!
!
!
SYSTEMROUTINE ZVIEW2(STRING (255)S, STRINGNAME PARM)
INTEGER I, J, ADR
STRING (255)NEXT
VIEW INIT
VDUI3 = 0; ! lines/page ---- initialise own variables
LPPAGE = 20
VDUS1 = ""; ! clear screen sequence
LIBRAR = 1 IF PROCUSER = "LIBRAR"
!
ADR = ADDR(NEXT)
J = DSFI(PROCUSER, -1, 18, 0, ADR)
RESTRICTED = 1
IF J = 0 START
RESTRICTED = 0 UNLESS NEXT = "#VIEWER"
FINISH
!
TERMINAL TYPE("") IF RESTRICTED = 1
REROUTECONTINGENCY(3, 65, X'2080A0002080A', STRAP, I)
!
SAVEMODE = ""
IF SITE = KENT START
SAVEMODE = MODESTR
SETMODE("H=0,W=0")
FINISH
!
IF VDUI(1) > 0 START ; ! user has set terminal type
WIDTH = VDUI(2)
WIDTH = WIDTH - 1 IF VDUB(4) # 0
START STANDOUT = VDUS(17)
END STANDOUT = VDUS(18)
VDUI3 = VDUI(3); ! lines/page, 0 = hardcopy
LPPAGE = VDUI3 - 4 IF VDUI3 > 0
LPPAGE = 20 IF LPPAGE > 20
VDUS1 = VDUS(1)
IF VDUI3 > 0 START ; ! its a video
IF VDUS1 = "" C
THEN VDUS1 = NLS10 C
ELSE VDUS1 = VDUS1 . TOSTRING(13)
FINISH
FINISH
!
NEXT = "" UNLESS S -> S . (",") . NEXT
S = DEFAULT FILE IF S = ""
!
PARM = VIEWFN(S, NEXT)
!
REROUTECONTINGENCY(0, 0, 0, STRAP, I)
SETMODE(SAVEMODE) UNLESS SAVEMODE = ""
END ; ! ZVIEW2
!
!
!
SYSTEMROUTINE ZVIEW(STRING (255)S)
STRING (255)PARM
ZVIEW2(S, PARM)
END ; ! ZVIEW
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!
EXTERNALROUTINE VIEW(STRING (255)S)
ZVIEW(S)
END ; ! VIEW
!
!
!-----------------------------------------------------------------------
!
SYSTEMINTEGERFN ZVIEWREFS(STRING (31)FILE, STRING (255)KEYS, C
INTEGER MAXREF, RECORD (REFF)ARRAYNAME REF, INTEGER SUBFILES)
!
! This function uses VIEW to scan the file FILE for the keys
! given in KEYS. Any 'hits' are returned in the record array
! REF up to a maximum of MAXREF. All the subsidiary files of
! FILE are examined automatically unless SUBFILES = 0. The number
! of 'hits' is returned as the result and may be greater than
! MAXREF.
!
! KEYS has the form
! key1 & key2 & ...
! where keyi may have an asterisk before and/or after
!
! REF is an array (1:MAXREF) of records whose format is
! %string(31)SECTION NAME, TOPIC, FILE, SECTION NUMBER
! To view a reference, call
! ZVIEW(FILE, SECTION NUMBER)
STRING (63)K
STRING (31)ARRAY SEARCHFILE(1:100)
INTEGER F, KEYADR, J
RECORD (FHDRF)NAME H
VIEW INIT
KKREFI = 0; ! number of refs found
KKTOPREF = MAXREF
KKREFADDR = ADDR(REF(1))
!
RESULT = 0 IF FILE = ""
UCTRANSLATE(ADDR(FILE)+1, LENGTH(FILE))
SEARCHFILEI = 1; ! number of searchfiles
TOPSEARCHFILE = 100
TOPSEARCHFILE = 1 IF SUBFILES = 0; ! don't look in subfiles
SEARCHFILEA = ADDR(SEARCHFILE(1))
SEARCHFILE(1) = FILE
!
KKTOPKEY = 0
UNLESS KEYS = "" START
UCTRANSLATE(ADDR(KEYS)+1, LENGTH(KEYS))
KEYS = KEYS . "&"
WHILE KEYS -> K . ("&") . KEYS CYCLE
IF K # "" AND CHARNO(K, 1) = '*' C
THEN K -> ("*") . K C
ELSE K = "," . K
!
IF K # "" AND CHARNO(K, LENGTH(K)) = '*' C
THEN LENGTH(K) = LENGTH(K) - 1 C
ELSE K = K . ","
!
UNLESS K = "" START
KKTOPKEY = KKTOPKEY + 1
KKEY(KKTOPKEY) = K
FINISH
EXIT IF KKTOPKEY = 10
REPEAT
FINISH
!
KKEYPT = 0
UNLESS FILE = "T#KEYWRK" START
OUTFILE("T#KEYWRK", 32768, 0, 0, KEYADR, J)
UNLESS J = 0 START
W("T#KEY WRK ".FAILURE MESSAGE(J))
RESULT = 0
FINISH
BYTEINTEGER(KEYADR + 32) = NL
KKEYPT = KEYADR + 33
KKTOP KEYPT = KKEYPT + 32768 - 40; ! cautious
FINISH
!
F = 0
UNTIL F = SEARCHFILEI CYCLE
F = F + 1
K = VIEWFN(SEARCHFILE(F), "K!*!")
REPEAT
!
UNLESS FILE = "T#KEYWRK" START
H == RECORD(KEYADR)
H_TYPE = 4
H_ADR = 3
H_NFB = KKEYPT - KEYADR
FINISH
!
RESULT = KKREFI
END ; ! ZVIEWREFS
ENDOFFILE