! **** **** Never attempt to compile any of the subsystem without **** ****
! **** **** the PARMS NOCHECK and STACK. **** ****
!
!
! %CONST declarations for conditional compilation:
! NEWLOADER - SEPRTN must have the same value
! MACHINE - SEPRTN " " " " "
! STUDENTSS - LOADER " " " " "
! PDFNFC
! PIPER
! NEWCONNECT.
!
!
! To be attended to:
! Change OPTION to call a %SYSTEM %ROUTINE SETOPT (% STRING (255) PARMS,
! %STRING (?) OPTION FILE NAME, %INTEGER %NAME FLAG)
! so that student supervisors' utilities can use it.
! Why doesn't DISCONNECT(.ALL) do T# files? Probably not relevant with
! the new CONNECT mechanism, but with the old mechanism I suppose it's
! to avoid disconnecting work files while they're in use (and to improve
! the chances of having them still connected at end-of-session, so that
! they will be destroyed).
! I can find no trace of the FILETYPE field in the %RECORD %FORMAT FRF
! being used at all.
! # in PD member names.
! RENAME should not accept wholly numeric filenames.
! ALIAS(?) should give a list of ALIASes in the current active directory
! (or in the whole directory structure?).
! Allow new INT:T to mean "stopped by user request" for batch jobs.
! Use some new DSTOP numbers to distinguish various reasons for DSTOP -
! e.g., INT:Y.
! History mechanism: ? commands should not be saved, perhaps.
! History mechanism: ! commands should be put back on top of stack of
! old commands.
! EDITOR should change context after setting up its work files, etc.
! We should have "wild cards" and "command variables" in the command
! structure.
! FILES(user,P) should not give permissions for the process owner
! because it's misleading.
! Should there be a way to find out how much space is left in an
! output file?
! PRINT DATE routine to say things like TODAY, YESTERDAY, LAST
! WEDNESDAY, etc.
! Resetting AUX STACK at command level, you always take it back to
! the same point, so there's no need to save it before each
! command. Also, it only needs to be reset if it has changed.
! Checking that first could avoid a write to an otherwise
! unchanged page.
!
!
!
!
! [ START OF GLOBAL TEXT -
!
!***********************************************************************
!* *
!* Conditional compilation constants *
!* *
!***********************************************************************
!
CONSTINTEGER DIAGOP = 0; ! Non-zero for diagnostic tracing code.
CONSTINTEGER FUNDS ON = 0; ! Zero to suppress generation of FUNDS code,
! non-zero to include FUNDS.
CONSTINTEGER MACHINE=2960; ! Used by CHARGE routine to choose
! charging formula. Machine may be
! equal to 2980 or 2972 or other
! values - see the text of CHARGE in BCOM.
! If MACHINE=0 then the formula will be
! selected at run time according to the
! processor type determined by grope.
! MACHINE=2960 also causes slight
! variations in METER and DETACHOBEY.
CONSTINTEGER NEWCONNECT = 0; ! Select old or new connect mechanism.
CONSTINTEGER NEWLOADER = 1; ! 0 for old loader
CONSTINTEGER NOTES ON = 0; ! Zero to suppress generation of NOTES code,
! non-zero to include NOTES.
CONSTINTEGER PDFNFC = 0; ! Non-zero to include default-PD-name facility.
CONSTINTEGER PIPER = 0; ! Non-zero to generate code to handle "pipes".
CONSTINTEGER STUDENTSS = 0
CONSTINTEGER ULCEQUIV = -1
! Zero to distinguish upper form lower case in keywords,
! non-zero to treat upper and lower case as equivalent.
!
!***********************************************************************
!* *
!* Version *
!* *
!***********************************************************************
!
IF STUDENTSS=0 THEN START
IF NEWLOADER=0 THEN START
CONSTSTRING (8) VERSION = "SS 2.14"
FINISH ELSE START
CONSTSTRING (8) VERSION = "SS 3.02j"
FINISH
FINISH ELSE START
IF NEWLOADER=0 THEN START
CONSTSTRING (9) VERSION = "SS 2.14s"
FINISH ELSE START
CONSTSTRING (9) VERSION = "SS 3.02js"
FINISH
FINISH
!
INCLUDE "SS0302S_SSOWNF"
!
!
!***********************************************************************
!* *
!* Initial values of SSOWN fields *
!* *
!***********************************************************************
!
CONSTINTEGER OPTEXT = 1
!
!
CONSTBYTEINTEGERARRAY INITVAL INTMESS(1 : 9) = C
10,10,'I','N','T',':','A',10,10
!
CONSTINTEGER INITVAL ALLCONNECT = 1; ! Hold off checking until routine can be loaded.
CONSTINTEGER INITVAL CKBITS=X'6A202020'
CONSTINTEGER INITVAL DIRDISCON = 1; !SET TO 1 WHEN DIRECTORY DISCONNECTED
CONSTINTEGER INITVAL FEPMODE = OPTEXT
CONSTINTEGER INITVAL INTINPROGRESS = 1
CONSTINTEGER INITVAL LOADLEVEL=1
CONSTINTEGER INITVAL MTCLOSEMODE = 8; !FULL UNLOAD BY DEFAULT
CONSTINTEGER INITVAL OPMODE = OPTEXT
CONSTINTEGER INITVAL RCLB = -1
CONSTINTEGER INITVAL SSUGLASIZE=X'00010000'
CONSTINTEGER INITVAL STATE = 1
CONSTINTEGER INITVAL TOPFD = 1; ! HIGHEST FD USED SO FAR THIS SESSION.
CONSTINTEGER INITVAL UNASSPATTERN = X'81'
!
CONSTLONGREAL INITVAL LASTCPUTIME = -1000000; ! Ensures X27{DSETIC} called first time. { in BCI}
!
CONSTSTRING (1) INITVAL ACTD = "0"
CONSTSTRING (80) INITVAL D DELIM 1 = ".DATA"
CONSTSTRING (80) INITVAL D DELIM 2 = ".ED"
CONSTSTRING (31) INITVAL OPTIONSFILE = "SS#OPT"
!
!***********************************************************************
!* *
!* Record formats *
!* *
!***********************************************************************
!
!
! **N.B. These two out of alphabetic order since PRMSF required by DPERMF
! ** and TMODEF required by DIRINFF.
RECORDFORMAT PRMSF(STRING (6) USER, BYTEINTEGER UPRM)
RECORDFORMAT TMODEF (HALFINTEGER FLAGS1, FLAGS2, BYTEINTEGER PROMPTCHAR, ENDCHAR, C
BYTE ARRAY BREAKBIT1 (0:3) {or %HALF %INTEGER %ARRAY BREAKBIT2 (0:1)}, C
BYTE INTEGER PADS, RPTBUF, LINELIMIT, PAGELENG, C
BYTEINTEGERARRAY TABS(0:7), BYTEINTEGER CR, ESC, DEL, CAN, C
BYTEINTEGER SCREED1, SCREED2, SCREED3, SCREED4, SCREED5, SCREED6)
!
RECORDFORMAT COMF(INTEGER OCPTYPE,IPLDEV,SBLKS,SEPGS,NDISCS, C
DLVNADDR,GPCTABSIZE,GPCA,SFCTABSIZE,SFCA,SFCK,DIRSITE, C
DCODEDA,SUPLVN,WASKLOKCORRECT,DATE0,DATE1,DATE2, C
TIME0,TIME1,TIME2,EPAGESIZE,USERS,CATTAD,DQADDR, C
BYTEINTEGER NSACS,RESV1,SACPORT1,SACPORT0, C
NOCPS,RESV2,OCPPORT1,OCPPORT0, C
INTEGER ITINT,CONTYPEA,GPCCONFA,FPCCONFA,SFCCONFA, C
BLKADDR,RATION,SMACS,TRANS,LONGINTEGER KMON, C
INTEGER DITADDR,SMACPOS,SUPVSN,PSTVA,SECSFRMN,SECSTOCD, C
SYNC1DEST,SYNC2DEST,ASYNCDEST,MAXPROCS,INSPERSEC,ELAPHEAD, C
COMMSRECA,STOREAAD,PROCAAD,SFCCTAD,DRUMTAD,TSLICE,FEPS,SP1, C
SP2,SP3,SP4,SP5,SP6,SP7,SP8, C
LSTL,LSTB,PSTL,PSTB,HKEYS,HOOT,SIM,CLKX,CLKY,CLKZ, C
HBIT,SLAVEOFF,INHSSR,SDR1,SDR2,SDR3, C
SDR4,SESR,HOFFBIT,S2,S3,S4,END)
! SECS TO CD gives the number of seconds to close-down (partial or
! full), or is zero if no close-down is planned.
!
! RATION is laid out as four bytes, viz.:
! SCARCITY, PRE-EMPT AT, ????, and NUMBER OF USERS.
!
! %RECORDFORMAT CONFF(%STRING (18) FILE, %C
! %INTEGER CONAD, SIZE, HOLE, MODE, USE, FSYS)
RECORDFORMAT CONTF (INTEGER DATAEND,DATASTART,PSIZE,FILETYPE, C
SUM,DATETIME,SPARE1,SPARE2,MARK, NULL1, UGLA, ASTK, USTK, C
NULL2, ITWIDTH, LDELIM, RDELIM, JOURNAL, SEARCHDIRCOUNT, C
ARRAYDIAG,INITWORKSIZE,SPARE,ITINSIZE,ITOUTSIZE, C
NOBL, ISTK, LONGINTEGER INITPARMS, INTEGER DATAECHO, C
TERMINAL, I23, I24, I25, I26, I27, I28, I29, I30, I31, I32, C
STRING (31) FSTARTFILE, BSTARTFILE, PRELOADFILE, MODDIR, C
CFAULTS, S6, S7, S8, S9, S10, S11, S12, S13, S14, S15, C
S16, S17, S18, S19, S20, S21, S22, S23, S24, S25, S26, S27, C
S28, S29, S30, S31, S32, C
STRING (31) ARRAY SEARCHDIR(1:16));!1/2/79
RECORDFORMAT DAHF(INTEGER DATAEND, DATASTART, SIZE, FILETYPE, C
DATE, TIME, FORMAT, RECORDS)
RECORDFORMAT DFF(INTEGER NKB, RUP, EEP, APF, USE, ARCH, FSYS, C
CONSEG, CCT {connect count since last zeroed}, C
CODES C
{1:not available,2:on offer,4:temporary,8:very temporary} C
{16:cherished,32:private,64:privacy violated,128:no archive}, C
BYTE INTEGER SPARE, DAY {when last connected}, POOL {obsolete}, C
CODES2 C
{1:write connected,2:NEWGEN,4:OLDGEN,8:write-shared allowed} C
{16:comms - not used,32:disc file - not used} C
{64: - not used,128:dead - obsolete}, C
INTEGER SSBYTE, STRING (6) TRAN)
RECORDFORMAT DHF(INTEGER DATAEND, DATASTART, SIZE, FILETYPE, C
SUM, DATETIME, PSTART, SPARE)
recordformat DIRINFF (string (6)USER, string (31)JOBDOCFILE,
{.28} integer MARK, FSYS,
{.30} PROCNO, ISUFF, REASON, BATCHID,
{.40} SESSICLIM, SCIDENSAD, SCIDENS, STARTCNSL,
{.50} AIOSTAT, SCT DATE, SYNC1 DEST, SYNC2 DEST,
{.60} ASYNC DEST, AACCT REC, AIC REVS,
{.6C} string (15)JOBNAME,
{.7C} string (31)BASEFILE,
{.9C} integer PREVIC,
{.A0} ITADDR0, ITADDR1, ITADDR2, ITADDR3,
{.B0} ITADDR4, STREAM ID, DIDENT, SCARCITY,
{.C0} PREEMPTAT, string (11)SPOOLRFILE,
{.D0} integer FUNDS, SESSLEN, PRIORITY, DECKS,
{.E0} DRIVES, PART CLOSE,
{.E8} record (TMODEF)TMODES,
{108} integer PSLOT,
{10C} string (63)ITADDR,
{14C} integerarray FCLOSING(0:3), integer CLO FES,
{160} integer OUTPUT LIMIT, DAPSECS, longinteger DAPINSTRS,
{170} integer OUT, string (15)OUTNAME,
{184} integer HISEG,
{188} string (31)FORK,
{1A8} integer INSTREAM, OUTSTREAM,
{1B0} integer DIRVSN, DAP NO, SCT BLOCK AD,PROTOCOL, {0 for ITP, 1 for X29}
integer UEND)
RECORDFORMAT DPERMF (INTEGER BYTESRETURNED, OWNP, EEP, SPARE, C
RECORD (PRMSF) ARRAY PRMS(0 : 15))
RECORDFORMAT DRF(INTEGER LENGTH,AD)
RECORDFORMAT DYNRF(INTEGER PC, DR0, DR1, ADESC, STRING (31) NAME)
! %RECORDFORMAT FDF(%INTEGER LINK, DSNUM, %C
! %BYTEINTEGER STATUS, ACCESSROUTE, VALID ACTION, CUR STATE, %C
! %BYTEINTEGER MODE OF USE, MODE, FILE ORG, DEV CODE, %C
! %BYTEINTEGER REC TYPE, FLAGS, LM, RM, %C
! %INTEGER ASVAR, AREC, RECSIZE, MINREC, MAXREC, MAXSIZE, %C
! LASTREC, CONAD, CURREC, CUR, END, TRANSFERS, DARECNUM, %C
! CURSIZE, DATASTART, %STRING (31) IDEN, %C
! %INTEGER KEYDESC0, KEYDESC1, RECSIZEDESC0, RECSIZEDESC1, %C
! %BYTE %INTEGER F77FLAG, F77FORM, F77ACCESS, F77STATUS, %C
! %INTEGER F77RECL, F77NREC, IDADDR, %C
! %BYTE %INTEGER F77BLANK, F77UFD, SPARE1, SPARE2)
RECORD FORMAT FINDF (STRING (31) FILE, INTEGER DIRNO, TYPE, STATUS)
RECORDFORMAT FRF(INTEGER CONAD, FILETYPE, DATASTART, DATEND, C
SIZE, RUP, EEP, APF, USERS, ARCH, C
STRING (6) TRAN, STRING (8) DATE, TIME, C
INTEGER COUNT, SPARE1, SPARE2)
RECORDFORMAT HF(INTEGER DATAEND, DATASTART, FILESIZE, FILETYPE, C
SUM, DATETIME, FORMAT, RECORDS)
! %RECORDFORMAT IOSTATF(%INTEGER INPOS, %STRING (15) INTMESS)
! %RECORDFORMAT ITF(%INTEGER INBASE, INLENGTH, INPOINTER, OUTBASE, %C
! OUTLENGTH, OUTPOINTER, OUTBUSY, OMWAITING, INTTWAITING, %C
! JNBASE, JNCUR, JNMAX, LASTFREE, SPARE5, SPARE6, SPARE7)
RECORDFORMAT LDF(INTEGER LINK, DISP, L, A, STRING (31) IDEN)
!LOAD DATA FORMAT (DATA ENTRY)
RECORDFORMAT LD7F(INTEGER LINK,REFLOC,STRING (31) IDEN)
RECORDFORMAT LEF(INTEGER LINK, LOC, STRING (31) IDEN)
! %RECORDFORMAT LLINFOF(%INTEGER TAB,GLA,ISTK) {Load level info held by LOADER}
RECORDFORMAT LNF(BYTEINTEGER TYPE, STRING (6) NAME, C
INTEGER REST, POINT, DR1)
!LONG NAME FORMAT
RECORDFORMAT LD13F(INTEGER LINK,A,DISP,LEN,REP,ADDR)
RECORDFORMAT PDF(INTEGER START, STRING (11) NAME, INTEGER HOLE, S5, S6, S7)
RECORDFORMAT PDHF(INTEGER DATAEND, DATASTART, SIZE, FILETYPE, C
SUM, DATETIME, ADIR, COUNT)
RECORDFORMAT PF(INTEGER DEST,SRCE,(INTEGER P1,P2,P3,P4,P5,P6 OR STRING (23) S))
RECORDFORMAT RF(INTEGER CONAD, FILETYPE, DATASTART, DATAEND)
RECORDFORMAT RRCF(INTEGER TYPE,CLASS,LONGINTEGER MASK,DR, INTEGER ZERO,XNB)
RECORDFORMAT SCTF (INTEGER HORIZ VECTOR BOUND, SCT RELST, C
IDENS ARRAY RELST, DT STAMP, C
STRING (15) FIXUP DATE, INTEGER ENDF)
! %RECORDFORMAT SIGDATAF(%INTEGER PC, LNB, CLASS, SUBCLASS, %C
! %INTEGERARRAY A(0 : 17))
RECORDFORMAT SNF(BYTEINTEGER TYPE, STRING (10) NAME, C
INTEGER POINT, DR1)
!SHORT NAME FORMAT
!
!***********************************************************************
!* *
!* Constants *
!* *
!***********************************************************************
!
CONSTBYTEINTEGERARRAY CHTOSYM (0 : 255) = C
0(10), 10, 0(15), 26, 0(5),
32, 33, 34, 35, 36, 37, 38, 39,
40, 41, 42, 43, 44, 45, 46, 47,
48, 49, 50, 51, 52, 53, 54, 55,
56, 57, 58, 59, 60, 61, 62, 63,
64, 65, 66, 67, 68, 69, 70, 71,
72, 73, 74, 75, 76, 77, 78, 79,
80, 81, 82, 83, 84, 85, 86, 87,
88, 89, 90, 91, 92, 93, 94, 95,
96, 97, 98, 99, 100, 101, 102, 103,
104, 105, 106, 107, 108, 109, 110, 111,
112, 113, 114, 115, 116, 117, 118, 119,
120, 121, 122, 123, 124, 125, 126, 0(129)
CONSTBYTEINTEGERARRAY HEX (0:15) = C
'0', '1', '2', '3', '4', '5', '6', '7',
'8', '9', 'A', 'B', 'C', 'D', 'E', 'F'
CONSTBYTEINTEGERARRAY SYMTOCH (0 : 255) = C
0(10), 10, 0, 12, 0(19),
32, 33, 34, 35, 36, 37, 38, 39,
40, 41, 42, 43, 44, 45, 46, 47,
48, 49, 50, 51, 52, 53, 54, 55,
56, 57, 58, 59, 60, 61, 62, 63,
64, 65, 66, 67, 68, 69, 70, 71,
72, 73, 74, 75, 76, 77, 78, 79,
80, 81, 82, 83, 84, 85, 86, 87,
88, 89, 90, 91, 92, 93, 94, 95,
96, 97, 98, 99, 100, 101, 102, 103,
104, 105, 106, 107, 108, 109, 110, 111,
112, 113, 114, 115, 116, 117, 118, 119,
120, 121, 122, 123, 124, 125, 126, 0,
0(10), 10, 0, 12, 0(19),
32, 33, 34, 35, 36, 37, 38, 39,
40, 41, 42, 43, 44, 45, 46, 47,
48, 49, 50, 51, 52, 53, 54, 55,
56, 57, 58, 59, 60, 61, 62, 63,
64, 65, 66, 67, 68, 69, 70, 71,
72, 73, 74, 75, 76, 77, 78, 79,
80, 81, 82, 83, 84, 85, 86, 87,
88, 89, 90, 91, 92, 93, 94, 95,
96, 97, 98, 99, 100, 101, 102, 103,
104, 105, 106, 107, 108, 109, 110, 111,
112, 113, 114, 115, 116, 117, 118, 119,
120, 121, 122, 123, 124, 125, 126, 0
!
CONSTINTEGER ABASEFILE = X'00800000'; !START OF BASEFILE AT SEG 32
CONSTINTEGER ABASEOBJ = X'00800020'; !ALLOWS FOR PD HEADER
CONSTINTEGER ALGOLIN = 2; !DEFAULT INPUT STREAM FOR ALGOL
CONSTINTEGER ALGOLOUT = 1; !DEFAULT OUTPUT STREAM FOR ALGOL
CONSTINTEGER APDATE = X'80C0003F'; !ADDR(PUBLIC_DATE)
CONSTINTEGER APTIME = X'80C0004B'; !ADDR(PUBLIC_TIME)
CONSTINTEGER ATRANS = X'80C0008F'; !ADDR OF ITOE AND ETOI TABLES
CONSTINTEGER AUSERS = X'80C0005B'; !ADDR
!OF WORD CONTAINING NO OF USERS
CONSTINTEGER INTERACTREASON = 0
CONSTINTEGER DSTARTREASON = 1
CONSTINTEGER BATCHREASON = 2
CONSTINTEGER TESTREASON=3
CONSTINTEGER DNEWSTARTREASON = 4
CONSTINTEGER FORKREASON = 5
!
! N.B. After CONSOLE has been initialised, INTERACT and DSTART are no
! longer distinguished. SSOWN_SSREASON will be changed from
! INTERACTREASON to DSTARTREASON, so a normal interactive process
! generally has SSOWN_SSREASON=DSTARTREASON. Similarly DNEWSTARTREASON
! and FORKREASON are changed to DSTARTREASON.
!
CONSTINTEGER CODE=2
CONSTINTEGER DATA=1
CONSTINTEGER DAYS70=25567; ! DAYS FROM JAN1 1900 TO JAN1 1970
CONSTINTEGER DEFCPL = 7200 ; !DEFAULT VALUE FOR CPULIMIT PER COMMAND
CONSTINTEGER EBCDICBIT=X'20'
CONSTINTEGER EM = 25
CONSTINTEGER FILESIZEALLOC = 4096; !SIZE IN BYTES OF FILE SIZE
! ALLOCATIONS
CONSTINTEGER IMAX = 2147483647; !LARGEST SIGNED POSITIVE INTEGER THAT
!CAN BE HELD IN A 32 BIT WORD.
!NEGATIVE NUMBERS DOWN TO -(IMAX-1) CAN
!BE HELD.
! IMAX is 2**31 - 1.
CONSTINTEGER K128 = X'20000'
CONSTINTEGER K16 = X'4000'
CONSTINTEGER K32 = X'8000'
CONSTINTEGER K4 = X'1000'
CONSTINTEGER K64 = X'10000'
CONSTINTEGER K8 = X'2000'
CONSTINTEGER KSHIFT = 10; !SHIFT BYTES TO KBYTES
IF NEWLOADER=0 THEN START
CONSTINTEGER LOADINPROGRESS=0
FINISH
CONST INTEGER ARRAY LONGINTLIM (0:7) = C
X'507FFFFF',X'FFFFFFFF',X'42FF0000',X'00000000', C
X'D0800000',X'00000000',X'C2000000',X'00000000'
! LONGLONGREAL(ADDR(LONGINTLIM(0))) is the largest %LONG %LONG %REAL
! value that can be converted to %LONG %INTEGER without overflow,
! viz. 2**63 - 1.
! LONGLONGREAL(ADDR(LONGINTLIM(4))) is the most negative
! %LONG %LONG %REAL value that can be converted to %LONG %INTEGER
! without overflow, viz. -2**63.
! Just for interest, 2**63 = 9,223,372,036,854,775,808.
CONSTINTEGER LVM = 32
CONSTINTEGER MACRO=4
! %CONSTINTEGER MAXCONF = 96; ! This MUST be one less than some prime number.
CONSTINTEGER MAXCPL=7200; !MAX VALUE FOR CPULIMIT COMMAND - SECONDS
! %CONSTINTEGER MAXFD = 48
CONSTINTEGER MAXITWIDTH = 132
CONSTINTEGER MAXPARMS = 63
! %CONSTINTEGER MAXPROMPTSIZE = 63; !CURRENT LIMIT IMPOSED BY COMMS
! MAXPROMPTSIZE must be consistent with declaration ofOWNSTRING
! PROMPTTEXT below.
CONSTINTEGER MAXROOT = 110; ! Number of command names, etc., used by PSYSMES.
CONSTINTEGER MAXRRC = 8; !MAXIMUM CONCURRENT RE-ROUTE CONTINGENCY REQUESTS
! %CONSTINTEGER MAXSIGLEVEL = 7
CONSTINTEGER MAXUSERSTACKSIZE = X'0003F000';!MAX SIZE OF USERSTACK = 252K
CONSTINTEGER MAXVREC = 65533; !MAX USER DATA IN V FORMAT RECORD
CONSTINTEGER MINITWIDTH = 20
CONSTINTEGER OPTFILESIZE = 4096; !SIZE OF OPTION FILE
! %CONSTINTEGER PCHARLIM = 615
CONSTINTEGER PRMKWDL = 20; ! Max length of keywords in parameters for commands.
! %CONSTINTEGER PRMLIM = 32; ! Max numbers of parameters for a command.
CONSTINTEGER RINGNEEDED=64
! %CONSTINTEGER RPLIM = 512
CONSTINTEGER SECSIN24HRS=86400; ! SECS IN DAY
CONSTINTEGER SEGSHIFT = 18; !SHIFT TO GIVE SEGMENTS
CONSTINTEGER SEGSIZE = X'40000'
CONSTINTEGER SSCHARFILETYPE = 3
CONSTINTEGER SSCORRUPTOBJFILETYPE=5
CONSTINTEGER SSDATAFILETYPE = 4
CONSTINTEGER SSFFORMAT = 1
CONSTINTEGER SSMAXWORKSIZE = X'200000';!MAX SIZE FOR WORKFILE
CONSTINTEGER SSOBJFILETYPE = 1
CONSTINTEGER SSOLDDIRFILETYPE = 2
CONSTINTEGER SSOPTFILETYPE = 9
CONSTINTEGER SSPDFILETYPE = 6
CONSTINTEGER SSPERMJOURNALSIZE = X'10000'
IF NEWLOADER=0 THEN START
CONSTINTEGER SSTEMPDIRSIZE = X'4000'; !SIZE OF TEMPORARY DIRECTORY
!MUST BE CONSISTENT WITH 'MAKEBASEFILE' COMMAND
FINISH
CONSTINTEGER SSTEMPJOURNALSIZE = X'10000'
CONSTINTEGER SSUFORMAT = 3
CONSTINTEGER SSVFORMAT = 2
CONSTINTEGER SYSPROCS=5; ! NO. OF SYSTEM PROCESSES ALWAYS RUNNING.
! They are DIRECT, VOLUMS, SPOOLR and MAILER.
CONSTINTEGER TEMPMARKER = X'40000000'
CONSTINTEGER UVM = 255
CONSTINTEGER VTEMPMARKER = X'20000000'
CONSTINTEGER XALIAS=8
!
CONSTINTEGERARRAY ACCEPT ALPHANUMERICS (0:7) = X'FFFFFFFF',
X'FFFF003F',
X'8000001F',
X'FFFFFFFF'(5)
CONSTINTEGERARRAY ACCEPT DIGITS (0:7) = X'FFFFFFFF',
X'FFFF003F',
X'FFFFFFFF'(6)
!
CONSTINTEGERNAME KIPS=X'80C000C0'; !KILO-INSTRUCTIONS PER SECOND
CONSTINTEGERNAME NUSERS=X'80C0005B'; !NO OF ACTIVE PROCESSES
IF FUNDS ON#0 THEN START
CONSTINTEGERNAME SCARCEWORD=X'80C00084'
FINISH
CONSTINTEGERNAME SECSFRMN=X'80C000A8'; !SECONDS FROM MIDNIGHT
CONSTINTEGERNAME SECSTOCLOSE=X'80C000AC'; !SECS TO CLOSEDOWN
!
CONSTLONGINTEGER DEFAULTPARM=X'0108000100000008';!STACK SIZE SET BIT
CONSTLONGINTEGER LONGONE=1
CONSTLONGINTEGER SECS70=X'0000000083AA7E80';! SECS DITTOM
!
CONSTLONGREALARRAY TENPOWERS (0:20) = 1,10,100,1000,1@4,1@5,1@6,
1@7,1@8,1@9,1@10,1@11,1@12,
1@13,1@14,1@15,1@16,1@17,
1@18,1@19,1@20
!
CONSTSTRING (21) BASEDIR = "SUBSYS.SYSTEM_BASEDIR"; ! If the loader is compiled separately, the
! constant appears there, and the two must
! have the same value.
CONSTSTRING (21) BMESSAGE = "SUBSYS.BMESSAGE"
CONSTSTRING (9) COMMANDPROMPT = "
Command:"
CONSTSTRING (15) DEFBASE = "S#DISC.SITEX380"
CONSTSTRING (15) STUDBASE = "S#DISC.SITEX400"
CONSTSTRING (21) FMESSAGE = "SUBSYS.FMESSAGE"
CONSTSTRING (4) ITFILENAME = "T#IT"
CONSTSTRING (4) LAST = "}{|~"; !UNLIKELY PATTERN
CONSTSTRING (12) SPOOLERCFILE = "SPOOLR.CFILE"
CONSTSTRING (10) SSPERMJNAME = "SS#JOURNAL"
CONSTSTRING (5) SSTEMPJNAME = "T#JN"
!
CONSTSTRING (10)ARRAY LT (0 : 10) = C
" !???! ", " IMP ", " FORTRAN ", "IMPS ", C
" ASMBLR ", " ALGOL(E) ", " OPTCODE ", C
" PASCAL ", " SIMULA ", " BCPL ", "FORTRAN 77"
!
! NEW PARMS FOR FORTRAN 77 ADDED AUGUST 1983 - MIKE BROWN
!
CONSTSTRING (10)ARRAY PARMS (0:MAXPARMS) = C
"", "I8", "L8", "R8", C {! COMREG(28)
"OPTEXT", "NOCOMMENTS", "NOWARNINGS", "STRICT", C
"MAXDICT", "", "", "", C
"", "", "MINSTACK", "", C
"", "", "", "", C
"OPT1", "OPT2", "OPT3", "OPT4", C
"", "", "", "", C
"", "", "", "", C
"QUOTES", "NOLIST", "NODIAG", "STACK", C {! COMREG(27)
"NOCHECK", "NOARRAY", "NOTRACE", "PROFILE", C
"IMPS", "INHIBIOF", "ZERO", "XREF", C
"LABELS", "LET", "CODE", "ATTR", C
"OPT", "MAP", "DEBUG", "FIXED", C
"DYNAMIC", "", "EBCDIC", "NOLINE", C
"", "", "PARMZ", "PARMY", C
"PARMX", "MISMATCH", "", ""
CONSTSTRING (12)ARRAY ROOTNAME (1 : MAXROOT) = C
"ACCEPT","TELL","ARCHIVE","ASSEMBLE","CHERISH",
"CLOSE","CONCAT","CONNECT","COPY","CREATEFILE",
"DELETEJOB","DESTROY","DETACH","DISCONNECT","INSERTMACRO",
"ANALYSE","SMADDR","FINDFILE","FINDJOB","FILES",
"FORTE","HAZARD","IMP","IMPS","INSERT",
"CLOSESM","DISCARD","LINK","LIST","OFFER",
"OPEN","PERMIT","CHANGESM","PRELINK","TIDYDIR",
"REMOVE","REMOVELIB","RENAME","RUN","SEND",
"NEWDIRECTORY","CLEAR","DEFINE","NEWSMFILE","EXTEND",
"OBEY","Load","ALGOL","OPENSQ","CLOSESQ","NEWPDFILE",
"PRELOAD","CPULIMIT","CONVERT","USERS",
"QUEUES","METER","RECALL","EDIT",
"PARM","NEWGEN","DELIVER","PASSWORDS","PROJECT",
"RESTORE","ARCHLIST","OPTION","HELP","SUGGESTION","ALERT",
"SELECTINPUT","SELECTOUTPUT","ECCE","SHOW","RECAP","SETMODE",
"ALIAS","LOOK","OPENDA","CLOSEDA","WRITEDA","READDA","WRITESQ","READSQ",
"READLSQ","CALL","CLOSEF","MESSAGES","PUTSQ","GETSQ","REWINDSQ",
"PUTDA","GETDA","TIDYDIR","RELAY","DOCUMENTS","DELETEDOC",
"PASCAL","SIMULA","DEFINEMT","DONATEFUNDS","FORT77","IMP80",
"IBMIMP","FROMSTRING","GECCE","DATASPACE","ALIASENTRY","LOADPARM",
"IOPT"
!
!***********************************************************************
!* *
!* DIRECTOR and SUPERVISOR Routine/fn/map spec *
!* *
!***********************************************************************
!
EXTERNALINTEGERFNSPEC X2{DTRANSFER}(STRING (31) FILEOWNER, PROCOWNER, OLDNAME, NEWNAME, C
INTEGER OLDFSYS, NEWFSYS, TYPE)
EXTERNALINTEGERFNSPEC X3{DASYNCINH}(INTEGER MODE, ATW)
EXTERNALINTEGERFNSPEC X4{DCHACCESS}(STRING (6) USER, C
STRING (11) FILE, INTEGER FSYS, NEWMODE)
EXTERNALINTEGERFNSPEC X5{DCHSIZE}(STRING (6) USER, C
STRING (11) FILE, INTEGER FSYS, NEWSIZE KB)
EXTERNALINTEGERFNSPEC X6{DCLEARINTMESSAGE}
EXTERNALINTEGERFNSPEC X7{DCONNECT}(STRING (6) USER, C
STRING (11) FILE, INTEGER FSYS, MODE, APF, C
INTEGERNAME SEG, GAP)
EXTERNALINTEGERFNSPEC DCPUTIME
EXTERNALINTEGERFNSPEC X8{DCREATE}(STRING (6) USER, C
STRING (11) FILE, INTEGER FSYS, NKB, TYPE)
EXTERNALINTEGERFNSPEC X9{DDESTROY}(STRING (6) USER, C
STRING (11) FILE, STRING (6) DATE, INTEGER FSYS, TYPE)
EXTERNALINTEGERFNSPEC X10{DDISABLETERMINALSTREAM1}( C
INTEGERNAME CURSOR, INTEGER STREAM, MODE)
EXTERNALINTEGERFNSPEC X11{DDISCONNECT}(STRING (6) USER, C
STRING (11) FILE, INTEGER FSYS, DESTROYMODE)
EXTERNALINTEGERFNSPEC X12{DENABLETERMINALSTREAM}( C
INTEGER STREAM, MODE, LEVEL, ADDRESS, LEN, CURSOR)
EXTERNALINTEGERFNSPEC X14{DFINFO}(STRING (6) USER, C
STRING (11) FILE, INTEGER FSYS, ADDR)
EXTERNALINTEGERFNSPEC X15{DFSTATUS}(STRING (6) USER, C
STRING (11) FILE, INTEGER FSYS, ACT, VALUE)
EXTERNALINTEGERFNSPEC X16{DMESSAGE2}(STRING (6) USER, C
INTEGERNAME LEN, INTEGER ACT, INVOC, FSYS, ADR)
EXTERNALINTEGERFNSPEC X17{DNEWGEN}(STRING (6) USER, C
STRING (11) FILE, NFILE, INTEGER FSYS)
EXTERNALINTEGERFNSPEC X18{DNEWOUTWARDCALL}( C
INTEGER ACR, EMAS, SEG, DR0, DR1, C
INTEGERNAME I, J)
EXTERNALINTEGERFNSPEC X19{DOFFER}(STRING (6) USER, TO, C
STRING (11) FILE, INTEGER FSYS)
EXTERNALINTEGERFNSPEC X22{DPERMISSION}( C
STRING (6) OWNER, USER, STRING (8) DATE, C
STRING (11) FILE, INTEGER FSYS, TYPE, AD)
EXTERNALINTEGERFNSPEC X24{DRENAME}(STRING (6) USER, C
STRING (11) OLD, NEW, INTEGER FSYS)
EXTERNALINTEGERFNSPEC X27{DSETIC}(INTEGER KI)
EXTERNALINTEGERFNSPEC X28{DSFI}(STRING (6) USER, C
INTEGER FSYS, TYPE, SET, ADR)
EXTERNALINTEGERFNSPEC X29{DSPOOL}(RECORD (PF)NAME P,INTEGER LEN,ADR)
EXTERNALINTEGERFNSPEC X31{PRIMECONTINGENCY}(ROUTINE R)
EXTERNALINTEGERFNSPEC X32{READID}(INTEGER AD)
EXTERNALINTEGERFNSPEC X33{REQUESTINPUT}(INTEGER T, AD)
EXTERNALINTEGERFNSPEC X34{REQUESTOUTPUT}(INTEGER T, AD)
EXTERNALSTRINGFNSPEC X44{DERRS} (INTEGER N)
!
! The next 2 routines are actually synonyms for DSTOP and DPRINTSTRING
! which have been renamed to ensure that they head the system call table regardless of
! any other changes. Thus we can guarantee a controlled stop when we find
! a shareable basegla with a mismatching system call table.
EXTERNALROUTINESPEC AAASTOP(INTEGER I) {Synonym for DSTOP}
EXTERNALROUTINESPEC AABPRINTSTRING(STRING (255) S) {Synonym for DPRINTSTRING}
EXTERNALROUTINESPEC X1{CHANGECONTEXT}
EXTERNALROUTINESPEC X20{DOPER}(INTEGER OPERNO, STRING (255) S)
EXTERNALROUTINESPEC X21{DOPERPROMPT}(INTEGER OPERNO, C
STRING (23) PROMPT)
EXTERNALROUTINESPEC X23{DPOFF}(RECORD (PF)NAME P)
! %EXTERNALROUTINESPEC DPRINTSTRING(%STRING(255) S)
EXTERNALROUTINESPEC X26{DRESUME}(INTEGER LNB, PC, AD)
EXTERNALROUTINESPEC X30{DSTOP}(INTEGER R)
!
!***********************************************************************
!* *
!* %SYSTEM Routine/fn/map spec *
!* *
!***********************************************************************
!
SYSTEMINTEGERFNSPEC ALLOW COMMAND (STRING (31) COMMAND)
SYSTEMINTEGERFNSPEC ALLOW CONNECT (STRING (6) USER, STRING (11) FILE)
SYSTEMINTEGERFNSPEC CURSTACK
SYSTEMINTEGERFNSPEC LAST CHAR COPY
SYSTEMINTEGERFNSPEC MASTERCHARIN(INTEGER MODE)
!
IF NEWLOADER#0 THEN START
SYSTEM INTEGER FN SPEC FIND C
(STRING (31) ENTRY, INTEGER NAME NREC, INTEGER ADDR, TYPE)
EXTERNAL ROUTINE SPEC PRELOAD (STRING (255) FILE)
SYSTEMLONGINTEGERFNSPEC LOADENTITY(STRING (31) ENTRY, INTEGERNAME TYPE,FLAG, INTEGER LOADLEVEL)
SYSTEMLONGINTEGERFNSPEC LOADEP(STRING (31) ENTRY, INTEGERNAME TYPE,FLAG, INTEGER LOADLEVEL)
SYSTEMLONGINTEGERFNSPEC LOOKLOADED(STRING (31) ENTRY, INTEGERNAME TYPE)
SYSTEM ROUTINE SPEC BDIRLIST
FINISH
!
SYSTEMROUTINESPEC ENTER(INTEGER MODE, DR0, DR1, STRING (255) PARAM)
SYSTEMROUTINESPEC EXAMINEMACRO(STRINGNAME M, C, C
INTEGER B, A, S, INTEGERNAME FLAG)
IF NEWLOADER=0 THEN START
SYSTEMROUTINESPEC FINDENTRY(STRING (32) ENTRY, C
INTEGER TYPE, DAD, STRINGNAME FILE, C
INTEGERNAME DR0, DR1, FLAG) {Old loader}
FINISH
SYSTEMROUTINESPEC FDIAG (INTEGER LNB, PC, MODE, DIAG, ASIZE, C
INTEGER NAME FIRST, NEWLNB)
SYSTEMROUTINESPEC INITCLIVARS
SYSTEMROUTINESPEC INITDYNAMICREFS
SYSTEMROUTINESPEC INITIALISE
IF NEWLOADER#0 THEN START
SYSTEMROUTINESPEC INITLOADER(INTEGERNAME FLAG)
FINISH
IF NEWLOADER=0 THEN START
SYSTEMROUTINESPEC INUST {Old loader}
SYSTEMROUTINESPEC LOAD(STRING (31) ENTRY, INTEGER TYPE, INTEGERNAME FLAG) {Old loader}
FINISH
SYSTEMROUTINESPEC MACOPEN
SYSTEMROUTINESPEC MAGIO(INTEGER AFD,OP,INTEGERNAME FLAG)
IF NEWLOADER=0 THEN START
SYSTEMROUTINESPEC MODDIRFILE(INTEGER EP, STRING (31) DIRFILE, C
STRING (32) ENTRY, FILENAME, C
INTEGER TYPE, DR0, DR1, INTEGERNAME FLAG)
FINISH
SYSTEMROUTINESPEC SUPPLYDATADESCRIPTOR(RECORD (DRF)NAME DR)
IF NEWLOADER=0 THEN START
SYSTEMROUTINESPEC UNLOAD(INTEGER CURGLA) {Old loader}
FINISH
IF NEWLOADER#0 THEN START
SYSTEMROUTINESPEC UNLOAD2(INTEGER LOADLEVEL,FAIL)
FINISH
!
!***********************************************************************
!* *
!* External/internal routine/fn/map specs *
!* *
!***********************************************************************
!
IF FUNDS ON#0 THEN START
EXTERNALROUTINESPEC FUNDS(STRING (255) S)
FINISH
! %EXTERNALROUTINESPEC LOADDUMP(%STRING(255) S)
EXTERNALROUTINESPEC OBEYJOB(STRING (255) S)
!
INTEGERFNSPEC CHECKFILENAME(STRING (31) FILE, INTEGER TYPE)
INTEGERFNSPEC CHECKCOMMAND(STRING (255) S)
INTEGERFNSPEC CLOSE(INTEGER AFD)
INTEGERFNSPEC CURRENT PACKED DT
INTEGERFNSPEC DEVCODE(STRING (16) S)
INTEGERFNSPEC DIRTOSS(INTEGER FLAG)
INTEGERFNSPEC FINDFN (STRING (31) FILE, INTEGERNAME POS)
INTEGERFNSPEC GETSPACE(INTEGER BYTES)
INTEGERFNSPEC INSTREAM
INTEGERFNSPEC IOCP(INTEGER EP, PARM)
INTEGERFNSPEC KINS
INTEGERFNSPEC OPEN(INTEGER AFD, MODE)
INTEGERFNSPEC OUTPOS
INTEGERFNSPEC OUTSTREAM
INTEGERFNSPEC PACKDATEANDTIME(STRING (8) DATE, TIME)
INTEGERFNSPEC PAGETURNS
INTEGERFNSPEC PSTOI(STRING (63) S)
INTEGERFNSPEC ROUNDUP (INTEGER N, ROUND)
INTEGERFNSPEC STARTSWITH (STRING NAME A, STRING (255) B, INTEGER CHOP)
INTEGERFNSPEC STOREMATCH (INTEGER L, A1, A2)
INTEGERFNSPEC TRAIL SPACES (INTEGER LINE END, LINE START, TRANS)
INTEGERFNSPEC UINFI(INTEGER I)
!
LONGREALFNSPEC CPUTIME
!
ROUTINESPEC ADDTOJOBOUTPUT(INTEGER START, LEN, INTEGERNAME FLAG)
ROUTINESPEC ALLOW INTERRUPTS
ROUTINESPEC BATCHSTOP(INTEGER REASON)
ROUTINESPEC BCI
ROUTINESPEC CAST OUT (STRING NAME PSTR)
ROUTINESPEC CHANGEFILESIZE(STRING (31)FILE, INTEGER NEWSIZE, C
INTEGERNAME FLAG)
ROUTINESPEC CHANGEACCESS(STRING (31) FILE, INTEGER MODE, INTEGERNAME FLAG)
ROUTINESPEC CHOPLDR (STRING NAME A, INTEGER I)
ROUTINESPEC CONNECT(STRING (31) FILE, C
INTEGER MODE, HOLE, PROT, RECORD (RF)NAME R, INTEGERNAME FLAG)
ROUTINESPEC CONSOLE(INTEGER EP, INTEGERNAME P1, P2)
ROUTINESPEC CONTROL
ROUTINESPEC DECWRITE2(INTEGER VALUE,AD)
ROUTINESPEC DEFINE(INTEGER CHAN, STRING (31) IDEN, C
INTEGERNAME AFD, FLAG)
ROUTINESPEC DEFINFO(INTEGER CHAN,STRINGNAME FILE,C
INTEGERNAME STATUS)
ROUTINESPEC DESTROY(STRING (31) FILE, INTEGERNAME FLAG)
ROUTINESPEC DIRTRAP (INTEGER CLASS, SUBCLASS)
ROUTINESPEC DISCONNECT(STRING (31) FILE, INTEGERNAME FLAG)
ROUTINESPEC ETOI(INTEGER AD, L)
ROUTINESPEC EXTEND(RECORD (FDF)NAME R, INTEGERNAME F)
ROUTINESPEC FILL(INTEGER LENGTH, FROM, FILLER)
ROUTINESPEC FINFO(STRING (31) FILE, INTEGER MODE, C
RECORD (FRF)NAME FR, INTEGERNAME FLAG)
ROUTINESPEC FPRINTFL(LONGREAL X, INTEGER N, T)
ROUTINESPEC FSTATUS(STRING (31)FILE, INTEGER ACT, VALUE C
INTEGERNAME FLAG)
ROUTINESPEC HALT
ROUTINESPEC HASHCOMMAND(STRING (255) COM, PARAM)
ROUTINESPEC INITJOURNAL
ROUTINESPEC ITOE(INTEGER AD, L)
ROUTINESPEC KDATE (INTEGER NAME D, M, Y, INTEGER K)
ROUTINESPEC METER(STRING (255) S)
IF NEWLOADER#0 THEN START
ROUTINESPEC MODDIRFILE(INTEGER EP, STRING (31) DIRFILE, C
STRING (32) ENTRY, FILENAME, C
INTEGER TYPE, DR0, DR1, INTEGERNAME FLAG)
FINISH
ROUTINESPEC MODPDFILE(INTEGER EP, C
STRING (31) PDFILE, STRING (11) MEMBER, C
STRING (31) INFILE, INTEGERNAME FLAG)
ROUTINESPEC MOVE(INTEGER LENGTH, FROM, TO)
ROUTINESPEC NCODE(INTEGER S, F, CA)
ROUTINESPEC NDIAG(INTEGER A, B, C, D)
IF NOTES ON#0 THEN START
ROUTINESPEC NOTE (STRING (255) S)
FINISH
ROUTINESPEC OUTFILE(STRING (31) FILE, INTEGER FILESIZE, HOLE, PROT, C
INTEGERNAME CONAD, FLAG)
ROUTINESPEC PHEX(INTEGER I)
ROUTINESPEC PRINTMESS(INTEGER N)
ROUTINESPEC PROMPT(STRING (255) S)
ROUTINESPEC PSYSMES(INTEGER ROOT, FLAG)
ROUTINESPEC RDISCON (STRING (31) FILE, INTEGER NAME F)
ROUTINESPEC SENDFILE(STRING (31) FILE, C
STRING (16) DEVICE, STRING (24) NAME, C
INTEGER COPIES, FORMS, INTEGERNAME FLAG)
ROUTINESPEC SET IO DEFAULT (INTEGER NAME D, INTEGER I)
ROUTINESPEC SETPAR(STRING (255) S)
ROUTINESPEC SETUSE(STRING (31) FILE, INTEGER MODE, VALUE)
ROUTINESPEC SETWORK(INTEGERNAME AD, FLAG)
ROUTINESPEC SIGNAL(INTEGER EP, P1, P2, INTEGERNAME FLAG)
ROUTINESPEC SSERR(INTEGER N)
ROUTINESPEC SSMESS(INTEGER N)
ROUTINESPEC TIDYFILES
ROUTINESPEC TOJOURNAL(INTEGER A, L)
ROUTINESPEC TRIM(STRING (31) FILE, INTEGERNAME FLAG)
ROUTINESPEC UCTRANSLATE (INTEGER ADDR,L)
ROUTINESPEC USEOPTIONS
ROUTINESPEC ZSTOP(STRING (255) S)
!
STRINGFNSPEC CONFILE (INTEGER AD)
STRINGFNSPEC DATE
STRINGFNSPEC DEVNAME(INTEGER CODE)
STRINGFNSPEC FAILUREMESSAGE(INTEGER MESS)
STRING (8)FNSPEC HTOS(INTEGER N, P)
STRINGFNSPEC ITOS(INTEGER N)
STRINGFNSPEC NEXT TEMP
STRINGFNSPEC SPAR(INTEGER N)
STRINGFNSPEC SUBSTRING (STRINGNAME S, INTEGER I, J)
STRINGFNSPEC TIME
STRINGFNSPEC UINFS(INTEGER N)
STRING (8)FNSPEC UNPACK TIME (INTEGER P)
STRING (8)FNSPEC UNPACK DATE(INTEGER P)
!
STRING (255)MAPSPEC GCL (INTEGER NAME BLC, FLAG)
!
!***********************************************************************
!* *
!* Own variables *
!* *
!***********************************************************************
!
! %OWNBYTEINTEGERARRAY INBUFF (0 : 255)
! %OWNBYTEINTEGERARRAY INTMESS(1 : 9) = %C
! 10,10,'I','N','T',':','A',10,10
! %OWNBYTEINTEGERARRAY OUTBUFF (0 : 133); !ALLOW ROOM FOR ADDED NL
! %OWNBYTEINTEGERARRAY PARSTRING(0 : 255)
! %OWNBYTEINTEGERARRAY PCHAR (0:PCHARLIM-1)
! %OWNBYTEINTEGERARRAY PINDEX (1 : PRMLIM); !MAX LIKELY NO OF PARAMS
! %OWNBYTEINTEGERARRAY RPS (0:RPLIM)
! !
! %OWNINTEGER ABGLA; !START OF BGLA
! %OWNINTEGER ACTIVE=0; ! CHECKS FOR LOOPS
! %OWNINTEGER ADCSL
! %OWNINTEGER AIOSTAT
! %OWNINTEGER AITBUFFER
! %OWNINTEGER ALLCOMMAND
! %OWNINTEGER ALLCONNECT = 1; ! Hold off checking until routine can be loaded.
! %OWNINTEGER APAGETURNS
! %OWNINTEGER BCIBLANKS = 0
! %OWNINTEGER BCIFREE = 0
! %OWNINTEGER BCIOLDEST = 0
! %OWNINTEGER BOPMESSSTART
! %OWNINTEGER BOPMESSLEN; !FOR BROADCAST OPER MESSAGES
! %OWNINTEGER BROADCASTFILEBASE
! %OWNINTEGER CALLBCISTARTED
! %OWNINTEGER CKBITS = X'6A202020'; ! Bits set for displacement 1,2,4,6,10,18,26.
! %OWNINTEGER CONTROLMODE
! %OWNINTEGER CURFSYS
! %OWNINTEGER CURLENGTH = 0
! %OWNINTEGER CURPAR
! %OWNINTEGER CURRKI
! %OWNINTEGER DATAECHO; !FOR INPUT ECHO IN OBEY AND BATCH
! %OWNINTEGER DELIVERYCHANGED
! %OWNINTEGER DEVARRAYBASE
! %OWNINTEGER DFDFINSDC = 0
! %OWNINTEGER DFDFOUTSDC = 0
! %OWNINTEGER FDLEVEL
! %OWNINTEGER FEPMODE = OPTEXT
! %OWNINTEGER FIRST; ! 1 while printing first stack frame,
! ! some other value for subsequent frames.
! %OWNINTEGER GCSTARTED {in GETCOMMAND}
! %OWNINTEGER GLOBPTR
! %OWNINTEGER GLSL
! %OWNINTEGER ICRSA = 0
! %OWNINTEGER ICRSE
! %OWNINTEGER INHIBITMESSAGES
! %OWNINTEGER INHIBITPSYSMES
! %OWNINTEGER INHIBITSPOOLER
! %OWNINTEGER INITFIO1
! %OWNINTEGER INITFIO2
! %OWNINTEGER INTINPROGRESS = 1
! %OWNINTEGER INTQ
! %OWNINTEGER ITINLENGTH
! %OWNINTEGER ITOUTLENGTH
! %OWNINTEGER LASTEP = 0
! %OWNINTEGER LASTMASTERREADCH
! %OWNINTEGER LASTSWEP = 0
! %OWNINTEGER LATEST; !IMPOSSIBLE VALUE {What is?}
! %OWNINTEGER LOCATE PRMS
! %OWNINTEGER MAXDEVARRAY
! %OWNINTEGER MTCLOSEMODE = 8; !FULL UNLOAD BY DEFAULT
! %OWNINTEGER OLDPAGETURNS
! %OWNINTEGER OPERNO; ! NO OF OPER IN USE. INITIAL VALUE MUST BE VALID FOR 'OR'ING FOR DPON.
! %OWNINTEGER OPMODE = OPTEXT
! %OWNINTEGER PCOUNT
! %OWNINTEGER PMAP
! %OWNINTEGER QPARMF
! %OWNINTEGER RCHLIM = 0
! %OWNINTEGER RCLB = -1
! %OWNINTEGER RCLF = 0
! %OWNINTEGER RPTR = 0
! %OWNINTEGER RRCBASE
! %OWNINTEGER RRCTOP
! %OWNINTEGER RSYMLIM = 0
! %OWNINTEGER SAVEIDPOINTER
! %OWNINTEGER SEQ = 0 {in NEXTTEMP}
! %OWNINTEGER SESSKIC
! %OWNINTEGER SSADIRINF
! %OWNINTEGER SSARRAYDIAG
! %OWNINTEGER SSDATAECHO
! %OWNINTEGER SSINITWORKSIZE
! %OWNINTEGER SSINVOCATION
! %OWNINTEGER SSITWIDTH
! %OWNINTEGER SSJOURNAL
! %OWNINTEGER SSLASTDFN; ! Last non-zero director error number translated by DIRTOSS.
! %OWNINTEGER SSLDELIM
! %OWNINTEGER SSMONITOR
! %OWNINTEGER SSNOBLANKLINES; !WHEN SET TO 1 SUPPRESS BLANK LINES ON I.T.
! %OWNINTEGER SSNOTE
! %OWNINTEGER SSOPERNO; !NO OF OPER STARTED FROM
! %OWNINTEGER SSOWNFSYS; !FSYS FOR THIS USER
! %OWNINTEGER SSRDELIM
! %OWNINTEGER SSREASON; !REASON FOR STARTING
! ! 0=INTERACTIVE
! !1=STARTED FROM OPER. 2=BATCH
! %OWNINTEGER SSTERMINALTYPE
! %OWNINTEGER SSTTHIDE = 0, SSTTACT = 0, SSTTKN = 0; ! Used for INT:K control - must stay
! ! together and in this order.
! %OWNINTEGER STARTSECS
! %OWNINTEGER TIDYFSTARTED=0
! %OWNINTEGER TOPFD = 1; ! HIGHEST FD USED SO FAR THIS SESSION.
! %OWNINTEGER TTYPE
! %OWNINTEGER UNASSPATTERN = X'81'
! %OWNINTEGER USEOPTSTARTED=0
! !
! %OWNINTEGERARRAY GL IOCP PARM (1:3)
! %OWNINTEGERARRAY GLOBAD(0:20)
! %OWNINTEGERARRAY PAPTR (1:PRMLIM)
! %OWNINTEGERARRAY SAVEIDATA (-2:20,0:3)
! %OWNINTEGERARRAY SSFDMAP (1:99)
! !
! %OWNINTEGERNAME ICREVS
! %OWNINTEGERNAME KINSTRS
! %OWNINTEGERNAME PREVIC
! %OWNINTEGERNAME RCODE; !POINTS TO COMREG(24) RETURN CODE
! !
! %OWNLONGINTEGER SSINITPARMS; !INITIAL PARMS OPTION
! !
! %OWNLONGREAL LASTCPUTIME = -1000000; ! Ensures X27{DSETIC} called first time. { in BCI}
! %OWNLONGREAL OLDCPUTIME
! !
! %OWNRECORD(CONFF)%ARRAY CONF (0 : MAXCONF)
! %OWNRECORD(FDF)%ARRAY FD (1 : MAXFD)
! %OWNRECORD(SIGDATAF)%ARRAY SIGDATA (1 : MAXSIGLEVEL)
! !
! %OWNRECORD(FDF)%NAME INF
! %OWNRECORD(IOSTATF)%NAME IOSTAT; !STATUS OF INPUT FROM FEP
! %OWNRECORD(ITF)%NAME IT
! %OWNRECORD(FDF)%NAME OUTF
! !
! %OWNSTRING(1) ACTD = "0"
! %OWNSTRING(31) BASEFILE
! %OWNSTRING(8) BOUTPUTDEVICE
! %OWNSTRING(255) CLICOMM
! %OWNSTRING(255) CLIPARM
! %OWNSTRING(255) CSL; ! CONTROL STREAM LINE
! %OWNSTRING(6) CURFOWNER
! %OWNSTRING(18) CURFILE
! %OWNSTRING(11) CURFNAME
! %OWNSTRING(11) CURMEMBER
! %OWNSTRING(255) EP6S; !STRING FOR ENTRY POINT 6 -
! ! COMPILER INPUT
! %OWNSTRING(11) HOLDAVD
! %OWNSTRING(50) LASTNAME=""
! %OWNSTRING(1) NULP = ""
! %OWNSTRING(31) PDPREFIX=""
! %OWNSTRING(MAXPROMPTSIZE) PROMPTTEXT
! %OWNSTRING(255) RCLH
! %OWNSTRING(18) SESSMONFILE
! %OWNSTRING(11) SSCFAULTS; !COMPILER FAULTS OPTION
! %OWNSTRING(8) SSSTARTTIME
! %OWNSTRING(3) SSSUFFIX; !ADDED TO NAMES OF TEMP FILES
! %OWNSTRING(31) STARTFILE
!
!
!***********************************************************************
!* *
!* Extrinsic variables *
!* *
!***********************************************************************
!
IF NEWLOADER#0 THEN START
! %EXTRINSICINTEGER LOADINPROGRESS
! %EXTRINSICINTEGER LOADLEVEL
! %EXTRINSICINTEGER MONFILEAD
! %EXTRINSICINTEGER MONFILETOP
! %EXTRINSICINTEGER NOWARNINGS {1 if no loader warning messages to be generated}
! %EXTRINSICINTEGER PERMISTK
! %EXTRINSICINTEGER USTB
!
! %EXTRINSICRECORD(LLINFOF)%ARRAY LLINFO(-1:31) {perm ISTK field can be updated by OPTION}
!
! %EXTRINSICSTRING(31) MONFILE
FINISH
!
!***********************************************************************
!* *
!* External variables *
!* *
!***********************************************************************
!
! %EXTERNALINTEGER DIRDISCON = 1; !SET TO 1 WHEN DIRECTORY DISCONNECTED
! %EXTERNALINTEGER INDEFAULT
! %EXTERNALINTEGER INITSTACKSIZE
! %EXTERNALINTEGER LOADMONITOR
! %EXTERNALINTEGER OUTDEFAULT
IF FUNDS ON#0 THEN START
! %EXTERNALINTEGER SCARCITYFOUND; ! **** Used by SEPRTNS but not by LOAD****
FINISH
! %EXTERNALINTEGER SSADEFOPT; !ADDRESS OF DEFAULT OPTION FILE IN BASEFILE
IF NEWLOADER=0 THEN START
! %EXTERNALINTEGER SSASESSDIR
FINISH
! %EXTERNALINTEGER SSASTACKSIZE
IF NEWLOADER=0 THEN START
! %EXTERNALINTEGER SSATEMPDIR; !ADDRESS OF TEMPORARY DIRECTORY
FINISH
! %EXTERNALINTEGER SSAUXDR0
! %EXTERNALINTEGER SSAUXDR1
! %EXTERNALINTEGER SSCURAUX
! %EXTERNALINTEGER SSCURBGLA; !CURRENT TOP OF BGLA
EXTERNALINTEGER SSDATELINKED; !THIS GETS FILLED IN BY THE
!COMMAND 'MAKEBASEFILE' WITH THE LINK DATE OF THE CURRENT
!SYSTEM CALL TABLE
IF NEWLOADER#0 THEN START
! %EXTERNALINTEGER SSDIRAD
FINISH
! %EXTERNALINTEGER SSINHIBIT, SSINTCOUNT; !THESE TWO MUST STAY TOGETHER
! %EXTERNALINTEGER SSMAXAUX
! %EXTERNALINTEGER SSMAXBGLA; !LAST BYTE OF BGLA
! %EXTERNALINTEGER SSMAXFSIZE; !MAXIMUM FILE SIZE ALLOWED
! %EXTERNALINTEGER SSOPENUSED
IF NEWLOADER=0 THEN START
! %EXTERNALINTEGER SSSCCOUNT
! %EXTERNALINTEGER SSSCTABLE; !ADDRESS OF SCTABLE
! %EXTERNALINTEGER SSUSTACKUSED
FINISH
! %EXTERNALINTEGER SSUSTACKSIZE
! %EXTERNALINTEGER STOPPING
! %EXTERNALINTEGER TEMPAVDSET; !USED BY PLU PACKAGES
!
! %EXTERNALINTEGERARRAY SSCOMREG(0:60)
!
! %EXTERNALSTRING(11) AVD; ! Active directory. **** N.B. Also used by SEPRTNS ****
! %EXTERNALSTRING(31) OPTIONSFILE = "SS#OPT"
! %EXTERNALSTRING(40) SSFNAME; !NAME FOR PSYSMES
! %EXTERNALSTRING(6) SSOWNER
!
!***********************************************************************
!* *
!* End of declarations *
!* *
!***********************************************************************
!
!*
! - END OF GLOBAL TEXT ]
!
SYSTEM ROUTINE SETSESSIONMONITOR (STRING (18) FILE)
SSOWN_SESSMONFILE <- FILE
END ; ! of SETSESSIONMONITOR.
!
! [ START OF HASH CODE -
!
IF STUDENTSS#0 THEN START
ROUTINE CXDUMP (INTEGER START, N, DF)
END
SYSTEM ROUTINE NCODE (INTEGER START, FINISH, CA)
END
SYSTEM ROUTINE DUMP (INTEGER START, LEN)
END
SYSTEM ROUTINE HASHCOMMAND (STRING (255) COM, PAR)
END
FINISH ELSE START
ROUTINE CXDUMP(INTEGER START, N, DF)
! DF=1 for a character dump, DF=2 for a hex dump, DF=3 for both.
STRING (64) WKS
INTEGER I, J, PERLINE, COUNT, BYTES, STAGE, FILLER
IF DF=1 THEN START
IF SSOWN_SSITWIDTH > 80 THEN PERLINE = 64 ELSE PERLINE = 32
BYTES = PERLINE
FILLER = ' '
FINISH ELSE IF DF=2 THEN START
IF SSOWN_SSITWIDTH > 90 THEN PERLINE = 8 ELSE PERLINE = 4
BYTES = PERLINE*4
! FILLER not used.
FINISH ELSE START
PERLINE = 8
BYTES = 32
FILLER = '_'
FINISH
! ROUTINE ACCEPTS PARAMS AS START,N OR AS START,LENGTH
IF N<START OR START<0<N THEN START ;!MEANS START,LENGTH
N=(N+(START&X'7FFFFFFF')-1) ! (START&X'80000000')
FINISH
START = START & (-4)
N = (N&(-4)) + 3
RETURN IF N < START
COUNT = N-START
!!
!! VALIDATE CODE AREA TO BE DUMPED
!!
I = X'18000000'!COUNT
*LDTB_I
*LDA_START
*VAL_(LNB +1)
*JCC_12,<OKADDR>
!!
PRINTSTRING("
INACCESSIBLE AREA TO BE DUMPED - ")
PHEX(START)
PRINTSTRING(" TO ")
PHEX(N)
RETURN
OKADDR:
LENGTH (WKS) = BYTES
COUNT = 0
CYCLE
NEWLINE
IF COUNT # 0 THEN START
IF DF=3 THEN WRITE (COUNT,50) ELSE WRITE (COUNT,16)
PRINTSTRING(" line(s) as above")
COUNT = 0
FINISH ELSE START
STAGE = DF
CYCLE
IF DF=3 THEN PRINT SYMBOL ('*')
IF STAGE>=3 THEN START
FILL (BYTES,ADDR(WKS)+1,FILLER)
FOR I=BYTES,-1,1 CYCLE
J = BYTE INTEGER (START+I-1)
IF 32<=J<127 THEN CHARNO (WKS,I) = J
REPEAT
PRINT STRING (WKS)
FINISH ELSE START
IF DF=3 THEN SPACES (2)
PRINT SYMBOL ('(')
PHEX(START)
PRINTSTRING(") ")
FINISH
STAGE = 5 - STAGE
REPEAT UNTIL STAGE&1#0
IF DF=1 THEN START = START + BYTES ELSE START
FOR I=PERLINE,-1,1 CYCLE
PHEX(INTEGER(START))
SPACES (DF-1)
START = START+4
EXIT IF START>N
REPEAT
FINISH
WHILE START+BYTES<=N AND STOREMATCH (BYTES, START, START-BYTES)#0 CYCLE
COUNT = COUNT+1
START = START+BYTES
REPEAT
FINISH
! %IF DF=2 %THEN NEWLINE
REPEAT UNTIL START>N
IF DF#2 THEN NEWLINE
END ; !OF CXDUMP
!
SYSTEMROUTINE DUMP(INTEGER START, FINISH)
CXDUMP (START, FINISH, 3)
END ; ! OF DUMP
!* 31/07/81
!*
!*********************************************
!* *
!* THIS ROUTINE RECODES FROM HEX INTO NEW *
!* RANGE ASSEMBLY CODE. *
!* *
!*********************************************
SYSTEMROUTINE NCODE(INTEGER START, FINISH, CA)
ROUTINESPEC DCD1; ! PRIMARY DECODE
ROUTINESPEC DCD2; ! SECONDARY DECODE
ROUTINESPEC DCD3; ! TERTIARY DECODE
ROUTINESPEC DECOMPILE
STRING (60) S
CONSTSTRING (4) ARRAY OPS(0 : 127) = C
" ","JCC ","JAT ","JAF ","TEST"," ","CLR*","SET*",
"VAL ","CYD ","INCA","MODD","PRCL","J ","JLK ","CALL",
"ADB ","SBB ","DEBJ","CPB ","SIG ","MYB ","VMY ","CPIB",
"LCT ","MPSR","CPSR","STCT","EXIT","ESEX","OUT ","ACT ",
"SL ","SLSS","SLSD","SLSQ","ST ","STUH","STXN","IDLE",
"SLD ","SLB ","TDEC","INCT","STD ","STB ","STLN","STSF",
"L ","LSS ","LSD ","LSQ ","RRTC","LUH ","RALN","ASF ",
"LDRL","LDA ","LDTB","LDB ","LD ","LB ","LLN ","LXN ",
"TCH ","ANDS","ORS ","NEQS","EXPA","AND ","OR ","NEQ ",
"PK ","INS ","SUPK"," ","COMA","DDV ","DRDV","DMDV",
"SWEQ","SWNE","CPS ","TTR ","FLT ","IDV ","IRDV","IMDV",
"MVL ","MV ","CHOV"," ","FIX ","RDV ","RRDV","RDVD",
"UAD ","USB ","URSB","UCP ","USH ","ROT ","SHS ","SHZ ",
"DAD ","DSB ","DRSB","DCP ","DSH ","DMY ","DMYD","CBIN",
"IAD ","ISB ","IRSB","ICP ","ISH ","IMY ","IMYD","CDEC",
"RAD ","RSB ","RRSB","RCP ","RSC ","RMY ","RMYD"," "
INTEGER I, K, KP, KPP, N, OPCODE
INTEGER INSL, DEC,LITERAL,JUMP
INTEGER H, Q, INS, KPPP
INTEGER PC
INTEGER SIGN,ILLEGAL
INTEGER ALL
!
! **** **** HX is not needed with the machine code version of PHX **** ****
! %CONSTSTRING(1)%ARRAY HX(0 : 15) = %C
! "0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F"
!*
!*************************************
!*
! %ROUTINE PHX(%INTEGER N,PLACES,SIGN)
! %INTEGER SYM ,LEADING ZEROES
! %IF 0<=N<=9 %START
! %IF SIGN#0 %THEN S=S." -" %ELSE S=S." "
! S=S.ITOS(N)
! %RETURN
! %FINISH
! %IF SIGN#0 %THEN S=S."-X'" %ELSE S=S." X'"
! LEADING ZEROES=0
! %WHILE PLACES>0 %CYCLE
! PLACES=PLACES-1
! SYM=(N>>((PLACES)*4))&15
! S=S.HX(SYM) %UNLESS (SYM=0 %AND LEADING ZEROES=0)
! LEADING ZEROES=1 %IF SYM#0 %OR PLACES=1
! %REPEAT
! S=S."'"
! %END
!
! **** **** MACHINE CODE VERSION OF PHX FOLLOWS: **** ****
!
ROUTINE PHX(INTEGER N,PLACES,SIGN)
INTEGER P, L
LONG INTEGER RW, DH
IF 0<=N<=9 START
IF SIGN#0 THEN S=S." -" ELSE S=S." "
LENGTH (S) = LENGTH (S) + 1
CHARNO (S, LENGTH(S)) = N + '0'
RETURN
FINISH
L = LENGTH(S) +4
S = S." X''''''''''"
IF SIGN#0 THEN CHARNO(S,L-3) = '-'
IF PLACES<=0 THEN P = 0 ELSE START
IF PLACES<8 THEN N = (N & (¬((-1)<<(PLACES<<2))))
*LSS_N
*LUH_0
*FLT_0
*STUH_RW
IF N=0 THEN P = 0 ELSE P = BYTE INTEGER (ADDR(RW)) - 64
DH = (LENGTHENI(X'18000000'!P)<<32) ! (ADDR(S)+L)
LENGTH (S) = LENGTH (S) + P
*LD_DH
*LSD_RW
*USH_8
*UCP_0
*SUPK_L =DR
*LSS_HEX+4
*ISB_240
*LUH_X'18000100'
*LD_DH
*TTR_L =DR
FINISH
LENGTH (S) = L + P
END
!*
!*
PC = 0
IF (START!!FINISH)>>18#0 THEN START
I = START
START = (FINISH>>18)<<18; ! FROM START OF SEGMENT
CA = CA + I - START
FINISH
ALL = FINISH-START
!!
!! VALIDATE CODE AREA TO BE DUMPED
!!
I = X'18000000'!ALL
*LDTB_I
*LDA_START
*VAL_(LNB +1)
*JCC_3,<BADADDR>
!!
WHILE PC < ALL CYCLE
NEWLINE
ILLEGAL=0
H = 0
LITERAL=0
JUMP=0
DEC = 0
MOVE(4,START+PC,ADDR(INS))
OPCODE = INS>>25<<1
IF OPCODE=0 OR OPCODE=254 OR 8<=OPCODE<=14 THEN START
INSL = 16
ILLEGAL = 1
FINISH ELSE IF 2<=OPCODE<=8 C
THEN DCD3 C
ELSE IF X'8'<=OPCODE>>4<=X'B' AND OPCODE&X'F'<7 C
THEN DCD2 C
ELSE DCD1
JUMP=1 IF X'1A'<=OPCODE<=X'1E' OR OPCODE=X'24'
DECOMPILE
PC = PC+(INSL>>3)
REPEAT
NEWLINE
RETURN
BADADDR:
PRINTSTRING("
INACCESSIBLE CODE AREA PASSED TO NCODE FOR PRINTING - ")
PHEX(START)
PRINTSTRING(" TO ")
PHEX(FINISH)
NEWLINES(2)
!***********************************************************************
!* ROUTINE TO INTERPRET PRIMARY FORMAT INSTRUCTION
ROUTINE DCD1; ! PRIMARY DECODE
DEC = 1
K = INS<<7>>30
N = INS<<9>>25
UNLESS K = 3 THEN START
LITERAL=1 IF K=0
INSL = 16
RETURN
FINISH
KP = INS<<9>>30
KPP = INS<<11>>29
LITERAL=1 IF KP=0 AND KPP=0
IF KPP < 6 THEN INSL = 32 AND N = INS&X'3FFFF' C
ELSE START
UNLESS INS&X'30000'=0 THEN ILLEGAL=1 ;! RES. FIELD NON ZERO
INSL = 16
FINISH
END
!***********************************************************************
!* ROUTINE TO INTERPRET SECONDARY FORMAT INSTRUCTIONS
ROUTINE DCD2; ! SECONDARY DECODE
DEC=2
H = INS<<7>>31
Q = INS<<8>>31
N = INS<<9>>25
IF Q = 1 THEN INSL = 32 ELSE INSL = 16
END
!***********************************************************************
!* ROUTINE TO INTERPRET TERTIARY FORMAT INSTRUCTIONS
ROUTINE DCD3; ! TERTIARY DECODE
DEC = 3
KPPP = INS<<11>>29
IF KPPP > 5 THEN INSL = 16 ELSE INSL = 32
N = INS&X'3FFFF'
IF INSL=16 AND (INS>>16)&3#0 THEN ILLEGAL=1 ;! 2 LS BITS # 0
END
!***********************************************************************
!* ROUTINE TO INTERPRET CURRENT INSTRUCTION
ROUTINE DECOMPILE
INTEGER I, J
CONSTSTRING (12) ARRAY PREFPOP(0 : 31) = C
"","*** ","(LNB","(XNB",
"(PC","(CTB","TOS ","B ",
"(DR","*** ","(DR+(LNB","(DR+(XNB",
"(DR+(PC","(DR+(CTB","(DR+TOS) ","(B",
"IS LOC N ","*** ","((LNB","((XNB",
"((PC","((CTB","(TOS) ","(DR) ",
"IS LOC B ","*** ","((LNB","((XNB",
"((PC","((CTB","(TOS+B) ","(DR+B) "
CONSTSTRING (8) ARRAY SUFPOP(0:31) = C
"","",") ",") ",
") ",") ","","",
") ","",")) ",")) ",
")) ",")) ","",")* ",
"","",")) ",")) ",
")) ",")) ","","",
"","",")+B) ",")+B) ",
")+B) ",")+B) ","",""
CONSTSTRING (8) ARRAY TOP(0 : 7) = C
"","(DR+","(LNB+","(XNB+","(PC+","(CTB+","(DR) ","(DR+B) "
CONSTSTRING (7) ARRAY JAS(0:15)= C
"FACC=0","FACC>0","FACC<0"," ? ","ACC=0","ACC>0","ACC<0",
" ? ","DACC=0","DACC>0","DACC<0","DRLEN=0",
" B=0 "," B>0 "," B<0 ","OV SET"
!%CONSTSTRING(7) %ARRAY BINS(0:15)= %C
!"B'0000'","B'0001'","B'0010'","B'0011'","B'0100'",
!"B'0101'","B'0110'","B'0111'","B'1000'","B'1001'",
!"B'1010'","B'1011'","B'1100'","B'1101'",
!"B'1110'","B'1111'"
!*
SIGN=0
J = (PC + CA)&X'3FFFF'
FOR I=4,-1,0 CYCLE
PRINTSYMBOL(HEX((J>>(I<<2))&15))
REPEAT
SPACES(4)
! %FOR I=3,-1,0 %CYCLE
! J=(INS>>(8*I))&X'FF'
! %IF 32<=J<=123 %THEN PRINTSYMBOL(J) %ELSE PRINTSYMBOL('.')
! %EXIT %IF I=2 %AND INSL=16
! %REPEAT
IF INSL = 16 START
SPACES(6)
FOR J=28,-4,16 CYCLE
PRINTSYMBOL(HEX((INS>>J)&15))
REPEAT
FINISH ELSE START
SPACES(2)
PHEX(INS)
FINISH
S=" "
-> END IF ILLEGAL#0 OR OPS(OPCODE//2)=" " OR INS=X'81818181'
S=S.OPS((OPCODE>>1))." "
IF DEC = 1 THEN START ; ! PRIMARY FORMAT
IF OPCODE=X'3A' C
OR OPCODE=X'4E' C
OR OPCODE=X'12' C
OR OPCODE=X'EE' C
OR OPCODE=X'DE' C
THEN -> END; ! NO OPERANDS
IF LITERAL=0 THEN S=S." "
IF K<3 THEN START
SIGN = 0
IF K=1 THEN S = S."(LNB +" C
ELSE IF K=2 THEN S = S."((LNB +" C
ELSE IF K=0 AND N>>6=1 THEN START
N = -(N!X'FFFFFF80')
SIGN = 1
FINISH
PHX (N&X'7F',2,SIGN) UNLESS JUMP=1 AND LITERAL=1
IF K=1 THEN S=S.") " C
ELSE IF K=2 THEN S=S.")) "
FINISH ELSE START
S = S.PREFPOP(KP*8+KPP)
IF INSL=32 THEN START
SIGN = 0
IF (KP=0 AND KPP=0) OR KPP=4 THEN START
IF (N>>16)>1 THEN START
N = -(N!X'FFFC0000')
SIGN = 1
FINISH
IF KPP=4 THEN START
IF SIGN=1 THEN S=S." -" ELSE IF SIGN=0 THEN S=S." +"
FINISH
FINISH ELSE S=S." +"
PHX(N&X'3FFFF',5,0) UNLESS LITERAL#0 AND JUMP#0
S=S.SUFPOP(KP*8+KPP)
FINISH
N=-N IF SIGN#0
IF KP=0 AND KPP=4 THEN START
S=S."[AT"
PHX((PC+CA+(N*2))&X'3FFFF',5,0)
S=S."]"
FINISH
FINISH
IF LITERAL#0 AND IMOD(N)>9 AND JUMP=0 START
S=S." " UNTIL LENGTH(S)>=27
S=S."["
IF SIGN#0 THEN S=S."-"
S=S.ITOS(N)."]"
FINISH
IF LITERAL#0 AND JUMP#0 START
N=-N IF SIGN#0 AND N>0
S=S." TO "
PHX((PC+CA+(N*2))&X'3FFFF',5,0)
FINISH
FINISH ELSE IF DEC=2 THEN START ; ! SECONDARY FORMAT
PHX((INS>>16)&X'7F',2,0) IF H=0
IF INSL=32 THEN START
S = S." MASK=X'".TOSTRING(HEX((INS>>8)&15))."' LIT.="
PHX (INS,2,0)
FINISH
FINISH ELSE IF DEC=3 THEN START ; ! TERTIARY FORMAT
S=S.TOP(KPPP)
IF INSL = 32 THEN START
SIGN=0
IF (KPPP=0 OR KPPP=4) AND (N>>16)>1 THEN START
N = -(N!X'FFFC0000')
SIGN = 1
FINISH
IF KPPP#0 THEN PHX(N&X'3FFFF',5,SIGN) ELSE START
N = -N IF SIGN#0
S = S." TO "
PHX((PC+CA+(N*2))&X'3FFFF',5,0)
FINISH
IF 1<=KPPP<=5 THEN S=S.")"
IF 4<=OPCODE<=6 C
THEN S=S." ON ".JAS((INS>>21)&15) C
ELSE S=S." MASK=X'".TOSTRING(HEX((INS>>21)&15))."'"
FINISH
FINISH
END:
PRINTSTRING(S)
END
END
SYSTEMROUTINE HASHCOMMAND(STRING (255) COMMAND, PARAM)
RECORD (FRF) FR
STRING (31) S1, S2, OUTF
INTEGER I, FLAG, LNB
CONSTINTEGER MAXCOM = 27
CONSTSTRING (8) ARRAY COM(1 : MAXCOM) = C
"SNAP","HEX","DEC","PCOM","SCOM","SBYTE","SWORD","SSTRING",
"SETBASE","CONNECT", "SNAPCH","SSTOP","N","SNAPCODE","LISTFD",
"MONITOR","PVM","DUMPFILE","REGS","MON","QUIT","PMESS",
"DUMP","ACR","MONLOAD","NOTE","LQUIET"
SWITCH CSW(1 : MAXCOM)
ROUTINE PVM
!PRINT VM TABLE
INTEGER I, SEG
RECORD (CONFF)NAME CUR
INTEGERARRAY POINT(LVM : UVM); !TO HOLD POINTERS TO SSOWN_CONF
FOR I=LVM,1,UVM CYCLE
POINT(I) = -1
REPEAT
FOR I=0,1,MAXCONF CYCLE
SEG = SSOWN_CONF(I)_CONAD>>SEGSHIFT
IF LVM <= SEG <= UVM THEN POINT(SEG) = I
REPEAT
PRINTSTRING(" SEG HOLE CONAD MODE USE K FSYS FILE
")
FOR SEG=LVM,1,UVM CYCLE
IF POINT(SEG)>=0 START
CUR == SSOWN_CONF(POINT(SEG))
WRITE(SEG,3)
WRITE(CUR_HOLE>>SEGSHIFT,4)
SPACES(2)
PHEX(SEG<<18)
WRITE(CUR_MODE&X'FFFFFDFF',5); ! discard "permanent connection" bit.
WRITE(CUR_USE&X'3FFFFFFF',4)
IF CUR_USE<0 THEN PRINT SYMBOL ('*') ELSE SPACE
WRITE(CUR_SIZE>>KSHIFT,4); !SIZE IN KBYTES
WRITE(CUR_FSYS,5)
SPACES(3)
PRINTSTRING(CUR_FILE)
NEWLINE
FINISH
REPEAT
NEWLINES(2)
END ; !OF PVM
ROUTINE GETNUM(INTEGERNAME I, FLAG)
INTEGER J, K, L, SIGN
STRING (80) S
S = SPAR(0)
-> ERR IF S = ""; !NO PARAM
L = LENGTH(S)
I = 0
J = CHARNO(S,1)
IF J='X' THEN START
IF L>9 THEN -> ERR
FOR K=2,1,L CYCLE
J = CHARNO(S,K) - '0'
IF J>9 THEN J = J + '0' - 'A' + 10
UNLESS 0<=J<=15 THEN -> ERR
I = (I<<4)!J
REPEAT
FINISH ELSE START
IF J='-' THEN START
SIGN = 13
K = 2
FINISH ELSE START
SIGN = 15
K = 1
FINISH
L = L - K + 1
IF L>0 THEN START
IF L>10 THEN -> ERR
K = ADDR (S) + K
*LDTB_X'18000000'
*LDB_L
*LDA_K
*STD_TOS
*LSS_ACCEPT DIGITS+4
*LUH_256
*TCH_L =DR
*JCC_7,<ERR>
*LD_TOS
*LB_SIGN
*LSQ_B
*PK_L =DR
*CBIN_0
*ST_TOS
*USH_32
*ISH_-32
*UCP_TOS
*JCC_7,<ERR>
*STUH_B
*ST_(I)
FINISH
FINISH
FLAG = 0
RETURN
ERR:
FLAG = 1
END ; ! GETNUM
!
ROUTINE REGS
INTEGER P, FLAG
ROUTINE OUTLINE(STRING (8) NAME, INTEGER I)
NEWLINE
PRINTSTRING(NAME.": ")
PHEX(SSOWN_SAVEIDATA(I,P))
END ; !OF OUTLINE
NEWLINE
P = 0
IF PARAM # "" THEN GETNUM(P,FLAG)
UNLESS -3 <= P <= 0 THEN P = 0
P = (SSOWN_SAVEIDPOINTER+P-1)&3
IF SSOWN_SAVEIDATA(18,P) = 0 THEN PRINTSTRING("NO INFO.
") C
AND RETURN
PRINTSTRING("CONTINGENCY AT ".STRING(ADDR(SSOWN_SAVEIDATA(18,P))))
NEWLINE
OUTLINE("CLASS",-2)
OUTLINE("SUBCLASS",-1)
OUTLINE("LNB",0)
OUTLINE("PSR",1)
OUTLINE("PC",2)
OUTLINE("SSR",3)
OUTLINE("SF",4)
OUTLINE("IT",5)
OUTLINE("IC",6)
OUTLINE("CTB",7)
OUTLINE("XNB",8)
OUTLINE("B",9)
OUTLINE("DR",10)
SPACE
PHEX(SSOWN_SAVEIDATA(11,P))
OUTLINE("ACC",12)
SPACE
PHEX(SSOWN_SAVEIDATA(13,P))
SPACE
PHEX(SSOWN_SAVEIDATA(14,P))
SPACE
PHEX(SSOWN_SAVEIDATA(15,P))
OUTLINE("FPC",16)
OUTLINE("SPARE",17)
NEWLINE
END ; !OF REGS
!
ROUTINE OUTHEX
INTEGER I
GETNUM(I,FLAG)
RETURN IF FLAG # 0
PRINTSTRING("X=")
PHEX(I); NEWLINE
END ; !OF OUTHEX
ROUTINE DEC
INTEGER I
GETNUM(I,FLAG)
RETURN IF FLAG # 0
PRINTSTRING("N=")
WRITE(I,1); NEWLINE
END ; !OF DEC
ROUTINE PRINTFD
INTEGER AFD
RECORD (FDF)NAME F
ROUTINE OUTLINE(STRING (12) S, INTEGER N)
IF N = 0 THEN RETURN
PRINTSTRING(S.":")
SPACES(13-LENGTH(S))
PHEX(N)
SPACES(2)
WRITE(N,8)
NEWLINE
END ; !OF OUTLINE
GETNUM(AFD,FLAG)
RETURN UNLESS FLAG = 0 AND 1 <= AFD <= 99
AFD = SSOWN_SSFDMAP(AFD)
IF AFD # 0 THEN START
F == RECORD(AFD)
OUTLINE("LINK",F_LINK)
OUTLINE("DSNUM",F_DSNUM)
OUTLINE("STATUS",F_STATUS)
OUTLINE("ACCESS ROUTE",F_ACCESSROUTE)
OUTLINE("VALID ACTION",F_VALIDACTION)
OUTLINE("CUR STATE",F_CUR STATE)
OUTLINE("MODE OF USE",F_MODEOFUSE)
OUTLINE("MODE",F_MODE)
OUTLINE("FILE ORG",F_FILEORG)
OUTLINE("DEV CODE",F_DEVCODE)
OUTLINE("RECTYPE",F_RECTYPE)
OUTLINE("FLAGS",F_FLAGS)
OUTLINE("ASVAR",F_ASVAR)
OUTLINE("AREC",F_AREC)
OUTLINE("RECSIZE",F_RECSIZE)
OUTLINE("MINREC",F_MINREC)
OUTLINE("MAXREC",F_MAXREC)
OUTLINE("MAXSIZE",F_MAXSIZE)
OUTLINE("LASTREC",F_LASTREC)
OUTLINE("CONAD",F_CONAD)
OUTLINE("CURREC",F_CURREC)
OUTLINE("CUR",F_CUR)
OUTLINE("END",F_END)
OUTLINE("TRANSFERS",F_TRANSFERS)
OUTLINE("DARECNUM",F_DARECNUM)
OUTLINE("CURSIZE",F_CURSIZE)
OUTLINE("DATASTART",F_DATASTART)
PRINTSTRING("IDEN: ".F_IDEN)
NEWLINE
FINISH
END ; !OF PRINTFD
ROUTINE PCOM
INTEGER I
GETNUM(I,FLAG)
RETURN IF FLAG # 0
PRINTSTRING("SSCOMREG(")
WRITE(I,1); PRINTSTRING(")=")
I = SSOWN_SSCOMREG(I); PHEX(I); NEWLINE
END ; !OF PCOM
ROUTINE SCOM
INTEGER I, J
GETNUM(I,FLAG)
RETURN IF FLAG # 0
GETNUM(J,FLAG)
IF FLAG # 0 THEN RETURN
SSOWN_SSCOMREG(I) = J
END ; ! SCOM
ROUTINE SNAP(INTEGER MODE)
!MODE=2 FOR SNAP MODE=1 FOR SNAPCH
INTEGER START, N
GETNUM(START,FLAG)
RETURN IF FLAG # 0
GETNUM(N,FLAG)
RETURN IF FLAG # 0
CXDUMP (START, N, MODE)
END ; !OF SNAP
!
ROUTINE OUTDUMP
! #DUMP ADDR,LEN,OUT
INTEGER START, LEN, AFD
STRING (31) OUT
GETNUM(START,FLAG)
RETURN IF FLAG # 0
GETNUM(LEN,FLAG)
RETURN IF FLAG # 0
OUT = SPAR(3)
IF OUT = "" THEN OUT = ".LP"
DEFINE(82,OUT,AFD,FLAG)
SELECTOUTPUT(82)
CXDUMP(START,LEN,3)
SELECTOUTPUT(0)
END ; !OF OUTDUMP
ROUTINE SNC {SNAPCODE}
STRING (31) OUT
INTEGER START, FINISH, N, AFD, FLAG
GETNUM(START,FLAG)
RETURN IF FLAG # 0
GETNUM(N,FLAG)
RETURN IF FLAG # 0
OUT = SPAR(3)
IF OUT#"" START
DEFINE(82,OUT,AFD,FLAG)
IF FLAG = 0 THEN SELECTOUTPUT(82)
FINISH
START = START&X'FFFFFFFC'
FINISH = START+N
NCODE(START,FINISH,START)
SELECTOUTPUT(0)
END ; !OF SNAPCODE
ROUTINE SBYTE
INTEGER I, J
GETNUM(I,FLAG)
RETURN IF FLAG # 0
GETNUM(J,FLAG)
RETURN IF FLAG # 0
BYTEINTEGER(I) = J
END ; ! SBYTE
ROUTINE SWORD
INTEGER I, J
GETNUM(I,FLAG)
RETURN IF FLAG # 0
GETNUM(J,FLAG)
RETURN IF FLAG # 0
IF I&3 # 0 THEN START
PRINTSTRING("
WORD ALIGN IT!
")
RETURN
FINISH
INTEGER(I) = J
END ; ! SWORD
ROUTINE SSTRING
INTEGER I
STRING (63) S
GETNUM(I,FLAG)
RETURN IF FLAG # 0
S = SPAR(2)
! MUST BE IN DOUBLE QUOTES - REMOVE THEM
RETURN UNLESS LENGTH(S)>=2 AND CHARNO(S,1)='"'=CHARNO(S,LENGTH(S))
BYTE INTEGER (I) = LENGTH (S) - 2
MOVE (LENGTH(S) - 2, ADDR (S) + 2, I + 1)
END ; ! SSTRING
ROUTINE CON
STRING (5)SMODE
STRING (63) S
RECORD (RF)R
INTEGER I, J
I = 0
L2: S = SPAR(0)
RETURN IF S = ""
CONNECT(S,3,0,0,R,J)
IF J = 0 THEN SMODE="WRITE" AND -> L1
CONNECT(S,0,0,0,R,J)
IF J # 0 THEN START
PSYSMES(8,J)
FINISH ELSE START
SMODE="READ"
L1: I = R_CONAD
PRINTSTRING(S." CONNECTED IN ".SMODE." MODE AT ")
PHEX(I); NEWLINE
FINISH
-> L2
END ; ! CON
ROUTINE DUMPFILE
RECORD (FDF)NAME F
RECORD (RF)R
STRING (32) FILE, OUT
INTEGER OFFSET, LEN, AFD, DUMMY, J
! #DUMPFILE FILE,OFFSET,LENGTH,OUT
FILE = SPAR(0)
GETNUM(OFFSET,FLAG)
RETURN IF FLAG # 0
IF OFFSET < 0 THEN FLAG = 1 AND RETURN
GETNUM(LEN,FLAG)
RETURN IF FLAG # 0
IF LEN <= 0 THEN LEN = 16
CONNECT(FILE,0,0,0,R,J)
IF J # 0 START
PSYSMES(8,J)
RETURN
FINISH
DUMMY = FINDFN (SSOWN_CURFILE, J)
IF OFFSET+LEN-SSOWN_CONF(J)_SIZE>0 THEN START
PRINTSTRING("
INVALID OFFSET OR LENGTH
")
IF NEWCONNECT#0 THEN START
DISCONNECT (LAST, J)
FINISH
RETURN
FINISH
OUT = SPAR(4)
IF OUT = "" THEN OUT = ".LP"
DEFINE(82,OUT,AFD,FLAG)
F==RECORD(AFD)
F_MAXSIZE=X'100000'; !ALLOW 1 MBYTE FILE
SELECTOUTPUT(82)
PRINTSTRING("
DUMP FROM FILE ".FILE."
")
CXDUMP(R_CONAD+OFFSET,LEN,3)
IF NEWCONNECT#0 THEN START
DISCONNECT (FILE,J)
FINISH
SELECTOUTPUT(0)
END ; !OF DUMPFILE
IF LENGTH(COMMAND) > 8 THEN LENGTH(COMMAND) = 8
!TRUNCATE IF NEC
FLAG = 0; !DEFAULT
SETPAR(PARAM); !FOR ANALYSIS BY SPAR
FOR I=MAXCOM,-1,1 CYCLE
IF COMMAND = COM(I) THEN -> CSW(I)
REPEAT
PRINTSTRING("#".COMMAND." NOT VALID")
NEWLINE
-> EXIT
CSW(1): !SNAP
SNAP(2)
-> EXIT
CSW(2):
!HEX
OUTHEX
-> EXIT
CSW(3): !DEC
DEC
-> EXIT
CSW(4): !PCOM
PCOM
-> EXIT
CSW(5): !SCOM
SCOM
-> EXIT
CSW(6): !SBYTE
SBYTE
-> EXIT
CSW(7): !SWORD
SWORD
-> EXIT
CSW(8): !SSTRING
SSTRING
-> EXIT
CSW(9): !SETBASE
UNLESS PARAM -> S1.(".").S2 OR PARAM = "" C
THEN PARAM = SSOWN_SSOWNER.".".PARAM
FLAG = X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,0,1,ADDR(PARAM));!SET BASEFILE IN SFI
-> EXIT
CSW(10): !CONNECT
CON
-> EXIT
CSW(11): !SNAPCH
SNAP(1)
-> EXIT
CSW(12): !SSTOP -INHIBIT SPOOLER
SSOWN_INHIBITSPOOLER = 1
-> EXIT
CSW(13): !N - SWITCH OFF SPECIALS
SSOWN_INHIBITSPOOLER = 0
SSOWN_SSMONITOR = 0
SSOWN_SSNOTE=0
SSOWN_NOWARNINGS=0
SSOWN_LOADMONITOR=0
IF SSOWN_MONFILE#"" THEN START
SETUSE(SSOWN_MONFILE,-1,0)
SSOWN_MONFILE=""
SSOWN_MONFILEAD=0
SSOWN_MONFILETOP=0
FINISH
-> EXIT
CSW(14): !SNAPCODE
SNC
-> EXIT
CSW(15): ! #LISTFD(CHANNEL)
PRINTFD
-> EXIT
CSW(16): !MONITOR
MONITOR
-> EXIT
CSW(17): !PVM
PVM
-> EXIT
CSW(18): !DUMPFILE
DUMPFILE
-> EXIT
CSW(19): !REGS
REGS
-> EXIT
CSW(20): !MON
SSOWN_SSMONITOR = SSOWN_SSMONITOR!1; !SET MON CPU AND PAGETURNS BIT
-> EXIT
CSW(21): !QUIT
HALT
CSW(22): !PMESS
GETNUM(I,FLAG)
IF FLAG = 0 THEN SSMESS(I)
-> EXIT
CSW(23): !DUMP
OUTDUMP
-> EXIT
CSW(24):
*STLN_LNB; !CURRENT LNB
PRINTSTRING("ACR =")
WRITE((INTEGER(LNB+4)>>20)&X'F',1)
NEWLINE
-> EXIT
CSW(25): !LMON (N)
IF SPAR(1)="?" THEN START
IF SSOWN_LOADMONITOR#0 THEN START
PRINTSTRING("Load monitor setting X")
PHEX(SSOWN_LOADMONITOR)
NEWLINE
IF SSOWN_MONFILE#"" THEN START
PRINTSTRING("Output to file ".SSOWN_MONFILE)
IF SSOWN_MONFILEAD#0 THEN PRINTSTRING(" - X") AND PHEX(SSOWN_MONFILEAD-32) C
AND PRINTSTRING(" Bytes written")
FINISH ELSE PRINTSTRING("Output to console")
FINISH ELSE PRINTSTRING("Load monitoring off")
NEWLINE
->EXIT
FINISH
! Not a query if here
! Check for legal number for first param
GETNUM(I,FLAG)
IF FLAG=0 THEN SSOWN_LOADMONITOR=I ELSE START
SSOWN_LOADMONITOR=0
IF SPAR(1)#"" THEN PRINTSTRING("Illegal integer ".SPAR(1)."
")
FINISH
IF SSOWN_LOADMONITOR=0 THEN START
IF SSOWN_MONFILE#"" THEN START
SETUSE(SSOWN_MONFILE,-1,0)
SSOWN_MONFILE=""
SSOWN_MONFILEAD=0
SSOWN_MONFILETOP=0
FINISH
->EXIT
FINISH
! O.K. so far. Now check if new MONFILE set
OUTF=SPAR(2)
IF OUTF#"" THEN START
IF SSOWN_MONFILE#"" THEN START
! One currently defined
SETUSE(SSOWN_MONFILE,-1,0)
SSOWN_MONFILEAD=0
SSOWN_MONFILETOP=0
SSOWN_MONFILE=""
FINISH
FLAG=CHECKFILENAME(OUTF,5); ! Check valid own filename
IF OUTF->S1.(".").S2 THEN OUTF=S2
UNLESS 'A'<=CHARNO(OUTF,1)<='Z' AND FLAG=0 THEN C
PRINTSTRING("Invalid own filename ".SPAR(2)."
") AND ->EXIT
! Check that OUTF doesn't exist
FINFO(OUTF,0,FR,FLAG)
IF FLAG#218 THEN PRINTSTRING(OUTF." already exists
") ELSE SSOWN_MONFILE=OUTF
FINISH
->EXIT
CSW(26): !#NOTE
GETNUM(I,FLAG)
IF FLAG=0 THEN SSOWN_SSNOTE=I ELSE SSOWN_SSNOTE=0
->EXIT
CSW(27): ! LQUIET
SSOWN_NOWARNINGS=1
->EXIT
EXIT:
END ; !OF HASHCOMMAND
FINISH
!
! - END OF HASH CODE ]
!
! [ START OF INFREQUENT CODE -
!
!
ROUTINE FSC(INTEGER SCTABLE, COUNT); ! FILL SYSTEM CALLS
!***********************************************************************
!* *
!*THIS VERSION CHANGED 17.8.78 FOR NEW FORMAT OBJECT FILES *
!* THIS ROUTINE FILLS IN THE SYSTEM CALL DESCRIPTORS IN THE BGLA *
!* USING INFORMATION IN A TABLE AT SCTABLE. THE INFORMATION *
!* CONSISTS OF AN I AND J VALUE FOR EACH OF THE DIRECTOR ROUTINES *
!* WHICH CAN BE ACCESSED BY SYSTEM CALL. *
!* *
!***********************************************************************
RECORDFORMAT TABF(STRING (31) NAME, INTEGER I, J)
RECORD (TABF)ARRAYFORMAT TABLEF(1 : COUNT)
RECORD (TABF)ARRAYNAME TABLE
RECORDFORMAT EPREFF(INTEGER LINK, REFLOC, STRING (31) IDEN)
RECORD (EPREFF)NAME EPREF
INTEGER LD, LOC, LINK, P
! %INTEGER ABGLA used to be declared, but I think we can use the %OWN of
! the same name in the surrounding environment.
! SSOWN_ABGLA = ABASEFILE+((INTEGER(ABASEFILE)+X'3FFFF')& %C
! X'FFFC0000')
! BASEGLA STARTS AT FIRST FREE SEG BEYOND BASEFILE
! That method of calculating SSOWN_ABGLA has been superseded (see first few lines
! of SSINIT), but in any case since we are no longer using a local SSOWN_ABGLA we
! don't need to assign a value to it.
TABLE == ARRAY(SCTABLE,TABLEF); !MAP ARRAY TABLE ONTO THE TABLE
LD = ABASEOBJ+INTEGER(ABASEOBJ+24); !START OF BASE LOAD DATA
LINK = INTEGER(LD+28); !TOP OF EPREF LIST
WHILE LINK#0 CYCLE
EPREF == RECORD(LINK+ABASEOBJ); !MAP EACH REF ONTO EPREF
FOR P=COUNT,-1,1 CYCLE ; !LOOK THROUGH SCTABLE
IF TABLE(P)_NAME = EPREF_IDEN START
LOC = (EPREF_REFLOC&X'FFFFFF')+SSOWN_ABGLA; !ASSUME IN GLA (NOT PLT)
INTEGER(LOC) = X'E3000000'!TABLE(P)_I
!SYS CALL DESCRIPTOR
INTEGER(LOC+4) = TABLE(P)_J
!SECOND WORD
EXIT
FINISH
REPEAT
LINK = EPREF_LINK
REPEAT
END ; !OF FIL SYSTEM CALLS
!
SYSTEMROUTINE SSINIT(INTEGER MARK, ADIRINF)
!THIS IS THE INITIALISATION
! ROUTINE FOR THE SUBSYSTEM.
! IT IS ENTERED
!ONCE FROM SSLDR AT THE START
! OF A SESSION
INTEGER FLAG, I, POS, BH, BGLALEN, AOFM,GLAAD
IF NEWLOADER#0 THEN START
INTEGER SSSCTABLE, SSSCCOUNT
FINISH
RECORD (DIRINFF)NAME DIRINF
RECORD (CONFF)NAME CUR
RECORD (RF)RR
ROUTINE CALL CONTROL
INTEGER LNB
*STLN_LNB; !PUT LNB FOR THIS ROUTINE INTO I
SSOWN_SSCOMREG(36) = LNB; !AND STORE IN COMREG 36
CONTROL; !CALL SS CODE
!IF FAILURE THEN EFFECTIVELY
! RETURN FROM THIS ROUTINE
END ; !OF CALL CONTROL
!
SSOWN=0; ! Initialise SSOWN record to 0
!
! Initialise all the subsystem globals which are not 0 (or "").
!
SSOWN_INTMESS(I)=INITVAL INTMESS(I) FOR I=9,-1,1
!
SSOWN_ALLCONNECT=INITVAL ALLCONNECT
SSOWN_CKBITS=INITVAL CKBITS
SSOWN_FEPMODE=INITVAL FEPMODE
SSOWN_INTINPROGRESS=INITVAL INTINPROGRESS
SSOWN_MTCLOSEMODE=INITVAL MTCLOSEMODE
SSOWN_OPMODE=INITVAL OPMODE
SSOWN_RCLB=INITVAL RCLB
SSOWN_TOPFD=INITVAL TOPFD
SSOWN_UNASSPATTERN=INITVAL UNASSPATTERN
!
SSOWN_LASTCPUTIME=INITVAL LASTCPUTIME
!
SSOWN_ACTD=INITVAL ACTD
!
SSOWN_OPTIONSFILE =INITVAL OPTIONSFILE
SSOWN_SSUGLASIZE=INITVAL SSUGLASIZE
SSOWN_LOADLEVEL=INITVAL LOADLEVEL
SSOWN_D DELIM 1 =INITVAL D DELIM 1
SSOWN_D DELIM 2 =INITVAL D DELIM 2
SSOWN_STATE =INITVAL STATE
!
! End of initialisations.
!
DIRINF == RECORD(ADIRINF); !DIRECTOR INFO RECORD
BH = ROUNDUP(INTEGER(ABASEFILE),SEGSIZE)
!HOLE FOR BASEFILE
AOFM = ABASEOBJ+INTEGER(ABASEOBJ+28);!ADDRESS OF OBJECT FILE MAP
SSOWN_ABGLA=ABASEFILE+BH
!***** END OF TEMP *****
!
LONGINTEGER(ADDR(SSOWN_SSCOMREG(27))) = DEFAULTPARM; !USE DEFAULT PROTEM - LATER TO COME FROM OPTION FILE
SSOWN_SSCOMREG(48) = X'0003D000'; !252K LESS MARGIN OF 8K
SSOWN_SSCOMREG(35) = SSOWN_ABGLA; !ADDRESS OF BGLA
SSOWN_SSOWNER = DIRINF_USER; !EXTRACT INFO FROM DIRINF
SSOWN_SSOWNFSYS = DIRINF_FSYS
SSOWN_SSREASON = DIRINF_REASON
SSOWN_SSOPERNO = DIRINF_STARTCNSL
SSOWN_AIOSTAT = DIRINF_AIOSTAT
SSOWN_APAGETURNS = DIRINF_AACCTREC+8
! AACTREC POINTS TO A RECORD OF THE
! FORM (%LONGINTEGER MUSECS,%INTEGER PAGETURNS,KINSTRS)
!
SSOWN_ICREVS == INTEGER(DIRINF_AICREVS); !INS. COUNTER REVS
SSOWN_PREVIC == INTEGER(ADDR(DIRINF_PREVIC)); !HORRID CONSTRUCT TO GET ROUND COMPILER LIMITATION
SSOWN_KINSTRS == INTEGER(DIRINF_AACCTREC+12); !K INS. WHEN LAST UPDATED
SSOWN_SSINVOCATION = DIRINF_ISUFF; ! Invocation number.
SSOWN_SSSUFFIX = ITOS (SSOWN_SSINVOCATION); ! STRING TO BE ADDED TO END OF
! TEMP FILENAMES
IF NEWLOADER#0 THEN START
SSSCTABLE = DIRINF_SCIDENSAD
SSSCCOUNT = DIRINF_SCIDENS
FINISH ELSE START
SSOWN_SSSCTABLE=DIRINF_SCIDENSAD
SSOWN_SSSCCOUNT = DIRINF_SCIDENS
FINISH
SSOWN_SSADIRINF = ADIRINF
IF NEWLOADER#0 THEN START
! Now find out whether we are running on a shareable or an unshareable
! basegla. Do this by extracting SSINIT's gla address from LNB+16. If
! this is in the same segment as SSOWN_ABGLA then it's unshared.
! After this inspect MARK and compare it to SSDATELINKED. If these are
! not the same then we have different system call tables in Director
! and Subsystem. Action is then as follows:
! MARK=SSDATELINKED Shared basegla ACTION
! Y Y OK
! Y N OK
! N Y DSTOP(130)
! N N Call FSC then OK
*LSS_(LNB +4); ! Gla for SSINIT
*ST_GLAAD
GLAAD=GLAAD&X'FFFC0000'
!****TEMP
!* %IF MARK#SSDATELINKED %THEN %START
!* %IF GLAAD#SSOWN_ABGLA %THEN AABPRINTSTRING("NewSCT Shared basegla
!* ") %ELSE AABPRINTSTRING("NewSCT Unshared basegla
!* ")
!* %FINISH %ELSE %START
!* %IF GLAAD#SSOWN_ABGLA %THEN AABPRINTSTRING("SameSCT Shared basegla
!* ") %ELSE AABPRINTSTRING("SameSCT Unshared basegla
!* ")
!* %FINISH
!****TEMP
IF MARK#SSDATELINKED THEN START
! Mismatching system call table
IF GLAAD#SSOWN_ABGLA THEN AAASTOP{DSTOP}(130) ELSE C
FSC(SSSCTABLE,SSSCCOUNT)
FINISH
FINISH ELSE START
IF DIRINF_SCDATE#SSDATELINKED THEN FSC(SSOWN_SSSCTABLE,SSOWN_SSSSSOUNT)
FINISH
IF GLAAD#SSOWN_ABGLA THEN BGLALEN=0 {Shared basegla} ELSE C
BGLALEN = INTEGER(AOFM+20)+INTEGER(AOFM+56) AND SSOWN_UNSHAREDBGLA=1; !LENGTH OF AREA 2(GLA)+LENGTH OF AREA 5(UST)
X1{CHANGECONTEXT}; !TO LOSE SS AND DIRECTOR GLAP PAGES FROM WORKING SET
SSOWN_BASEFILE = DIRINF_BASEFILE
IF SSOWN_BASEFILE = "" THEN SSOWN_BASEFILE = DEFBASE
!DEFAULT NAME
FLAG = X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,12,0,ADDR(SSOWN_SSMAXFSIZE))
SSOWN_SSMAXFSIZE = SSOWN_SSMAXFSIZE<<10; !MAXIMUM FILE SIZE IN BYTES
FLAG = FINDFN(SSOWN_BASEFILE,POS)
CUR == SSOWN_CONF(POS)
CUR_FILE = SSOWN_BASEFILE; !PUT NAME IN TABLE
CUR_SIZE = ROUNDUP(INTEGER(ABASEFILE),FILESIZEALLOC)
CUR_CONAD = ABASEFILE; !ADDRESS OF BASEFILE
CUR_HOLE = BH
IF NEWCONNECT#0 THEN START
CUR_USE = X'80000001'; !NEVER DISCONNECT
FINISH ELSE START
CUR_USE = 8
FINISH
!PUT T#BGLA INTO SSOWN_CONF TABLE
FLAG = FINDFN(SSOWN_SSOWNER.".T#BGLA",POS)
CUR == SSOWN_CONF(POS)
CUR_FILE = SSOWN_SSOWNER.".T#BGLA"
CUR_CONAD = SSOWN_ABGLA
CUR_HOLE = SEGSIZE
CUR_SIZE = SEGSIZE
IF NEWCONNECT=0 THEN START
CUR_USE = 8
FINISH ELSE START
CUR_USE = X'80000001'; !NEVER DISCONNECT
FINISH
CONNECT(SSOWN_BASEFILE."_BASEDIR",0,0,0,RR,FLAG)
IF FLAG # 0 THEN X30{DSTOP}(126); !CANNOT CONNECT BASEDIR
IF NEWLOADER=0 THEN START
SSOWN_SSASESSDIR = RR_CONAD
FINISH ELSE START
SSOWN_SSDIRAD = RR_CONAD
FINISH
CONNECT(SSOWN_BASEFILE."_OPTIONFILE",0,0,0,RR,FLAG)
IF FLAG # 0 THEN X30{DSTOP}(127); !CANNOT CONNECT DEFAULT OPTION FILE
SSOWN_SSADEFOPT = RR_CONAD
IF NEWLOADER=0 THEN START
SSOWN_SSATEMPDIR = SSOWN_ABGLA+BGLALEN; !ADDR OF SESSION DIRECTORY
SSOWN_SSCURBGLA = SSOWN_SSATEMPDIR+SSTEMPDIRSIZE
FINISH ELSE START
SSOWN_SSCURBGLA = SSOWN_ABGLA + BGLALEN; ! Available from here.
FINISH
SSOWN_SSMAXBGLA = SSOWN_ABGLA+SEGSIZE-1; !LAST BYTE IN BGLA
SSOWN_SSCOMREG(11) = INTEGER(ATRANS)+256; !ADDRESS OF ETOI TABLE
SSOWN_SSCOMREG(12) = INTEGER(ATRANS); !ADDRESS OF ITOE TABLE
SSOWN_DIRDISCON = INITVAL DIRDISCON
IF NEWLOADER#0 THEN START
SSOWN_SSAUXDR1=0; ! To ensure auxstack initialised when req
INITLOADER(FLAG)
IF FLAG#0 THEN X30{DSTOP}(129)
FINISH
INITDYNAMICREFS
I = X27{DSETIC}(40000); !LARGE DEFAULT TIME LIMIT
CALL CONTROL; !THIS IS SUBSYSTEM
X30{DSTOP}(104); !IN CASE WE GET BACK HERE
END ; !OF SSINIT
!
SYSTEMROUTINE USEOPTIONS
INTEGER FLAG, I
INTEGER NAME J, K
RECORD (RF) RR
RECORD (CONTF) NAME C, D
IF STUDENTSS=0 THEN START
CONNECT(SSOWN_OPTIONSFILE,0,0,0,RR,FLAG)
IF FLAG#0 THEN RR_CONAD = SSOWN_SSADEFOPT; ! Cannot connect own control file.
! so use default one.
FINISH ELSE START
! If we ever went through here with SSOWN_USEOPTSTARTED#0, then RR would
! not get set up and we would would get horrid failures in trying
! to access the record C. There is supposed to be protection to
! prevent USEOPTIONS being called more than once, so that problem
! should not arise. But in that case, we don't need to test SSOWN_USEOPTSTARTED
! at all.
IF SSOWN_USEOPTSTARTED=0 THEN START ; ! Only allow this the first time.
FLAG = X28{DSFI} (SSOWN_SSOWNER, SSOWN_SSOWNFSYS, 2, 0, ADDR(SSOWN_OPTIONSFILE))
CONNECT (SSOWN_OPTIONSFILE, 0, 0, 8, RR, FLAG); ! Cannot be DISCONNECTed.
IF FLAG#0 THEN RR_CONAD = SSOWN_SSADEFOPT
FINISH
FINISH
C == RECORD(RR_CONAD)
IF FLAG=0 AND (SSOWN_USEOPTSTARTED=0 OR RR_FILETYPE#9) THEN START
D == RECORD(SSOWN_SSADEFOPT); ! CHECK VERSION, FIRST MAP DEF OPTIONS FILE
IF C_MARK#D_MARK OR RR_FILETYPE#9 THEN START ; ! UPDATE REQUIRED
IF NEWCONNECT=0 THEN START
CONNECT (SSOWN_OPTIONSFILE,3,0,0,RR,FLAG)
FINISH ELSE START
CHANGEACCESS (LAST,3,FLAG); !RECONNECT IN WRITE MODE
FINISH
FOR I=36,4,4092 CYCLE ; ! UPDATE IF -1(=UNUSED) IN EITHER
J == INTEGER (RR_CONAD + I)
K == INTEGER (SSOWN_SSADEFOPT + I)
IF (J=X'81818181' OR J=-1 OR K=-1) AND J#K THEN J = K
REPEAT
MOVE(36,SSOWN_SSADEFOPT,RR_CONAD); !UPDATE HEADER AND VERSION NO
FINISH
FINISH
SSOWN_SSNOBLANKLINES = C_NOBL&1; !ONLY 0 OR 1 VALID
SSOWN_SSASTACKSIZE = C_ASTK
SSOWN_SSUSTACKSIZE = C_USTK
IF SSOWN_SSUSTACKSIZE>MAXUSERSTACKSIZE THEN SSOWN_SSUSTACKSIZE = MAXUSERSTACKSIZE
IF C_ISTK>0 THEN SSOWN_INITSTACKSIZE = C_ISTK; ! PART OF USERSTACK RESERVED
! FOR INIT STACK
SSOWN_SSTERMINALTYPE=C_TERMINAL
SSOWN_SSITWIDTH = C_ITWIDTH
SSOWN_SSLDELIM = C_LDELIM
SSOWN_SSRDELIM = C_RDELIM
SSOWN_AVD = C_MODDIR; ! Active directory.
SSOWN_HOLDAVD = SSOWN_AVD; ! Save active directory name for use in TIDYFILES.
SSOWN_SSARRAYDIAG = C_ARRAYDIAG
SSOWN_SSCFAULTS <- C_CFAULTS; !COMPILER FAULTS
SSOWN_SSINITPARMS = C_INITPARMS
SSOWN_SSDATAECHO = C_DATAECHO
SSOWN_DATAECHO=SSOWN_SSDATAECHO IF SSOWN_FDLEVEL >1; !IN CASE CALLED FROM OBEY
IF C_INITWORKSIZE # 0 THEN SSOWN_SSINITWORKSIZE = C_INITWORKSIZE
IF SSOWN_SSJOURNAL#C_JOURNAL AND SSOWN_SSREASON#BATCHREASON THEN START
!NOT BATCH JOB
IF SSOWN_SSJOURNAL = 2 START ; !CURRENT SETTING IS PERMRECALL
FSTATUS(SSPERMJNAME,5,0,FLAG);!MARK FILE TO BE DESTROYED AT LOGOFF
FINISH
SSOWN_SSJOURNAL = C_JOURNAL
INITJOURNAL IF SSOWN_USEOPTSTARTED = 1; !ONLY IF ALREADY RUNNING
FINISH
IF SSOWN_USEOPTSTARTED = 0 START ; ! ONLY RELEVANT AT START UP
SSOWN_RCODE==SSOWN_SSCOMREG(24); !COMREG(24) IS RETURNCODE
LONGINTEGER(ADDR(SSOWN_SSCOMREG(27))) = C_INITPARMS
!LOAD INITIAL SETTING
IF SSOWN_SSREASON#BATCHREASON START ; !FOREGROUND SESSION
SSOWN_ITINLENGTH = C_ITINSIZE
SSOWN_ITOUTLENGTH = C_ITOUTSIZE
SSOWN_STARTFILE = C_FSTARTFILE
FINISH ELSE SSOWN_STARTFILE = C_BSTARTFILE; !BATCH JOB
SSOWN_USEOPTSTARTED = 1
FINISH
IF NEWCONNECT#0 THEN START
DISCONNECT (SSOWN_OPTIONSFILE, FLAG)
FINISH
END ; !OF USEOPTIONS
!
SYSTEMROUTINE BATCHSTOP(INTEGER REASON)
!***********************************************************************
!* *
!* This routine is called from STOP or when input ended is detected *
!* during a batch job. It closes the main output file and sends a *
!* message to the user - who might be logged on. *
!* *
!***********************************************************************
INTEGER FLAG, START, LEN
STRING (40) MESSAGE
RECORD (DIRINFF)NAME DIRINF
DIRINF == RECORD(SSOWN_SSADIRINF)
SSOWN_FDLEVEL = 1
TIDYFILES; !IN CASE CALLED FROM WITHIN OBEY
NEWLINES(5)
IF REASON = 1 THEN PRINTSTRING( C
"***JOB TIME LIMIT EXCEEDED***")
IF REASON = 2 THEN PRINTSTRING( C
"***JOB TERMINATED BY OPERATOR***")
IF REASON = 3 THEN PRINTSTRING( C
"***NO MORE SPACE FOR JOB OUTPUT***")
NEWLINES(2)
PRINTSTRING("*** BATCH JOB ENDED AT ".TIME." ON ".DATE. C
" ****")
NEWLINES(2)
METER("")
NEWLINES(3)
FLAG = CLOSE(SSOWN_SSFDMAP(91)); !CLOSE MAIN OUTPUT FILE
MESSAGE = "BATCH JOB ".DIRINF_JOBNAME." COMPLETED"
START = ADDR(MESSAGE)+1
LEN = LENGTH(MESSAGE)
FLAG = X16{DMESSAGE2}(SSOWN_SSOWNER,LEN,1,SSOWN_SSINVOCATION!!1,SSOWN_SSOWNFSYS,START)
! The fourth parameter of DMESSAGE2 is the invocation number of the
! process to which the message is to be sent. It is quite common
! for an interactive process, being invocation 0, to detach a batch
! job which becomes invocation 1. When the batch job completes, the
! completion message should naturally go to the interactive process,
! so this code used to specify an invocation number of 0. However,
! other combinations of invocation numbers can occur, so we now
! attempt to make a better guess.
! SSOWN_SSINVOCATION !! 1 is not guaranteed to be the right invocation,
! but it is more likely than simply using 0. Even if it is wrong, the
! consequences will not be disastrous.
HALT
END ; !OF BATCHSTOP
!
SYSTEMROUTINE REROUTECONTINGENCY(INTEGER EP,CLASS, C
LONGINTEGER MASK, DR,INTEGER S,XNB,INTEGERNAME FLAG)
!NOTE THAT THE 16 BYTES STARTING AT DR ARE REPLACED BY ONE PARAMETER
!%ROUTINENAME RR WHEN THIS ROUTINE IS SPECIFIED
CONSTINTEGER MAXEP = 5
RECORD (RRCF)NAME RRC
FLAG = 0; !DEFAULT REPLY
IF 0<EP<=MAXEP THEN START
IF SSOWN_RRCBASE=0 THEN SSOWN_RRCBASE = GETSPACE(32*MAXRRC); !ROOM FOR 8 ENTRIES
! Check for 'no room' or 'table full':
IF SSOWN_RRCBASE=0 OR SSOWN_RRCTOP=MAXRRC THEN FLAG = 300 ELSE START
RRC == RECORD(SSOWN_RRCBASE+(32*SSOWN_RRCTOP))
RRC_TYPE = EP
RRC_CLASS = CLASS
RRC_MASK = MASK
RRC_DR = DR
RRC_XNB = XNB
SSOWN_RRCTOP = SSOWN_RRCTOP+1
FINISH
FINISH ELSE IF EP=0 THEN SSOWN_RRCTOP = 0 ELSE FLAG = 202; ! EP out of range.
END ; !OF REROUTECONTINGENCY
!
SYSTEMROUTINE INITJOURNAL
RECORD (FRF)FR
RECORD (RF)RR
INTEGER FLAG, I, JNSIZE
STRING (10) FILE
RETURN IF SSOWN_SSJOURNAL = 0 OR SSOWN_AITBUFFER = 0
IF SSOWN_SSJOURNAL = 1 START ; !TEMPJOURNAL SELECTED
FILE = SSTEMPJNAME
JNSIZE = SSTEMPJOURNALSIZE
FINISH ELSE START
FILE = SSPERMJNAME
FINFO(FILE,0,FR,FLAG); !IF FILE EXISTS TAKE SIZE FROM IT
IF FLAG = 0 THEN JNSIZE = FR_SIZE C
ELSE JNSIZE = SSPERMJOURNALSIZE
FINISH
CONNECT(FILE,3,0,8,RR,FLAG); !CONNECT PERMANENTLY
IF FLAG = 218 START ; !FILE DOES NOT EXIST
OUTFILE(FILE,JNSIZE,0,8,RR_CONAD,FLAG)
-> ERR IF FLAG # 0
INTEGER(RR_CONAD) = 32
INTEGER(RR_CONAD+4) = 32
INTEGER(RR_CONAD+12) = 8; !TYPE = JOURNAL FILE
FINISH ELSE START
-> ERR IF FLAG # 0 OR RR_FILETYPE # 8
FINISH
SSOWN_IT_JNBASE = RR_CONAD
SSOWN_IT_JNMAX = SSOWN_IT_JNBASE+JNSIZE
IF INTEGER(SSOWN_IT_JNBASE) = 0 START ; !LAST SESSION ENDED WITHOUT CLOSING JOURNAL
FOR I=SSOWN_IT_JNBASE+32,1,SSOWN_IT_JNMAX-1 CYCLE
IF BYTEINTEGER(I) = 255 THEN START
SSOWN_IT_JNCUR = I
-> ENDFOUND
FINISH
REPEAT
SSOWN_IT_JNCUR = SSOWN_IT_JNBASE+32; ! NO TERMINATOR FOUND
BYTEINTEGER(SSOWN_IT_JNMAX-1) = 0; !SO GETJOURNAL WILL NOT PRODUCE INVALID WRAP AROUND
FINISH ELSE SSOWN_IT_JNCUR = SSOWN_IT_JNBASE+INTEGER(SSOWN_IT_JNBASE)
BYTE INTEGER (SSOWN_IT_JNCUR) = 255
ENDFOUND:
INTEGER(SSOWN_IT_JNBASE) = 0; !TO INDICATE FAILURE DURING SESSION
ERR:
END ; !OF INITJOURNAL
!
SYSTEMROUTINE CLOSEJOURNAL
RETURN IF SSOWN_IT_JNBASE <= 0
INTEGER(SSOWN_IT_JNBASE) = SSOWN_IT_JNCUR-SSOWN_IT_JNBASE; !OFFSET OF END
END ; !OF CLOSEJOURNAL
!
SYSTEM ROUTINE JOURNAL OFF
IF STUDENTSS=0 THEN START
IF SSOWN_IT_JNBASE>0 THEN START
SSOWN_IT_JNBASE = - SSOWN_IT_JNBASE
SSOWN_SSOPENUSED=1; !to make sure tidyfiles will be called before
!the next command to turn on recall again
FINISH
FINISH
END
!
SYSTEMROUTINE GETJOURNAL(STRINGNAME FILE, INTEGERNAME FLAG)
!THIS ROUTINE IS USED BY RECALL AND RECAP
INTEGER LEN, START, CONAD, WRAP, AFM, LFM
IF SSOWN_IT_JNBASE<=0 THEN START ; ! JOURNAL NOT SELECTED
FLAG = 304
-> ERR
FINISH
WRAP = BYTEINTEGER(SSOWN_IT_JNMAX-1); !WRAPPED ROUND IF NON-ZERO
! IF LAST BYTE IN JOURNAL FILE NON ZERO THEN WRAP ROUND
IF WRAP=0 C
THEN LEN = SSOWN_IT_JNCUR-SSOWN_IT_JNBASE C
ELSE LEN = SSOWN_IT_JNMAX-SSOWN_IT_JNBASE-1; ! The byte at SSOWN_IT_JNCUR is a marker (X'FF')
! and we don't want it in the output file.
FILE = "T#TMPJN"
OUTFILE(FILE,LEN,0,0,CONAD,FLAG)
-> ERR IF FLAG#0
INTEGER(CONAD) = LEN
INTEGER(CONAD+12) = 3; !TYPE=CHARACTER
START = CONAD+32
IF WRAP#0 THEN START ; !MUST HAVE WRAPPED AROUND
AFM = SSOWN_IT_JNCUR + 1
LFM = SSOWN_IT_JNMAX - AFM
MOVE (LFM,AFM,START)
START = START + LFM
LEN = LEN - LFM
FINISH
MOVE(LEN-32,SSOWN_IT_JNBASE+32,START)
ERR:
SSOWN_IT_JNBASE = -SSOWN_IT_JNBASE; !TO INHIBIT JOURNAL DURING RECALL AND RECAP
SSOWN_SSOPENUSED = 1; !TO ENSURE SSOWN_IT_JNBASE GETS RESET AT COMMAND LEVEL
END ; !OF GETJOURNAL
!
!
SYSTEMROUTINE OFFER(STRING (31) FILE, C
STRING (6) TO, INTEGERNAME FLAG)
FLAG = CHECKFILENAME(FILE,5)
IF FLAG=0 THEN START
IF NEWCONNECT=0 THEN START
DISCONNECT(LAST,FLAG); !IGNORE FLAG
FINISH ELSE START
RDISCON (LAST, FLAG); ! to make sure that Director disconnects it.
FINISH
FLAG = DIRTOSS(X19{DOFFER}(SSOWN_CURFOWNER,TO,SSOWN_CURFNAME,SSOWN_CURFSYS))
IF FLAG#0 THEN START
IF FLAG=201 THEN SSOWN_SSFNAME = TO ELSE SSOWN_SSFNAME = SSOWN_CURFNAME
FINISH
FINISH
END ; !OF OFFER
!
SYSTEMROUTINE ACCEPT(STRING (31) FILE, NEWNAME, C
INTEGERNAME FLAG)
STRING (6) OWNER
STRING (11) NAME
INTEGER FSYS
FLAG = CHECKFILENAME(FILE,6); !ANY NAME EXCEPT OWN
-> ERR IF FLAG # 0
OWNER = SSOWN_CURFOWNER
NAME = SSOWN_CURFNAME; !HOLD FOR USE IN CALL OF X2{DTRANSFER}
FSYS = SSOWN_CURFSYS
IF NEWNAME # "" START ; !NEW NAME TO BE GIVEN TO FILE
FLAG = CHECKFILENAME(NEWNAME,5)
!ANY OWN FILE
-> ERR IF FLAG # 0
FINISH
NEWNAME = SSOWN_CURFNAME; !PROTEM - DEFAULT VALUE OF
! NEWNAME IS SAME AS ORIGINAL
! SSOWN_CURFNAME
FLAG = DIRTOSS(X2{DTRANSFER}(OWNER,SSOWN_SSOWNER,NAME,NEWNAME,FSYS,SSOWN_SSOWNFSYS,0))
IF FLAG=218 OR FLAG=278 OR FLAG=505 THEN SSOWN_SSFNAME=OWNER.".".NAME ELSE SSOWN_SSFNAME=SSOWN_CURFILE
ERR:
END ; !OF ACCEPT
!
!****************************************************************************
!
! ROUTINE PERMIT INNER
!
!****************************************************************************
!
! This routine is the routine which calls DPERMISSION and is used
! by all the other permit routines. Note that it is passed an
! integer FILETYPE - this should be set to either
! 0 - to refer to a disc file or
! 1 - to refer to the archived file index.
!
! Note also that this routine will permit other users files if
! the caller has the neccessary privilege. If the caller has
! not got the privilege then the privilege error (93) is
! translated into the subsystem error - Illegal use of another
! users file <file>. This makes the command appear no different
! tham it was formerly to the unprivileged caller.
!
! CHECKFILENAME is used to set up the neccesary FILEname, FSYS,
! fileOWNER this means no special code is needed for the
! permitting of other users files.
!
! Note also that 16 is added to the TYPE Field if the file
! to be permitted is archived. This is to let director know.
ROUTINE PERMIT INNER (STRING (31) FILE, STRING (8) DATE,
STRING (6) USER, INTEGER FILE TYPE, MODE,
INTEGERNAME FLAG)
STRING (31)FOWNER,FNAME
CONSTINTEGER DISC FILE = 0; ! FILE TYPE = DISC FILE
INTEGER TYPE
IF FILE->FOWNER.(".").FNAME AND FNAME="" THEN FILE="" ELSE FOWNER=SSOWN_SSOWNER
IF FILE # "" THEN START ; !PERMIT 1 FILE
FLAG = CHECKFILENAME(FILE,7)
!ANY OWN FILE
RETURN IF FLAG # 0
FILE = SSOWN_CURFNAME; !FILE USED IN CALL OF X22{DPERMISSION}
IF SSOWN_CURFOWNER=USER=SSOWN_SSOWNER THEN {SET OWNP} TYPE = 0 C
ELSE IF USER="" THEN {SET EEP} TYPE = 1 C
ELSE IF MODE>=0 THEN {ADD USER TO LIST} TYPE = 2 C
ELSE {REMOVE USER FROM LIST} TYPE = 3
TYPE=TYPE+16 IF FILE TYPE#DISC FILE
FLAG=DIRTOSS(X22{DPERMISSION}(SSOWN_CURFOWNER,USER,DATE,FILE,SSOWN_CURFSYS,TYPE,MODE))
FINISH ELSE START
! {WHOLE INDEX PERMISSION}
IF MODE>=0 THEN TYPE = 6 ELSE TYPE = 7
TYPE = TYPE + 16 IF FILE TYPE # DISC FILE; ! If referring to archive file
FLAG = DIRTOSS(X22{DPERMISSION}(FOWNER,USER,DATE,FILE,-1,TYPE,MODE)); !-1 for unknown fsys
FINISH
FLAG = 258 IF FLAG = 593; ! Illegal use of other users file
IF FLAG # 0 THEN SSOWN_SSFNAME = SSOWN_CURFNAME
END ; !OF PERMIT INNER
SYSTEMROUTINE ARCHIVEPERMIT (STRING (31) FILE, STRING (8) DATE,
STRING (6) USER,
INTEGER MODE,
INTEGERNAME FLAG)
! = the old PERMIT - for archived files
CONSTINTEGER ARCHIVED FILE = 1
IF USER="=" THEN USER=UINFS(1); !short form for self
PERMIT INNER (FILE, DATE, USER, ARCHIVED FILE, MODE, FLAG)
END ; !OF ARCHIVEPERMIT
SYSTEMROUTINE PERMIT(STRING (31) FILE, C
STRING (6) USER, INTEGER MODE, INTEGERNAME FLAG)
! = the old PERMIT - for online files
CONSTINTEGER DISC FILE = 0
IF USER="=" THEN USER=UINFS(1); !short form for self
PERMIT INNER (FILE, "", USER, DISC FILE, MODE, FLAG)
END ; !PERMIT
!
!
SYSTEMINTEGERFN GIVEREGS(INTEGERARRAYNAME ARR, INTEGER P)
! P should be in the range 0 -> -3.
! The most recent contingency is 0, the next most recent is -1 and
! so on. (Just like #REGS).
! The result of the function is a bit significant flag.
! If the 2**0 bit is set then there was no info.
! If the 2**1 bit is set then P was out of range
! and was defaulted to 0, i.e. the most recent.
! If there was contingency information then a copy is made to the
! array ARR: a 23 member, one dimensional array declared (-2:20).
INTEGER I,FLAG
FLAG=0
UNLESS -3<=P<=0 THEN P=0 AND FLAG=2
P=(SSOWN_SAVEIDPOINTER+P-1)&3
IF SSOWN_SAVEIDATA(18,P)=0 THEN RESULT =FLAG!1
ARR(I)=SSOWN_SAVEIDATA(I,P) FOR I=20,-1,-2
RESULT =FLAG
END ; ! OF GIVEREGS
!
!
! - END OF INFREQUENT CODE ]
!
! [ START OF SMES CODE -
!
CONSTINTEGER MINMESS=1
CONSTINTEGER MAXMESS = 425
!
!**START
STRING (71)FN MESSAGE(INTEGER N)
!***********************************************************************
!* *
!* Outputs an error message stored in a compressed format *
!* *
!* 1 Real overflow *
!* 2 Real underflow *
!* 3 Integer overflow *
!* 4 Decimal overflow *
!* 5 Zero divide *
!* 6 Array bounds exceeded *
!* 7 Capacity exceeded *
!* 8 Illegal operation *
!* 9 Address error *
!* 10 Interrupt of class *
!* 11 Unassigned variable *
!* 12 Time exceeded *
!* 13 No more space for output *
!* 14 Operator termination *
!* 15 Illegal exponentiation *
!* 16 Switch label not set *
!* 17 Corrupt dope vector *
!* 18 Illegal cycle *
!* 19 Int pt too large *
!* 20 Array inside out *
!* 21 No result *
!* 22 Param not destination *
!* 23 Arrays too large or too much recursion *
!* 24 Stream not defined *
!* 25 Input ended *
!* 26 Symbol in data *
!* 27 IOCP error *
!* 28 SUB character in data *
!* 29 Stream in use *
!* 30 Graph fault *
!* 31 Diagnostics fail *
!* 32 Resolution fault *
!* 33 Invalid margins *
!* 34 Symbol instead of string *
!* 35 String inside out *
!* 36 Wrong params provided *
!* 37 Unsatisfied reference *
!* 38 Unassigned switch variable *
!* 39 Illegal system call *
!* 40 Unrecoverable disc fault *
!* 41 Unrecoverable store or processor fault *
!* 50 SQRT arg negative *
!* 51 LOG arg negative *
!* 52 LOG arg zero *
!* 53 EXP arg out of range *
!* 54 SIN arg out of range *
!* 55 COS arg out of range *
!* 56 TAN arg out of range *
!* 57 TAN arg inappropriate *
!* 58 ASIN arg out of range *
!* 59 ACOS arg out of range *
!* 60 ATAN2 args zero *
!* 61 SINH arg out of range *
!* 62 COSH arg out of range *
!* 63 LGAMMA arg not positive *
!* 64 LGAMMA arg too large *
!* 65 GAMMA arg out of range *
!* 66 COT arg out of range *
!* 67 COT arg inappropriate *
!* 68 Real exponentiation fault *
!* 69 Complex exponentiation fault *
!* 70 RADIUS args too large *
!* 71 ARCTAN args zero *
!* 72 ARCSIN arg out of range *
!* 73 ARCCOS arg out of range *
!* 74 HYPSIN arg out of range *
!* 75 HYPCOS arg out of range *
!* 76 Matrix bound zero or negative *
!* 101 Missing left bracket *
!* 102 Missing right bracket *
!* 103 Negative sign incorrect *
!* 104 Invalid format *
!* 105 Decimal field too wide *
!* 106 Format width zero invalid *
!* 107 Repetition factor invalid *
!* 108 Null literal invalid *
!* 109 Integer field too large *
!* 110 No width field allowed *
!* 111 Literal in input format *
!* 112 Minimum digits greater than width *
!* 114 Non-repeatable edit desc *
!* 115 Comma required *
!* 116 Decimal point not allowed *
!* 117 Unit not connected *
!* 118 File already connected *
!* 119 Access conflict *
!* 120 RECL conflict *
!* 121 Form conflict *
!* 122 Status conflict *
!* 123 Invalid status *
!* 124 Form not suitable *
!* 125 Specifier not recognised *
!* 126 Specifiers inconsistent *
!* 127 Illegal specifier value *
!* 128 Invalid filename *
!* 129 No filename specified *
!* 130 Record length not specified *
!* 132 Value separator missing *
!* 133 No digits specified *
!* 134 Invalid scaling *
!* 135 Invalid logical value *
!* 136 Invalid character value *
!* 137 Value not recognised *
!* 138 Invalid repetition value *
!* 139 Illegal repetition factor *
!* 140 Invalid integer *
!* 141 Invalid real *
!* 142 Invalid subscript(s) *
!* 143 Invalid complex constant *
!* 144 Variable is not an array *
!* 145 Equals sign missing after name *
!* 146 Variable not in NAMELIST list *
!* 147 Invalid item *
!* 148 Invalid character *
!* 149 Invalid variable name *
!* 150 Literal not terminated *
!* 151 Channel not defined *
!* 152 File does not exist *
!* 153 Input file ended *
!* 154 Wrong length record *
!* 155 Incompatible format descriptor *
!* 156 Read after write *
!* 157 Write after ENDFILE *
!* 158 Record number out of range *
!* 159 No format descriptor for data item *
!* 160 DECODE/ENCODE buffer fault *
!* 161 Invalid record size *
!* 162 No write permission for file *
!* 163 Physical end of tape *
!* 164 Invalid channel number *
!* 165 Too many files defined *
!* 166 Invalid record size *
!* 167 Invalid filename & *
!* 168 File already exists *
!* 169 Output file capacity exceeded *
!* 170 Unrecoverable system I/O error *
!* 171 Invalid operation on file *
!* 172 Wrong length record *
!* 173 No access permission *
!* 174 Invalid file description *
!* 175 File not available *
!* 176 File already open *
!* 177 Addresses inside out *
!* 178 File not open *
!* 179 File description incorrect for D.A. *
!* 180 File record size incorrect for D.A. *
!* 181 Facility not available *
!* 182 I/O error-unspecified *
!* 183 Illegal I/O operation *
!* 184 Format text too large *
!* 185 File has conflicting use *
!* 186 Blank field not permitted *
!* 187 Invalid format specification *
!* 188 RECL too large *
!* 189 NREC too large *
!* 191 F77JINIT not called *
!* 192 Delete status invalid *
!* 193 Not connected for unformatted I/O *
!* 194 Not connected for formatted I/O *
!* 195 BACKSPACE not allowed *
!* 196 Illegal BACKSPACE *
!* 197 DA workfiles not available *
!* 198 No filetype for a new DA file *
!* 199 Number of DA records not specified *
!* 200 Direct-access not a file property *
!* 201 Invalid username & *
!* 202 Invalid parameter & *
!* 203 CPU limit exceeds permitted maximum *
!* 204 Output limit exceeds permitted maximum *
!* 205 Resource allowance exceeded *
!* 206 Invalid control statement *
!* 207 No file access allowed *
!* 208 Data file not on-line *
!* 209 Tape access not allowed *
!* 210 Tape not available *
!* 211 CPU time exceeded *
!* 212 Job output limit exceeded *
!* 213 Termination requested *
!* 214 Invalid keyword *
!* 215 Too many parameters *
!* 216 User not registered for file use *
!* 217 Spool data area full *
!* 218 File & does not exist *
!* 219 File already exists *
!* 220 Invalid filename & *
!* 221 Source library not defined *
!* 222 No object file *
!* 223 Invalid channel number *
!* 224 File name too long *
!* 225 Failed to create area *
!* 226 Corrupt object file *
!* 227 Too many external names *
!* 228 Program too large *
!* 229 File names must be different *
!* 230 File facilities not available *
!* 231 Invalid filename for level two user *
!* 232 Files in library still connected *
!* 233 & *
!* 256 File & not connected *
!* 257 File & not inserted *
!* 258 Illegal use of another user's file - & *
!* 259 Illegal use of own file *
!* 260 Invalid connect mode *
!* 261 VM hole too small *
!* 262 VM full *
!* 263 Wrong number of parameters *
!* 264 Invalid device code & *
!* 265 Attempt to re-define open channel *
!* 266 Inconsistent file use *
!* 267 Invalid filetype & *
!* 268 Multiple BACKSPACE not allowed *
!* 269 Illegal use of PD file member *
!* 270 Invalid membername & *
!* 271 Attempt to write to PD member *
!* 272 Subsystem error *
!* 273 File & on offer *
!* 274 File not on offer *
!* 275 File system full *
!* 276 No free descriptors in file index *
!* 277 Too many input files *
!* 278 File connected in another VM *
!* 279 Conflicting use of file & in another process *
!* 280 User individual file limit exceeded *
!* 281 Too many permissions *
!* 282 User not in permission list *
!* 283 Own permission insufficient *
!* 284 Spooler failure *
!* 285 Looping on alias & *
!* 286 Not a PD file *
!* 287 Member already exists *
!* 288 Member & does not exist *
!* 289 Entry & not found *
!* 290 Entry & already in directory *
!* 291 Too many entries *
!* 292 Point list full *
!* 293 Inconsistent directory entry for & *
!* 294 Illegal use of .NULL *
!* 295 Attempt to DEFINE too large file *
!* 296 Inconsistent length for data area & *
!* 297 Inconsistent parameters *
!* 298 No main entry in file *
!* 299 Attempt to load FORTRAN dynamically *
!* 300 Table too small *
!* 301 Channel not open *
!* 302 Channel is open *
!* 303 Requested access permission not allowed *
!* 304 RECALL option not selected *
!* 305 No input files *
!* 306 Duplicate request *
!* 307 Illegal call from within program *
!* 308 User total limit exceeded *
!* 309 Too many files connected *
!* 310 Attempt to overwrite PD file *
!* 311 Corrupt file & *
!* 312 Too little space for initialised stack *
!* 313 Directory & not in SEARCHDIR list *
!* 314 SEARCHDIR list full *
!* 315 Cannot OBEY within OBEY *
!* 316 Cannot call macro from program *
!* 317 Document & belongs to another user *
!* 318 Document & not queued or active *
!* 319 Attempt to write - no Write Ring requested *
!* 320 Illegal parameter format *
!* 321 Ambiguous keyword *
!* 322 Keyword not recognised *
!* 323 Too many parameters *
!* 324 Duplicated parameter *
!* 325 Missing keyword *
!* 326 Invalid value for & parameter *
!* 327 No such stream *
!* 328 No input selected *
!* 329 No output selected *
!* 330 No format information supplied in DEFINEMT *
!* 331 Spooler queue full *
!* 332 Invalid access permission *
!* 333 Group members cannot donate funds *
!* 334 Insufficient funds *
!* 335 Insufficient privilege to use device & *
!* 336 Invalid macro header *
!* 337 Too many input levels *
!* 338 Invalid parameter for READ *
!* 339 OUT parameter invalid *
!* 340 Cannot set own permission for all files *
!* 341 Cannot remove all own permissions *
!* 342 Cannot set .ALL archived files permission *
!* 343 Cannot set self permission for archived files *
!* 350 File & already loaded *
!* 351 Maximum load level exceeded *
!* 352 Chain of aliases too long *
!* 353 Entry & not loaded *
!* 354 Entry & already loaded *
!* 355 Data area not wholly within file *
!* 356 Overlaps previously defined data area & *
!* 357 & not positive integer *
!* 358 Not callable from within user program *
!* 359 Too many separate USEFOR requests *
!* 401 Unassigned variable *
!* 402 Adjustable dimension bound is unassigned *
!* 403 Assigned value is invalid *
!* 404 Assigned label is not in specified list *
!* 405 Integer is not assigned with a format label *
!* 406 Array bound exceeded *
!* 407 Array parameter upper bound is less than lower bound *
!* 408 Array parameter declared size is greater than actual *
!* 409 Assumed size array requires zero last dimension *
!* 410 Character array param only valid for FORT77 call *
!* 411 Invalid character substring position value *
!* 412 Character param declared size is greater than actual *
!* 415 Do loop increment is zero *
!* 418 Recursive call to a procedure *
!* 419 Wrong type or size of function *
!* 421 Wrong number of parameters *
!* 422 Wrong type or size of parameter *
!* 424 Negative unit number specified *
!* 425 Fault no. *
!***********************************************************************
CONSTBYTEINTEGERARRAY OUTTT(0:73)= '?','A','B','C','D','E','F','G',
'H','I','J','K','L','M','N',
'O','P','Q','R','S','T','U',
'V','W','X','Y','Z','&','-',
'/','''','(',')',
'a','b','c','d','e','f','g',
'h','i','j','k','l','m','n',
'o','p','q','r','s','t','u',
'v','w','x','y','z','.','%',
'#','?','?',
'0','1','2','3','4','5','6',
'7','8','9'
CONSTINTEGER WORDMAX= 1510,DEFAULT= 1507
CONSTHALFINTEGERARRAY WORD(0:WORDMAX)=0,C
1, 32769, 32770, 2, 32769, 32772, 3, 32774,
32770, 4, 32776, 32770, 5, 32778, 32779, 6,
32781, 32782, 32784, 7, 32786, 32784, 8, 32788,
32790, 9, 32792, 32794, 10, 32795, 32797, 32798,
11, 32799, 32801, 12, 32803, 32784, 13, 32804,
32805, 32806, 32807, 32808, 14, 32810, 32812, 15,
32788, 32815, 16, 32818, 32820, 32821, 32822, 17,
32823, 32825, 32826, 18, 32788, 32828, 19, 32829,
32824, 32830, 32831, 20, 32781, 32832, 32834, 21,
32804, 32835, 22, 32837, 32821, 32838, 23, 32841,
32830, 32831, 32843, 32830, 32844, 32845, 24, 32847,
32821, 32849, 25, 32851, 32852, 26, 32853, 32855,
32856, 27, 32857, 32794, 28, 32858, 32859, 32855,
32856, 29, 32847, 32855, 32861, 30, 32862, 32863,
31, 32864, 32867, 32, 32868, 32863, 33, 32870,
32872, 34, 32853, 32874, 32797, 32876, 35, 32878,
32832, 32834, 36, 32880, 32881, 32883, 37, 32885,
32888, 38, 32799, 32890, 32801, 39, 32788, 32892,
32894, 40, 32895, 32898, 32863, 41, 32895, 32899,
32843, 32900, 32863, 50, 32902, 32903, 32904, 51,
32906, 32903, 32904, 52, 32906, 32903, 32907, 53,
32908, 32903, 32834, 32797, 32909, 54, 32910, 32903,
32834, 32797, 32909, 55, 32911, 32903, 32834, 32797,
32909, 56, 32912, 32903, 32834, 32797, 32909, 57,
32912, 32903, 32913, 58, 32916, 32903, 32834, 32797,
32909, 59, 32917, 32903, 32834, 32797, 32909, 60,
32918, 32920, 32907, 61, 32921, 32903, 32834, 32797,
32909, 62, 32922, 32903, 32834, 32797, 32909, 63,
32923, 32903, 32821, 32925, 64, 32923, 32903, 32830,
32831, 65, 32927, 32903, 32834, 32797, 32909, 66,
32928, 32903, 32834, 32797, 32909, 67, 32928, 32903,
32913, 68, 32769, 32815, 32863, 69, 32929, 32815,
32863, 70, 32931, 32920, 32830, 32831, 71, 32933,
32920, 32907, 72, 32935, 32903, 32834, 32797, 32909,
73, 32937, 32903, 32834, 32797, 32909, 74, 32939,
32903, 32834, 32797, 32909, 75, 32941, 32903, 32834,
32797, 32909, 76, 32943, 32945, 32907, 32843, 32904,
101, 32946, 32948, 32949, 102, 32946, 32951, 32949,
103, 32952, 32954, 32955, 104, 32870, 32957, 105,
32776, 32959, 32830, 32960, 106, 32961, 32963, 32907,
32964, 107, 32966, 32968, 32964, 108, 32970, 32971,
32964, 109, 32774, 32959, 32830, 32831, 110, 32804,
32963, 32959, 32973, 111, 32975, 32855, 32977, 32957,
112, 32978, 32980, 32982, 32984, 32963, 114, 32985,
32988, 32989, 115, 32990, 32991, 116, 32776, 32993,
32821, 32973, 117, 32994, 32821, 32995, 118, 32997,
32998, 32995, 119, 33000, 33002, 120, 33004, 33002,
121, 33005, 33002, 122, 33006, 33002, 123, 32870,
33008, 124, 33005, 32821, 33010, 125, 33012, 32821,
33014, 126, 33016, 33018, 127, 32788, 33021, 33023,
128, 32870, 33024, 129, 32804, 33024, 33026, 130,
33028, 33030, 32821, 33026, 132, 33032, 33033, 33035,
133, 32804, 32980, 33026, 134, 32870, 33037, 135,
32870, 33039, 33023, 136, 32870, 32859, 33023, 137,
33032, 32821, 33014, 138, 32870, 33041, 33023, 139,
32788, 33041, 32968, 140, 32870, 33043, 141, 32870,
33045, 142, 32870, 33046, 143, 32870, 33049, 33051,
144, 33053, 33055, 32821, 33056, 33057, 145, 33058,
32954, 33035, 33060, 33061, 146, 33053, 32821, 32855,
33062, 33064, 147, 32870, 33065, 148, 32870, 32859,
149, 32870, 32801, 33061, 150, 32975, 32821, 33066,
151, 33068, 32821, 32849, 152, 32997, 33070, 32821,
33071, 153, 32851, 33072, 32852, 154, 32880, 33030,
33073, 155, 33075, 32957, 33078, 156, 33080, 33060,
33081, 157, 33082, 33060, 33083, 158, 33028, 33085,
32834, 32797, 32909, 159, 32804, 32957, 33078, 32807,
32856, 33065, 160, 33087, 33090, 32863, 161, 32870,
33073, 33092, 162, 32804, 33081, 33093, 32807, 33072,
163, 33095, 33097, 32797, 33098, 164, 32870, 33099,
33085, 165, 33101, 33102, 33103, 32849, 166, 32870,
33073, 33092, 167, 32870, 33024, 33104, 168, 32997,
32998, 33105, 169, 33107, 33072, 33109, 32784, 170,
32895, 32892, 33111, 32794, 171, 32870, 32790, 33112,
33072, 172, 32880, 33030, 33073, 173, 32804, 33113,
33093, 174, 32870, 33072, 33115, 175, 32997, 32821,
33118, 176, 32997, 32998, 33120, 177, 33121, 32832,
32834, 178, 32997, 32821, 33120, 179, 32997, 33115,
32955, 32807, 33123, 180, 32997, 33073, 33092, 32955,
32807, 33123, 181, 33124, 32821, 33118, 182, 33111,
33126, 183, 32788, 33111, 32790, 184, 32961, 33130,
32830, 32831, 185, 32997, 33131, 33132, 32861, 186,
33135, 32959, 32821, 33136, 187, 32870, 32957, 33138,
188, 33004, 32830, 32831, 189, 33141, 32830, 32831,
191, 33142, 32821, 33144, 192, 33146, 33008, 32964,
193, 33148, 32995, 32807, 33149, 33111, 194, 33148,
32995, 32807, 33152, 33111, 195, 33154, 32821, 32973,
196, 32788, 33154, 197, 33156, 33157, 32821, 33118,
198, 32804, 33159, 32807, 33161, 33162, 33156, 33072,
199, 33163, 32797, 33156, 33165, 32821, 33026, 200,
33167, 32821, 33161, 33072, 33170, 201, 32870, 33172,
33104, 202, 32870, 33174, 33104, 203, 33176, 33177,
33178, 33136, 33180, 204, 33107, 33177, 33178, 33136,
33180, 205, 33182, 33184, 32784, 206, 32870, 33186,
33188, 207, 32804, 33072, 33113, 32973, 208, 33190,
33072, 32821, 33191, 209, 33193, 33113, 32821, 32973,
210, 33193, 32821, 33118, 211, 33176, 33194, 32784,
212, 33195, 32808, 33177, 32784, 213, 33196, 33199,
214, 32870, 33201, 215, 33101, 33102, 33203, 216,
33205, 32821, 33206, 32807, 33072, 32861, 217, 33208,
32856, 33209, 33210, 218, 32997, 33104, 33070, 32821,
33071, 219, 32997, 32998, 33105, 220, 32870, 33024,
33104, 221, 33211, 33213, 32821, 32849, 222, 32804,
33215, 33072, 223, 32870, 33099, 33085, 224, 32997,
33061, 32830, 33217, 225, 33218, 33220, 33221, 33209,
226, 32823, 33215, 33072, 227, 33101, 33102, 33223,
33225, 228, 33226, 32830, 32831, 229, 32997, 33225,
33228, 33229, 33230, 230, 32997, 33232, 32821, 33118,
231, 32870, 33024, 32807, 33234, 33235, 33236, 232,
33237, 32855, 33213, 33238, 32995, 233, 33104, 256,
32997, 33104, 32821, 32995, 257, 32997, 33104, 32821,
33239, 258, 32788, 32861, 32797, 33241, 33243, 33072,
33245, 33104, 259, 32788, 32861, 32797, 33246, 33072,
260, 32870, 33247, 33249, 261, 33250, 33251, 32830,
33252, 262, 33250, 33210, 263, 32880, 33085, 32797,
33203, 264, 32870, 33253, 33255, 33104, 265, 33256,
33220, 33258, 33120, 33099, 266, 33260, 33072, 32861,
267, 32870, 33159, 33104, 268, 33263, 33154, 32821,
32973, 269, 32788, 32861, 32797, 33265, 33072, 33266,
270, 32870, 33268, 33104, 271, 33256, 33220, 33081,
33220, 33265, 33266, 272, 33270, 32794, 273, 32997,
33104, 33112, 33272, 274, 32997, 32821, 33112, 33272,
275, 32997, 32892, 33210, 276, 32804, 33273, 33274,
32855, 33072, 33277, 277, 33101, 33102, 32977, 33103,
278, 32997, 32995, 32855, 33241, 33250, 279, 33278,
32861, 32797, 33072, 33104, 32855, 33241, 33281, 280,
33205, 33283, 33072, 33177, 32784, 281, 33101, 33102,
33285, 282, 33205, 32821, 32855, 33093, 33064, 283,
33288, 33093, 33289, 284, 33292, 33294, 285, 33296,
33112, 33298, 33104, 286, 33148, 33161, 33265, 33072,
287, 33299, 32998, 33105, 288, 33299, 33104, 33070,
32821, 33071, 289, 33301, 33104, 32821, 33302, 290,
33301, 33104, 32998, 32855, 33303, 291, 33101, 33102,
33305, 292, 33307, 33064, 33210, 293, 33260, 33303,
33308, 32807, 33104, 294, 32788, 32861, 32797, 33309,
295, 33256, 33220, 33310, 32830, 32831, 33072, 296,
33260, 33030, 32807, 32856, 33209, 33104, 297, 33260,
33203, 298, 32804, 33312, 33308, 32855, 33072, 299,
33256, 33220, 33313, 33314, 33316, 300, 33319, 32830,
33252, 301, 33068, 32821, 33120, 302, 33068, 33055,
33120, 303, 33320, 33113, 33093, 32821, 32973, 304,
33322, 33324, 32821, 33326, 305, 32804, 32977, 33103,
306, 33328, 33330, 307, 32788, 32894, 33332, 33333,
33335, 308, 33205, 33337, 33177, 32784, 309, 33101,
33102, 33103, 32995, 310, 33256, 33220, 33338, 33265,
33072, 311, 32823, 33072, 33104, 312, 33101, 33340,
32806, 32807, 33342, 33345, 313, 33346, 33104, 32821,
32855, 33348, 33064, 314, 33348, 33064, 33210, 315,
33350, 33352, 33333, 33352, 316, 33350, 32894, 33353,
33332, 33335, 317, 33354, 33104, 33356, 33220, 33241,
33236, 318, 33354, 33104, 32821, 33358, 32843, 33360,
319, 33256, 33220, 33081, 33245, 33362, 33082, 33363,
33199, 320, 32788, 33174, 32957, 321, 33364, 33201,
322, 33366, 32821, 33014, 323, 33101, 33102, 33203,
324, 33368, 33174, 325, 32946, 33201, 326, 32870,
33023, 32807, 33104, 33174, 327, 32804, 33370, 33371,
328, 32804, 32977, 33326, 329, 32804, 32808, 33326,
330, 32804, 32957, 33373, 33376, 32855, 33378, 331,
33292, 33380, 33210, 332, 32870, 33113, 33093, 333,
33381, 33382, 33384, 33386, 33388, 334, 33389, 33388,
335, 33389, 33392, 33220, 32861, 33253, 33104, 336,
32870, 33353, 33394, 337, 33101, 33102, 32977, 33396,
338, 32870, 33174, 32807, 33398, 339, 33399, 33174,
32964, 340, 33350, 32822, 33246, 33093, 32807, 33400,
33103, 341, 33350, 33401, 33400, 33246, 33285, 342,
33350, 32822, 33403, 33404, 33103, 33093, 343, 33350,
32822, 33406, 33093, 32807, 33404, 33103, 350, 32997,
33104, 32998, 33407, 351, 33409, 33313, 33234, 32784,
352, 33411, 32797, 33412, 32830, 33217, 353, 33301,
33104, 32821, 33407, 354, 33301, 33104, 32998, 33407,
355, 33190, 33209, 32821, 33414, 33333, 33072, 356,
33416, 33418, 32849, 32856, 33209, 33104, 357, 33104,
32821, 32925, 33043, 358, 33148, 33420, 33332, 33333,
33236, 33335, 359, 33101, 33102, 33422, 33424, 33426,
401, 32799, 32801, 402, 33428, 33430, 32945, 33055,
33432, 403, 33434, 33023, 33055, 32964, 404, 33434,
32820, 33055, 32821, 32855, 33026, 33064, 405, 32774,
33055, 32821, 33436, 33438, 33161, 32957, 32820, 406,
32781, 32945, 32784, 407, 32781, 33174, 33439, 32945,
33055, 33440, 32984, 33441, 32945, 408, 32781, 33174,
33442, 33092, 33055, 32982, 32984, 33444, 409, 33446,
33092, 33057, 33448, 32907, 33450, 33430, 410, 33451,
33057, 33453, 33454, 33455, 32807, 33456, 32894, 411,
32870, 32859, 33458, 33460, 33023, 412, 33451, 33453,
33442, 33092, 33055, 32982, 32984, 33444, 415, 33462,
33463, 33464, 33055, 32907, 418, 33466, 32894, 33220,
33161, 33468, 419, 32880, 33470, 32843, 33092, 32797,
33471, 421, 32880, 33085, 32797, 33203, 422, 32880,
33470, 32843, 33092, 32797, 33174, 424, 32952, 33473,
33085, 33026, 425, 33474, 33475, 0
CONSTINTEGERARRAY LETT(0: 707)=0,C
X'252C3600',X'5FB4B94D',X'597EE000',X'6B7492E5',
X'4D65FB80',X'137692CF',X'4B900000',X'092C74DB',
X'43600000',X'352E5780',X'494ED4C9',X'4A000000',
X'039650F2',X'457EB749',X'66000000',X'4BC472CB',
X'492C8000',X'070E10C7',X'53A72000',X'136592CF',
X'43600000',X'5F84B943',X'694DF700',X'0324994B',
X'67980000',X'4B9657E4',X'137692E5',X'65AE1A00',
X'5F300000',X'476439E6',X'2B7439E7',X'533DD2C8',
X'6D0E54C3',X'4564A000',X'294DB280',X'1D780000',
X'5B7E5280',X'678431CA',X'4D7E4000',X'5FAE986B',
X'68000000',X'1F84B943',X'697E4000',X'692E56D3',
X'5D0E94DF',X'5C000000',X'4BC617DD',X'4B7694C3',
X'694DF700',X'27BD3A47',X'50000000',X'590C52D8',
X'5D7E8000',X'672E8000',X'077E596B',X'61A00000',
X'497E1280',X'6D2C7A5F',X'64000000',X'47CC764A',
X'13768000',X'697DE000',X'590E53CA',X'537674C9',
X'4A000000',X'5FAE8000',X'652E7AD9',X'68000000',
X'210E50DA',X'492E7A53',X'5D0E94DF',X'5C000000',
X'039650F3',X'66000000',X'5F900000',X'5BAC7400',
X'652C7AE5',X'674DF700',X'27A652C3',X'5A000000',
X'492CD4DD',X'4B200000',X'13761AE8',X'4B7492C8',
X'27CDB15F',X'58000000',X'53700000',X'490E9080',
X'12786800',X'26A84000',X'47443943',X'47A4B900',
X'6B9CA000',X'0F943850',X'4D0EB668',X'094C33DD',
X'5F9E94C7',X'66000000',X'4D0D3600',X'252E77D9',
X'6BA537DC',X'1376D0D9',X'53200000',X'5B0E53D3',
X'5D980000',X'53767A4B',X'43200000',X'67A654DD',
X'4E000000',X'27A654DD',X'4E000000',X'2F95F74E',
X'610E50DB',X'66000000',X'6195FB53',X'492C8000',
X'2B7670E9',X'539CD4CB',X'48000000',X'652CD2E5',
X'4B747280',X'67BD3A47',X'50000000',X'67CE7A4B',
X'5A000000',X'470D9600',X'2B7652C7',X'5FB4B943',
X'4564A000',X'494E7180',X'67A5F94A',X'6195F1CB',
X'679DF900',X'268A4A00',X'4394E000',X'5D2CF0E9',
X'53B4A000',X'1878E000',X'752E5780',X'0AC20000',
X'650DD3CA',X'2649C000',X'067A6000',X'2809C000',
X'53743861',X'657E1953',X'43A4A000',X'02992700',
X'0219E980',X'02A0277D',X'06000000',X'4394F980',
X'2649C400',X'067A6400',X'1838269B',X'02000000',
X'617E74E9',X'53B4A000',X'0E09A682',X'067A8000',
X'077DB859',X'4BC00000',X'240884AB',X'26000000',
X'02906A03',X'1C000000',X'02906993',X'1C000000',
X'0290619F',X'26000000',X'10CA0993',X'1C000000',
X'10CA019F',X'26000000',X'1B0E9953',X'70000000',
X'457EB748',X'1B4E79D3',X'5D380000',X'592CDA00',
X'459431D7',X'4BA00000',X'654CF468',X'1D2CF0E9',
X'53B4A000',X'674CF700',X'537477E5',X'652C7A00',
X'4D7E56C3',X'68000000',X'4D4CB648',X'6F4C9280',
X'0D7E56C3',X'68000000',X'6F4C9A50',X'5376D0D9',
X'53200000',X'252E12E9',X'53A537DC',X'4D0C7A5F',
X'64000000',X'1DAD9600',X'594E92E5',X'43600000',
X'436597EF',X'4B200000',X'194E92E5',X'43600000',
X'53761AE8',X'1B4DD4DB',X'6B680000',X'494CF4E9',
X'66000000',X'4F94B0E9',X'4B900000',X'69443700',
X'1D7DCE65',X'4B84B0E9',X'43159280',X'4B253A00',
X'492E7180',X'077DB6C2',X'652E3AD3',X'652C8000',
X'617D3768',X'2B753A00',X'477DD74B',X'47A4B200',
X'0D4D9280',X'436652C3',X'49C80000',X'031C72E7',
X'66000000',X'477DD359',X'531E8000',X'24286600',
X'0D7E5680',X'27A43A6B',X'66000000',X'67A43A6B',
X'66000000',X'67AD3A43',X'4564A000',X'2784B1D3',
X'4D4CB900',X'652C77CF',X'5D4E72C8',X'2784B1D3',
X'4D4CB966',X'537477DD',X'674E7A4B',X'5DA00000',
X'6784B1D3',X'4D4CB900',X'6D0D9ACA',X'4D4D92DD',
X'436CA000',X'6784B1D3',X'4D4CB200',X'252C77E5',
X'48000000',X'592DD3E9',X'50000000',X'2D0D9ACA',
X'672E10E5',X'43A5F900',X'5B4E79D3',X'5D380000',
X'671C3653',X'5D380000',X'597CF4C7',X'43600000',
X'652E12E9',X'53A537DC',X'537692CF',X'4B900000',
X'652C3600',X'67AC59C7',X'654E1A3F',X'67000000',
X'477DB859',X'4BC00000',X'477DD9E9',X'43768000',
X'2D0E54C3',X'4564A000',X'53980000',X'43700000',
X'439650F2',X'0B8EB0D9',X'66000000',X'433692E4',
X'5D0DB280',X'1C09A299',X'129A8000',X'594E7A00',
X'53A4B680',X'692E56D3',X'5D0E92C8',X'0744375D',
X'4B600000',X'497CB980',X'4BC539E8',X'4D4D9280',
X'652C77E5',X'48000000',X'137477DB',X'610E94C5',
X'59280000',X'492E71E5',X'538697E4',X'252C3200',
X'6F953A4A',X'2F953A4A',X'0A708313',X'18280000',
X'5DADB14B',X'64000000',X'08286789',X'0AE8A707',
X'1E20A000',X'45ACD34B',X'64000000',X'674F5280',
X'612E56D3',X'679D37DC',X'214739D3',X'470D8000',
X'4B748000',X'690E1280',X'4744375D',X'4B600000',
X'297DE000',X'5B0DDC80',X'4D4D92E6',X'36000000',
X'4BC539E9',X'66000000',X'1FAE986B',X'68000000',
X'470E10C7',X'53A72000',X'12E9E000',X'5F700000',
X'431C72E7',X'66000000',X'492E71E5',X'538694DF',
X'5C000000',X'43B434D9',X'43159280',X'5F84B700',
X'0324994B',X'679CB980',X'09D83D80',X'0D0C74D9',
X'53A72000',X'4B9657E5',X'39ADD9E1',X'4B1D3353',
X'4B200000',X'692F1A00',X'510E6000',X'477DD359',
X'531E94DD',X'4E000000',X'05643756',X'612E56D3',
X'69A4B200',X'6784B1D3',X'4D4C70E9',X'537DC000',
X'1C90A180',X'0DF11F11',X'1449C4A8',X'470D964B',
X'48000000',X'092D92E9',X'4A000000',X'1D7E8000',
X'6B74D7E5',X'5B0E9A4B',X'48000000',X'4D7E56C3',
X'69A4B200',X'040865A7',X'20086280',X'08080000',
X'6F7E55CD',X'5364B980',X'4D4D92E9',X'7384A000',
X'42000000',X'5D2EE000',X'1DADB14B',X'64000000',
X'652C77E5',X'49980000',X'094E52C7',X'68E431C7',
X'4B9E6000',X'6195F84B',X'65A72000',X'6B9CB95D',
X'436CA000',X'610E50DB',X'4BA4B900',X'0682A000',
X'594DB4E8',X'4BC472CB',X'49980000',X'5B0F14DB',
X'6B680000',X'252E77EB',X'651CA000',X'436597EF',
X'43747280',X'477DDA65',X'5F600000',X'67A43A4B',
X'5B2DDA00',X'090E9080',X'5F739653',X'5D280000',
X'290E1280',X'694DB280',X'157C4000',X'292E56D3',
X'5D0E94DF',X'5C000000',X'652E3ACB',X'67A4B200',
X'572F3BDF',X'65200000',X'610E50DB',X'4BA4B966',
X'2B9CB900',X'652CF4E7',X'692E52C8',X'2785F7D8',
X'4394B080',X'4DAD9600',X'277EB947',X'4A000000',
X'594C5943',X'65C80000',X'5F1552C7',X'68000000',
X'597DD380',X'0D0D364B',X'48000000',X'69780000',
X'4794B0E9',X'4A000000',X'4BC692E5',X'5D0D8000',
X'5D0DB2E6',X'2195F3E5',X'43680000',X'5BAE7A00',
X'45280000',X'494CD34B',X'652DDA00',X'4D0C74D9',
X'53A532E6',X'592ED2D8',X'69BDE000',X'6B9CB900',
X'0D4D92E6',X'67A53658',X'537672E5',X'692C8000',
X'4375FA51',X'4B900000',X'6B9CB93D',X'66000000',
X'38000000',X'5FBDC000',X'477DD74B',X'47A00000',
X'5B7C9280',X'2C680000',X'517D9280',X'676C3658',
X'492ED4C7',X'4A000000',X'477C9280',X'03A692DB',
X'61A00000',X'652B924B',X'4D4DD280',X'137477DD',
X'674E7A4B',X'5DA00000',X'1BAD9A53',X'6164A000',
X'20200000',X'5B2DB14B',X'64000000',X'5B2DB14B',
X'657436CA',X'27AC59F3',X'67A4B680',X'5F34D2E4',
X'4D94B280',X'492E71E5',X'538697E5',X'66000000',
X'537492F0',X'077DD359',X'531E94DD',X'4E000000',
X'6195F1CB',X'67980000',X'537494ED',X'5326B0D8',
X'612E56D3',X'679D37DD',X'66000000',X'1FBDC000',
X'53767ACD',X'4D4C74CB',X'5DA00000',X'2785F7D9',
X'4B900000',X'4D0D366B',X'65280000',X'197DF853',
X'5D380000',X'436530E6',X'1B2DB14B',X'64000000',
X'0B769972',X'4D7EB748',X'494E52C7',X'697E5C80',
X'4B769953',X'4B980000',X'217D3768',X'4B769972',
X'7672A618',X'0828C49D',X'0A000000',X'5B0D3700',
X'597C3200',X'0C7A4A25',X'02700000',X'49CDD0DB',
X'531C3659',X'72000000',X'290C564A',X'252E3ACB',
X'67A4B200',X'24286099',X'18000000',X'5F8694DF',
X'5C000000',X'672D92C7',X'692C8000',X'09AE1653',
X'470E9280',X'652E3ACB',X'67A00000',X'4D95F680',
X'6F4E9453',X'5C000000',X'6195F3E5',X'43680000',
X'697E90D8',X'5FB4B96F',X'654E9280',X'594E9A59',
X'4A000000',X'53753A53',X'436539CB',X'48000000',
X'67A431D6',X'094E52C7',X'697E5C80',X'26282907',
X'10212900',X'070DD75F',X'68000000',X'1E10AC80',
X'5B0C795E',X'097C7ADB',X'4B768000',X'452D97DD',
X'4F980000',X'63ACBACB',X'48000000',X'431E94ED',
X'4A000000',X'5D780000',X'254DD380',X'036C54CF',
X'6B7EB980',X'172F3BDF',X'65200000',X'09AE1653',
X'470E92C8',X'67AC7400',X'67A652C3',X'5A000000',
X'5374D7E5',X'5B0E94DF',X'5C000000',X'67AE1859',
X'532C8000',X'0828C49D',X'0A6A8000',X'63ACBACA',
X'0F95FAE0',X'5B2DB14B',X'65980000',X'470DD75F',
X'68000000',X'497DD0E9',X'4A000000',X'4DADD266',
X'13767ACD',X'4D4C74CB',X'5DA00000',X'61953B53',
X'592CF280',X'512C324B',X'64000000',X'592ED2D9',
X'66000000',X'24282200',X'1EAA8000',X'43658000',
X'652DB7ED',X'4A000000',X'76098600',X'43947453',
X'6D2C8000',X'672D9300',X'597C324B',X'48000000',
X'1B0F14DB',X'6B680000',X'074434DC',X'436530E7',
X'4B980000',X'6F45F659',X'72000000',X'1FB4B959',
X'43866000',X'6194BB53',X'5FAE7672',X'470D9643',
X'4564A000',X'672E10E5',X'43A4A000',X'2A98A31F',
X'24000000',X'652E3ACB',X'67A66000',X'03255AE7',
X'690C564A',X'494DB2DD',X'674DF700',X'6B7439E7',
X'533DD2C8',X'039E74CF',X'5D2C8000',X'439E74CF',
X'5D2C8000',X'6F4E9400',X'6B8612E4',X'592E7980',
X'597EF2E4',X'492C7643',X'652C8000',X'431E9AC3',
X'58000000',X'039E7ADB',X'4B200000',X'652E3AD3',
X'652E6000',X'590E7A00',X'07443943',X'47A4B900',
X'610E50DA',X'5F759C80',X'6D0D94C8',X'0C7A4A7D',
X'11F10000',X'67AC59E9',X'654DD380',X'617E74E9',
X'537DC000',X'09780000',X'597DF800',X'5374794B',
X'5B2DDA00',X'252C7AE5',X'674ED280',X'6195F1CB',
X'49AE5280',X'69CE1280',X'4DADD1E9',X'537DC000',
X'6B753A00',X'0D0EB668',X'5D7F6000'
INTEGER I,J,K,M,Q,S,UP
STRING (70)OMESS
OMESS=" "
FOR I=1,1,WORDMAX-1 CYCLE
-> FOUND IF N=WORD(I)
REPEAT
I=DEFAULT
FOUND:
J=1
UP=0
CYCLE
K=WORD(I+J)
IF K&X'8000'=0 THEN EXIT
K=K!!X'8000'
OMESS=OMESS." " UNLESS J=1
CYCLE
M=LETT(K); S=25
CYCLE
Q=M>>S&63;
IF Q=62 THEN UP=63 ELSE START
IF Q¬=0 THEN OMESS=OMESS.TOSTRING(OUTTT(Q+UP))
UP=0
FINISH
S=S-6
REPEAT UNTIL S<0
K=K+1
REPEAT UNTIL M&1=0
J=J+1
REPEAT
RESULT =OMESS
END
!**END
!
SYSTEMSTRINGFN FAILUREMESSAGE(INTEGER MESS)
STRING (255) S1, S2, RES
IF SSOWN_SSFNAME -> S1.(".").S2 AND S1=SSOWN_SSOWNER THEN SSOWN_SSFNAME = S2
IF (MESS=278 AND (SSOWN_SSLASTDFN=25 OR SSOWN_SSLASTDFN=40 OR SSOWN_SSLASTDFN=42)) C
OR (MESS=276 AND (SSOWN_SSLASTDFN=15 OR SSOWN_SSLASTDFN=17 OR SSOWN_SSLASTDFN=36 OR SSOWN_SSLASTDFN=43)) C
OR (MESS=274 AND SSOWN_SSLASTDFN=9) C
OR (MESS=219 AND SSOWN_SSLASTDFN=16) C
OR (MESS=280 AND SSOWN_SSLASTDFN=41) C
THEN MESS = 500 + SSOWN_SSLASTDFN
IF MINMESS<=MESS<=MAXMESS AND MESSAGE(MESS)#"" THEN START
RES = MESSAGE(MESS)
IF RES=" Fault no." THEN RES = " Fault no. ".ITOS(MESS)
! SPECIAL FOR FILE DOES NOT EXIST
IF MESS=218 AND LENGTH(SSOWN_SSFNAME)>7 AND CHARNO(SSOWN_SSFNAME,7)='.' C
THEN RES = RES." or no access"
IF RES -> S1.("&").S2 THEN RES = S1.SSOWN_SSFNAME.S2
FINISH ELSE IF 500<MESS<600 C
THEN RES = X44{DERRS}(MESS - 500) C
ELSE RES = "Failure No. ".ITOS(MESS)
RESULT = RES."
"; !ADD A NEWLINE
END ; !OF FAILUREMESSAGE
SYSTEMROUTINE PRINTMESS(INTEGER MESS)
PRINTSTRING(FAILUREMESSAGE(MESS))
END ; !OF PRINTMESS
EXTERNALSTRINGFN SSFMESSAGE
!RETURNS THE CURRENT FAILURE MESSAGE - FROM THE LAST EMAS FOREGROUND COMMAND
STRING (255) RES
RES = FAILUREMESSAGE(SSOWN_SSCOMREG(24)); !RETURNCODE
LENGTH(RES) = LENGTH(RES)-1; !REMOVE NEWLINE FROM END
RESULT = RES
END ; !OF SSFMESSAGE
SYSTEMROUTINE SSERR(INTEGER N)
IF N # 0 START
SELECTOUTPUT(0)
PRINTSTRING(FAILUREMESSAGE(N))
MONITOR
FINISH
STOP
END ; !OF SSERR
EXTERNALROUTINE SSFOFF
SSOWN_SSOPENUSED = 1; !TO ENSURE TIDYFILES CALLED ON THE WAY BACK TO COMMAND LEVEL
SSOWN_INHIBITPSYSMES = 1
END ; !OF SSFOFF
EXTERNALROUTINE SSFON
SSOWN_INHIBITPSYSMES = 0
END ; !OF SSFON
SYSTEMROUTINE PSYSMES(INTEGER ROOT, MESS)
INTEGER STOP
STRING (40) P1, P2
STOP = ROOT>>31; !IF NEGATIVE ROOT THEN STOP REQUESTED
IF SSOWN_INHIBITPSYSMES # 0 AND STOP = 0 THEN RETURN
!SSFOFF HAS BEEN CALLED SUPPRESS FAILURE MESSAGES
!UNLESS CATASTROPHIC FAILURE
ROOT = IMOD(ROOT); ! This fails for ROOT=X'80000000', but
! ROOT = IMOD(ROOT<<1)>>1 would work better, if that situation were expected.
IF SSOWN_SSFNAME -> P1.(".").P2 AND P1=SSOWN_SSOWNER THEN SSOWN_SSFNAME = P2
IF LENGTH(SSOWN_SSFNAME)>2 C
AND CHARNO(SSOWN_SSFNAME,1)='T' C
AND CHARNO(SSOWN_SSFNAME,2)='#' C
THEN LENGTH(SSOWN_SSFNAME) = LENGTH(SSOWN_SSFNAME) - 1
!REMOVE PROCESS SUFFIX
IF 1 <= ROOT <= MAXROOT C
THEN PRINTSTRING("
".ROOTNAME(ROOT)." fails - ") C
ELSE PRINTSTRING("
Failure: ") AND WRITE(ROOT,1) C
AND SPACES(3)
PRINTSTRING(FAILUREMESSAGE(MESS))
IF STOP # 0 START ; !MONITOR AND STOP
! **** **** Can we change this so that the action can be **** ****
! **** **** specified by the user, and leave %MONITOR **** ****
! **** **** and %STOP as the default action? Perhaps we **** ****
! **** **** could signal some event which the user can **** ****
! **** **** trap. **** ****
! **** **** We can't afford to %RETURN, as there will be **** ****
! **** **** many bits of code which call PSYSMES **** ****
! **** **** expecting a %STOP. **** ****
MONITOR
SSOWN_SSCOMREG(10) = 1; !FOR JCL
STOP
FINISH
END ; !OF PSYSMES
SYSTEMROUTINE SETFNAME(STRING (40) NAME)
!ALLOWS SSOWN_SSFNAME TO BE SET FROM EXTERNAL PROCEDURE - E.G. EDITOR
SSOWN_SSFNAME = NAME
END ; !OF SETFNAME
SYSTEMROUTINE SSMESS(INTEGER N)
SSOWN_SSFNAME = ""
PRINTSTRING(FAILUREMESSAGE(N))
NEWLINES(2)
END ; ! SSMESS
!*
SYSTEMROUTINE SSMESSA(INTEGER N, STRING (63) A)
SSOWN_SSFNAME = A
PRINTSTRING(FAILUREMESSAGE(N))
END ; ! SSMESSA
!
! - END OF SMES CODE ]
!
! [ START OF NDIAG CODE -
!
! NDIAG EXTENDED 02-09-80 TO PROVIDE FOR PASCAL, FORTRAN 77 AND SIMULA DIAGNOSTICS
! EXTENDED FOR ALGOLE(60) WITH EBCDIC STRING
!INCORPORATES CODE FOR NEW FORTRAN DIAGNOSTICS
!INCLUDES ICL MATHS ROUTINE ERROR ROUTINE
!INCLUDES CORRECTION FOR FAULT AT THE END OF ONCOND. R.M.1/12/77
!REFS TO WRITE JS VAR COMMENTED OUT
!IMP AND ALGOL SECTION REPLACED 13.4.78
!*
!*
!*
ROUTINESPEC INDIAG(INTEGER OLDLNB, LANG, PCOUNT, MODE, DIAG, C
ASIZE, INTEGERNAME FIRST, NEWLNB)
ROUTINESPEC ERMESS(INTEGER N, INF)
INTEGERFNSPEC WTFAULT(INTEGER INF)
! FAULT EVENT MESSAGE
! 1 (1/2) REAL OVERFLOW
! 2 (0/0) REAL UNDERFLOW
! 3 (1/1) INTEGER OVERFLOW
! 4 (0/0) DECIMAL OVERFLOW
! 5 (1/3) ZERO DIVIDE
! 6 (6/2) ARRAY BOUNDS EXCEEDED
! 7 (6/1) CAPACITY EXCEEDED
! 8 (0/0) ILLEGAL OPERATION
! 9 (0/0) ADDRESS ERROR
! 10 (0/0) INTERRUPT OF CLASS
! 11 (8/1) UNASSIGNED VARIABLE
! 12 (F/1) TIME EXCEEDED
! 13 (F/2) OUTPUT EXCEEDED
! 14 (F/3) OPERATOR TERMINATION
! 15 (5/5) ILLEGAL EXPONENT
! 16 (5/4) SWITCH LABEL NOT SET
! 17 (0/0) CORRUPT DOPE VECTOR *** NO LONGER USED*****
! 18 (5/1) ILLEGAL CYCLE
! 19 (1/7) INT PT TOO LARGE
! 20 (5/6) ARRAY INSIDE OUT
! 21 (0/0) NO RESULT
! 22 (0/0) PARAM NOT DESTINATION
! 23 (2/1) PROGRAM TOO LARGE
! 24 (0/0) STREAM NOT DEFINED
! 25 (9/1) INPUT ENDED
! 26 (4/1) SYMBOL IN DATA
! 27 (0/0) IOCP ERROR *** NOT USED ON EMAS VMEB???*****
! 28 (3/1) SUB CHARACTER IN DATA
! 29 (0/0) STREAM IN USE
! 30 (B/1) GRAPH FAULT
! 31 (0/0) DIAGNOSTICS FAIL
! 32 (7/1) RESOLUTION FAULT
! 33 (0/0) INVALID MARGINS
! 34 (4/2) SYMBOL INSTEAD OF STRING
! 35 (0/0) STRING INSIDE OUT
! 36 (0/0) WRONG PARAMS PROVIDED
! 37 (0/0) UNSATISFIED REFERENCE
! 38 (8/2) Unassigned switch variable
! 39 (0/0) Failure No. 39
! 40 (0/0) Failure No. 40
! 41 (0/0) Failure No. 41
! 42 (0/0) Failure No. 42
! 43 (0/0) Failure No. 43
! 44 (0/0) Failure No. 44
! 45 (0/0) Failure No. 45
! 46 (0/0) Failure No. 46
! 47 (0/0) Failure No. 47
! 48 (0/0) Failure No. 48
! 49 (0/0) Failure No. 49
! 50 (5/2) SQRT ARG NEGATIVE
! 51 (5/3) LOG ARG NEGATIVE
! 52 (5/3) LOG ARG ZERO
! 53 (1/6) EXP ARG OUT OF RANGE
! 54 (1/4) SIN ARG OUT OF RANGE
! 55 (1/4) COS ARG OUT OF RANGE
! 56 (1/4) TAN ARG OUT OF RANGE
! 57 (1/4) TAN ARG INAPPROPRIATE
! 58 (0/0) ASIN ARG OUT OF RANGE
! 59 (0/0) ACOS ARG OUT OF RANGE
! 60 (0/0) ATAN2 ARGS ZERO
! 61 (0/0) SINH ARG OUT OF RANGE
! 62 (0/0) COSH ARG OUT OF RANGE
! 63 (0/0) LGAMMA ARG NOT POSITIVE
! 64 (0/0) LGAMMA ARG TOO LARGE
! 65 (0/0) GAMMA ARG OUT OF RANGE
! 66 (1/4) COT ARG OUT OF RANGE
! 67 (1/4) COT ARG INAPPROPRIATE
! 68 (0/0) REAL EXPONENTIATION FAULT
! 69 (0/0) COMPLEX EXPONENTIATION FAULT
! 70 (A/6) RADIUS ARGS TOO LARGE
! 71 (A/3) ARCTAN ARGS ZERO
! 72 (A/1) ARCSIN ARG OUT OF RANGE
! 73 (A/2) ARCCOS ARG OUT OF RANGE
! 74 (A/4) HYPSIN ARG OUT OF RANGE
! 75 (A/5) HYPCOS ARG OUT OF RANGE
! 76 (A/7) Matrix bound zero or negative
ROUTINE TRANS(INTEGERNAME FAULT, EVENT, SUBEVENT)
!***********************************************************************
!* TRANSLATE FAULT TO EVENT & VICE VERSA *
!***********************************************************************
CONSTINTEGER MAXFAULTS=76
CONSTBYTEINTEGERARRAY FTOE(0:MAXFAULTS)= C
0,X'12',0,X'11',0,X'13',X'62',X'61',0(3),
X'81',X'F1',X'F2',X'F3',X'55',X'54',
0,X'51',X'17',X'56',0(2),X'21',0,
X'91',X'41',0,X'31',0,X'B1',0,X'71',
0,X'42',0(3),X'82',0(11),X'52',X'53',X'53',X'16',
X'14'(4),0(8),X'14'(2),0(2),
X'A6',X'A3',X'A1',X'A2',X'A4',X'A5',X'A7'
INTEGER K,J
IF FAULT=0 THEN START ; ! EVENT-SUBEVENT GIVEN
J=EVENT<<4+SUBEVENT
! %RETURN %IF J=0; ! %MONITOR
! %FOR K=MAXFAULTS,-1,1 %CYCLE
! %IF J=FTOE(K) %THEN FAULT=K %AND %RETURN
! %REPEAT
!
! **** **** Machine code equivalent follows: **** ****
!
RETURN UNLESS 0<J<256; ! %MONITOR
*LD_FTOE
*LB_J
*SWNE_L =DR
*JCC_8,<MISSED>
*STD_TOS
*LSS_TOS
*ISB_FTOE+4
*ST_(FAULT)
MISSED:
! **** **** End of machine code **** ****
!
FINISH ELSE START
IF 1<=FAULT<=MAXFAULTS START
K=FTOE(FAULT)
EVENT=K>>4; SUBEVENT=K&15
FINISH
FINISH
END
ROUTINE PRHEX(INTEGER VALUE)
! %INTEGER I
! %FOR I=28,-4,0 %CYCLE
! PRINT SYMBOL(HEX(VALUE>>I&15))
! %REPEAT
! **** **** Machine code equivalent: **** ****
!
STRING (8) S
LONG INTEGER DH
*LD_S
*LSS_8
*UCP_0
*ST_(DR )
*MODD_1
*STD_DH
*LUH_VALUE
*SUPK_L =8
*LSS_HEX+4
*ISB_240
*LUH_X'18000100'
*LD_DH
*TTR_L =8
PRINT STRING (S)
!
! **** **** End of machine code **** ****
!
END
ROUTINE ASSDUMP(INTEGER PCOUNT, OLDLNB)
INTEGER I
PRINTSTRING("
PC =")
PRHEX(PCOUNT)
PRINTSTRING("
LNB =")
PRHEX(OLDLNB)
PRINTSTRING("
CODE
")
NCODE(PCOUNT-64,PCOUNT+64,PCOUNT-64)
IF STUDENTSS=0 THEN START
PRINTSTRING("
GLA
")
I=INTEGER(OLDLNB+16)
CXDUMP(I,I+128,3)
PRINTSTRING("
STACK FRAME
")
CXDUMP(OLDLNB,OLDLNB+256,3)
FINISH
END
ROUTINE ONCOND(INTEGER EVENT, SUBEVENT, LNB)
!***********************************************************************
!* UNWIND THE IMP STACK LOOKING FOR ON CONDITIONS *
!* There is only one call of ONCOND - it is in NDIAG. *
!***********************************************************************
LONGREAL INFO
INTEGER GLAAD, LANG, TSTART, BIT, ONWORD, PREVLNB, I, STSTART, C
STSEG
UNLESS 1<=EVENT<=14 THEN RETURN
BIT=1<<(EVENT+17)
*LSS_(LNB +0); *ST_PREVLNB
CYCLE
I = INTEGER (PREVLNB) & X'FFFFFFFC'
EXIT UNLESS LNB<I<PREVLNB
PREVLNB = I
REPEAT
STSTART=SSOWN_SSCOMREG(36)
STSEG=STSTART>>18
WHILE LNB>>18=STSEG AND LNB>=STSTART CYCLE
! Should we do some VALidates here? LNB has had a good
! checking already. Remember that saved stack frame pointers
! can have their bottom bit set by PRCL to indicate the
! presence of a spare word between stack frames (to improve
! the alignment of stack frames).
GLAAD=INTEGER(LNB+16); ! PLT ADDR
! Perhaps we should check that it's an EMAS standard GLA.
! 1. What if GLAAD<0? Don't worry, local controller would
! not do ONCONDs.
! 2. What if GLAAD&3#0?
! 3. Check for standard GLA as in early stages of NDIAG.
! VALidate the GLA address.
*LDTB_X'18000020'
*LDA_GLAAD
*VAL_(LNB +1)
*JCC_3,<NSG>
! Now we check that the GLA is in standard EMAS form. If it is,
! then we will pick up the language flag from the 17th. byte of
! the GLA. The test
! depends on VALidating the third and fourth words of the GLA,
! which should be the addresses of the unshareable and shareable
! symbol tables. This test cannot be guaranteed, but it should
! make the right decision most of the time.
*LXN_GLAAD
*LDTB_X'18000001'
*LDA_(XNB +2); ! Fetch third word of GLA: should be address of
! unshareable symbol tables.
*VAL_(LNB +1); ! Ought to be a valid address which is readable and
! writeable at the current ACR level.
*JCC_3,<NSG>; ! but we'll risk it if it's read only.
! Otherwise we get problems with shared basegla!
*LDA_(XNB +3); ! Fourth word of GLA - should be address of shareable
! symbol tables.
*VAL_(LNB +1); ! Should be a valid read-only address
*JCC_12,<SG>; ! but we'll risk it if it's read-and-write.
NSG:
RETURN ; ! if non-standard GLA.
!
SG:
LANG=INTEGER(GLAAD+16)>>24; ! LANGUAGE
! Why not BYTE INTEGER (GLAAD+16)?
RETURN UNLESS LANG=1 OR LANG=3; ! NO MIXED LANG ONCONDS
TSTART=INTEGER(LNB+12)&X'FFFFFF'
! Now work through nested blocks:
WHILE TSTART#0 CYCLE
TSTART=TSTART+INTEGER(GLAAD+12)
! TSTART points to shareable symbol tables.
*LDTB_X'18000010'
*LDA_TSTART
*VAL_(LNB +1)
*JCC_12,<TSTOK>
RETURN ; ! if VALidate fails.
TSTOK: I=INTEGER(TSTART+12)>>24; ! LENGTH OF NAME
! Why not BYTE INTEGER (TSTART+12)? This line and the next
! could be reduced to I = BYTE INTEGER(TSTART+12)&(-4) + 16.
I=I>>2<<2+16
ONWORD=INTEGER(TSTART+I)
IF ONWORD&BIT#0 THEN -> HIT
EXIT IF INTEGER(TSTART+12)#0; !ROUTINE
TSTART=INTEGER(TSTART+4)&X'FFFF';!ENCLOSING BLOCK
! Presumably that is supposed to be quicker than
! HALF INTEGER (TSTART+6).
REPEAT
PREVLNB=LNB
LNB=INTEGER(LNB)
REPEAT
RETURN
HIT: ! ON CONDITION FOUND
! If here and SSOWN_RCODE is 103050709 then we have arrived via the
! ENTERONUSERSTACK trap. Since we have found an %ON %EVENT trap prepared
! to deal with the contingency then SSOWN_RCODE can be reset to 0
IF SSOWN_RCODE=103050709 THEN SSOWN_RCODE=0
I=INTEGER(TSTART)&X'FFFF'; ! LINE NOS WORD
IF I#0 THEN I=INTEGER(LNB+I)
INTEGER(ADDR(INFO))=EVENT<<8!SUBEVENT
INTEGER(ADDR(INFO)+4)=I
SIGNAL(1,0,0,I)
! AMEND EXIT DESCRIPTOR OF NEXT LEVEL
! TO ENSURE ACS=2 AND PRCL UNSTACKS
! CORRECTLY IF RELEVANT
INTEGER(PREVLNB)=(LNB&X'FFFFFFFE')!(INTEGER(PREVLNB)&1)
INTEGER(PREVLNB+4)=INTEGER(PREVLNB+4)&(-4)!X'12'
! ACS=2
INTEGER(PREVLNB+8)=INTEGER(GLAAD+ONWORD&X'3FFFF')
SSOWN_ACTIVE=0
*LSD_INFO; ! INFO FOR THE ON SEQUENCE
*LLN_PREVLNB; ! LNB TO RT AFTER EXIT RT
*EXIT_-64; ! PRESERVING ACC SIZE
END
!*
!*
ROUTINE CALL DIAGS(INTEGER OLDLNB, PC, ASIZE, INTEGERNAME FIRST, NEWLNB, C
INTEGER LF)
! This routine simply passes on the parameters (less LANGFLAG) to
! PDIAG or SDIAG.
!
! %CONSTSTRING (10) %ARRAY LD (7:10) = %C
! "S#PDIAG", "S#SDIAG", "", "S#F77DIAG"
! As far as I can see, CALL DIAGS can only be called with LF=7
! (PASCAL) or 8 (SIMULA) - so we only need:
CONST STRING (7) ARRAY LD (7:8) = "S#PDIAG", "S#SDIAG"
INTEGER DR0, DR1, A, FLAG, TYPE
STRING (1) DUMMY
LONG INTEGER NAME DESC
IF NEWLOADER=0 THEN START
FINDENTRY(LD(LF),0,0,DUMMY,DR0,DR1,FLAG)
IF FLAG # 0 THEN START
PRINTSTRING(LD(LF)." NOT LOADED")
NEWLINE
STOP
FINISH
FINISH ELSE START
DESC==LONGINTEGER(ADDR(DR0))
TYPE=CODE
DESC=LOOKLOADED(LD(LF),TYPE)
IF DESC=0 THEN START
PRINTSTRING(LD(LF)." NOT LOADED")
NEWLINE
STOP
FINISH
FINISH
A = ADDR(OLDLNB)
*PRCL_4
*LSQ_(LNB +5)
*SLSD_(LNB +9)
*SLSS_(LNB +11)
*ST_TOS
*LD_DR0
*RALN_12
*CALL_(DR )
END
!
!
SYSTEMROUTINE NDIAG(INTEGER PCOUNT, LNB, FAULT, INF)
!***********************************************************************
!* 'MASTER DIAGNOSTIC ROUTINE'. DISCOVERS THE LANGUAGE OF THE *
!* FAILED ROUTINE FROM WORD 4 OF THE GLA AND CALLS APPROPRIATE *
!* DIAGNOSTIC ROUTINE. THIS IS REPEATED TILL ALL DIAGNOSTICS *
!* GIVEN. *
!* PCOUNT = PCOUNTER AT FAILURE *
!* LNB = LOCAL NAME BASE AT FAILURE *
!* FAULT = FAILURE (0=%MONITOR REQUESTED) *
!* INF =ANY FURTHER INFORMATION *
!***********************************************************************
! Nothing in NDIAG changes the value of INF.
INTEGER LF, I, J, GLA, OLDLNB, NEWLNB, EVENT, SUBEVENT, C
CONTFLAG
INTEGER PREASON
LONGINTEGER JJ
SWITCH LGE(0:10)
CONSTINTEGER MAXLANGUAGE = 10
STRING (20) FAILNO
CONTFLAG = 0
! LAY DOWN A CONTINGENCY
!AGAINST ERRORS IN NDIAG
I=0
! **** **** Perhaps we should validate PCOUNT. **** ****
*STLN_OLDLNB
*JLK_3
*J_<MDERROR>; !CONTINGENCY JUMPS HERE
*LSS_TOS ; *ST_J
SIGNAL(-1,J,OLDLNB,I)
SSOWN_ACTIVE=SSOWN_ACTIVE+1
FAILNO=" LOOPING"
IF SSOWN_ACTIVE>5 THEN ->EOUT
FAILNO=" CONT STACK FULL"
IF I>0 THEN ->EOUT; ! CONTINGENCY DID NOT GO DOWN
PREASON = -1
OLDLNB = LNB
IF SSOWN_FULLDUMP#0 THEN HASHCOMMAND("REGS","")
CYCLE
CYCLE ; ! IGNORE BLOCKS WITH PUBLIC GLA -
! THEY MUST BE IN LOCAL CONTROLLER.
! VALidate the LNB.
*LDTB_X'18000010'
*LDA_OLDLNB
*VAL_(LNB +1)
*JCC_3,<EXIT>
GLA = INTEGER(OLDLNB + 16)
IF GLA&3#0 START
PRINTSTRING("CORRUPT STACK FRAME - DUMP FROM LNB:")
NEWLINE
IF STUDENTSS=0 THEN START
CXDUMP(OLDLNB,32,3)
FINISH
SSOWN_ACTIVE=0
->QUIT
FINISH
EXIT IF GLA>=0
OLDLNB=INTEGER(OLDLNB)
REPEAT
! VALidate the GLA address.
*LDTB_X'18000020'
*LDA_GLA
*VAL_(LNB +1)
*JCC_3,<NSG>
! Now we check that the GLA is in standard EMAS form. If it is,
! then we will pick up the language flag from the 17th. byte of
! the GLA. Otherwise we will have to assume a language flag of
! zero and produce diagnostics as if for assembler. The test
! depends on VALidating the third and fourth words of the GLA,
! which should be the addresses of the unshareable and shareable
! symbol tables. This test cannot be guaranteed, but it should
! make the right decision most of the time.
*LXN_GLA
*LDTB_X'18000001'
*LDA_(XNB +2); ! Fetch third word of GLA: should be address of
! unshareable symbol tables.
*VAL_(LNB +1); ! Ought to be a valid address which is readable and
! writeable at the current ACR level.
*JCC_3,<NSG>; ! We'll risk it readable (for shareable basegla's sake)
*LDA_(XNB +3); ! Fourth word of GLA - should be address of shareable
! symbol tables.
*VAL_(LNB +1); ! Should be a valid read-only address
*JCC_12,<SG>; ! but we'll risk it if it's read-write.
NSG:
LF = 0
-> LSD
!
SG:
LF = INTEGER(GLA + 16) >> 24
LF=0 IF LF>MAXLANGUAGE
LSD:
IF PREASON#0 THEN START
PREASON = 0
SUBEVENT=0; EVENT=FAULT>>8
IF 400<=FAULT<=500 THEN START
ERMESS (FAULT,INF)
NEWLINE
FINISH ELSE START
IF 50<=FAULT<=76 {Error reported by Maths. function} C
THEN CONTFLAG = 2 C
ELSE IF FAULT=10 {Interrupt} C
THEN START
{ INF has the "weight" or "class", which is the same as
{ the PE number for Program Error interrupts. Only
{ Program Error interrupts are reported by this route -
{ others have nothing to do with the program and are
{ handled by other parts of the system - but a few other
{ faults which do not involve real interrupts are reported
{ as "simulated" interrupts with class numbers which are
{ impossible as Program Error numbers, and this code can
{ cope with those.
FAULT = WTFAULT (INF) { Convert "class" or "weight" to a "Fault
{ number", which is also the number for
{ the appropriate error message.
CONTFLAG = 1
FINISH
IF 7#LF#8 THEN START { i.e., not for PASCAL or SIMULA}
{ If the FAULT parameter is >= 256, it consists of an
{ event number in the top 24 bits and a subevent number
{ in the bottom eight bits. We have already extracted
{ the event number, so we pick up the subevent number.
{ Then we clear FAULT, so that TRANS will convert the
{ event and subevent numbers into a 'proper' fault number
{ which will yield an appropriate error message.
IF FAULT>=256 THEN START
SUBEVENT = FAULT & 255
FAULT = 0
FINISH
TRANS (FAULT,EVENT,SUBEVENT) { Ensures that FAULT, EVENT
{ and SUBEVENT are all set
{ to define the same occurrence.
ONCOND(EVENT,SUBEVENT,LNB)
UNLESS FAULT=0=EVENT THEN SSOWN_SSCOMREG(10)=1; !FOR USE BY JCL
FINISH
SSOWN_FIRST = 1
IF FAULT>=0 THEN START
IF FAULT=0 AND EVENT#0 START
PRINTSTRING("
MONITOR ENTERED
")
PRINTSTRING("EVENT"); WRITE(EVENT,1)
PRINTSYMBOL('/'); WRITE(SUBEVENT,1)
FINISH ELSE START
IF FAULT#0 THEN SELECT OUTPUT(99); !DONT SELECT IF JUST CALL OF %MONITOR
IF LF = 7 OR LF = 8 THEN START
SSOWN_FIRST = -1
CALL DIAGS(CONTFLAG,INF,FAULT,SSOWN_FIRST,NEWLNB,LF)
SSOWN_FIRST = 1
FINISH ELSE START
ERMESS(FAULT,INF)
FINISH
FINISH
NEWLINE
FINISH ELSE EVENT=0
FINISH
FINISH
->LGE(LF)
LGE(0):
LGE(4): ! UNKNOWN & ASSEMBLER
LGE(6): ! OPTCODE
LGE(9): ; !BCPL
PRINTSTRING("
NO DIAGNOSTICS FOR CALLING PROCEDURE
")
ASSDUMP(PCOUNT,OLDLNB)
NEWLNB = INTEGER (OLDLNB)
-> IMPJOIN
LGE(7):; ! PASCAL.
LGE(8):; ! SIMULA.
CALL DIAGS(OLDLNB,PCOUNT,SSOWN_SSARRAYDIAG,SSOWN_FIRST,NEWLNB,LF)
-> IMPJOIN
LGE(2): ! FORTRAN
LGE(10): ! FORTRAN 77.
FDIAG (OLDLNB, PCOUNT, 0, 4, SSOWN_SSARRAYDIAG, SSOWN_FIRST, NEWLNB)
IF NEWLNB=0 THEN ->EXIT
I= INTEGER(OLD LNB + 16); !GLA adr of current procedure
J= INTEGER( I + 16) & 2 ; !extract the PARM(MINSTACK) flag
IF J> 0 THEN PCOUNT= INTEGER(OLD LNB +8)-4 C
ELSE PCOUNT= INTEGER( INTEGER(OLD LNB)+8)-4
!AGRK 9/8/84: The three statements above examine the FLAGS word
! of the procedure just monitored and if it was
! compiled with PARM(MINSTACK) then PCOUNT is
! extracted from the preceding stack frame (a la IMP)
! otherwise, as standard, from the second preceding
! stack frame
-> NEXT RTF
!
!
!
LGE(1):
LGE(3): ! IMP & IMPS
LGE(5): ! ALGOL 60
INDIAG(OLDLNB,LF,PCOUNT,0,2,SSOWN_SSARRAYDIAG,SSOWN_FIRST, C
NEWLNB)
! IMP DIAGS
IMPJOIN:
IF NEWLNB=0 THEN ->EXIT
PCOUNT=INTEGER(OLDLNB+8); ! CONTINUE TO UNWIND STACK
NEXTRTF:
IF LF=7 AND OLDLNB&X'FFFFFFFC'=NEWLNB&X'FFFFFFFC' THEN -> SKIPC36
-> EXIT IF OLDLNB&X'FFFFFFFC'=SSOWN_SSCOMREG(36) OR (OLDLNB!!NEWLNB)>>SEGSHIFT#0
! FAR ENOUGH
SKIPC36:
OLDLNB=NEWLNB
REPEAT
!
!
MDERROR: ! ENTER FROM CONTINGENCY
*ST_JJ; ! DESCPTR TO IMAGE STORE
J<-JJ; ! GET ADDRESS FROM DESCRIPTOR
PRINTSTRING("
INTERRUPT DURING DIAGNOSTICS WT= ")
WRITE(INTEGER(J),3)
ASSDUMP(INTEGER(J+16),OLDLNB)
->QUIT
EOUT: ! ERRROR EXIT
PRINTSTRING("
NDIAG FAILS ".FAILNO."
")
SSOWN_ACTIVE=0
-> QUIT
EXIT:
SIGNAL(1,0,0,I); ! POP UP CONTINGENCY
SSOWN_ACTIVE=0
IF FAULT=0=EVENT THEN ->END
! %IF COMREG(27)&X'400000'#0 %THEN -> END
! FTRAN ERROR RECOV
QUIT:
IF NEWLOADER#0 THEN START
IF SSOWN_LOADINPROGRESS#0 THEN START
UNLOAD2 (1,1)
SSOWN_LOADINPROGRESS = 0
FINISH
FINISH
STOP
END:
END ; ! OF NDIAG
!!
! LAYOUT OF DIAGNOSIC TABLES
!****** ** ********* ******
! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF
! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE
! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.
! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY
! FIRST WORD IN THE SST).
! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL
! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT
! FORM OF THE TABLES:-
! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)
! WORD 1 = (12 LANG DEPENDENT BITS)<<20 ! ENVIRONMENT
! (TOP 2 BITS FOR ROUTINE TYPE.B'01'==SYSTEM ROUTINE)
! (NEXT BIT SET FOR EBCDIC CHARS&STRINGS(ALGOLE ONLY))
! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO
! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE
! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED
! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC
! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY
! A WORD OF X'FFFFFFFF'
! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY
! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF
! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT
! BIT 2**19 =0 UNDER LNB =1 IN GLA
! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES
! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST
! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS
! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN
! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.
!!
SYSTEMROUTINE INDIAG(INTEGER OLDLNB, LANG, PCOUNT, MODE, C
DIAG, ASIZE, INTEGERNAME FIRST, NEWLNB)
!***********************************************************************
!* THE DIAGNOSTIC ROUTINE FOR IMP %AND ALGOL(LANG=5) *
!* THE ALGOL SYMBOL TABLES ARE SET UP AS FOR IMP *
!* MODE = 0 FOR JOBBER&EMAS2900, =1 FOR OPEH IN VMEB&VMEK *
!* DIAG = DIAGNOSTIC LEVEL *
!* 1 = ROUTE SUMMARY ONLY (ASIZE)=ADDR MODULE NAME FROM OPEH *
!* 2 = DIAGNOSTICS AS TRADITIONALLY PERFORMED *
!* ASIZE IS NO OF ELEMENTS OF EACH ARRAY TO BE PRINTED(DIAG>1) *
!***********************************************************************
RECORDFORMAT F(INTEGER VAL, STRING (11) VNAME)
ROUTINESPEC PLOCALS(INTEGER ADATA, STRING (15) LOC)
ROUTINESPEC PSCALAR(RECORD (F)NAME VAR)
ROUTINESPEC PARR(RECORD (F)NAME VAR, INTEGER ASIZE)
ROUTINESPEC PVAR(INTEGER TYPE, PREC, NAM, LANG, FORM, C
VADDR)
INTEGERFNSPEC CKREC(STRING (50) NAME); ! CHECK RECURSION
INTEGER GLAAD, FLINE, NAM, TYPE, PREC, TSTART, PREV BLK, C
WORD0, WORD1, WORD2, WORD3, I
INTEGER INHIBIT
STRING (10) STMNT
STRING (20) PROC
STRING (50) NAME
INTEGER COUNT; ! Used in checking for recursion.
CONSTINTEGER ALGOL=5; ! LANGUAGE CODE
*MPSR_X'000040C0'; ! Mask underflow
IF FIRST=1 THEN START
SSOWN_GLOBPTR=0
COUNT = 0
FINISH
OLDLNB = OLDLNB & X'FFFFFFFC'
! **** **** Should we VALidate OLDLNB and GLAAD? **** ****
IF LANG#ALGOL THEN START
STMNT=" LINE"
PROC=" ROUTINE/FN/MAP "
FINISH ELSE START
STMNT=" STATEMENT"
PROC=" PROCEDURE "
FINISH
GLAAD=INTEGER(OLDLNB+16); ! ADDR OF GLA/PLT
TSTART=INTEGER(OLDLNB+12)&X'FFFFFF'; ! Extracts bound of PLT descriptor.
! The next statement seems to assume that the bound of the PLT
! descriptor is zero for a routine in the basefile.
IF TSTART=0 THEN START
IF PCOUNT<SSOWN_SSCURBGLA START ; ! IGNORE IF IN BASEFILE
PRINTSTRING("
".PROC."COMPILED WITHOUT DIAGNOSTICS
")
ASSDUMP(PCOUNT,OLDLNB)
FINISH ELSE NEWLNB=0 AND RETURN
NEWLNB=INTEGER(OLDLNB)
RETURN
FINISH
CYCLE
TSTART=TSTART+INTEGER(GLAAD+12); ! Address of shareable symbol tables.
! **** **** We should probably VALidate TSTART. **** ****
*LDTB_X'18000010'
*LDA_TSTART
*VAL_(LNB +1)
*JCC_12,<TSTOK>
PRINT STRINGC
("Symbol tables inaccessible - cannot print diagnostics")
NEWLINE
NEWLNB = INTEGER (OLDLNB)
RETURN ; ! if symbol tables inaccessible.
TSTOK:
WORD0=INTEGER(TSTART)
WORD1=INTEGER(TSTART+4)
WORD2=INTEGER(TSTART+8)
WORD3=INTEGER(TSTART+12)
IF (PCOUNT<SSOWN_SSCURBGLA OR WORD1&X'C0000000'=X'40000000') THEN START
! We must be in the basefile.
IF SSOWN_SSCOMREG(25)=0=SSOWN_FULLDUMP THEN START
! Don't diagnose BASEFILE or SYSTEM routines if true.
NEWLNB=INTEGER(OLDLNB)
RETURN
FINISH ELSE START
! Dump stack and gla if full dump
IF SSOWN_FULLDUMP#0 THEN ASSDUMP(PCOUNT,OLDLNB)
FINISH
FINISH
NAME=STRING(TSTART+12)
I=WORD0&X'FFFF'; ! LINE NO DISP
IF I=0 THEN FLINE=-1 ELSE FLINE=INTEGER(OLDLNB+I)
INHIBIT = CKREC (NAME); ! CHECK RECURSION
IF INHIBIT=0 START
NEWLINE
IF MODE=1 THEN PRINTSTRING(LT(LANG)) ELSE START
IF FIRST=1 THEN FIRST=0 C
AND PRINTSTRING("DIAGNOSTICS ")
PRINTSTRING("ENTERED FROM")
FINISH
IF WORD0>>16=0 THEN START
IF MODE=0 THEN PRINTSTRING(LT(LANG))
PRINTSTRING("ENVIRONMENTAL BLOCK
")
FINISH ELSE START
IF FLINE>=0 AND FLINE#WORD0>>16 THEN START
PRINTSTRING(STMNT)
WRITE(FLINE,4)
PRINTSTRING(" OF")
FINISH
IF WORD3=0 THEN PRINTSTRING(" BLOCK") C
ELSE PRINT STRING(PROC.NAME)
PRINTSTRING(" STARTING AT".STMNT)
WRITE(WORD0>>16,2)
IF MODE=1 AND DIAG=1 THEN START
PRINTSTRING("(MODULE ".STRING(ASIZE).")")
FINISH
NEWLINE
IF LANG#ALGOL THEN I=20 ELSE I=16
IF MODE=0 OR DIAG>1 THEN START
PLOCALS(TSTART+I+(WORD3>>26)<<2,"LOCAL")
IF WORD1&X'C0000000'#0 THEN START
! EXTERNAL(ETC) ROUTINE
I=WORD1&X'3FFFF'+INTEGER(GLAAD+12)+I
PLOCALS(I,"GLOBAL")
FINISH
FINISH
FINISH
FINISH
IF WORD3#0 START
NEWLNB=INTEGER(OLDLNB)
UNLESS DIAG = 1 OR INHIBIT=1 THEN NEWLINE
RETURN
FINISH
PREV BLK=WORD1&X'FFFF'
TSTART=PREV BLK
REPEAT UNTIL PREVBLK=0
NEWLNB=0
NEWLINE
RETURN
ROUTINE QSORT(RECORD (F)ARRAYNAME A, INTEGER I, J)
RECORD (F)D
INTEGER L, U
IF I>=J THEN RETURN
L = I - 1; U = J; D = A(J)
CYCLE
CYCLE
L = L+1
{%EXIT outer loop} IF L=U THEN -> FOUND
REPEAT UNTIL A(L)_VNAME>D_VNAME
A(U) = A(L)
CYCLE
U = U-1
{%EXIT outer loop} IF L=U THEN -> FOUND
REPEAT UNTIL D_VNAME>A(U)_VNAME
A(L) = A(U)
REPEAT
FOUND:
A(U) = D
QSORT(A,I,L-1)
QSORT(A,U+1,J)
END
!*
INTEGERFN CKREC(STRING (50) NAME); ! CHECK RECURSION
!********************************************************
!* AVOID PRINTING TRACE OF RECURSING RTS *
!********************************************************
IF SSOWN_LASTNAME=NAME START
COUNT=COUNT+1
IF COUNT=6 THEN PRINTSTRING("
**** ".NAME." CONTINUED TO RECURSE ****
")
RESULT =1 IF COUNT>5
FINISHELSESTART
IF COUNT>6 THEN START
PRINTSTRING("**** (FOR A FURTHER ")
WRITE(COUNT-6,1)
PRINTSTRING(" LEVEL")
IF COUNT>7 THEN PRINTSYMBOL('S')
PRINTSTRING(") ****
")
FINISH
COUNT=0
SSOWN_LASTNAME=NAME
FINISH
RESULT =0
END
ROUTINE PLOCALS(INTEGER ADATA, STRING (15) LOC)
!***********************************************************************
!* ADATA POINTS TO THE FIRST ENTRY FOR LOCALS IN THE SYMBOL TABLES*
!***********************************************************************
INTEGER I, NRECS, SADATA
IF LOC="GLOBAL" THEN START
I=0
WHILE I<SSOWN_GLOBPTR CYCLE
IF SSOWN_GLOBAD(I)=ADATA THEN RETURN
I=I+1
REPEAT
IF SSOWN_GLOBPTR<=20 THEN START
SSOWN_GLOBAD(SSOWN_GLOBPTR)=ADATA
SSOWN_GLOBPTR=SSOWN_GLOBPTR+1
FINISH
FINISH
NEWLINE
IF INTEGER(ADATA)<0 THEN PRINTSTRING("NO ")
PRINTSTRING(LOC." VARIABLES
")
NRECS=0; SADATA=ADATA
WHILE INTEGER(ADATA)>0 CYCLE
NRECS=NRECS+1
ADATA=ADATA+8+BYTE INTEGER(ADATA+4)&(-4)
REPEAT
RETURN IF NRECS=0
BEGIN
RECORD (F)ARRAY VARS(1:NRECS)
INTEGER I
ADATA=SADATA
FOR I=NRECS,-1,1 CYCLE
VARS(I)<-RECORD(ADATA)
ADATA=ADATA+8+BYTEINTEGER(ADATA+4)&(-4)
REPEAT
QSORT(VARS,1,NRECS)
FOR I=1,1,NRECS CYCLE
IF VARS(I)_VAL>>28&3=0 THEN PSCALAR(VARS(I))
REPEAT
IF ASIZE>0 THEN START
FOR I=1,1,NRECS CYCLE
IF VARS(I)_VAL>>28&3#0 THEN PARR(VARS(I), C
ASIZE)
REPEAT
FINISH
END
END
ROUTINE PSCALAR(RECORD (F)NAME VAR)
!***********************************************************************
!* OUTPUT THE NEXT VARIABLE IN THE CURRENT BLOCK. *
!* A VARIABLE ENTRY IN THE TABLES IS:- *
!* FLAG<<20!VBREG<<18!DISP *
!* WHERE:- *
!* VBREG IS VARIABLE'S BASE REGISTER, DISP IS IT'S OFFSET *
!* AND FLAGS=NAM<<6!PREC<<3!TYPE *
!***********************************************************************
INTEGER I, K, VADDR, F
STRING (11) LNAME
I=VAR_VAL
K=I>>20
TYPE=K&7
PREC=K>>4&7
NAM=K>>10&1
LNAME<-VAR_VNAME." "
PRINT STRING(LNAME."=")
IF I&X'40000'=0 THEN VADDR=OLDLNB ELSE VADDR=GLAAD
VADDR=VADDR+I&X'3FFFF'
IF TYPE=3=PREC {record} THEN F=16 ELSE F=0
PVAR(TYPE,PREC,NAM,LANG,F,VADDR)
NEWLINE
END
ROUTINE PVAR(INTEGER TYPE, PREC, NAM, LANG, FORM, VADDR)
!***********************************************************************
!* OUTPUT A VARIABLE. FIXED FORMAT(FORM#0) TAKE 14 PLACES FOR *
!* VARIABLES UP TO 32 BITS AND 21 PLACES THEREAFTER *
!* For records FORM is size in bytes *
!***********************************************************************
INTEGER K, I, J, DTOPHALF
STRING (255) EBCDIC
CONSTINTEGER UNASSI=X'81818181'
SWITCH INTV, REALV(3:7)
! USE VALIDATE HERE TO CHECK ACCESS
*LDTB_X'18000010'
*LDA_VADDR
*VAL_(LNB +1)
*JCC_3,<INVALID>
DTOPHALF=255
IF NAM#0 OR (TYPE=5 AND FORM=0 AND LANG#3 {IOPT}) THEN START
IF INTEGER(VADDR)>>24=X'E5' THEN ->ESC
DTOPHALF=INTEGER(VADDR)
VADDR=INTEGER(VADDR+4)
->NOT ASS IF VADDR=UNASSI
*LDTB_X'18000010'
*LDA_VADDR
*VAL_(LNB +1)
*JCC_3,<INVALID>
IF TYPE=3=PREC THEN FORM=DTOPHALF&X'0000FFFF'
FINISH
->ILL ENT IF PREC<3; ! BITS NOT IMPLEMENTED
IF TYPE=1 THEN ->INTV(PREC)
IF TYPE=2 THEN ->REALV(PREC)
IF TYPE=3 AND PREC=3 THEN ->RECORD
IF TYPE=3 AND PREC=5 THEN ->BOOL
IF TYPE=5 THEN ->STR
INTV(4): ! 16 BIT INTEGER
K=BYTEINTEGER(VADDR)<<8!BYTEINTEGER(VADDR+1)
->NOT ASS IF K=UNASSI>>16
WRITE(K,12*FORM+1)
RETURN
INTV(7): ! 128 BIT INTEGER
REALV(3): ! 8 BIT REAL
REALV(4): ! 16 BIT REAL
ILL ENT: ! SHOULD NOT OCCURR
PRINTSTRING("UNKNOWN TYPE OF VARIABLE")
RETURN
INTV(5): ! 32 BIT INTEGER
->NOT ASS IF INTEGER(VADDR)=UN ASSI
WRITE(INTEGER(VADDR),1+12*FORM)
UNLESS LANG=ALGOL OR FORM=1 OR -255<=INTEGER(VADDR)<=255 START
PRINTSTRING(" (X'")
PRHEX(INTEGER(VADDR)); PRINTSTRING("')")
FINISH
RETURN
INTV(3): ! 8 BIT INTEGER
WRITE(BYTEINTEGER(VADDR),1+12*FORM); RETURN
REALV(5): ! 32 BIT REAL
->NOT ASS IF INTEGER(VADDR)=UN ASSI
PRINT FL(REAL(VADDR),7)
RETURN
INTV(6): ! 64 BIT INTEGER
->NOT ASS IF UN ASSI=INTEGER(VADDR)=INTEGER(VADDR+4)
PRINTSTRING("X'")
PRHEX(INTEGER(VADDR)); SPACES(2)
PRHEX(INTEGER(VADDR+4))
PRINTSYMBOL('''')
RETURN
REALV(6): ! 64 BIT REAL
->NOT ASS IF UNASSI=INTEGER(VADDR)=INTEGER(VADDR+4)
PRINT FL(LONG REAL(VADDR),14)
RETURN
REALV(7): ! 128 BIT REAL
->NOT ASS IF UNASSI=INTEGER(VADDR)=INTEGER(VADDR+4)
PRINT FL(LONGREAL(VADDR),14)
IF FORM=0 THEN START
PRINTSTRING(" (R'"); PRHEX(INTEGER(VADDR))
PRHEX(INTEGER(VADDR+4))
SPACE; PRHEX(INTEGER(VADDR+8))
PRHEX(INTEGER(VADDR+12))
PRINTSTRING("')")
FINISH
RETURN
RECORD: ! Record, Print 1st FORM (max 16) bytes meantime
->NOT ASS IF UNASSI=INTEGER(VADDR)=INTEGER(VADDR+4)
PRINTSTRING(" X'"); PRHEX(INTEGER(VADDR))
IF FORM=0 OR FORM>4 THEN PRHEX(INTEGER(VADDR+4))
IF FORM=0 OR FORM>8 THEN SPACE AND PRHEX(INTEGER(VADDR+8))
IF FORM=0 OR FORM>12 THEN PRHEX(INTEGER(VADDR+12))
PRINTSTRING("'")
RETURN
BOOL: ! BOOLEAN
->NOT ASS IF INTEGER(VADDR)=UNASSI
IF INTEGER(VADDR)=0 THEN PRINTSTRING(" 'FALSE' ") C
ELSE PRINTSTRING(" 'TRUE' ")
RETURN
STR:
IF WORD1&X'20000000'=0 START ; ! STRINGS IN ISO CODE
I=BYTEINTEGER(VADDR)
->NOT ASS IF BYTE INTEGER(VADDR+1)=UNASSI&255=I
->WRONGL IF I>DTOPHALF&X'1FF';!CUR LENGTH>MAX LENGTH
FINISH ELSE START ; ! STRINGS IN EBCDIC
I=DTOPHALF&255
CHARNO(EBCDIC,0)=I; ! SET LENGTH
K=0
WHILE K<I CYCLE
CHARNO(EBCDIC,K+1)=BYTE INTEGER(VADDR+K)
K=K+1
REPEAT
ETOI(ADDR(EBCDIC)+1,I)
VADDR=ADDR(EBCDIC); ! USE TRANSLATED COPY HEREAFTER
FINISH
K=1
WHILE K<=I CYCLE
J=BYTE INTEGER(VADDR+K)
->NPRINT UNLESS 32<=J<=126 OR J=10
K=K+1
REPEAT
PRINT SYMBOL ('"')
PRINTSTRING(STRING(VADDR)); PRINT SYMBOL ('"')
RETURN
ESC: ! ESCAPE DESCRIPTOR
PRINTSTRING("ESCAPE ROUTINE")
->AIGN
INVALID:
PRINTSTRING("INVALID ADDRSS")
->AIGN
NPRINT:
PRINT STRING(" CONTAINS UNPRINTABLE CHARS")
RETURN
WRONGL:
PRINTSTRING("WRONG LENGTH ")
-> AIGN
NOT ASS:
PRINTSTRING(" NOT ASSIGNED")
AIGN:
IF PREC>=6 AND FORM=1 THEN SPACES(7)
END ; ! PVAR
INTEGERFN XDP (INTEGER REFADDR, VADDR, ELSIZE); ! CHECK DUPS
!***********************************************************************
!* CHECK IF VAR THE SAME AS PRINTED LAST TIME *
!***********************************************************************
ELSIZE=ELSIZE!X'18000000'
*LDTB_ELSIZE; *LDA_REFADDR
*CYD_0; *LDA_VADDR
*CPS_L =DR
*JCC_8,<A DUP>
RESULT =0
ADUP:
RESULT =1
END
ROUTINE DDV(LONGINTEGER DV,INTEGERARRAYNAME LB,UB); ! decode dope vector.
!***********************************************************************
!* WORK DOWN A DOPE VECTOR DESCRIBED BY WORD DESCRIPTOR DV AND *
!* RETURN SIZE,DIMENIONALITY AND SUBSCRIPT RANGES IN DATA *
!***********************************************************************
INTEGER I, ND, AD, U
ND=(DV>>32)&255; ND=ND//3
LB(0)=ND; UB(0)=ND
AD=INTEGER(ADDR(DV)+4)
FOR I=ND,-1,1 CYCLE
U=INTEGER(AD+8)//INTEGER(AD+4)-1
LB(I)=INTEGER(AD)
UB(I)=LB(I)+U
AD=AD+12
REPEAT
UB(ND+1)=0
LB(ND+1)=0
END
ROUTINE PARR(RECORD (F)NAME VAR, INTEGER ASIZE)
!***********************************************************************
!* PRINT THE FIRST ASIZE ELEMENTS OF THE ARRAY DEFINED BY VAR *
!* ARRAYNAMES PRINTED ALSO AT PRESENT. UP TO COMPILERS TO AVOID THIS*
!***********************************************************************
INTEGER I, J, K, TYPE, PREC, ELS, ND, VADDR, HDADDR, C
BASEADDR, ELSP, M1, REFADDR, ELSL, DUPSEEN
LONGINTEGER ARRD,DOPED
INTEGERARRAY LBS, UBS, SUBS(0:13)
I=VAR_VAL
K=I>>20
PREC=K>>4&7
TYPE=K&7
PRINTSTRING("
ARRAY ".VAR_VNAME)
IF I&X'40000'#0 THEN VADDR=GLAAD ELSE VADDR=OLDLNB
HDADDR=VADDR+I&X'3FFFF'
! VALIDATE HEADER AND THE 2 DESCRIPTORS
*LDTB_X'18000010'
*LDA_HDADDR
*VAL_(LNB +1)
*JCC_3,<HINV>
ARRD=LONG INTEGER(HDADDR)
DOPED=LONG INTEGER(HDADDR+8)
*LD_ARRD
*VAL_(LNB +1)
*JCC_3,<HINV>
*LD_DOPED
*VAL_(LNB +1)
*JCC_3,<HINV>
! Check the descriptor of the dope vector:
! It must be a (scaled, bounded) word vector.
! The bound must be a multiple of 3. It is in fact
! (3 * No. of dimensions). The number of dimensions
! must be greater than zero and not greater than 12.
I = (DOPED>>32) !! X'28000000'
ND = I // 3
-> HINV UNLESS 3*ND=I AND 0<ND<=12
BASEADDR=INTEGER(ADDR(ARRD)+4)
DDV(DOPED,LBS,UBS); ! decode dope vector.
! ELS is ELement Size
IF TYPE<3 THEN ELS=1<<(PREC-3) ELSE START
I=INTEGER(ADDR(DOPED)+4)
ELS=INTEGER(I+12*(ND-1)+4)
FINISH
! PRINT OUT AND CHECK BOUND PAIR LIST
PRINT SYMBOL('('); J=0
FOR I=1,1,ND CYCLE
SUBS(I)=LBS(I); ! SET UP SUBS TO FIRST EL
WRITE(LBS(I),1)
PRINT SYMBOL(':')
WRITE(UBS(I),1)
PRINT SYMBOL(',') UNLESS I=ND
J=1 IF LBS(I)>UBS(I)
REPEAT
PRINT SYMBOL(')')
NEWLINE
IF J#0 THEN PRINTSTRING("BOUND PAIRS INVALID") AND RETURN
! WORK OUT HOW MANY ELEMENTS TO PRINT ON A LINE
IF TYPE=5 THEN ELSP=1 C
ELSE IF ELS<=4 THEN ELSP=6 C
ELSE ELSP=4
CYCLE ; ! THROUGH ALL THE COLUMNS
! PRINT COLUMN HEADER EXCEPT FOR 1-D ARRAYS
IF ND>1 THEN START
PRINT STRING("
COLUMN (*,")
FOR I=2,1,ND CYCLE
WRITE(SUBS(I),1)
PRINT SYMBOL(',') UNLESS I=ND
REPEAT
PRINT SYMBOL(')')
FINISH
! COMPUTE THE ADDRESS OF FIRST ELEMENT OF THE COLUMN
K=0; M1=1; I=1
WHILE I<=ND CYCLE
K=K+M1*(SUBS(I)-LBS(I))
M1=M1*(UBS(I)-LBS(I)+1)
I=I+1
REPEAT
VADDR=BASEADDR+K*ELS
REFADDR=0; ! ADDR OF LAST ACTUALLY PRINTED
DUPSEEN=0; ELSL=99; ! FORCE FIRST EL ONTO NEW LINE
!!
! %CYCLE DOWN THE COLUMN AND PRINT THE ELEMENTS. SEQUENCES OF REPEATED
! ELEMENTS ARE REPLACED BY "(RPT)". AT THE START OF EACH LINE THE
! CURRENT VALUE OF THE FIRST SUBSCRIPTED IS PRINTED FOLLOWED BY A APAREN
!!
FOR I=LBS(1),1,UBS(1) CYCLE
IF REFADDR#0 THEN START ; ! CHK LAST PRINTED IN THIS COL
K = XDP(REFADDR,VADDR,ELS); ! CHECK DUPS
IF K#0 THEN START
PRINT STRING("(RPT)") IF DUPSEEN=0
DUPSEEN=DUPSEEN+1
->SKIP
FINISH
FINISH
! START A NEW LINE AND
! PRINT SUBSCRIPT VALUE IF NEEDED
IF DUPSEEN#0 OR ELSL>=ELSP START
NEWLINE; WRITE(I,3); PRINT STRING(")")
DUPSEEN=0; ELSL=0
FINISH
PVAR(TYPE,PREC,0,LANG,ELS,VADDR)
ELSL=ELSL+1
REFADDR=VADDR
SKIP:
VADDR=VADDR+ELS
ASIZE=ASIZE-1
EXIT IF ASIZE<0
REPEAT ; ! UNTIL COLUMN FINISHED
NEWLINE
EXIT IF ASIZE<=0 OR ND=1
! UPDATE SECOND SUBSCRIPT TO NEXT COLUMN
! CHECK FOR AND DEAL WITH OVERFLOW
! INTO NEXT OR FURTHER CLOUMNS
I=2; SUBS(1)=LBS(1)
CYCLE
SUBS(I)=SUBS(I)+1
EXIT UNLESS SUBS(I)>UBS(I)
SUBS(I)=LBS(I); ! RESET TO LOWER BOUND
I=I+1
REPEAT
EXIT IF I>ND; ! ALL DONE
REPEAT ; ! FOR FURTHER CLOMUNS
RETURN
HINV:
PRINTSTRING(" HAS INVALID HEADER
")
END ; ! OF RT PARR
END ; ! OF RT INDIAG
!*
INTEGERFN WTFAULT(INTEGER INF)
!***********************************************************************
!* TURNS INTERRUPT WT INTO PROPER FAULT FOR COMMON CASES *
!***********************************************************************
! %CONSTBYTEINTEGERARRAY TR(0 : 13) = 1,2,3,4,5,6,7,3,
! 9,9,7,7,8,10
! %INTEGER N
! N=10; ! DEFAULT FOR UNUSUAL CASE
! %IF INF=32 %THEN N=9; ! VSI MSG=ADDRESS ERROR
! %IF INF=64 %THEN N=211; ! CPU TIME EXCEEDED
! %IF INF=65 %THEN N=213; ! TERMINATION REQUESTED
! %IF INF<=13 %THEN N=TR(INF)
! %IF INF=136 %THEN N=13; ! OUTPUT EXCEEDED
! %IF INF=140 %THEN N=25; ! INPUT ENDED
! %RESULT=N
! **** Equivalent machine code: ****
CONST INTEGER N = 23
CONST BYTE INTEGER ARRAY V(0:2*N+2) = C
0,1,2,3,4,5,6,7,8,9,10,11,12,13,16,18,19,20,21,32, 64, 65,136,140,
1,2,3,4,5,6,7,3,9,9, 7, 7, 8,10,39,40,40,41,39, 9,211,213, 13, 25,10
IF 0<=INF<256 THEN START
*LD_V
*LB_INF
*SWNE_L =24; ! Should be N+1.
*LSS_(DR +24); ! Should be N+1.
*EXIT_-64
FINISH
RESULT = 10
! **** End of machine code. ****
END
ROUTINE ERMESS(INTEGER N, INF)
!***********************************************************************
!* OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT *
!***********************************************************************
RETURN IF N<=0
PRINTMESS(N)
IF N=26 OR N=34 THEN PRINT SYMBOL(NEXT SYMBOL)
IF N=10 THEN WRITE(INF,1); ! GIVE WT FOR FUNNY INTS
NEWLINE
END ; ! ERMESS
!*
SYSTEMROUTINE MLIBERR(INTEGER N)
INTEGER I
*STLN_I
NDIAG(0,INTEGER(I),N,0)
END ; ! MLIBERR
!*
!%SYSTEMINTEGERFNSPEC WRITE JS VAR(%STRING (32) NAME, %C
INTEGER OPTION, ADDR)
!*
!*
! %OWNINTEGER FLX; ! used to be FLABINDEX.
! %OWNINTEGER FLABMAX
! %OWNINTEGER FTRACELEVEL=2
!*
!*
!
! The following routine PTRACE never seems to be called
! so I have suppressed it, but the text is still included in
! case it is needed:
IF 0#0 THEN START
ROUTINE PTRACE(INTEGER INDEX)
STRING (63) S
INTEGER I, P1, AD
I=FLABKEY(INDEX)
P1=FLABINF(INDEX)
AD=FLABAD(INDEX)
S=STRING(AD)
IF I>0 THEN START
IF I=1 THEN START
IF S="S#GO" THEN START
PRINTSTRING("ENTER MAIN PROGRAM
")
RETURN
FINISH
PRINTSTRING("ENTER FN./SUBR. ")
FINISH ELSE START
PRINTSTRING("EXIT FN./SUBR. ")
FINISH
FINISH ELSE START
PRINTSTRING("LABEL ")
WRITE(P1,9)
FINISH
IF S="S#GO" THEN S="MAIN PROGRAM"
PRINTSTRING(" ".S)
IF I<0 THEN START
PRINTSTRING(" (")
WRITE(-I,1)
PRINTSYMBOL(')')
FINISH
NEWLINE
RETURN
END ; ! PTRACE
FINISH
!
!*
SYSTEMROUTINE ICL MATHS ERROR ROUTINE( C
INTEGER AOP {ADDRESS OF PARMS})
! MODIFIED 1/02/78 11.30
! THIS ROUTINE ACCEPTS CONTROL FROM AN ICL MATHS ROUTINE
! AFTER IT HAS FOUND A FAULT WITH ONE OF ITS
! PARAMETERS. THE ICL ERROR CONDITION NUMBER
! IS CONVERTED INTO A FORTRANG FAULT NUMBER,
! AND A MONITOR FROM THE APPROPRIATE POINT
! IS GIVEN. EXECUTION IS THEN TERMINATED
! UNDER CONTROL.
! THE PARAMETER ('AOP') POINTS TO A FIVE BYTE AREA.
! EACH BYTE IS IDENTIFIED BY THE NAMES:- P1
! PROCNO
! ERRNO
! P2
! P3 RESPECTIVELY
! OF THE FIVE PARAMETERS PASSED, ONLY 'PROCNO' AND 'ERRNO' ARE
! RELEVANT: 'PROCNO' IDENTIFIES THE ICL MATHS ROUTINE WHICH
! ISSUED THE FAULT
! 'ERRNO' IDENTIFIES THE ACTUAL FAULT
! IN THIS ROUTINE, 'PROCNO' CAN TAKE THE FOLLOWING VALUES:-
! PROCNO ICL MATHS ROUTINE
! 1 - 3 SIN (SINGLE, DOUBLE, QUADRUPLE PRECISION)
! 4 - 6 COS
! 13 - 15 TAN
! 16 - 18 COT
! 22 - 24 ASIN
! 25 - 27 ACOS
! 37 - 39 ATAN2
! 49 - 51 CSIN
! 52 - 54 CCOS
! 73 - 75 SINH
! 76 - 78 COSH
! 97 - 99 EXP
! 103 - 105 LOG
! 106 - 108 LOG10
! 112 - 114 CEXP
! 115 - 117 CLOG
! 118 - 120 SQRT
! 124 - 126 'REAL' ** 'REAL'
! 133 - 135 'COMPLEX' ** 'REAL'
! 145 - 147 GAMMA
! 148 - 150 LGAMMA
! THE FOLLOWING TABLE REPRESENTS THE TRANSLATIONS EFFECTED
! FROM ICL ERROR CONDITION NUMBERS TO FORTRANG FAULTS
CONSTBYTEINTEGERARRAY ERROR CODE TABLE( 1:2 , 0:49)= C
54 , 71 , 55 , 71 , 70 , 70 , 70 , 70 , 56 , 57 ,
66 , 67 , 70 , 70 , 58 , 71 , 59 , 71 , 70 , 70 ,
70 , 70 , 70 , 70 , 60 , 71 , 70 , 70 , 70 , 70 ,
70 , 70 , 54 , 54 , 55 , 55 , 70 , 70 , 70 , 70 ,
70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 61 , 71 ,
62 , 71 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 ,
70 , 70 , 70 , 70 , 53 , 53 , 70 , 70 , 51 , 52 ,
51 , 52 , 70 , 70 , 53 , 53 , 52 , 71 , 50 , 71 ,
70 , 70 , 68 , 68 , 70 , 70 , 70 , 70 , 69 , 69 ,
70 , 70 , 70 , 70 , 70 , 70 , 65 , 65 , 63 , 64
! THE LIST OF FORTRANG MATHEMATICAL LIBRARY ERROR MESSAGES
! IS AS FOLLOWS:-
! FAULT MESSAGE
! 50 SQRT ARG NEGATIVE
! 51 LOG ARG NEGATIVE
! 52 LOG ARG ZERO
! 53 EXP ARG OUT OF RANGE
! 54 SIN ARG OUT OF RANGE
! 55 COS ARG OUT OF RANGE
! 56 TAN ARG OUT OF RANGE
! 57 TAN ARG INAPPROPRIATE
! 58 ASIN ARG OUT OF RANGE
! 59 ACOS ARG OUT OF RANGE
! 60 ATAN2 ARGS ZERO
! 61 SINH ARG OUT OF RANGE
! 62 COSH ARG OUT OF RANGE
! 63 LGAMMA ARG NOT POSITIVE
! 64 LGAMMA ARG TOO LARGE
! 65 GAMMA ARG OUT OF RANGE
! 66 COT ARG OUT OF RANGE
! 67 COT ARG INAPPROPRIATE
! 68 REAL EXPONENTIATION FAULT
! 69 COMPLEX EXPONENTIATION FAULT
! 70 FUNCTION NOT SUPPORTED
! 71 UNKNOWN FUNCTION FAULT
INTEGER PVB {PREVIOUS LNB}; !POINTER TO THE STACK OF
! THE PREVIOUS ROUTINE
INTEGER FAULT; !FORTRANG EQUIVALENT FAULT TO
!ISSUED ICL MATHS FUNCTION
!ERROR NUMBER
INTEGER SSN; !SEGMENT NUMBER OF THE STACK
INTEGER I; !WORK VARIABLE
INTEGER PROCNO
INTEGER ERRNO
INTEGER PC, GLA
BYTEINTEGER LF, VSN
PROCNO=BYTEINTEGER(AOP {ADDRESS OF PARMS}+1)
ERRNO=BYTEINTEGER(AOP+2)
! CONVERT ICL ERROR NUMBER TO FORTRANG FAULT
IF PROCNO<=0 OR PROCNO>150 THEN FAULT=70 ELSE START
I=(PROCNO-1)//3
IF 0<ERRNO<3 THEN FAULT=ERROR CODE TABLE(ERRNO,I) C
ELSE IF 112<=PROCNO<=114 THEN FAULT=53 C
ELSE IF 124<=PROCNO<=126 THEN FAULT=68 C
ELSE IF 133<=PROCNO<=135 THEN START
IF ERRNO=4 THEN RETURN ELSE FAULT=69
FINISH ELSE START
FAULT=ERROR CODE TABLE(1,I)
IF FAULT¬=70 THEN FAULT=71
FINISH
FINISH
! GET THE STACK SEGMENT NUMBER
*STLN_PVB {PREVIOUS LNB}; !GET CURRENT STACK FRAME PTR
SSN {STACK SEGMENT NUMBER} = (PVB>>18)&X'00003FFF'
! SELECT OUTPUT (107)
SELECTOUTPUT(99)
! FIND THE STACK FRAME OF THE FORTRANG ROUTINE
! THAT CALLED THE ICL MATHS FUNCTION
! ------- AND WRITE OUT THE APPROPRIATE ERROR MESSAGE
GET NEXT FRAME:
PC=INTEGER(PVB {PREVIOUS LNB}+8)-4
PVB {PREVIOUS LNB} = INTEGER(PVB)
GLA = INTEGER(PVB + 16)
*LDTB_X'18000020'
*LDA_GLA
*VAL_(LNB + 1)
*JCC_3,<ERR>
LF = BYTEINTEGER(GLA + 16)
VSN = BYTEINTEGER(GLA + 17)
IF LF=X'08' THEN -> P2; ! For SIMULA.
IF LF = X'07' THEN -> P1
IF SSN {STACK SEGMENT NUMBER}¬=((PVB {PREVIOUS LNB}>>18)& C
X'00003FFF') THEN PRINT STRING("
DIAGNOSTICS FAIL STACK CORRUPT
") C
AND STOP
!AGRK 9/8/84:
!
!The following code has been modified to take account of PARM(MINSTACK). If
!the language flag is 2 (FORTE) or 10 (FORT77) and if the current procedure
!was compiled with PARM(MINSTACK) then word 6 of the pseudo stack frame
!which is addressed via LNB+12 is examined for M'FDIA'.
IF (LF= 2 ORC
LF=10) AND (BYTEINTEGER(GLA+19) & 2)> 0 THEN I= INTEGER(PVB+12) C
ELSE I= PVB
-> GET NEXT FRAME UNLESS INTEGER(I+24)= M'FDIA'
P1:
IF VSN = X'0A' THEN -> P2
IF LF = X'07' THEN START
CYCLE
GLA = INTEGER(PVB {PREVIOUS LNB} + 16)
*LDTB_X'18000020'
*LDA_GLA
*VAL_(LNB + 1)
*JCC_3,<ERR>
LF = BYTEINTEGER(GLA + 16)
VSN = BYTEINTEGER(GLA + 17)
IF LF = X'07' AND VSN = X'0A' THEN EXIT
PC = INTEGER(PVB {PREVIOUS LNB} + 8) - 4
PVB = INTEGER(PVB)
REPEAT
FINISH
P2:
NDIAG(PC,PVB {PREVIOUS LNB},FAULT,0); !WRITE OUT THE ERROR MESSAGE
! AND GIVE A MONITOR TRACE
RETURN
ERR:
PRINTSTRING("DIAGS FAIL - STACK CORRUPT")
NEWLINE
END ; !OF ICL MATHS ERROR ROUTINE
SYSTEMROUTINE PPROFILE(INTEGER A, B)
!***********************************************************************
!* SUPPORTS THE PROFILE FEATURE IN IMP BY GIVING THE LINE MAP *
!* AND RESTTING ALL COUNTS *
!***********************************************************************
INTEGER LINES, V, I, J, MAX, MAXMAX
LINES=A&X'FFFF'-1
MAX=0
FOR I=LINES,-1,1 CYCLE
IF INTEGER(B+4*I)>MAX THEN MAX=INTEGER(B+4*I)
REPEAT
MAXMAX=MAX
MAX=1+MAX//40; ! TWO&AHALF PER CENT
FOR I=1,1,LINES CYCLE
V=INTEGER(B+4*I)
IF V>=MAX THEN START
WRITE(I,4)
J=I
WHILE INTEGER(B+4*J+4)=V CYCLE
J=J+1
REPEAT
IF J#I THEN PRINTSTRING("->") C
AND WRITE(J,4) ELSE SPACES(7)
I=J
WRITE(V,6)
IF V=MAXMAX THEN PRINTSTRING(" ***")
NEWLINE
FINISH
REPEAT
FOR I=LINES,-1,1 CYCLE
INTEGER(B+4*I)=0
REPEAT
END
!
!
! - END OF NDIAG CODE ]
!
! [ START OF BCOM TEXT -
!
!
! **** ****
! N.B. Various points in the text are flagged with the comment "!{SEQ}".
! These are places where the sequential connect mode should be exploited
! when it becomes accessible.
! **** ****
!
!
!
!
!
SYSTEMROUTINE SETPAR(STRING (255) S)
!STORE PARAM LIST FOR
! SUBSEQUENT EXTRACTION OF
! INDIVIDUAL PARAMS
!USING SPAR
INTEGER I, J, POINT, LENS, APARSTRING; ! J is only needed for the machine
! code version.
SSOWN_LOCATE PRMS = 0
STRING(ADDR(SSOWN_PARSTRING(0))) = S
SSOWN_PCOUNT = 0
SSOWN_PMAP = 0; !MAP OF BITS INDICATING
! PARAMS SET
SSOWN_CURPAR = 1; !FIRST PARAM OF LIST
LENS = LENGTH(S)
IF LENS > 0 START ; !IF ANY PARAMS AT ALL
POINT = 0
! %FOR I=1,1,LENS+1 %CYCLE
! %IF I = LENS+1 %OR SSOWN_PARSTRING(I) = ',' %START
! PCOUNT = PCOUNT+1
! SSOWN_PINDEX(PCOUNT) = POINT; !START OF THIS PARAM
! SSOWN_PARSTRING(POINT) = I-POINT-1
! !LENGTH OF THIS PARAM
! %IF SSOWN_PARSTRING(POINT) > 0 %C
! %THEN SSOWN_PMAP = SSOWN_PMAP!1<<(PCOUNT-1)
! POINT = I
! %FINISH
! %REPEAT
!
! **** **** Machine code equivalent: **** ****
!
I = 0
APARSTRING=ADDR(SSOWN_PARSTRING(0))
CYCLE
J = LENS - I
I = I + 1
*LDTB_X'18000100'
*LDA_APARSTRING
*INCA_I
*LDB_J
*SWNE_L =DR ,0,44; ! %MASK=0,%REF=','
*CYD_0
*STUH_B
*ISB_APARSTRING
*ST_I
SSOWN_PCOUNT = SSOWN_PCOUNT+1
SSOWN_PINDEX(SSOWN_PCOUNT) = POINT; !START OF THIS PARAM
J = I - POINT - 1
SSOWN_PARSTRING(POINT) = J
!LENGTH OF THIS PARAM
IF J>0 THEN SSOWN_PMAP = SSOWN_PMAP!(1<<(SSOWN_PCOUNT-1))
POINT = I
REPEAT UNTIL I>LENS
!
! **** **** End of machine code **** ****
!
FINISH
END ; ! SETPAR
!
SYSTEMINTEGERFN PARMAP
!RETURNS AN INTEGER SHOWING
! WHICH PARAMETERS ARE
! NON-NULL. BIT 2**0=
!PARAM 1 ETC.
RESULT = SSOWN_PMAP
END ; !OF PARMAP
SYSTEMSTRINGFN SPAR(INTEGER N)
!N SHOULD BE NUMBER OF
! REQUIRED PARAM, OR 0
! MEANING NEXT PARAM
!ON EXIT RESULT WILL CONTAIN
! PARAM OR NULL IF NONE
! AVAILABLE.
STRING (255) S
INTEGER SAVE
SAVE = N
NEXT:
IF N=0 THEN START
N = SSOWN_CURPAR
SSOWN_CURPAR = SSOWN_CURPAR+1
FINISH
IF N>SSOWN_PCOUNT THEN RESULT = ""; !NO PARAM AVAILABLE
IF SSOWN_LOCATE PRMS=0 THEN START
S = STRING(ADDR(SSOWN_PARSTRING(0))+SSOWN_PINDEX(N))
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FINISH ELSE S = STRING (SSOWN_PAPTR(N))
IF S="" AND SAVE=0 THEN START ; ! IGNORE NULL STRING IN SIMPLE LIST
N = 0
-> NEXT
FINISH
RESULT = S
END ; ! SPAR
SYSTEM ROUTINE ANALYSE PARAMETERS C
(STRING NAME DCL PARMS, CALL PARMS, INTEGER MAX PARMS, C
STRING ARRAY NAME KEYS, INTEGER MAX KEY SIZE, C
RECORD (DRF) ARRAY NAME ACTUAL, C
INTEGER NAME TOTAL KEYS, RESPONSE)
!
! THIS ROUTINE TAKES TWO 'PARAMETER STRINGS', 'DCL PARMS' FROM A
! MACRO DECLARATION AND 'CALL PARM' FROM A CALL OF THE SAME MACRO.
! IT PRODUCES IN THE %STRING %ARRAY 'KEYS' ALL THE KEYWORDS DECLARED IN
! THE MACRO DECLARATION, IN THE CORRECT ORDER, AND IN %RECORD %ARRAY
! 'ACTUAL', BYTE-VECTOR DESCRIPTORS TO THE CORRESPONDING ACTUAL
! PARAMETER TEXTS TO BE USED IN THE CALL. THESE DESCRIPTORS WILL BE
! TO AREAS WITHIN THE %STRING 'CALL PARMS' OR (WHERE A DEFAULT IS
! USED) WITHIN 'DCL PARMS'. A DESCRIPTOR WITH BOUND ZERO WILL
! INDICATE A NULL STRING. A DESCRIPTOR WITH A TYPE-AND-BOUND WORD
! OF X'FFFFFFFF' INDICATES THAT NO VALUE WAS SUPPLIED FOR THE PARAMETER,
! EITHER AS A DEFAULT IN 'DCL PARMS' OR IN 'CALL PARM'.
! THE VALUES OF 'MAX PARMS' AND 'MAX KEY SIZE' MUST BE SET ON ENTRY
! TO INDICATE THE MAXIMUM NUMBER OF PARAMETERS AND THE MAXIMUM LENGTH
! OF THE KEYWORD STRINGS WHICH CAN BE ACCEPTED. THE %ARRAYS 'KEYS'
! AND 'ACTUAL' MUST BE DECLARED WITH UPPER BOUNDS NOT LESS THAN
! 'MAX PARMS' AND LOWER BOUNDS OF 1. THE %STRINGS IN %ARRAY 'KEYS'
! MUST HAVE MAXIMUM LENGTH NOT LESS THAN 'MAX KEY SIZE'.
! ON EXIT, 'RESPONSE' WILL BE =0 FOR SUCCESS, >0 FOR WARNINGS AND
! <0 FOR FAILURE. AS WELL AS THE SIGN BIT, OTHER BITS MAY BE SET
! TO INDICATE SPECIFIC WARNING OR ERROR CONDITIONS.
! BIT 24 (VALUE 128)- KEYWORDS INDISTINCT: TWO KEYWORDS HAVE THE
! SAME FIRST CHARACTERS, SO THAT THEIR
! ABBREVIATIONS COULD NOT BE DISTINGUISHED
! IN A CALL.
! BIT 25 (VALUE 64) - 'WRAP-AROUND': FIRST CHARACTER HAS BEEN
! SPECIFIED BY POSITION, BUT NOT IN FIRST
! POSITION IN THE CALL.
! BIT 26 (VALUE 32) - SOME PARAMETER SPECIFIED MORE THAN ONCE:
! LATEST VALUE ACCEPTED.
! BIT 27 (VALUE 16) - UNRECOGNISED KEYWORD IN CALL: FIELD IGNORED.
! BIT 28 (VALUE 8) - KEYWORD TOO LONG IN CALL:
! EXTRA CHARACTERS IGNORED.
! BIT 29 (VALUE 4) - TOO MANY FIELDS IN DECLARATION.
! BIT 30 (VALUE 2) - KEYWORD TOO LONG IN DECLARATION:
! EXTRA CHARACTERS IGNORED.
! BIT 31 (VALUE 1) - FIELD WITH NO KEYWORD IN DECLARATION.
!
! IF 'RESPONSE'>=0, THEN 'TOTAL KEYS' WILL ALSO BE SET TO INDICATE HOW
! MANY PARAMETERS THERE ARE.
!
!
ROUTINE PICK UNIT (INTEGER NAME CHAD, CHEND, C
INTEGER DECL, STRING NAME KEYWORD, INTEGER KSIZE, C
INTEGER NAME VLIM, VADDR, INTEGER NAME R)
! THIS ROUTINE SCANS BYTES FROM ADDRESS CHAD+1 TO
! ADDRESS CHEND (INCREMENTING CHAD AS IT GOES), TO FIND
! A KEYWORD AND/OR A PARAMETER VALUE. IT COPIES THE KEYWORD
! INTO THE PARAMETER 'KEYWORD', AND PUTS THE LENGTH AND
! ADDRESS OF THE PARAMETER VALUE INTO VLIM AND VADDR
! RESPECTIVELY.
! VADDR WILL BE BETWEEN (INITIAL VALUE OF) CHAD + 1 AND
! THE FINAL VALUE OF CHAD - 1. VLIM+VADDR-1 WILL ALSO LIE
! IN THAT RANGE. VLIM WILL NOT BE LESS THAN ZERO.
! ON ENTRY, CHAD MUST HAVE (ADDRESS OF THE FIRST CHARACTER
! TO BE EXAMINED) - 1. CHEND MUST HAVE THE ADDRESS OF THE
! LAST CHARACTER TO BE EXAMINED. ON EXIT, CHAD WILL HAVE BEEN
! UPDATED TO POINT TO THE LAST CHARACTER EXAMINED. IF IT
! IS THEN GREATER THAN CHEND, THE ORIGINAL TEXT HAS BEEN
! EXHAUSTED. IF IT IS EQUAL TO CHEND, THEN THE LAST CHARACTER
! OF THE ORIGINAL TEXT WAS THE COMMA WHICH TERMINATED THE
! PARAMETER FIELD. IF CHAD IS GREATER THAN OR EQUAL TO CHEND ON
! ENTRY, THEN THE ROUTINE WILL RETURN IMMEDIATELY WITH CHAD
! UNALTERED, WITH A NULL STRING IN KEYWORD, AND WITH VLIM=0.
! THERE WILL BE NO ERROR INDICATION IN THIS CASE.
! IF NO KEYWORD IS DETECTED IN A CALL ON PICK UNIT, THEN
! KEYWORD WILL BE ASSIGNED A NULL STRING. IF NO PARAMETER
! VALUE IS DETECTED, THEN VLIM WILL BE -1. IF THE VALUE
! SUPPLIED IS A NULL STRING (AS IN ...,KWD=,...), THEN
! VLIM WILL BE ZERO. WHERE A FIELD CONTAINS NO "=" SYMBOL
! (AND WHEN THERE IS NO OTHER WAY OF RESOLVING THE AMBIGUITY),
! THE VALUE OF THE PARAMETER DECL DECIDES WHETHER ANY TEXT
! FOUND IS TO BE TAKEN TO BE A KEYWORD (APPROPRIATE IN
! ANALYSING MACRO DECLARATIONS: DECL NON-ZERO) OR A
! PARAMETER VALUE (APPROPRIATE IN ANALYSING A CALL: DECL ZERO).
! THE PARAMETER KSIZE SPECIFIES THE MAXIMUM PERMISSIBLE SIZE OF
! THE STRING KEYWORD.
! ERRORS ARE NOTIFIED BY THE VALUE OF R ON EXIT. A ZERO VALUE
! MEANS THAT NO ERRORS HAVE OCCURRED. THE ONLY ERROR CONDITION
! DEFINED SO FAR IS "KEYWORD TOO LONG", GIVING R=1.
INTEGER TS, KADDR, KLIM, CHIN, CHYPE, BL, PAST
!
! THE ARRAY 'PROCN' IS INDEXED BY 'CHYPE' AND 'PAST' TO SELECT A
! DESTINATION IN THE SWITCH 'PROCN'. THIS PASSES CONTROL TO A
! PROCESS APPROPRIATE TO THE PRESENT STATE OF THE ANALYSIS ('PAST')
! AND THE CHARACTER BEING INSPECTED IN THE PARAMETER STRING ('CHYPE').
! VALUES OF 'CHYPE' ARE:
! 0 - NO TEXT LEFT TO EXAMINE:
! 1 - LETTER:
! 2 - DIGIT:
! 3 - SPACE:
! 4 - COMMA:
! 5 - 'EQUALS' SIGN:
! 6 - OPEN BRACKET:
! 7 - CLOSE BRACKET:
! 8 - DOUBLE-QUOTE:
! 9 - ANYTHING ELSE.
! VALUES OF 'PAST' ARE:
! 1 - STARTING: NO NON-SPACE CHARACTER SEEN YET.
! 2 - TEXT FOUND, BUT STILL UNDECIDED WHETHER IT IS KEYWORD OR VALUE.
! 3 - PROCESSING THE 'VALUE' PART OF THE PARAMETER FIELD.
! 4 - IN QUOTES (AND THIS CAN ONLY BE IN THE VALUE PART).
CONST BYTE INTEGER ARRAY PROCN (0:9,1:4) = C
16, 10, 8, 0, 16, 8, 9, 8, 7, 8,
15, 11, 11, 2, 15, 4, 9, 8, 7, 8,
17, 1, 1, 3, 14, 1, 12, 13, 6, 1,
17, 1, 1, 2, 1, 1, 1, 1, 5, 1
! %STRING (1) CHST
! %STRING (5) DISCARD
! %CONST %STRING (6) SPC = " ,=()"""
SWITCH PERFORM (0:17)
! LENGTH (CHST) = 1
R = 0
KADDR = ADDR (KEYWORD)
KLIM = 0
VADDR = CHAD + 1
VLIM = 0
BL = 0
PAST = 1
TS = 0
-> SEECH
!
!
PERFORM(10):
PAST = 2
PERFORM(11):
IF KLIM>=KSIZE C
THEN R = R ! 1 C
ELSE START
KLIM = KLIM + 1
BYTE INTEGER (KADDR+KLIM) = CHIN
FINISH
PERFORM(1):
ADD NS:
TS = 0
ADD TO F:
VLIM = VLIM + 1
!
SEECH:
CHAD = CHAD + 1
IF CHAD>CHEND THEN -> PERFORM (PROCN(0,PAST))
CHIN = BYTE INTEGER (CHAD)
!
! **** **** THIS NEXT SECTION IS A CANDIDATE **** ****
! **** **** FOR MACHINE CODING, BUT FOR THE **** ****
! **** **** MOMENT I HAVE USED A BIT OF **** ****
! **** **** TRICKERY WITH %STRINGS SPC, CHST **** ****
! **** **** AND DISCARD. THEIR DECLARATIONS **** ****
! **** **** WILL NOT BE NEEDED IF THIS BIT **** ****
! **** **** OF CODE IS REPLACED. **** ****
! **** **** IN FACT MY NEW CODE ACTUALLY **** ****
! **** **** TAKES MORE SPACE THAN THE OLD, **** ****
! **** **** SO I HAVE COMMENTED IT OUT, BUT **** ****
! **** **** I HAVE LEFT THE TEXT HERE AS AN **** ****
! **** **** INDICATION OF THE SORT OF CODE **** ****
! **** **** I HAD IN MIND. **** ****
IF 'A'<=CHIN<='Z' OR (ULCEQUIV#0 AND 'a'<=CHIN<='z') C
THEN CHYPE = 1 C
ELSE IF '0'<=CHIN<='9' THEN CHYPE = 2 ELSE START
IF CHIN=' ' THEN CHYPE = 3 C
ELSE IF CHIN=',' THEN CHYPE = 4 C
ELSE IF CHIN='=' THEN CHYPE = 5 C
ELSE IF CHIN='(' THEN CHYPE = 6 C
ELSE IF CHIN=')' THEN CHYPE = 7 C
ELSE IF CHIN='"' THEN CHYPE = 8 C
ELSE CHYPE = 9
! EQUIVALENT TO THAT, AND (I HOPE) FASTER AND MORE COMPACT:
! BUT IN FACT IT TAKES MORE SPACE, AND I HAVE NOT CHECKED ITS
! SPEED!
! BYTE INTEGER (ADDR(CHST)+1) = CHIN
! %IF SPC->DISCARD.(CHST) %C
! %THEN CHYPE = LENGTH(DISCARD) + 3 %C
! %ELSE CHYPE = 9
FINISH
! **** **** END OF MACHINE CODE SECTION **** ****
!
-> PERFORM (PROCN(CHYPE,PAST))
!
PERFORM(9):
BL = 1
PERFORM(8):
KLIM = 0
PERFORM(5):
PAST = 3
-> ADD NS
!
PERFORM(7):
KLIM = 0
PERFORM(6):
PAST = 4
-> ADD NS
!
PERFORM(4):
VADDR = CHAD + 1
VLIM = 0
TS = 0
PAST = 3
-> SEECH
!
PERFORM(3):
IF VLIM#0 THEN -> ADD S
PERFORM(0):
VADDR = VADDR + 1
-> SEECH
PERFORM(2):
ADD S:
TS = TS + 1
-> ADD TO F
!
PERFORM(12):
BL = BL + 1
-> ADD NS
!
PERFORM(13):
IF BL>0 THEN BL = BL - 1
-> ADD NS
!
PERFORM(14):
IF BL>0 THEN -> ADD NS
-> UNIT COMPLETE
!
PERFORM(16):
VLIM = -1
-> TIDY
PERFORM(15):
IF DECL=0 THEN KLIM = 0 ELSE TS = VLIM + 1
PERFORM(17):
UNIT COMPLETE:
VLIM = VLIM - TS
TIDY:
LENGTH (KEYWORD) = KLIM
IF ULCEQUIV=0 THEN START
IF KLIM=0 THEN R = R & X'FFFFFFFE'
FINISH ELSE START
IF KLIM=0 THEN R = R & X'FFFFFFFE' ELSE UCTRANSLATE (KADDR+1,KLIM)
FINISH
RETURN
END
!
!
INTEGER CPTR, CLIM, RESULT, VS, VP, L, M, KM, KN, CSTART
INTEGER WRAPPING, KEY VALID
INTEGER NAME VALSIZE, VALPTR
RECORD (DRF) NAME VAL
STRING (255) CALL KEY
STRING NAME THIS KEY, THAT KEY
!
RESPONSE = 0
CPTR = ADDR (DCL PARMS)
CLIM = CPTR + LENGTH (DCL PARMS)
IF CLIM=CPTR THEN START
TOTAL KEYS = 0
RETURN
FINISH
KN = 0
WHILE CPTR<CLIM AND KN<MAX PARMS CYCLE
KN = KN + 1
THIS KEY == KEYS (KN)
VAL == ACTUAL (KN)
VALSIZE == VAL_LENGTH
VALPTR == VAL_AD
PICK UNIT (CPTR,CLIM,-1,THIS KEY,MAX KEY SIZE,VALSIZE,VALPTR,RESULT)
VALSIZE = VALSIZE ! X'18000000'
L = LENGTH (THIS KEY)
IF L=0 THEN START
RESPONSE = RESPONSE ! X'80000001'
CPTR = CLIM + 1
FINISH ELSE START
IF RESULT#0 THEN RESPONSE = RESPONSE ! 2
KM = 1
IF L>3 THEN L=3
WHILE KM<KN CYCLE
THAT KEY == KEYS (KM)
M = LENGTH (THAT KEY)
IF M>L THEN M=L
!
! **** **** MACHINE CODE HERE? **** ****
IF STOREMATCH(M,ADDR(THIS KEY)+1,ADDR(THAT KEY)+1)#0 C
THEN RESPONSE = RESPONSE ! X'80000080'
! **** **** END OF MACHINE CODE **** ****
!
KM = KM + 1
REPEAT
FINISH
REPEAT
IF CPTR<=CLIM THEN RESPONSE = RESPONSE ! X'80000004'
IF RESPONSE<0 THEN RETURN
TOTAL KEYS = KN
KN = 1
WRAPPING = 0
CSTART = ADDR (CALL PARMS)
CPTR = CSTART
CLIM = CPTR + LENGTH (CALL PARMS)
WHILE CPTR<CLIM CYCLE
PICK UNIT (CPTR,CLIM,0,CALL KEY,MAX KEY SIZE,VS,VP,RESULT)
IF RESULT#0 THEN RESPONSE = RESPONSE ! 8
KEY VALID = 0
IF LENGTH(CALL KEY)>0 THEN START
KN = 0
IF LENGTH(CALL KEY)<3 THEN START
CYCLE
KN = KN + 1
REPEAT UNTIL KN>TOTAL KEYS OR KEYS(KN)=CALL KEY
FINISH ELSE START
CYCLE
KN = KN + 1
REPEAT UNTIL KN>TOTAL KEYS OR STARTSWITH(KEYS(KN),CALL KEY,0)#0
FINISH
IF KN>TOTAL KEYS THEN START
RESPONSE = RESPONSE ! X'00000010'; ! UNRECOGNISED KEYWORD.
FINISH ELSE START
KEY VALID = -1
FINISH
FINISH ELSE IF VS#0 THEN START
IF KN=1 AND WRAPPING#0 THEN RESPONSE = RESPONSE ! X'00000040'
KEY VALID = -1
FINISH
IF KEY VALID#0 AND VS>=0 THEN START
VAL == ACTUAL (KN)
IF CSTART<=VAL_AD<CLIM C
THEN RESPONSE = RESPONSE ! X'00000020'
VAL_LENGTH = VS ! X'18000000'
VAL_AD = VP
FINISH
KN = KN + 1
IF KN>TOTAL KEYS THEN START
KN = 1
WRAPPING = -1
FINISH
REPEAT
RETURN
!
!
END
!
SYSTEM ROUTINE FILPS (STRING NAME DPF, S)
INTEGER N, R
STRING (PRMKWDL) ARRAY KY (1:PRMLIM)
RECORD (DRF) ARRAY VL (1:PRMLIM)
INTEGER I, J, K, L, OINST, OOUTST, RPL
STRING (MAXPROMPTSIZE) OPRPT, TPRPT
ANALYSE PARAMETERS (DPF, S, PRMLIM, KY, PRMKWDL, VL, N, R)
SSOWN_LOCATE PRMS = 1
SSOWN_PMAP = 0
SSOWN_PCOUNT = N
SSOWN_CURPAR = 1
IF UINFI(2)=1 THEN START ; ! Only for interactive working -
OINST = INSTREAM
OOUTST = OUTSTREAM
IF OINST#0 THEN SELECT INPUT (0)
IF OOUTST#0 THEN SELECT OUTPUT (0)
OPRPT = UINFS (4)
I = 1
WHILE I<=N CYCLE
K = VL(I)_LENGTH
IF SSOWN_QPARMF#0 OR K=-1 THEN START
TPRPT = KY(I)
J = LENGTH (TPRPT)
IF SSOWN_QPARMF#0 AND K#-1 AND J<MAXPROMPTSIZE-1 THEN START
K = K & X'00FFFFFF'
L = J + K + 2
IF L>MAXPROMPTSIZE-1 THEN L = MAXPROMPTSIZE - 1
LENGTH (TPRPT) = L
CHARNO (TPRPT,J+1) = '('
CHARNO (TPRPT,L) = ')'
MOVE (L-J-2,VL(I)_AD,ADDR(TPRPT)+J+2)
FINISH
PROMPT (TPRPT.":")
RPL = 0
WHILE NEXT CH#NL CYCLE
IF SSOWN_RPTR+RPL>=RPLIM THEN START
MOVE (RPL, ADDR(SSOWN_RPS(SSOWN_RPTR)), ADDR(SSOWN_RPS(0)))
SSOWN_RPTR = 0
FINISH
RPL = RPL + 1
READ CH (SSOWN_RPS(SSOWN_RPTR+RPL))
REPEAT
SKIP SYMBOL
SSOWN_RPS (SSOWN_RPTR) = RPL
IF SSOWN_QPARMF=0 OR VL(I)_LENGTH=-1 OR RPL#0 THEN START
CAST OUT (STRING(ADDR(SSOWN_RPS(SSOWN_RPTR))))
VL(I)_AD = ADDR (SSOWN_RPS(SSOWN_RPTR)) + 1
VL(I)_LENGTH = X'18000000' ! SSOWN_RPS (SSOWN_RPTR)
SSOWN_RPTR = SSOWN_RPTR + SSOWN_RPS(SSOWN_RPTR) + 1
FINISH
FINISH
I = I + 1
REPEAT
PROMPT (OPRPT)
IF OINST#0 THEN SELECT INPUT (OINST)
IF OOUTST#0 THEN SELECT OUTPUT (OOUTST)
FINISH
IF N>0 THEN START
FOR I=1,1,N CYCLE
IF VL(I)_LENGTH#-1 THEN START
K = VL(I)_LENGTH & X'00FFFFFF'
IF K>0 THEN START
L = VL(I)_AD
UNLESS L-RPLIM<=ADDR(SSOWN_RPS(0))<=L THEN START
IF SSOWN_RPTR+K>RPLIM THEN SSOWN_RPTR = 0
J = ADDR (SSOWN_RPS(SSOWN_RPTR))
SSOWN_RPS (SSOWN_RPTR) = K
MOVE (K,L,J+1)
SSOWN_PAPTR (I) = J
SSOWN_RPTR = SSOWN_RPTR + K + 1
FINISH ELSE SSOWN_PAPTR (I) = L - 1
SSOWN_PMAP = SSOWN_PMAP ! (1<<(I-1))
FINISH ELSE SSOWN_PAPTR (I) = ADDR (SSOWN_NULP)
FINISH ELSE SSOWN_PAPTR (I) = ADDR (SSOWN_NULP)
REPEAT
FINISH
END
IF DIAGOP#0 THEN START
EXTERNAL ROUTINE LIST PARAMETERS C
(INTEGER P, C
STRING ARRAY NAME KNAME, C
RECORD (DRF) ARRAY NAME VALUE)
INTEGER I, J, K, L
IF P>0 THEN START
FOR I=1,1,P CYCLE
L = ADDR (KNAME(I))
L = BYTE INTEGER (L)
PRINT STRING (KNAME(I))
SPACES (12-LENGTH(KNAME(I)))
IF VALUE(I)_LENGTH#-1 THEN START
PRINT SYMBOL ('"')
K = VALUE(I)_LENGTH & X'00FFFFFF'
IF K>0 THEN START
L = VALUE(I)_AD
FOR J=L,1,L+K-1 CYCLE
PRINT SYMBOL (BYTE INTEGER(J))
REPEAT
FINISH
PRINT SYMBOL ('"')
FINISH ELSE PRINT STRING ("<NONE>")
NEWLINE
REPEAT
FINISH
END
FINISH
!
EXTERNALLONGREALFN ZCPUTIME
SYSTEMLONGREALFNSPEC CPUTIME
RESULT = CPUTIME
END ; !OF CPUTIME
SYSTEM STRING (255) FN PRINTPARMS (LONGINTEGER P)
! **** **** This used to be a ROUTINE. It ought to be documented. **** ****
STRING (255) T
INTEGER I
T = ""
P = P !! DEFAULTPARM
FOR I=0,1,MAXPARMS CYCLE
IF P&1=1 AND PARMS(I)#"" THEN START ; ! IGNORE BLANK PARMS
IF T#"" THEN T = T.","
T = T.PARMS(I)
FINISH
P = P>>1
REPEAT
IF T="" THEN T = "DEFAULTS"
RESULT = T
END ; !OF PRINTPARMS
!
SYSTEMROUTINE CONSOURCE(STRING (31)FILE,INTEGERNAME AD)
!FOR USE BY INCLUDE FACILITY IN IMP COMPILER
INTEGER FLAG
RECORD (RF)RR
CONNECT(FILE,0,0,0,RR,FLAG); !{SEQ}
IF FLAG=0 THEN START
IF RR_FILETYPE#SSCHARFILETYPE THEN START ; !INVALID FILETYPE
IF NEWCONNECT#0 THEN START
DISCONNECT (LAST, FLAG)
FINISH
FLAG= 267
SSOWN_SSFNAME=FILE
FINISH ELSE START
AD=RR_CONAD
IF NEWCONNECT#0 THEN START
SETUSE (LAST,-1,0)
FINISH
RETURN
FINISH
FINISH
IF SSOWN_SSCOMREG(23)#0 THEN START
SELECT OUTPUT (0)
PSYSMES(23,FLAG)
FINISH
STOP
END ; !OF CONSOURCE
!
! BATCHSTOP and USE OPTIONS have been moved into the
! INFREQUENT CODE module.
!
!
EXTERNALROUTINE ZACCEPT(STRING (255) S)
INTEGER FLAG
STRING (31) FILE, NEWNAME,TEMPLATE
TEMPLATE = "FILE,NEWNAME="
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS (TEMPLATE,S)
IF 1#PARMAP#3 THEN START ; ! WRONG NO OF PARAMS
FLAG = 263
-> ERR
FINISH
FILE = SPAR(1)
NEWNAME = SPAR(2)
ACCEPT(FILE,NEWNAME,FLAG)
ERR:
SSOWN_RCODE = FLAG
IF FLAG # 0 THEN PSYSMES(1,FLAG)
END ; !OF ACCEPT
EXTERNALROUTINE ALIAS(STRING (255) S)
!WARNING - DOES NOT ALLOW FOR
! FULL LENGTH NAMES - UNLIKELY
INTEGER FLAG
STRING (32) CURRENT, NEW
STRING (11) TEMPLATE
TEMPLATE = "NAME,ALIAS="
IF S#"" THEN LENGTH (TEMPLATE) = 11 ELSE LENGTH (TEMPLATE) = 10
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS (TEMPLATE,S)
IF 1#PARMAP#3 THEN START ; ! WRONG NO. OF PARAMS
FLAG = 263
-> ERR
FINISH
CURRENT = "=".SPAR(1); ! INDICATES ALIAS
NEW = SPAR(2)
IF NEW#"" START
IF CHECKCOMMAND(NEW)#0 OR CHARNO(NEW,1)='#' THEN START
FLAG = 202
SSOWN_SSFNAME = NEW
-> ERR
FINISH
MODDIRFILE(9,SSOWN_AVD,NEW,CURRENT,0,0,0,FLAG)
FINISH ELSE MODDIRFILE(2,SSOWN_AVD,"",CURRENT,0,0,0,FLAG)
!REMOVE ALIAS
ERR:
SSOWN_RCODE = FLAG
IF FLAG # 0 THEN PSYSMES(77,FLAG)
END ; !OF ALIAS
EXTERNALROUTINE CLEAR(STRING (255) S)
INTEGER FLAG, CHAN
STRING (31) SCHAN
RECORD (FDF)NAME F
FLAG = 0; !DEFAULT REPLY
IF S = "" START ; !CLEAR ALL NON-OPEN CHANNELS
FOR CHAN=80,-1,1 CYCLE
IF SSOWN_SSFDMAP(CHAN)#0 AND SSOWN_SSCOMREG(22)#CHAN#SSOWN_SSCOMREG(23) THEN START
!CHANNEL DEFINED
!AND NOT SELECTED
F == RECORD(SSOWN_SSFDMAP(CHAN))
IF F_STATUS = 0 START ; !CHANNEL CLOSED
F_DSNUM = 0; !TO MARK IT AS UNUSED
SSOWN_SSFDMAP(CHAN) = 0; !CLEAR POINTER
FINISH
FINISH
REPEAT
FINISH ELSE START ; !CLEAR(N1,N2,N3)
SETPAR(S)
LOOP:
SCHAN = SPAR(0); !NEXT PARAMETER
IF SCHAN = "" THEN -> ERR; !END OF LIST
CHAN = PSTOI(SCHAN)
UNLESS 1<=CHAN<=80 THEN START ; ! INVALID CHAN
FLAG = 223
-> FAIL
FINISH
IF SSOWN_SSFDMAP(CHAN)=0 THEN START ; ! CHANNEL NOT DEFINED
FLAG = 151
-> FAIL
FINISH
F == RECORD(SSOWN_SSFDMAP(CHAN))
IF F_STATUS#0 OR SSOWN_SSCOMREG(22)=CHAN OR SSOWN_SSCOMREG(23)=CHAN THEN START
! CHANNEL OPEN OR SELECTED
FLAG = 265
-> FAIL
FINISH
F_DSNUM = 0; !TO SHOW DESCRIPTOR FREE
SSOWN_SSFDMAP(CHAN) = 0; !CLEAR POINTER
-> LOOP
FAIL: PSYSMES(42,FLAG)
-> LOOP
FINISH
ERR:
SSOWN_RCODE = FLAG
END ; !OF CLEAR
EXTERNALROUTINE CPULIMIT(STRING (255) S)
STRING (17) TEMPLATE
INTEGER MIN, SEC, FLAG, KI
STRING (8) SSEC, SMIN
IF S = "?" START ; !PRINT CURRENT SETTING
FLAG = 0
SEC = SSOWN_CURRKI//KIPS; !NO OF SECONDS
MIN = SEC//60
SEC = SEC-(MIN*60)
PRINTSTRING("Current cpulimit: ".ITOS(MIN)."m ".ITOS(SEC). C
"s")
NEWLINE
FINISH ELSE START
SEC = 0
MIN = 0
IF S#"" AND CHARNO(S,1)#',' C
THEN TEMPLATE = "MINUTES,SECONDS=0" C
ELSE TEMPLATE = "MINUTES=0,SECONDS"
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS (TEMPLATE,S)
! CHECK NO OF PARAMS.
UNLESS 0<PARMAP<=3 THEN FLAG = 263 ELSE START
SMIN = SPAR(1); !MINUTES
SSEC = SPAR(2)
IF SMIN # "" THEN MIN = PSTOI(SMIN)
IF SSEC # "" THEN SEC = PSTOI(SSEC)
KI = 60*MIN+SEC
IF MIN<0 OR SEC<0 OR KI>MAXCPL THEN FLAG = 202 ELSE START
KI = KI*KIPS
FLAG = X27{DSETIC}(KI)
IF FLAG=0 THEN SSOWN_CURRKI = KI ELSE START
! INVALID PARAMETER.
FLAG = 202
SSOWN_SSFNAME = ""
FINISH
FINISH
FINISH
FINISH
SSOWN_RCODE = FLAG
IF FLAG # 0 THEN PSYSMES(53,FLAG)
END ; !OF CPULIMIT
!
EXTERNALROUTINE ZDEFINE(STRING (255) S)
! **** **** Allow DEFINE (unit,name,Rnn,Fnn) to define size in terms
! **** **** of records.
!
STRING (34) TEMPLATE
STRING (31) IDEN; ! IDEN should have length 255 if we are
! going to make concatenation work.
STRING (10) SCHAN, SKB, SRECFM
INTEGER CHAN, AFD, I, J, FLAG, IKB, MOD, RECCOUNT
RECORD (FDF)NAME F
TEMPLATE = "CHANNEL,FILE,KBYTES=,RECORDFORMAT="
FLAG = 0
IF S = "?" START
FOR CHAN=1,1,80 CYCLE
AFD=SSOWN_SSFDMAP(CHAN)
IF AFD#0 START
WRITE(CHAN,2)
SPACES(2)
DEFINFO(CHAN,IDEN,I)
PRINTSTRING(IDEN)
NEWLINE
FINISH
REPEAT
NEWLINE
-> ERR
FINISH
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS (TEMPLATE,S)
IF PARMAP&3#3 OR PARMAP>15 THEN START ; ! WRONG NO OF PARAMS
FLAG = 263
-> ERR
FINISH
SCHAN = SPAR(1)
FOR I=1,1,LENGTH(SCHAN) CYCLE ; !SCHAN MIGHT CONTAIN ALPHA
! CHAS AT FRONT - IGNORE THEM
IF '0' <= CHARNO(SCHAN,I) <= '9' THEN START
SCHAN = SUBSTRING(SCHAN,I,LENGTH(SCHAN))
!TRUNCATE SCHAN
EXIT
FINISH
REPEAT
CHAN = PSTOI(SCHAN)
UNLESS 0<CHAN<81 THEN START ; ! RANGE = 1-80
FLAG=223
-> ERR
FINISH
IDEN = SPAR(2)
IF IDEN -> IDEN.("-MOD") THEN MOD = 8 ELSE MOD = 0
!APPEND MODE
SKB = SPAR(3); !MAX SIZE IN K BYTES
IF SKB="" THEN START
IKB = 0 {Use default value for MAXSIZE}
RECCOUNT = 0
FINISH ELSE START
RECCOUNT = STARTSWITH (SKB,"R",-1)
IKB = PSTOI(SKB); !INTEGER VALUE
IF IKB<=0 THEN START
FLAG = 202
SSOWN_SSFNAME = SKB
-> ERR
FINISH
IF RECCOUNT=0 AND IKB#0 THEN IKB = ((IKB+4)&X'FFFC')<<KSHIFT
! SIZE IN BYTES - ALLOWING FOR HEADER
FINISH
SRECFM = SPAR(4)
DEFINE(CHAN,IDEN,AFD,FLAG)
-> ERR IF FLAG # 0
F == RECORD(AFD)
F_FLAGS = F_FLAGS!MOD; !OR IN THE MOD BIT IF NEC.
IF SRECFM="C" THEN {Character output} F_MODEOFUSE = 1 ELSE START
IF STARTSWITH(SRECFM,"E",1)#0 THEN F_FLAGS=F_FLAGS!EBCDICBIT
IF SRECFM#"" THEN START
F_MODEOFUSE = 2
J = CHARNO (SRECFM,1)
IF J='D' THEN START
F_MODEOFUSE = 3; ! Mark it DIRECT ACCESS
IF LENGTH(SRECFM)=1 THEN F_RECTYPE = 1
! "D" on its own is not a fault - it's useful
! for FORTRAN with an existing file (but FORTRAN support
! software will have to change F_MODE from 3 to 13).
FINISH ELSE IF 'F'#J#'V' THEN START
SSOWN_SSFNAME = SRECFM
FLAG = 202
FINISH
IF LENGTH(SRECFM)>1 THEN START
I = PSTOI (SUBSTRING(SRECFM,2,LENGTH(SRECFM)))
IF I>0 AND (I<=MAXVREC OR J#'V') THEN START
F_MAXREC = I
IF J#'V' THEN START
F_RECTYPE = 1; !FIXED FORMAT
F_MINREC = I
! %IF RECCOUNT#0 %THEN IKB = (I*IKB+4127)&(-4096)
! That gave size rounded up to a page. But it leaves no trace in the
! the FD record of the number of records which the user requested. So
! for the time being I am trying
IF RECCOUNT#0 THEN IKB = I*IKB + 32
FINISH ELSE IF RECCOUNT#0 THEN START
FLAG = 202
SSOWN_SSFNAME = SKB
FINISH
FINISH ELSE START
SSOWN_SSFNAME = SRECFM
FLAG = 202
FINISH
FINISH
FINISH
FINISH
IF IKB>SSOWN_SSMAXFSIZE THEN START
FLAG = 295
SSOWN_SSFNAME = SKB
FINISH
! Perhaps we shouldn't check that for temporary files.
IF IKB # 0 THEN F_MAXSIZE = IKB
IF FLAG#0 THEN START ; ! CLEAR the definition.
F_DSNUM = 0
SSOWN_SSFDMAP (CHAN) = 0
FINISH
ERR:
SSOWN_RCODE = FLAG
IF FLAG # 0 THEN PSYSMES(43,FLAG)
END ; !OF DEFINE
!
EXTERNALROUTINE DEFINFO(INTEGER CHAN, C
STRINGNAME FILE, INTEGERNAME STATUS)
!RETURNS INFO ABOUT CHANNEL CHAN IN FILE AND STATUS
RECORD (FDF)NAME F
INTEGER AFD
FILE = ""; !DEFAULT VALUE
STATUS = 0
UNLESS 0<CHAN<=80 THEN RETURN ; ! OUT OF RANGE
AFD = SSOWN_SSFDMAP(CHAN)
IF AFD=0 THEN RETURN
F == RECORD(AFD)
IF F_ACCESSROUTE=5 {MAGNETIC TAPE} C
THEN FILE=STRING(AFD+87)."(".STRING(AFD+105).")" C
ELSE IF F_ACCESSROUTE=10 C
THEN FILE=".NULL" C
ELSE IF F_ACCESSROUTE=11 {ALIEN DATA} C
THEN FILE="*" C
ELSE IF F_DEVCODE#0 C
THEN FILE = DEVNAME(F_DEVCODE!(F_F4<<8)) {SMH} C
ELSE FILE = F_IDEN
IF F_STATUS=0 THEN START ; ! DEFINED BUT NOT OPEN
STATUS = 1
RETURN
FINISH
STATUS = 3; !DEFINED AND OPEN
END ; !OF DEFINFO
EXTERNALROUTINE DELIVER(STRING (255) S)
INTEGER FLAG
IF S="" THEN FLAG = 263 C
ELSE IF S="?" THEN START ; !GET DELIVERY INFO
FLAG = X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,1,0,ADDR(S))
!GET DELIVERY INFO
PRINTSTRING("Current delivery information: ".S)
NEWLINE
FINISH ELSE START ; !ELSE SET DELIVERY INFO
SSOWN_DELIVERYCHANGED=1; !FORCES BATCH JOB TO SEPARATE OUTPUT
IF LENGTH(S) > 31 THEN LENGTH(S) = 31
FLAG = X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,1,1,ADDR(S))
FINISH
SSOWN_RCODE = FLAG
IF FLAG # 0 THEN PSYSMES(62,FLAG)
END ; !OF DELIVER
EXTERNALROUTINE ZDESTROY(STRING (255) S)
INTEGER FLAG, DUMMYI
STRING (31) FILE, MEMBER, NAME
FLAG = 0
SETPAR(S)
CYCLE
FILE = SPAR(0); !NEXT PARAMETER
EXIT IF FILE = ""; !END OF LIST
IF FILE -> NAME.("_").MEMBER C
THEN MODPDFILE(2,NAME,MEMBER,"",FLAG) C
ELSE DESTROY(FILE,FLAG)
IF FLAG = 0 THEN MODDIRFILE(2,SSOWN_AVD,"",FILE,0,0,0, C
DUMMYI)
!REMOVE FROM SS#DIR
IF FLAG # 0 THEN PSYSMES(12,FLAG)
REPEAT
SSOWN_RCODE = FLAG
END ; !OF DESTROY
!
EXTERNALINTEGERFN EXIST (STRING (31) FILE)
RECORD (RF)RR
RECORD (FRF)FR
INTEGER FLAG, J
STRING (31) DUMMY1, DUMMY2
IF FILE -> DUMMY1.("_").DUMMY2 START
!MUST BE PD FILE
CONNECT(FILE,0,0,0,RR,FLAG)
IF NEWCONNECT#0 THEN START
SETUSE (LAST, -1, 0)
FINISH
!HAVE TO USE CONNECT TO CHECK
! THAT MEMBER EXISTS
FINISH ELSE START
FINFO(FILE,0,FR,FLAG)
FINISH
IF FLAG = 0 THEN RESULT = 1
RESULT = 0
END ; !OF EXIST
!
EXTERNALROUTINE INSERT(STRING (255) S)
STRING (31) OBJFILE
INTEGER FLAG, I
FLAG = 0
SETPAR(S)
CYCLE
OBJFILE = SPAR(0)
-> ERR IF OBJFILE = ""; !END OF LIST
MODDIRFILE(3,SSOWN_AVD,"",OBJFILE,0,0,0,FLAG)
IF FLAG # 0 START
PSYSMES(25,FLAG)
MODDIRFILE(2,SSOWN_AVD,"",OBJFILE,0,0,0,I)
!REMOVE INFO
FINISH
REPEAT
ERR:
SSOWN_RCODE = FLAG
END ; !OF INSERT
EXTERNALROUTINE INSERTMACRO(STRING (255) S)
INTEGER FLAG, I
RECORD (RF)RR
STRING (31) FILE,DUMMYS, MACRONAME
SETPAR(S)
INITCLIVARS
MACOPEN
FLAG = 0
CYCLE
FILE = SPAR(0)
EXIT IF FILE = ""
CONNECT(FILE,0,0,0,RR,FLAG); !{SEQ}
IF NEWCONNECT#0 THEN START
SETUSE(LAST,-1,0)
FINISH
IF FLAG=0 AND RR_FILETYPE=SSCHARFILETYPE THEN START
EXAMINEMACRO(MACRONAME,DUMMYS,RR_DATAEND-RR_DATASTART,RR_ C
CONAD+RR_DATASTART,0,FLAG)
IF FLAG=0 THEN START
MODDIRFILE(2,SSOWN_AVD,"",FILE,0,0,0,FLAG); ! REMOVE EXISTING INFO
MODDIRFILE(9,SSOWN_AVD,MACRONAME,FILE,0,0,0,FLAG); ! PUT SINGLE ENTRY IN
IF FLAG#0 C
THEN MODDIRFILE(2,SSOWN_AVD,"",FILE,0,0,0,I) C
ELSE START
PRINTSTRING("Macro ".MACRONAME." inserted in active directory")
NEWLINE
FINISH
FINISH ELSE IF FLAG=X'80000800' THEN FLAG = 336 C
ELSE IF FLAG=X'80001000' THEN FLAG = 337
FINISH ELSE IF FLAG=0 THEN FLAG = 267
IF FLAG#0 THEN PSYSMES(15,FLAG)
REPEAT
SSOWN_RCODE = FLAG
END ; !OF INSERTMACRO
EXTERNALROUTINE MESSAGES(STRING (255) S)
!ROUTINE TO SUPPRESS OR ALLOW MESSAGES
!FROM OTHER PROCESSES
INTEGER FLAG, DUMMY
STRING (5) TEMPLATE
TEMPLATE = "PRINT"
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS (TEMPLATE,S)
S = SPAR (1)
FLAG = 0
IF S = "OFF" THEN SSOWN_INHIBITMESSAGES = 1 C
ELSE IF S = "ON" THEN START
SSOWN_INHIBITMESSAGES = 0
DUMMY=0
CONSOLE(6,DUMMY,DUMMY); !PRINT ANY OUTSTANDING
FINISH ELSE START
! ILLEGAL PARAM:
SSOWN_SSFNAME = S
FLAG = 202
FINISH
SSOWN_RCODE = FLAG
IF FLAG # 0 THEN PSYSMES(88,FLAG)
END ; !OF MESSAGES
INTEGERFN CHARGE (LONGREAL CPU,INTEGER PTURNS,CONMINS)
!RETURNS COST IN PENCE OF THIS SESSION SO FAR - ALGORITHM DEPENDS ON
!VALUE OF %CONSTINTEGER MACHINE. USED BY METER AND BY UINFI
CONST RECORD (COMF) NAME COM = X'80C00000'
INTEGER RES, PROCESSOR
RES=0; !IN CASE NO FORMULA PROVIDED FOR THIS MACHINE
IF MACHINE=2972 START
RES=INT(8.5*(CPU+PTURNS/600))
! %IF SSOWN_SSREASON=BATCHREASON %AND PRIORITY<=2 %THEN RES=RES//2
FINISH
IF MACHINE=2980 OR MACHINE=2988 THEN START
RES=INT(6.5*(CPU+PTURNS/700))
! %IF SSOWN_SSREASON=BATCHREASON %AND PRIORITY<=2 %THEN RES=RES//2
FINISH
IF MACHINE=2960 THEN START
RES = INT (3.85*(CPU + PTURNS/250 + CONMINS))
FINISH
IF MACHINE=0 THEN START
PROCESSOR = COM_OCPTYPE & X'000000FF'
IF PROCESSOR=4 THEN START ; ! 2980 or 2988.
RES=INT(6.5*(CPU+PTURNS/700))
! %IF SSOWN_SSREASON=BATCHREASON %AND PRIORITY<=2 %THEN RES=RES//2
FINISH
IF PROCESSOR>4 THEN START ; ! 5 for 2972, 6 for 2976 (?).
RES=INT(8.5*(CPU+PTURNS/600))
! %IF SSOWN_SSREASON=BATCHREASON %AND PRIORITY<=2 %THEN RES=RES//2
FINISH
IF PROCESSOR=2 THEN START ; ! 2 for 2960.
RES = INT (3.85*(CPU + PTURNS/250 + CONMINS))
FINISH
FINISH
RESULT =RES
END ; !OF CHARGE
EXTERNALROUTINE METER(STRING (255) DUMMY)
INTEGER CT, PT,PENCE, COST
LONGREAL CPU
CPU = CPUTIME
PT = PAGETURNS
CT = (SECSFRMN-SSOWN_STARTSECS)//60
IF CT < 0 THEN CT = CT+1440; !WRAPPED AROUND - ADD IN 24*60 MINS
PRINTSTRING(DATE." ".TIME." CPU=")
PRINT(CPU,1,2)
PRINTSTRING(" Secs")
IF SSOWN_SSREASON # BATCHREASON START
PRINTSTRING(" CT=")
WRITE(CT,1)
PRINTSTRING(" Mins")
FINISHELSE CT = 0; !NO CONNECT TIME FOR BATCH JOB
PRINTSTRING(" PT=")
WRITE(PT,1)
PENCE=CHARGE(CPU,PT,CT)
IF PENCE>0 START ; !MAY BE NO CHARGING FORMULA
PRINTSTRING(" Ch=")
WRITE(PENCE,1)
IF MACHINE#2960 THEN PRINTSYMBOL('p') ELSE PRINTSTRING (" units")
FINISH
NEWLINE
IF FUNDS ON#0 THEN START
COST=UINFI(20)
PRINTSTRING("Funds left : ")
PRINT(COST/100,1,2)
IF SCARCEWORD&x'FF'>=SCARCEWORD>>24 THENSTART
! INTERACTIVE USERS > SCARCITY LIMIT
SSOWN_SCARCITYFOUND=1
PRINTSTRING("**Resources are Scarce.")
IF UINFI(20)=0 THEN PRINTSTRING(" You are liable to pre-emption.")
FINISH
NEWLINE
FINISH
SSOWN_RCODE = 0
END ; !OF METER
EXTERNALROUTINE NEWDIRECTORY(STRING (255) S)
CONSTINTEGER DFH = 160; ! DEFAULT HASHCONST
CONSTINTEGER DFPL = 856; ! DEFAULT PLENGTH
INTEGER HASHCONST, FLAG, PLENGTH
STRING (31) FILE
RECORD (FRF)FR
STRING (8) SH, SP
STRING (27) TEMPLATE
TEMPLATE = "NAME,HASH=".ITOS(DFH).",PSIZE=".ITOS(DFPL)
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS (TEMPLATE,S)
IF 1#PARMAP#7 THEN START ; ! WRONG NO OF PARAMS
FLAG = 263
-> ERR
FINISH
FILE = SPAR(1)
FINFO(FILE,0,FR,FLAG)
IF FLAG=0 THEN START ; ! FILE ALREADY EXISTS
FLAG = 219
-> ERR
FINISH
IF PARMAP = 1 START ; !USE DEFAULT VALUES
HASHCONST = DFH; ! DEFAULT HASHCONST
PLENGTH = DFPL; ! DEFAULTPLENGTH
FINISH ELSE START
SH = SPAR(2); !NO OF ENTRIES
SP = SPAR(3); !SIZE OF PLIST
HASHCONST = PSTOI(SH); !HASHCONST SUPPLIED
PLENGTH = PSTOI(SP); !PLENGTH SUPPLIED
IF HASHCONST<=0 OR PLENGTH<=0 THEN START
FLAG = 202
-> ERR
FINISH
FINISH
MODDIRFILE(10,FILE,"","",0,HASHCONST,PLENGTH,FLAG)
-> ERR IF FLAG # 0
PRINTSTRING("New directory '".FILE."' created")
NEWLINE
ERR:
SSOWN_RCODE = FLAG
IF FLAG # 0 THEN PSYSMES(41,FLAG)
END ; !OF NEWDIRECTORY
EXTERNALROUTINE ZNEWGEN(STRING (255) S)
SYSTEMROUTINESPEC NEWGEN(STRING (31) S, T, INTEGERNAME FLAG)
STRING (31) OLD, NEW
INTEGER FLAG
STRING (7) TEMPLATE
TEMPLATE = "FROM,TO"
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS (TEMPLATE,S)
IF PARMAP#3 THEN START ; ! WRONG NO OF PARAMETERS
FLAG = 263
-> ERR
FINISH
OLD = SPAR(1)
NEW = SPAR(2)
NEWGEN(OLD,NEW,FLAG)
ERR:
SSOWN_RCODE = FLAG
IF FLAG # 0 THEN PSYSMES(61,FLAG)
END ; !OF NEWGEN
EXTERNALROUTINE OBEY(STRING (255) S)
!CURRENTLY THIS ONLY ACCEPTS
! ONE LEVEL OF OBEYING
STRING (31) INFILE, OUTFILE
RECORD (FDF)NAME F
RECORD (RF)RR
INTEGER FLAG, AFD, CURFDLEVEL
STRING (9) TEMPLATE
TEMPLATE = "FILE,OUT="
IF CURSTACK#0 THEN START
FLAG = 307
-> ERR
FINISH
IF SSOWN_FDLEVEL>1 THEN START ; ! CANNOT OBEY IN OBEY
FLAG = 315
-> ERR
FINISH
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS (TEMPLATE,S)
IF 1#PARMAP#3 THEN START ; !WRONG NO OF PARAMS
FLAG=263
->ERR
FINISH
INFILE = SPAR(1)
OUTFILE = SPAR(2)
CONNECT(INFILE,0,0,0,RR,FLAG)
-> ERR IF FLAG # 0
IF RR_FILETYPE#SSCHARFILETYPE THEN START ; ! INVALID FILE TYPE
SSOWN_SSFNAME = INFILE
FLAG = 267
-> E1
FINISH
SSOWN_SSOPENUSED=1; !TO ENSURE TIDY CALLED AT END OF OBEY IF IT FAILS
DEFINE(88,INFILE,AFD,FLAG)
-> E1 IF FLAG # 0
F == RECORD(AFD)
SET IO DEFAULT (SSOWN_INDEFAULT,88); !DEFAULT INPUTCHANNEL
IF OUTFILE # "" START
DEFINE(89,OUTFILE,AFD,FLAG)
-> E1 IF FLAG#0
SELECTOUTPUT(89); !IF IT FAILS WILL GIVE
! MESSAGE ON CURRENT STREAM
SET IO DEFAULT (SSOWN_OUTDEFAULT,89)
FINISH
SELECTINPUT(0)
SELECTOUTPUT(0)
CURFDLEVEL = SSOWN_FDLEVEL
SSOWN_FDLEVEL = SSOWN_FDLEVEL+1
SSOWN_DATAECHO = SSOWN_SSDATAECHO; !USE OPTIONS FILE SETTING
BCI
SSOWN_FDLEVEL = CURFDLEVEL; !RESET IT
IF SSOWN_SSREASON = DSTARTREASON THEN SSOWN_DATAECHO = 0
!RETURN TO NO ECHO
TIDYFILES; !MUST TIDY HERE
E1:
IF NEWCONNECT#0 THEN START
DISCONNECT (INFILE, FLAG)
FINISH
ERR:
IF FLAG # 0 THEN PSYSMES(46,FLAG)
END ; !OF OBEY
EXTERNALROUTINE ZOFFER(STRING (255) S)
STRING (255) FILE, USER
INTEGER FLAG
STRING (11) TEMPLATE
TEMPLATE = "FILE,USER="
IF S="" THEN LENGTH(TEMPLATE) = 9 ELSE LENGTH(TEMPLATE) = 10
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS (TEMPLATE,S)
! Check number of parameters:
IF 1#PARMAP#3 THEN FLAG = 263 ELSE START
FILE = SPAR(1)
USER = SPAR(2)
IF LENGTH(FILE)>31 THEN START
SSOWN_SSFNAME = FILE
FLAG = 220
FINISH ELSE IF 0#LENGTH(USER)#6 THEN START
SSOWN_SSFNAME = USER
FLAG = 201
FINISH ELSE START
OFFER(FILE,USER,FLAG)
FINISH
FINISH
SSOWN_RCODE = FLAG
IF FLAG#0 THEN PSYSMES(30,FLAG)
END ; !OF OFFER
!
!
!
EXTERNALROUTINE OPTION(STRING (255) S)
! **** **** There should be a NOCFAULTS option.
!
SYSTEMROUTINESPEC NEWGEN(STRING (31) FILE,NEW FILE,INTEGERNAME FLAG)
CONSTINTEGER MAXVKEY = 17
CONSTINTEGER MAXKEY = 14
CONSTSTRING (8) TEMPOPTIONS = "T#OPTION"
RECORD (RF)RR
RECORD (CONTF)NAME C
CONSTINTEGER MAXSEARCHDIRCOUNT = 16
STRING (63) VALUE, KEYWORD, PARAM
INTEGER I, CONAD, FLAG, IVALUE, MODE, OLDFLAG
IF NEWLOADER#0 THEN START
INTEGER OLDPERMISTK, INUSE
FINISH
CONSTSTRING (13) ARRAY VKEY(1 : MAXVKEY) = C
"INITSTACKSIZE","AUXSTACKSIZE","USERSTACKSIZE",
"ITWIDTH","FSTARTFILE","BSTARTFILE",
"PRELOADFILE","ACTIVEDIR","REMOVEDIR","SEARCHDIR","ARRAYDIAG",C
"INITWORKSIZE","NULL","ITINSIZE","ITOUTSIZE","CFAULTS","TERMINAL"
SWITCH SW(1 : MAXKEY)
SWITCH VSW(1 : MAXVKEY)
CONSTSTRING (12) ARRAY KEY(1 : MAXKEY) = C
"BRACKETS","NOBRACKETS","NORECALL","TEMPRECALL","PERMRECALL",
"NOFSTARTFILE","?","NOBLANKLINES","BLANKLINES","NOBSTARTFILE",
"INITPARMS","NOECHO","PARTECHO","FULLECHO"
ROUTINE RMSD(STRING (31) DIR, INTEGERNAME FLAG); ! REMOVESEARCHDIR
INTEGER I
FLAG = 313; !NOT FOUND - DEFAULT
RETURN IF C_SEARCHDIRCOUNT = 0
FOR I=C_SEARCHDIRCOUNT,-1,1 CYCLE
IF C_SEARCHDIR(I) = DIR START
C_SEARCHDIRCOUNT = C_SEARCHDIRCOUNT-1;!DECREMENT COUNTER
WHILE I <= C_SEARCHDIRCOUNT CYCLE ; !COMPACT REST OF LIST IF NEC
C_SEARCHDIR(I) = C_SEARCHDIR(I+1)
I = I+1
REPEAT
FLAG = 0
RETURN
FINISH
REPEAT
END ; !OF REMOVESEARCHDIR
ROUTINE ADSD(STRING (31) DIR); ! ADDSEARCHDIR
INTEGER I
IF C_SEARCHDIRCOUNT > 0 START ; !SOME ALREADY - MOVE UP
FOR I=C_SEARCHDIRCOUNT,-1,1 CYCLE
C_SEARCHDIR(I+1) = C_SEARCHDIR(I)
REPEAT
FINISH
C_SEARCHDIRCOUNT = C_SEARCHDIRCOUNT+1; !INCREMENT COUNTER
C_SEARCHDIR(1) = DIR; !NEW DIRECTORY TO TOP OF LIST
END ; !OF ADDSEARCHDIR
ROUTINE OUTI(STRING (255) S, INTEGER N)
PRINTSTRING(S." :")
WRITE(N,1)
NEWLINE
END ; !OF OUTI
ROUTINE OUTS(STRING (255) S, T)
PRINTSTRING(S." : ".T)
NEWLINE
END ; !OF OUTS
!
!
!FIRST CALCULATE APPROPRIATE MODE FOR OPERATING ON OPTION FILE
!IF ONLY PARAMETER IS '?' THEN USE READ MODE. OTHERWISE WRITE.
IF STUDENTSS=0 THEN START
IF S = "?" THEN MODE = 0 ELSE MODE = 3
FINISH ELSE START
MODE = 0
FINISH
CONNECT(SSOWN_OPTIONSFILE,0,0,0,RR,FLAG); !CONNECT ONLY IN READ MODE TO AVOID CONCURRENCY PROBLEMS
IF NEWCONNECT#0 THEN START
SETUSE (LAST, -1, 0)
FINISH
IF FLAG = 218 START ; !FILE DOES NOT EXIST
IF STUDENTSS#0 THEN START
FLAG = 0
C == RECORD (SSOWN_SSADEFOPT)
FINISH ELSE START
IF MODE = 0 START ; !ONLY READ ACCESS REQUIRED
FLAG = 0
C == RECORD(SSOWN_SSADEFOPT); !NO OPTION FILE - USE DEFAULT
FINISH ELSE START ; !NEED TO CREATE ONE
OUTFILE(SSOWN_OPTIONSFILE,4096,0,0,CONAD,FLAG)
-> ERR IF FLAG # 0
FSTATUS(SSOWN_OPTIONSFILE,1,0,FLAG); !CHERISH OPTIONS FILE
MOVE(OPTFILESIZE,SSOWN_SSADEFOPT,CONAD); !COPY INTO MY CONTROL FILE
FINISH
FINISH
FINISH ELSE IF FLAG=0 THEN START
IF RR_FILETYPE#SSOPTFILETYPE THEN START
FLAG = 267
SSOWN_SSFNAME = SSOWN_OPTIONSFILE
-> ERR
FINISH
C == RECORD(RR_CONAD); !MAP RECORD ONTO FILE
FINISH ELSE -> ERR; !FAILED TO CONNECT FOR SOME OTHER REASON
IF MODE = 3 THEN START ; !FILE IS TO BE CHANGED
IF NEWCONNECT#0 THEN START
RDISCON(SSOWN_OPTIONSFILE,FLAG); !IGNORE FLAG - ENSURE WE GET LATEST COPY
FINISH ELSE START
DISCONNECT (SSOWN_OPTIONSFILE, FLAG)
FINISH
OUTFILE(TEMPOPTIONS,4096,0,0,CONAD,FLAG)
-> ERR IF FLAG # 0
IF NEWCONNECT#0 THEN START
SETUSE (LAST, -1, 0)
FINISH
CONNECT(SSOWN_OPTIONSFILE,0,0,0,RR,FLAG)
-> ERR IF FLAG # 0
IF NEWCONNECT#0 THEN START
SETUSE (LAST, -1, 0)
FINISH
MOVE(OPTFILESIZE,RR_CONAD,CONAD); !COPY INTO TEMP FILE
IF NEWCONNECT=0 THEN START
DISCONNECT (SSOWN_OPTIONSFILE,FLAG)
FINISH
C == RECORD(CONAD); !MAP RECORD ONTO TEMPORARY COPY
C_DATETIME = CURRENTPACKEDDT; !UPDATE DATE AND TIME
FINISH
!
!
SETPAR(S)
!
AGAIN:
!
PARAM = SPAR(0); !NEXT PARAM
OLDFLAG = FLAG; !SAVE PREVIOUS FLAG
FLAG = 0; !RESET FOR NEXT PARAM
-> USEINFO IF PARAM = ""; !END OF LIST
FOR I=MAXKEY,-1,1 CYCLE ; !FIRST CHECK FOR SIMPLE KEYWORDS
IF PARAM = KEY(I) THEN -> SW(I)
REPEAT
IF PARAM -> KEYWORD.("=").VALUE START
IF '0' <= CHARNO(VALUE,1) <= '9' START
IVALUE = PSTOI(VALUE); !SOME TAKE A POSITIVE INTEGER AS PARAM
FINISH ELSE START
!MUST BE A FILENAME
IF (LENGTH(VALUE)<8 OR CHARNO(VALUE,7)#'.') C
AND CHARNO(VALUE,1)#'.' C
THEN VALUE = SSOWN_SSOWNER.".".VALUE
IVALUE = -1; !IMPOSSIBLE VALUE
FINISH
FOR I=MAXVKEY,-1,1 CYCLE
IF KEYWORD = VKEY(I) THEN -> VSW(I)
REPEAT
FINISH
SSOWN_SSFNAME = PARAM
FLAG = 202; !INVALID PARAM
PSYSMES(67,FLAG)
-> AGAIN
SW(1): !BRACKETS
IF STUDENTSS=0 THEN START
C_LDELIM = '('
C_RDELIM = ')'
FINISH
-> AGAIN
SW(2): !NOBRACKETS
IF STUDENTSS=0 THEN START
C_LDELIM = ' '
C_RDELIM = NL
FINISH
-> AGAIN
SW(3): !NOJOURNAL
IF STUDENTSS=0 THEN START
C_JOURNAL = 0
FINISH
-> AGAIN
SW(4): !TEMPRECALL
IF STUDENTSS=0 THEN START
C_JOURNAL = 1
FINISH
-> AGAIN
SW(5): !PERMJOURNAL
IF STUDENTSS=0 THEN START
C_JOURNAL = 2
FINISH
-> AGAIN
SW(6): !NOFSTARTFILE
IF STUDENTSS=0 THEN START
C_FSTARTFILE = ""
FINISH
-> AGAIN
SW(7): ! ? LIST OPTIONS
PRINTSTRING("List of current options:")
NEWLINES(2)
PRINTSTRING(KEY(3+C_JOURNAL)); !NORECALL ETC
NEWLINE
IF C_LDELIM = ' ' THEN PRINTSTRING("NO")
PRINTSTRING("BRACKETS")
NEWLINE
IF C_NOBL = 1 THEN PRINTSTRING("NO")
PRINTSTRING("BLANKLINES")
NEWLINE
OUTI("ITWIDTH",C_ITWIDTH)
OUTI("ARRAYDIAG",C_ARRAYDIAG)
OUTI("ITINSIZE",C_ITINSIZE>>KSHIFT)
OUTI("ITOUTSIZE",C_ITOUTSIZE>>KSHIFT)
! OUTI("USERSTACKSIZE",C_USTK>>KSHIFT)
IF C_ISTK >= 0 THEN OUTI("INITSTACKSIZE",C_ISTK>>KSHIFT)
OUTI("AUXSTACKSIZE",C_ASTK>>KSHIFT)
IF C_INITWORKSIZE#0 THEN OUTI("INITWORKSIZE",C_INITWORKSIZE>>KSHIFT)
OUTS("ACTIVEDIR",C_MODDIR)
IF C_FSTARTFILE#"" C
THEN OUTS("FSTARTFILE",C_FSTARTFILE) C
ELSE START
PRINTSTRING("NOFSTARTFILE")
NEWLINE
FINISH
IF C_BSTARTFILE#"" C
THEN OUTS("BSTARTFILE",C_BSTARTFILE) C
ELSE START
PRINTSTRING("NOBSTARTFILE")
NEWLINE
FINISH
PRINTSTRING("INITPARMS : "); PRINTSTRING(PRINTPARMS(C_INITPARMS))
NEWLINE
IF C_CFAULTS # "" THEN OUTS("CFAULTS",C_CFAULTS)
PRINTSTRING(KEY(12+C_DATAECHO))
NEWLINE
IF C_SEARCHDIRCOUNT > 0 START
NEWLINE
FOR I=1,1,C_SEARCHDIRCOUNT CYCLE
OUTS("SEARCHDIR ".ITOS(I),C_SEARCHDIR(I))
REPEAT
FINISH
-> AGAIN
SW(8): !NOBLANKLINES
IF STUDENTSS=0 THEN START
C_NOBL = 1
FINISH
-> AGAIN
SW(9): !BLANKLINES
IF STUDENTSS=0 THEN START
C_NOBL = 0
FINISH
-> AGAIN
SW(10): !NOBSTARTFILE
IF STUDENTSS=0 THEN START
C_BSTARTFILE = ""
FINISH
-> AGAIN
SW(11): !SET INITIAL PARMS ON STARTUP
IF STUDENTSS=0 THEN START
C_INITPARMS = LONGINTEGER(ADDR(SSOWN_SSCOMREG(27)))
FINISH
-> AGAIN
SW(12): !NOECHO
SW(13): !PARTECHO
SW(14): !FULLECHO
IF STUDENTSS=0 THEN START
C_DATAECHO = I-12; != 0, 1 OR 2
FINISH
->AGAIN
VSW(1): !INITSTACKSIZE
!
IF STUDENTSS=0 THEN START
!
! **** Comment relevant only to new loader:
! Altering the initstacksize is slightly complicated by the
! introduction of 'permanent' initialised stack at ss3.00. The
! PERMISTK is held at the top of the initialised stack area and
! expands 'downwards' to meet the TEMPISTK expanding upwards.
! Since altering the INITSTACKSIZE effectively means moving
! the perm ISTK which would of course cause severe problems
! for the routines expecting to find it, the operation cannot be
! permitted if any perm ISTK is in use.
! ********************************************************************
IVALUE = IVALUE<<KSHIFT
! MUST LEAVE AT LEAST 32K HOLE IN USERSTACK
UNLESS 0<=IVALUE<=C_USTK-K32 THEN -> INVLU ELSE START
IF NEWLOADER#0 THEN START
IF SSOWN_USTB=0 THEN C_ISTK=IVALUE AND ->AGAIN
INUSE=SSOWN_INITSTACKSIZE+SSOWN_USTB-SSOWN_PERMISTK; ! Perm currently in use
IF INUSE#0 THEN START
INUSE=(INUSE+4095)>>KSHIFT
PRINTSTRING("Unable to reset INITSTACKSIZE - ". C
ITOS(INUSE)."K perm loaded.
Call RESETLOADER and repeat")
NEWLINE
->INVLU
FINISH
SSOWN_SSINHIBIT=1; ! Prevent interrupts
SSOWN_PERMISTK=SSOWN_USTB+IVALUE
SSOWN_LLINFO(-1)_ISTK=SSOWN_PERMISTK
SSOWN_LLINFO(0)_ISTK=SSOWN_PERMISTK
INTEGER(SSOWN_USTB)=IVALUE
FINISH
C_ISTK = IVALUE
IF NEWLOADER#0 THEN START
SSOWN_SSINHIBIT = 0
FINISH
-> AGAIN
FINISH
!
FINISH ELSE START
-> AGAIN
FINISH
!
VSW(2): !AUX STACK
!
IF STUDENTSS=0 THEN START
IF 0<IVALUE<=(SSOWN_SSMAXFSIZE>>KSHIFT) THEN START
C_ASTK = IVALUE<<KSHIFT
-> AGAIN
FINISH
-> INVLU
FINISH ELSE START
-> AGAIN
FINISH
!
VSW(3): !USER STACK
! %UNLESS 64 <= IVALUE <= 252 %THEN -> INVLU
! IVALUE = IVALUE << KSHIFT
! %IF C_ISTK+K32 > IVALUE %THEN -> INVLU
! !MUST ENSURE AT LEAST 32K HOLE REMAINS
! C_USTK = IVALUE
-> AGAIN
!
VSW(4): !ITWIDTH
IF MINITWIDTH<=IVALUE<=MAXITWIDTH THEN START
IF STUDENTSS=0 THEN START
C_ITWIDTH = IVALUE
FINISH ELSE START
SSOWN_SSITWIDTH = IVALUE
FINISH
-> AGAIN
FINISH
-> INVLU
!
VSW(5): !FSTARTFILE
!
IF STUDENTSS=0 THEN START
FLAG = CHECKFILENAME(VALUE,15); !ANY FILE INCLUDING PD MEMBER
IF FLAG=0 THEN START
C_FSTARTFILE = VALUE
-> AGAIN
FINISH
-> INVLU
FINISH ELSE START
-> AGAIN
FINISH
!
VSW(6): !BSTARTFILE
!
IF STUDENTSS=0 THEN START
FLAG = CHECKFILENAME(VALUE,15); !ANY FILE INCLUDING PD MEMBER
IF FLAG=0 THEN START
C_BSTARTFILE = VALUE
-> AGAIN
FINISH
-> INVLU
FINISH ELSE START
-> AGAIN
FINISH
!
VSW(7): !PRELOADFILE
!
IF STUDENTSS=0 THEN START
FLAG = CHECKFILENAME(VALUE,15)
IF FLAG=0 THEN START
C_PRELOADFILE = VALUE
-> AGAIN
FINISH
-> INVLU
FINISH ELSE START
-> AGAIN
FINISH
!
VSW(8): !ACTIVEDIR
!
IF STUDENTSS=0 THEN START
FLAG = CHECKFILENAME(VALUE,5); !OWN FILE
IF FLAG # 0 THEN -> INVLU
C_MODDIR = SUBSTRING(VALUE,8,LENGTH(VALUE)); !REMOVE USERNAME IN ALL CASES
SSOWN_DIRDISCON = 1; !TELL LOADER TO REBUILD SEARCH LIST
FINISH
-> AGAIN
!
VSW(9): !REMOVEDIR
!
IF STUDENTSS=0 THEN START
RMSD(VALUE,FLAG); ! REMOVESEARCHDIR
IF FLAG # 0 THEN -> INVLU
SSOWN_DIRDISCON = 1; !TELL LOADER TO REBUILD SEARCH LIST
FINISH
-> AGAIN
!
VSW(10): !SEARCHDIR
!
IF STUDENTSS=0 THEN START
RMSD(VALUE,FLAG); ! REMOVESEARCHDIR IF ALREADY IN LIST
IF C_SEARCHDIRCOUNT=MAXSEARCHDIRCOUNT THEN START ; ! SEARCHDIR LIST FULL
FLAG = 314
-> INVLU
FINISH
SSOWN_DIRDISCON = 1; !TELL LOADER TO REBUILD SEARCH LIST
CONNECT(VALUE,0,0,0,RR,FLAG); !CONNECT TO CHECK TYPE
IF FLAG=0 AND RR_FILETYPE=SSOLDDIRFILETYPE THEN START
ADSD(VALUE); ! ADDSEARCHDIR
-> AGAIN
FINISH
IF FLAG=0 THEN FLAG = 267; !INVALID FILETYPE
-> INVLU
FINISH ELSE START
-> AGAIN
FINISH
!
VSW(11): !ARRAYDIAG FOR DIAGNOSTICS
!
IF STUDENTSS=0 THEN START
IF IVALUE>=0 THEN START
C_ARRAYDIAG = IVALUE
-> AGAIN
FINISH
-> INVLU
FINISH ELSE START
-> AGAIN
FINISH
!
VSW(12): !INITWORKSIZE
!
IF STUDENTSS=0 THEN START
IF 256<=IVALUE THEN START
C_INITWORKSIZE = IVALUE<<KSHIFT
-> AGAIN
FINISH
-> INVLU
FINISH ELSE START
-> AGAIN
FINISH
!
VSW(14): !ITINSIZE
!
IF STUDENTSS=0 THEN START
IF 16>=IVALUE>0 THEN START
C_ITINSIZE = IVALUE<<KSHIFT
-> AGAIN
FINISH
IF CHARNO(VALUE,LENGTH(VALUE))='B' START ; !SIZE IN BYTES - TEMP FOR TESTING
LENGTH(VALUE) = LENGTH(VALUE)-1; !REMOVE THE 'B'
C_ITINSIZE = PSTOI(VALUE)+64; !ALLOW FOR CONTROL RECORD
-> AGAIN
FINISH
-> INVLU
FINISH ELSE START
-> AGAIN
FINISH
!
VSW(15): !ITOUTSIZE
!
IF STUDENTSS=0 THEN START
IF 16>=IVALUE>0 THEN START
C_ITOUTSIZE = IVALUE<<KSHIFT
-> AGAIN
FINISH
IF CHARNO(VALUE,LENGTH(VALUE))='B' START ; !AS ABOVE - TEMP
LENGTH(VALUE) = LENGTH(VALUE)-1
C_ITOUTSIZE = PSTOI(VALUE)
-> AGAIN
FINISH
-> INVLU
FINISH ELSE START
-> AGAIN
FINISH
!
VSW(16): !CFAULTS
!
IF STUDENTSS=0 THEN START
IF CHARNO(VALUE,1) = '.' THEN START ; !DEVICE CODE
IF LENGTH(VALUE) > 15 THEN FLAG = 202; !INVALID PARAMETER
FINISH ELSE START
FLAG = CHECKFILENAME(VALUE,5); !OWN FILE
IF FLAG = 0 THEN VALUE = SSOWN_CURFNAME; !REMOVE OWNERNAME
FINISH
IF FLAG # 0 THEN -> INVLU
C_CFAULTS = VALUE
FINISH
-> AGAIN
!
VSW(17): !TERMINAL=N
!
IF STUDENTSS=0 THEN START
C_TERMINAL=IVALUE
FINISH ELSE START
SSOWN_SSTERMINALTYPE = IVALUE
FINISH
->AGAIN
INVLU:
SSOWN_SSFNAME = VALUE
IF FLAG = 0 THEN FLAG = 202; !INVALID PARAM UNLESS OTHERWISE STATED
PSYSMES(67,FLAG)
-> AGAIN
USEINFO: !NOW USE NEW OPTIONS - WHERE RELEVANT
IF STUDENTSS=0 THEN START
IF MODE = 3 THEN START
NEWGEN(TEMPOPTIONS,SSOWN_OPTIONSFILE,FLAG)
-> ERR IF FLAG # 0
USEOPTIONS
FINISH
FINISH
ERR:
IF FLAG # 0 THEN START
PSYSMES(67,FLAG)
IF STUDENTSS=0 THEN START
DESTROY(TEMPOPTIONS,OLDFLAG); !MUST LEAVE FLAG INTACT FOR SSOWN_RCODE
FINISH
FINISH ELSE FLAG = OLDFLAG
SSOWN_RCODE = FLAG; !SET RETURN FLAG
END ; !OF OPTION
!
!
EXTERNALROUTINE PARM(STRING (255) S)
! **** There should perhaps be a complete set of "inverse PARMs".
!
CONST LONG INTEGER FREEBIT = X'0008000000000000'
INTEGER J, FLAG
LONGINTEGER PAT
FLAG = 0
IF S = "?" START
PRINTSTRING("Parms set: ")
PRINTSTRING(PRINTPARMS(LONGINTEGER(ADDR(SSOWN_SSCOMREG(27)))))
NEWLINE
FINISH ELSE START
PAT = DEFAULTPARM !! FREEBIT
IF ""#S#"FREE" THEN START ; ! Test for "FREE" only needed
! during transition from default "FIXED" to default "FREE".
FLAG = 202
SETPAR(S)
CYCLE
S = SPAR(0); !GET NEXT PARAM
EXIT IF S=""; ! End of list.
J = 0
WHILE J<=MAXPARMS AND S#PARMS(J) CYCLE
J = J + 1
REPEAT
IF J<=MAXPARMS THEN START
PAT = PAT!(LONGONE<<J)
FLAG = 0
FINISH ELSE START
SSOWN_SSFNAME = S; !FOR ERROR MESSAGE
PSYSMES (60,202)
FINISH
REPEAT
FINISH
IF FLAG=0 THEN LONGINTEGER(ADDR(SSOWN_SSCOMREG(27))) = PAT !! FREEBIT
FINISH
SSOWN_RCODE = FLAG
END ; !OF PARM
!
!
!**************************************************************************
!
! DOPERMIT
!
!***************************************************************************
!
! This routine analyses the string PARAMS passed to it and determines the
! values of the parameters. The integer TYPE must either be 0 or 1 -
! This is used to indicate if the file is on-line or archived.
! 0 - Indicates that the file is on-line (disc file)
! 1 - Indicates that the file is archived.
! NOte that no other values of type should be used, as the values
! are used for offsetting in spar to get the right parameters.
! No check is made on the non zero value of TYPE.
ROUTINE DO PERMIT (INTEGER TYPE,
STRING (255) PARAMS)
ROUTINE PRPERM(INTEGER I)
!Routine used to print permissions. An integer is passed in and
! translated as follows:
! 1=read,2=write,4=execute - combined total is acceptable
OWNSTRING (3)ARRAY PTYPE(0:2)="R","W","E"
STRING (7)TP
INTEGER K
TP=""
FOR K=0,1,2 CYCLE
IF I&1=1 THEN TP=TP.PTYPE(K)
I=I>>1
REPEAT
WHILE LENGTH(TP)<3 CYCLE
TP=TP." "
REPEAT
PRINTSTRING(TP)
RETURN
END ; !OF PRPERM
CONSTINTEGER DISC FILE = 0; ! type = disc file
CONSTINTEGER TRUE=0, FALSE=1
CONSTBYTEINTEGERARRAY VMODE(0 : 4) = C
'R', 'W', 'E', 'P', 'D'; ! Valid modes
RECORD (DPERMF)DPERM
INTEGER ARRAY VSEEN (0:4); ! stores modes given
INTEGER I, J, K, CHAR, IMODE, FLAG, DFLAG, DD, MM, ADRPRM, N, NN, PRINT
STRING (63) TEMPLATE
STRING (31) MODE,QMODE,FILE
STRING (8) DATE, QDATE
STRING (6) USER, QUSER
STRING (3)D,M,Y
ADRPRM=ADDR(DPERM)
UCTRANSLATE (ADDR(PARAMS)+1,LENGTH(PARAMS))
IF TYPE = DISC FILE START ; ! Calculate filps template
IF PARAMS = "" THEN TEMPLATE = "FILE,USER,MODE" C
ELSE TEMPLATE = "FILE=.ALL,USER=.ALL,MODE="
FINISHELSESTART ; ! for archived files inc DATE
IF PARAMS = "" THEN TEMPLATE = "FILE,DATE,USER,MODE" C
ELSE TEMPLATE = "FILE=.ALL,DATE=,USER=.ALL,MODE="
FINISH
FILPS (TEMPLATE,PARAMS)
IF PARMAP = 0 START
FLAG = 263
-> ERR
FINISH
FILE = SPAR(1)
UNLESS "*"#FILE#".ALL" THEN FILE = ""; ! * or .ALL means 'all files',
! i.e., whole index permission.
QDATE=SPAR(2);QUSER=SPAR(3);QMODE=SPAR(4); !find the params
IF FILE = "" AND TYPE # DISC FILE START
! user has tried to give .ALL permission to his archived files. but
! This should not be allowed because any files restored will take on
! the EEP of the disc file index.
!However the permissions mode "?" is permissable
UNLESS QDATE="?" OR QUSER="?" OR QMODE="?" THEN FLAG = 342 AND ->ERR
!Cannot set all archived files permission
FINISH
IF TYPE#DISC FILE START
! In order to determine the permissions of an archived file, a
! special mode "?" has been set up. This mode can be the 2nd, 3rd or 4th
! parameter - ie APERMIT(file,,,?), APERMIT(file,,?) and APERMIT(file,?)
! are all permissable.
IF QDATE="?" OR QUSER="?" OR QMODE="?" START
PRINT=TRUE
DPERM=0
UNLESS FILE="" START ; !file="" means only whole index permissions
IF QDATE="?" THEN QDATE=""; !set to null for call on dpermission
!unless a call is made for a specific version of a file
DFLAG=DIRTOSS(X22{DPERMISSION}(UINFS(1),"",QDATE,SPAR(1),UINFI(1),20,ADRPRM))
UNLESS DFLAG=0 THEN FLAG=DFLAG AND -> ERR
IF DPERM_EEP=0 AND DPERM_PRMS(0)_USER="" THEN PRINT=FALSE C
AND -> PART2
PRINTSTRING("Access permissions:")
UNLESS DPERM_EEP=0 START
PRINTSTRING(" All Users : ")
PRPERM(DPERM_EEP)
FINISH
NEWLINE
IF DPERM_PRMS(0)_USER="" THEN -> PART2
FOR J=0,1,15 CYCLE
IF DPERM_PRMS(J)_USER="" THEN EXIT
PRINTSTRING(DPERM_PRMS(J)_USER);SPACE
PRPERM(DPERM_PRMS(J)_UPRM)
SPACES(4)
K=J+1
IF (K//5)*5=K THEN NEWLINE
REPEAT
NEWLINE
FINISHELSE PRINT=FALSE
PART2:
DPERM=0
DFLAG=DIRTOSS(X22{DPERMISSION}(UINFS(1),UINFS(1),"","",UINFI(1),8,ADRPRM))
UNLESS DFLAG=0 THEN FLAG=DFLAG AND ->ERR
! The all files permissions for archived files are the same as
! those for online files
IF DPERM_PRMS(0)_USER="" START
IF PRINT=FALSE THEN PRINTSTRING("Access permissions: None") ANDRETURN
FINISHELSE PRINTSTRING("Permissions for all files:");NEWLINE
FOR N=0,1,15 CYCLE
IF DPERM_PRMS(N)_USER="" THEN EXIT
PRINTSTRING(DPERM_PRMS(N)_USER);SPACE
PRPERM(DPERM_PRMS(N)_UPRM);SPACES(4)
NN=N+1
IF (NN//5)*5=NN THEN NEWLINE; !print five permissions to a line
REPEAT
RETURN
FINISH
FINISH
! Now get the date if the file is archived.
IF TYPE # DISC FILE START
DATE = SPAR(2)
UNLESS (LENGTH(DATE)=8 AND DATE->D.("/").M.("/").Y) OR DATE="" START
SETFNAME(DATE)
FLAG=202
-> ERR
FINISH
UNLESS DATE="" START
DD=PSTOI(D)
MM=PSTOI(M)
UNLESS 0<DD<32 AND 0<MM<13 START
SETFNAME(DATE)
FLAG=202
-> ERR
FINISH
FINISH
FINISHELSEC
DATE = ""
! Now start using offsets to access the parameters. Note we "add" one
! to the parameters if the TYPE is archived, as there is an extra
! parameter supplied.
IF SPAR(2 + TYPE) # "." THEN USER = SPAR(2 + TYPE) ELSEC
USER = SSOWN_SSOWNER
IF USER="=" THEN USER=UINFS(1); !short form for self
IF USER="??????" OR USER="*" OR USER=".ALL" THEN USER="" ELSE START
IF LENGTH(USER)#6 AND USER#"" THEN START
FLAG = 201; ! Invalid user name
SSOWN_SSFNAME=USER
-> ERR
FINISH
IF USER=SSOWN_SSOWNER START
IF TYPE#DISC FILE START
IF FILE="" THEN FLAG=340 ELSE FLAG=343
-> ERR
!340 = cannot set own permission for all files
!343 = cannot set self permission for archived files
FINISH
FINISH
FINISH
! FILE must now be a filename or a null string (meaning 'whole index').
! USER must be a user name or a group or a null string (meaning 'all users').
! Setting own permission to all files has been weeded out already.
MODE = SPAR(3 + TYPE)
IF MODE="" OR MODE="A" OR MODE=".ALL" OR MODE="*" START
IF USER=SSOWN_SSOWNER OR MODE#""#FILE THEN MODE="WER" ELSE MODE = "ER"
FINISH
! Now analyse the modes given. Ensure that there are no duplications
! no illegal calls omisuse of the modes. (e.g. C and N not allowed to own files)
IMODE = 0
IF MODE="N" OR MODE="C" THEN START
IF USER=SSOWN_SSOWNER THEN START
FLAG = 341; !Cannot remove all own permissions
-> ERR
FINISH ELSE IF USER="" THEN START
IF FILE="" THEN MODE = "C" ELSE MODE = "N"
FINISH
IF MODE="C" THEN IMODE = -1
FINISH ELSE START
IF MODE="P" THEN MODE = "PER" C
ELSE IF MODE="D" THEN MODE = "DWER"
FOR J=0,1,4 CYCLE
VSEEN (J) = 0
REPEAT
FOR I=LENGTH(MODE),-1,1 CYCLE
CHAR = CHARNO (MODE,I)
J = 0
WHILE J<5 AND (VMODE(J)#CHAR OR VSEEN(J)#0) CYCLE
J = J + 1
REPEAT
IF J>=3 THEN START
IF J>4 C
OR USER#SSOWN_SSOWNER C
THEN START
FLAG = 332; !Invalid access permission
-> ERR
FINISH ELSE VSEEN (7-J) = -1
FINISH
VSEEN (J) = -1
IF J<4 THEN IMODE = IMODE ! (1<<J)
REPEAT
IF IMODE&2#0 AND FILE="" THEN START ; ! Can't set W for all files.
FLAG = 332; !Invalid access permission
-> ERR
FINISH
FINISH
IF FILE=""=USER THEN USER = "??????"
FLAG = 0
PERMIT INNER (FILE, DATE, USER, TYPE, IMODE, FLAG); ! Permit the file
ERR:
IF FLAG#0 START
IF TYPE=DISC FILE THEN PSYSMES(32, FLAG) ELSE C
PRINTSTRING("APERMIT fails - ".FAILUREMESSAGE(FLAG))
FINISH
END ; ! DO PERMIT
EXTERNALROUTINE ZPERMIT (STRING (255) PARAM)
! = the old ZPERMIT - for online files
CONSTINTEGER DISC FILE = 0
DO PERMIT (DISC FILE, PARAM)
END ; !OF ZPERMIT
EXTERNALROUTINE APERMIT (STRING (255) PARAM)
! = the old ZPERMIT - for archived files
CONSTINTEGER ARCHIVED FILE = 1
DO PERMIT (ARCHIVED FILE, PARAM)
END ; !OF APERMIT
EXTERNALROUTINE REMOVE(STRING (255) S)
STRING (31) OBJFILE
INTEGER FLAG
FLAG = 0
SETPAR(S)
CYCLE
OBJFILE = SPAR(0)
-> ERR IF OBJFILE = ""; !END OF LIST
MODDIRFILE(2,SSOWN_AVD,"",OBJFILE,0,0,0,FLAG)
IF FLAG # 0 THEN PSYSMES(36,FLAG)
REPEAT
ERR:
SSOWN_RCODE = FLAG
END ; !OF REMOVE
EXTERNALROUTINE REMOVEMACRO(STRING (255)S)
REMOVE(S)
END ; !OF REMOVEMACRO
EXTERNALROUTINE ZRENAME(STRING (255) S)
SYSTEMROUTINESPEC RENAME(STRING (31) OLD, NEW, C
INTEGERNAME FLAG)
INTEGER FLAG, PD
STRING (31) OLD, NEW, OLDMEMBER, NEWMEMBER
STRING (15) TEMPLATE
TEMPLATE = "OLDNAME,NEWNAME"
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS (TEMPLATE,S)
IF PARMAP#3 THEN START ; ! WRONG NO OF PARAMS
FLAG = 263
-> ERR
FINISH
OLD = SPAR(1); !OLD NAME
NEW = SPAR(2)
IF OLD -> OLD.("_").OLDMEMBER THEN PD = 1 ELSE PD = 0
IF PD = 1 START
UNLESS NEW -> NEW.("_").NEWMEMBER AND NEW=OLD THEN START
! INCONSISTENT PARAMETERS
FLAG = 297
-> ERR
FINISH
MODPDFILE(3,OLD,OLDMEMBER,NEWMEMBER,FLAG)
FINISH ELSE RENAME(OLD,NEW,FLAG)
ERR:
SSOWN_RCODE = FLAG
IF FLAG # 0 THEN PSYSMES(38,FLAG)
END ; !OF RENAME
!
EXTERNALINTEGERFN RETURNCODE
RESULT = SSOWN_RCODE
END ; !OF RETURNCODE
EXTERNALROUTINE SEND(STRING (255) S)
STRING (31) FILE, DEVICE
INTEGER FLAG
STRING (23) TEMPLATE
TEMPLATE = "FILE=T#LIST,DEVICE=.LP"
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS (TEMPLATE,S)
IF PARMAP>3 THEN START
FLAG=263
->ERR
FINISH
FILE = SPAR(1); !FILENAME
IF FILE = "" THEN FILE = "T#LIST"; !DEFAULT FILENAME
DEVICE = SPAR(2)
IF DEVICE = "" THEN DEVICE = ".LP"
! SIMPLE TEST FOR INVALID DEVICE CODE
IF CHARNO(DEVICE,1)#'.' THEN START
FLAG = 264
-> ERR
FINISH
SENDFILE(FILE,DEVICE,"",0,0,FLAG)
ERR:
SSOWN_RCODE = FLAG
IF FLAG # 0 THEN PSYSMES(40,FLAG)
END ; !OF SEND
EXTERNALROUTINE SETRETURNCODE(INTEGER I)
SSOWN_RCODE = I
END ; !OF SETRETURNCODE
EXTERNALROUTINE ZSTOP(STRING (255) S)
INTEGER I
IF STUDENTSS#0 THEN START
ROUTINE MONITORSESSION
CONSTINTEGER RECLENGTH = 32
RECORDFORMAT MF(STRING (6) USER, BYTEINTEGER S1, C
INTEGER PDT, CPUMILLSECS, PAGETURNS, ELSECS, S2, S3)
RECORD (MF) NAME M
INTEGERNAME COUNT
INTEGER FLAG, CT, MAX, HOLDCOUNT, POS
RECORD (RF) RR
SSOWN_ALLCONNECT = 1; !To ensure we can connect monitor file
CONNECT(SSOWN_SESSMONFILE,11,0,0,RR,FLAG); !Connect WRITE and other users
IF FLAG # 0 THEN RETURN
FLAG = FINDFN (SSOWN_CURFILE, POS)
MAX = (SSOWN_CONF(POS)_SIZE-36)//RECLENGTH; !Maximum of records it can hold
COUNT == INTEGER(RR_CONAD+32)
*INCT_(COUNT)
*ST_HOLDCOUNT
IF HOLDCOUNT<MAX THEN START
M == RECORD(RR_CONAD+36+HOLDCOUNT*RECLENGTH)
M = 0; !CLEAR IT OUT IN CASE ITS BEEN USED BEFORE
M_USER = SSOWN_SSOWNER
M_PDT = CURRENT PACKED DT
M_CPUMILLSECS = INT(CPUTIME*1000); !CPU MILLISECS
M_PAGETURNS = PAGETURNS
CT = SECSFRMN-SSOWN_STARTSECS
IF CT < 0 THEN CT = CT+86400; !SECS PER DAY - BECAUSE IT WRAPPED AROUND
M_ELSECS = CT
FINISH
IF NEWCONNECT#0 THEN START
DISCONNECT (LAST, FLAG)
FINISH
END ; !MONITORSESSION
FINISH ELSE START
ROUTINE MONITORSESSION
END
FINISH
METER("")
DESTROY("T#LIST",I); !IGNORE FLAG
IF SSOWN_SSREASON = BATCHREASON THEN BATCHSTOP(0); !SPECIAL ACTION FOR BATCH JOBS
PRINTSTRING("Logged-off")
NEWLINES(1)
CLOSEJOURNAL; !CLOSE JOURNAL FILE - IF THERE IS ONE
IF STUDENTSS#0 THEN START
MONITORSESSION; ! Put info in course supervisor's log.
FINISH
SSOWN_STOPPING = 1; ! Checked by contingency handling to avoid problems
! with contingencies during process close-down.
I = -1; ! Makes CONSOLE(9,..) await completion of REQUESTOUTPUT.
CONSOLE(9,I,I); !TO CLEAR OUT ALL TT OUTPUT
HALT
END ; !OF STOP
!
EXTERNALROUTINE USERS(STRING (255) S)
INTEGER PENCE
PRINTSTRING("Users =")
WRITE(NUSERS-SYSPROCS,1)
NEWLINE
IF FUNDS ON#0 THEN START
IF SCARCEWORD&x'FF'>=SCARCEWORD>>24 THENSTART
! INTERACTIVE USERS > SCARCITY LIMIT
SSOWN_SCARCITYFOUND=1
PRINTSTRING("**Resources are Scarce.")
PENCE=UINFI(20)
IF PENCE=0 START
PRINTSTRING(" Funds left : 0.00 You are liable to pre-emption.")
FINISHELSESTART
PRINTSTRING("Funds left : ")
PRINT(PENCE/100,1,2)
FINISH
NEWLINE
FINISH
FINISH
SSOWN_RCODE = 0
END ; !OF USERS
!
!
! - END OF BCOM TEXT ]
!
! [ START OF PRINT TEXT -
!NEW ASSEMBLER WRITE ROUTINE ADDED RRM 29.3.78
LONGINTEGERFNSPEC LINT(LONGLONGREAL X)
!*
!*
SYSTEMROUTINE READ(INTEGER TYPEBND,ADR)
!***********************************************************************
!* THIS ROUTINE IS THE IMP IMPLICITLY SPECIFIED ROUTINE WITH A *
!* %NAME PARAMETER. TYPEBND AND ADR ARE A 64 BIT DESCRIPTOR TO *
!* THE ACTUAL PARAMETER. THE BND FIELD HAS THE TYPE CODE IN IT *
!* (=1 FOR INTEGER =2 FOR REAL). FOR %SHORT %INTEGER, THE *
!* PARAMETER WILL BE A STRING DESCRIPTOR OF LENGTH 2. *
!* *
!* THE METHOD USED IS SIMPLE REPEATED MULTIPLICATION USING LONG *
!* REAL VARIABLES. SOME ROUNDING ERRORS ARE INTRODUCED WHICH *
!* COULD BE AVOIDED BY USING PACKED DECIMAL INSTNS WITH NECESSARY*
!* SCALING. *
!***********************************************************************
INTEGER TYPE,PREC,FLAG,CURSYM; ! FLAG= 0FOR'-',1 FOR '+'
INTEGER IVALUE,PARTYPE
LONGINTEGER LIVALUE
LONGLONGREAL RWORK,SCALE
SWITCH RL(5:7)
FLAG=1; TYPE=0
IF TYPEBND=X'58000002' THEN START
PARTYPE = 1
PREC = 4
FINISH ELSE START
PARTYPE = TYPEBND&7
PREC = (TYPEBND>>27)&7
FINISH
IF TYPEBND=X'20000001' THEN TYPEBND = X'58000002'
CURSYM = NEXT SYMBOL; ! CARE NOT TO READ TERMINATOR
! NOW IGNORE LEADING SPACES
WHILE CURSYM=' ' OR CURSYM=NL CYCLE
SKIP SYMBOL
CURSYM=NEXT SYMBOL
REPEAT
IF CURSYM=X'19' THEN SIGNALEVENT 9,1
! RECORD INITIAL MINUS
IF CURSYM='-' THEN FLAG=0 AND CURSYM='+'
! MOVE OVER SIGN ONCE IT HAS
! BEEN RECORDED IN FLAG
IF CURSYM='+' THEN START
CYCLE
SKIP SYMBOL
CURSYM=NEXT SYMBOL
REPEAT UNTIL CURSYM#' '
FINISH
IF '0'<=CURSYM AND CURSYM<='9' THEN START
RWORK=CURSYM-'0'; ! KEEP TOTAL IN RWORK
TYPE=1; ! VALID DIGIT
CYCLE
SKIP SYMBOL
CURSYM=NEXT SYMBOL
EXIT UNLESS '0'<=CURSYM AND CURSYM<='9'
RWORK=R'41A00000000000000000000000000000'*RWORK C
+(CURSYM-'0');! CONTINUE EVALUATING
REPEAT
FINISH ELSE RWORK=0
IF CURSYM='.' AND PARTYPE=2 THEN START
SCALE=R'41A00000000000000000000000000000'
CYCLE
SKIP SYMBOL
CURSYM=NEXT SYMBOL
EXIT UNLESS '0'<=CURSYM AND CURSYM<='9'
TYPE=1
RWORK=RWORK+(CURSYM-'0')/SCALE
SCALE=R'41A00000000000000000000000000000'*SCALE
REPEAT
FINISH
!
! THE VALUE HAS NOW BEEN READ INTO RWORK. THERE MIGHT BE AN EXPONENT
! E.G. '1.7@10 ' IS VALID DATA FOR READ
!
IF (CURSYM='@' OR CURSYM='&') AND PARTYPE=2 THEN START
IF TYPE=0 THEN TYPE=1 AND RWORK=1
SKIP SYMBOL; ! MOVE PAST THE '@'
READ(X'29000001',ADDR(IVALUE));! RECURSIVE CALL TO FIND EXPONENT
IF IVALUE=-99 THEN RWORK=0 ELSE C
RWORK=RWORK*R'41A00000000000000000000000000000'**IVALUE
FINISH
SIGNALEVENT 4,1 IF TYPE=0; ! NO VALID DIGIT FOUND
!
! KNOCK NUMBER INTO RIGHT FORM
!
IF PARTYPE=1 THEN START
IF PREC = 6 THEN START
IF FLAG=0 THEN RWORK = - RWORK
IF RWORK>LONGLONGREAL(ADDR(LONGINTLIM(0))) C
OR RWORK<LONGLONGREAL(ADDR(LONGINTLIM(4))) C
THEN SIGNAL EVENT 1,1
LIVALUE = LINT(RWORK)
*LSD_LIVALUE
*ST_(TYPEBND)
RETURN
FINISH
IF FLAG=0 THEN RWORK=-RWORK
IF RWORK-IMAX>=0.5 C
OR RWORK+IMAX<-1.5 C
THEN SIGNAL EVENT 1,1
IVALUE= INT(RWORK)
! If %HALF %INTEGERs were signed, we would have to include
! the following code to recognise 'capacity exceeded':
! %IF PREC=4 %THEN %START
! %IF X'0001FFFF'#IVALUE>>15#0 %THEN %START
! ! Force 'capacity exceeded':
! IVALUE = IVALUE ! X'FFFF0000'
! %FINISH %ELSE %START
! ! Avoid 'capacity exceeded' if it's negative:
! IVALUE = IVALUE & X'0000FFFF'
! %FINISH
! %FINISH
!
*LSS_IVALUE
*ST_(TYPEBND)
RETURN
FINISH
IF PARTYPE#2 THEN PSYSMES (X'80000000',338)
IF FLAG=0 THEN RWORK=-RWORK
IF PREC<5 THEN PREC = 5
-> RL(PREC)
RL(5): ! 32 BIT REAL
*LSD_=X'7F'; *USH_=25
*OR_=1; *USH_=31; ! ACC=X'7F00000080000000'
*AND_RWORK; *RAD_RWORK; ! SOFTWARE ROUND
*STUH_(TYPEBND)
RETURN
RL(6): ! 64 BIT REAL
*LSD_=X'7F'; *USH_=56; *AND_RWORK
*SLSD_=1; *USH_=55; *AND_RWORK+8
*LUH_TOS ; *RAD_RWORK; ! SOFTWARE ROUND
*STUH_(TYPEBND)
RETURN
RL(7): ! 128 BIT REAL
*LSQ_RWORK
*ST_(TYPEBND)
!
! %MONITOR (N) == FORCE FAULT NO N
! N=16 REAL INSTEAD OF INTEGER IN DATA
! N=14 SYMBOL IN DATA
!
END
CONSTLONGREAL DZ=0
SYSTEMLONGREALFN FRACPT(LONGREAL X)
!***********************************************************************
!* RETURNS (X-INTPT(X)) AS THE RESULT *
!***********************************************************************
INTEGER EXP
LONG REAL IPT
EXP = (BYTEINTEGER(ADDR(X))&X'7F') - 64
IF EXP>=14 THEN RESULT = 0.0 C
ELSE START
IF EXP>0 THEN START
LONGINTEGER(ADDR(IPT)) = C
LONGINTEGER(ADDR(X)) & (¬((LENGTHENI(-1))>>(8+4*EXP)))
X = X - IPT
FINISH
IF X>=0.0 THEN RESULT = X ELSE RESULT = X + 1.0
FINISH
END
ROUTINESPEC PRINTFL(LONGREAL X,INTEGER N)
SYSTEMROUTINE PRINT(LONGREAL X,INTEGER N,M)
!***********************************************************************
!* PRINTS A REAL NUMBER (X) ALLOWING N PLACES BEFORE THE DECIMAL *
!* POINT AND M PLACES AFTER.IT REQUIRES (M+N+2) PRINT PLACES *
!* UNLESS (M=0) WHEN (N+1) PLACES ARE REQUIRED. *
!* *
!* A LITTLE CARE IS NEEDED TO AVOID UNNECESSARY LOSS OF ACCURACY *
!* AND TO AVOID OVERFLOW WHEN DEALING WITH VERY LARGE NUMBERS *
!***********************************************************************
LONGREAL ROUND
LONGLONGREAL Y,Z
STRING (127)S
INTEGER I,J,L,SIGN,SPTR
M=M&63; ! DEAL WITH STUPID PARAMS
IF N<0 THEN N=1 ELSE START
IF N>31 THEN START
SPACES (N-31)
N = 31
FINISH
FINISH
X=X+DZ; ! NORMALISE
SIGN=' '; ! '+' IMPLIED
IF X<0 THEN SIGN='-'
Y=MOD(X); ! ALL WORK DONE WITH Y
IF Y>1@15 OR N=0 THEN START ; ! MEANINGLESS FIGURES GENERATED
IF N>M THEN M=N; ! FOR FIXED POINT PRINTING
PRINT FL(X,M); ! OF ENORMOUS NUMBERS
RETURN ; ! SO PRINT IN FLOATING FORM
FINISH
IF M<=20 THEN ROUND=1/(2*TENPOWERS(M)) ELSE C
ROUND= 0.5/R'41A00000000000000000000000000000'**M;! ROUNDING FACTOR
Y=Y+ROUND
->FASTPATH IF N+M<=16 AND Y<TENPOWERS(N)
I=0;Z=1
CYCLE ; ! COUNT LEADING PLACES
I=I+1;Z=10*Z; ! NO DANGER OF OVERFLOW HERE
REPEAT UNTIL Z>Y
SPTR=1
WHILE SPTR<=N-I CYCLE
CHARNO(S,SPTR)=' '
SPTR=SPTR+1
REPEAT
CHARNO(S,SPTR)=SIGN
SPTR=SPTR+1
J=I-1; Z=R'41A00000000000000000000000000000'**J
CYCLE
CYCLE
L=INT PT(Y/Z); ! OBTAIN NEXT DIGIT
Y=Y-L*Z;Z=Z/10; ! AND REDUCE TOTAL
CHARNO(S,SPTR)=L+'0'
SPTR=SPTR+1
J=J-1
REPEAT UNTIL J<0
IF M=0 THEN EXIT ; ! NO DECIMAL PART TO BE O/P
CHARNO(S,SPTR)='.'
SPTR=SPTR+1
J=M-1; Z=R'41A00000000000000000000000000000'**(J-1)
M=0
Y=10*Y*Z
REPEAT
LENGTH(S)=SPTR-1
-> OPUT
FASTPATH: ! USE SUPK WITHOUT SCALING
L=M+N+2; ! NO OF BYTES TO BE OPUT
IF M=0 THEN L=L-1
Y=Y*TENPOWERS(M); ! CONVERT TO INTEGER
J=N-1
I=30-M-N; ! FOR DECIMAL SHIFT
*LSQ_Y
*FIX_B
*MYB_4
*ISH_B
*CDEC_0
*LD_S
*LB_L
*MVL_L =1; ! LENGTH INTO STRING
*DSH_I
*CPB_B ; ! SET CC=0 FOR SUPK
*LDB_J
*JAT_11,6; ! TILL SUPK FIXED!
*SUPK_L =DR ,0,32; ! UNPACK WITH LEADING SPACES
*JCC_7,<DESSTACKED>
*STD_TOS ; ! FOR SIGN INSERTION
DESSTACKED:
*LDB_2
*SUPK_L =1,0,32
*SUPK_L =1,0,48; ! FORCE ZERO BEFORE DP
*SLD_TOS
*LB_SIGN
*STB_(DR ); ! INSERT SIGN
*LB_46; ! ISO DECIMAL POINT
*LD_TOS
*LDB_M
*JAT_11,<NOFRPART>; ! INTEGER PRINTING
*STB_(DR )
*INCA_1
*SUPK_L =DR ,0,48; ! ZEROFILL
NOFRPART:
*LDB_(S)
*INCA_1
*ANDS_L =DR ,0,63; ! FORCE ISO ZONE CODES
OPUT:
J=IOCP(15,ADDR(S))
END ; ! OF ROUTINE PRINT
!8
SYSTEMROUTINE WRITE(INTEGER VALUE,PLACES)
STRING (16)S
INTEGER D0,D1,D2,D3,L
IF PLACES>14 THEN START
SPACES (PLACES-14)
PLACES = 14
FINISH
*LSS_VALUE; *CDEC_0
! Acc is now 64 bits, holding the value as a packed decimal
! number, i.e. 15 decimal digits coded in binary in 4 bits
! each, followed by a 'sign' quartet at the least significant
! end. The largest possible absolute value would be 2**31
! which is 2,147,483,648. Hence at least the first five
! quartets must be zero.
*LD_S; *INCA_1; *STD_TOS
! *LD_S gets a byte vector descriptor to the whole of S -
! the bound will be 17 and the address will point to the
! 'length byte'. So DR (and TOS) now point to the text
! field of the IMP string.
*CPB_B ; ! SET CC=0
*SUPK_L =15,0,32; ! UNPACK & SPACE FILL
! Acc is now zero except for the sign quartet which is
! unchanged at the least significant end. The first
! 15 text bytes of S now have the value in unpacked
! decimal format (unsigned). CC will be zero if the
! value is zero, and non-zero otherwise. The unpacked
! decimal string in S will have no leading zeros: leading
! bytes will be X'20' (ISO space) - but the digits will
! be in EBCDIC form, i.e. X'Fn'. If the number is zero,
! then all fifteen bytes will be spaces. If it is not, then
! a descriptor will have been planted on TOS which points
! to the byte immediately preceding the first digit (i.e.,
! to the last of the leading spaces).
!
! D2 will get a (zero length) descriptor to the byte immediately
! after the fifteenth digit - i.e., to the last byte of S.
*STD_D2; *JCC_8,<WASZERO>
!
! If the value was not zero -
! copy the descriptor-to-last-leading-space into D0:
*LD_TOS ; *STD_D0; ! FOR SIGN INSERTION
! restore the descriptor to the first byte of text:
*LD_TOS
! convert digits to ISO:
! (this uses the MASK to clear the top two bits of each byte,
! thus leaving the spaces - X'20' - unchanged, but coverting
! EBCDIC digits X'Fn' to their ISO equivalents X'3n'.)
*MVL_L =15,63,0; ! FORCE ISO ZONE CODES
IF VALUE<0 THEN BYTEINTEGER(D1)='-'; ! D0 is a descriptor
! to the appropriate place for a sign, and D1 is the
! address word of that descriptor.
L=D3-D1; ! L is the number of bytes occupied by significant
! digits with a leading space or sign.
OUT: IF PLACES>=L THEN L=PLACES+1
! D3=D3-L-1
! BYTEINTEGER(D3)=L
! D3=IOCP(15,D3)
! Since we know the characters are all valid, we can use IOCP
! entry point 19 to avoid the checking involved in IOCP 15
! (which is PRINT STRING, i.e. simulating repeated PRINT
! SYMBOLs).
D3 = D3 - L
D2 = L
! D2, D3 are a descriptor to the stuff to be printed. IOCP
! does not mind that the TYPE fields are zero.
D3 = IOCP (19,ADDR(D2))
RETURN
WASZERO:
BYTEINTEGER(D3-1)='0'
L=2; -> OUT
END ; !OF WRITE
!*
SYSTEMROUTINE PRINTFL(LONGREAL XX,INTEGER N)
!***********************************************************************
!* PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE *
!* DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS. *
!* CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X *
!***********************************************************************
STRING (47)S
LONGLONGREAL ROUND,FACTOR,LB,UB,X,Y
INTEGER COUNT,INC,SIGN,L,J
N=N&31
IF N<=20 THEN Y=TENPOWERS(N) ELSE C
Y=TENPOWERS(20)*TENPOWERS(N-20)
ROUND=R'41100000000000000000000000000000'/(2*Y)
LB=1-ROUND; UB=10-ROUND
SIGN=' '
X=XX+DZ; ! NORMALISE
IF X=0 THEN COUNT=-99 ELSE START
IF X<0 THEN X=-X AND SIGN='-'
INC=1; COUNT=0
FACTOR=R'4019999999999999999999999999999A'
IF X<=1 THEN FACTOR=10 AND INC=-1
! FORCE INTO RANGE 1->10
WHILE X<LB OR X>=UB CYCLE
X=X*FACTOR; COUNT=COUNT+INC
REPEAT
FINISH
X=X+ROUND
IF N>16 THEN START ; ! TOO BIG FOR CDEC WITHOUT SCALING
LENGTH(S)=N+4
CHARNO(S,1)=SIGN
L=INTPT(X)
CHARNO(S,2)=L+'0'
CHARNO(S,3)='.'
J=1
WHILE J<=N CYCLE
X=(X-L)*10
L=INTPT(X)
CHARNO(S,J+3)=L+'0'
J=J+1
REPEAT
FINISH ELSE START
X=X*Y
J=30-N
*LSQ_X
*FIX_B
*MYB_4
*ISH_B ; ! NOCHECKING NEEDED AS N LIMITED
*CDEC_0; ! GIVES 128 BIT DECIMAL N0
*LB_N
*ADB_4
*LD_S
*MVL_L =1; ! LENGTH INTO STRING
*DSH_J
*LB_SIGN
*MVL_L =1; ! SIGN INTO STRING
*SUPK_L =1,0,48; ! FIRST DIGIT INTO STRING
*MVL_L =1,0,46; ! DOT INTO STRING
*LDB_N
*SUPK_L =DR ,0,48; ! UNPACK FR PT &ZEROFILL
*LDB_(S)
*INCA_1
*ANDS_L =DR ,0,63; ! FORCE ISO ZONE CODES
FINISH
CHARNO(S,N+4)='@'
J=IOCP(15,ADDR(S))
WRITE(COUNT,2)
END ; ! OF ROUTINE PRINTFL
SYSTEMROUTINE FPRINTFL(LONGREAL XX,INTEGER N,TYPE)
!***********************************************************************
!* PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE *
!* DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS. *
!* CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X *
!***********************************************************************
!
LONGREAL ROUND,FACTOR,LB,UB,X,Y
INTEGER COUNT,INC,SIGN,L,J
ROUND=0.5/R'41A0000000000000'**N;! TO ROUND SCALED NO
LB=1-ROUND; UB=10-ROUND
SIGN=' '
X=XX+DZ; ! NORMALISE
Y=X
IF X=0 THEN COUNT=-99 ELSE START
IF X<0 THEN X=-X AND SIGN='-'
INC=1; COUNT=0; FACTOR=R'401999999999999A'
IF X<=1 THEN FACTOR=10 AND INC=-1
! FORCE INTO RANGE 1->10
WHILE X<LB OR X>=UB CYCLE
X=X*FACTOR; COUNT=COUNT+INC
REPEAT
FINISH
X=X+ROUND
PRINTSYMBOL(SIGN)
L=INTPT(X)
PRINTSYMBOL(L+'0')
PRINTSYMBOL('.')
J=1
WHILE J<=N CYCLE
X=(X-L)*10
L=INTPT(X)
PRINTSYMBOL(L+'0')
J=J+1
REPEAT
IF TYPE=1 THEN PRINTSTRING("E") ELSE PRINTSTRING("D")
WRITE(COUNT,2)
END ; ! OF ROUTINE PRINTFL
!
!
!
!
! THREE BODIES ONLY USED IF INTRINSICS PASSED AS RT PARAMETERS
!
SYSTEMINTEGERFN INT(LONGREAL X)
RESULT =INTPT(X+0.5)
END
INTEGERFN FIX(LONGREAL X)
RESULT =INTPT(X)
END
SYSTEMINTEGERFN INTPT(LONGREAL X)
RESULT =FIX(X)
END
!
EXTERNALLONGINTEGERFN LINTPT ALIAS "S#LINTPT"(LONGLONGREAL X)
LONGINTEGER WORK
*LSQ_X
*RCP_R'50800000000000000000000000000000'
*JCC_10,<FAIL>
*RRSB_0
*RCP_R'50800000000000000000000000000000'
*JCC_2,<FAIL>
*LSQ_X
*RAD_R'51880000000000000000000000000000'
*STUH_WORK
*USH_-44
*AND_X'FFF'
*ST_B
*L_WORK
*USH_12
*NEQ_X'8000000000000000'
*OR_B
*EXIT_-64
FAIL:SIGNAL EVENT 1,1
END ; ! OF LINTPT
!
!
EXTERNALLONGINTEGERFN LINT ALIAS "S#LINT"(LONGLONGREAL X)
LONGINTEGER WORK
*LSQ_X
*RAD_R'40800000000000000000000000000000'
*RCP_R'50800000000000000000000000000000'
*JCC_10,<FAIL>
*ST_X
*RRSB_0
*RCP_R'50800000000000000000000000000000'
*JCC_2,<FAIL>
*LSQ_X
*RAD_R'51880000000000000000000000000000'
*STUH_WORK
*USH_-44
*AND_X'FFF'
*ST_B
*L_WORK
*USH_12
*NEQ_X'8000000000000000'
*OR_B
*EXIT_-64
FAIL:SIGNAL EVENT 1,1
END ; ! OF LINT
!
! - END OF PRINT TEXT ]
!
! [ START OF IOCP TEXT -
!*
!*
SYSTEMINTEGERFN IOCP(INTEGER EP, PARM)
CONSTINTEGER MAXEP = 27
CONST INTEGER ARRAY XSP (0:7) = C
X'FFFFFFDF', X'00000000', X'00000000', X'00000001',
X'FFFFFFFF', X'FFFFFFFF', X'FFFFFFFF', X'FFFFFFFF'
! The bits in XSP correspond to the bytes in CHTOSYM. For each I in
! the range 0 to 255, if CHTOSYM(I)#I or CHTOSYM(I)=0 or CHTOSYM(I)=NL,
! then XSP bit I will be one, and otherwise bit I will be zero.
! It is vital that, if CHTOSYM is changed, the corresponding changes
! should be made to XSP. Accordingly, the code used to generate
! XSP is appended as a comment:
! **** **** **** **** **** **** **** **** **** **** **** ****
! **** %INTEGER I, S
! **** %INTEGER %ARRAY XSP (0:7)
! **** %ROUTINE PRHEX(%INTEGER VALUE, PLACES)
! **** %CONST %BYTE %INTEGER %ARRAY HEX (0:15) = '0','1','2','3','4', %C
! **** '5','6','7','8','9','A','B','C','D','E','F'
! **** %INTEGER I
! **** %FOR I=PLACES<<2-4,-4,0 %CYCLE
! **** PRINT SYMBOL(HEX(VALUE>>I&15))
! **** %REPEAT
! **** %END
! **** %ROUTINE SET BIT (%INTEGER N)
! **** %INTEGER BNDX
! **** BNDX = N >> 5
! **** XSP (BNDX) = XSP(BNDX) ! (1<<(31-(N&31)))
! **** %RETURN
! **** %END
! **** %FOR I=0,1,7 %CYCLE
! **** XSP (I) = 0
! **** %REPEAT
! **** SET BIT (0)
! **** %FOR I=255,-1,1 %CYCLE
! **** S = CHTOSYM (I)
! **** %UNLESS I=S#NL %THEN SET BIT (I)
! **** %REPEAT
! **** PRINT STRING ("%CONST %INTEGER %ARRAY XSP (0:7) = ")
! **** %FOR I=0,1,7 %CYCLE
! **** PRINT STRING ("X'")
! **** PRHEX (XSP(I),8)
! **** PRINT SYMBOL ('''')
! **** %IF I<7 %THEN PRINT STRING (", ") %ELSE NEWLINE
! **** %REPEAT
! **** **** **** **** **** **** **** **** **** **** **** ****
SWITCH SW (0 : 2*MAXEP)
! %SWITCH AUXSW (1:MAXEP) not needed now SW is declared up to 2*MAXEP.
INTEGER TOP, C, FLAG, HOLD, LEN, AFD, RES, I, FROM, TO
INTEGER TRTAD, AEP6S, EP6SEND, SENDNL, CHAD, CHS LEFT
! %INTEGER INFEND
INTEGER SAVEOUTDSNUM, MCICNTRL, NEXTRES, ACURREC, READING
INTEGER PART AD, PART LEN, RESIDUE LEN, NLF, ACKBITS, ADFORLIM
LONG INTEGER DRH
!
!
ROUTINE PECHO
IF SSOWN_OUTF_DSNUM=SSOWN_OUTDEFAULT C
THEN SAVEOUTDSNUM = -1 C
ELSE START
SAVEOUTDSNUM = SSOWN_OUTF_DSNUM
SELECTOUTPUT(0)
FINISH
I = IOCP (7,ADDR(SSOWN_PROMPTTEXT)); ! PRINTSTRING(SSOWN_PROMPTTEXT)
! %FOR I=SSOWN_INF_CUR,1,INF_END-1 %CYCLE
! ! %UNTIL end of available data or end of line.
! PRINTSYMBOL(BYTEINTEGER(I))
! %IF BYTEINTEGER(I) = NL %THEN %EXIT
! %REPEAT
DRH = SSOWN_INF_CUR ! (LENGTHENI((SSOWN_INF_END-SSOWN_INF_CUR-1)!X'18000000')<<32)
!
! This code prepares a descriptor in DRH ready for a call
! on IOCP entry 23 ('PRINT SEVERAL SYMBOLS'), which will
! be equivalent to the IMP code commented out above.
! A byte vector descriptor must be ready in DRH. Its
! address must be a copy of SSOWN_INF_CUR, and its bound must be
! one LESS than the length of the available data. This is
! so that we don't test last byte - if SWNE gets that
! far then it will be printed anyway.
!
!
!
*LD_DRH
*SWNE_L =DR ,0,10; ! %MASK=0, %REF=NL.
*INCA_1; ! Take one more byte than what SWNE has skipped.
*CYD_0
*STUH_B
! Acc now has address of first byte NOT to be printed.
*ISB_DRH+4; ! That is a copy of SSOWN_INF_CUR.
! Acc now has count of bytes to be printed.
*ST_DRH; ! DRH has lost its type, but that is not
! needed for the ensuing call on IOCP.
I = IOCP (23,ADDR(DRH))
IF SAVEOUTDSNUM > 0 THEN SELECTOUTPUT(SAVEOUTDSNUM)
END ; ! of PECHO.
!
!
ROUTINE GETINPUT
INTEGER LEN, LNB, FLAG, START, ADICRSA
SSOWN_RSYMLIM = 0
SSOWN_RCHLIM = 0
IF SSOWN_INF_ACCESSROUTE = 9 THEN START ; ! For console:
ADICRSA=ADDR(SSOWN_ICRSA)
IF SSOWN_ICRSA=0 THEN LEN = 0 ELSE START
START = SSOWN_ICRSA + 1
LEN = SSOWN_ICRSE - SSOWN_ICRSA
FINISH
IF LEN=0 THEN START
CONSOLE(1,START,LEN)
SSOWN_ICRSE = START + LEN
FINISH
SSOWN_INF_CUR = START
SSOWN_INF_CURREC = START
*LDTB_X'18000000'
*LDB_LEN
*LDA_START
*SWNE_L =DR ,0,25; ! %MASK=0, %REF=EM.
*JCC_8,<NOEOF>
*CYD_0
*STUH_B
*LDTB_X'28000001'
*LDA_ADICRSA
*ST_(DR )
SSOWN_INF_END = SSOWN_ICRSA
RETURN
!
NOEOF: SSOWN_INF_END = SSOWN_ICRSE
SSOWN_ICRSA = 0
FINISH ELSE START ; ! For anything but console:
! For file, .NULL or *, signal input ended:
IF 8<=SSOWN_INF_ACCESSROUTE<=11 THEN SIGNAL(2,140,0,FLAG)
! The following code forces exit from IOCP
! with %RESULT = 25.
*STLN_LNB; !FOR THIS ROUTINE
LNB = INTEGER(LNB)&X'FFFFFFFE'; !REMOVE BOTTOM BIT
*LLN_LNB; !FOR IOCP
*LSS_25; !EM CHARACTER AS RESULT
*EXIT_-64
FINISH
END ; !OF GET INPUT
ROUTINE PUTOUTPUT
INTEGER START, LEN, FLAG
IF SSOWN_OUTF_ACCESSROUTE = 8 START
!CHAR FILE
EXTEND(SSOWN_OUTF,FLAG)
IF FLAG # 0 THEN START
IF SSOWN_OUTF_DSNUM=SSOWN_OUTDEFAULT THEN START ; ! Mac's version tests =91.
SSOWN_OUTF_CUR = SSOWN_OUTF_CUR - 500
BATCHSTOP (3)
FINISH
SIGNAL(2,136,0,FLAG)
FINISH
!SIGNAL OUTPUT EXCEEDED
FINISH
IF SSOWN_OUTF_ACCESSROUTE = 9 START
!TERMINAL
LEN = SSOWN_OUTF_CUR-SSOWN_OUTF_CURREC
CONSOLE(2,START,LEN); !SEND OUTPUT TO TERMINAL
SSOWN_OUTF_CUR = START
SSOWN_OUTF_CURREC = START
SSOWN_OUTF_END = SSOWN_OUTF_CUR+LEN
FINISH
IF SSOWN_OUTF_ACCESSROUTE = 10 START
SSOWN_OUTF_CUR = SSOWN_OUTF_CONAD+32; !RESET TO START OF FILE
SSOWN_OUTF_CURREC = SSOWN_OUTF_CUR
FINISH
END ; !OF PUTOUTPUT
ROUTINE SELECTIN(INTEGER CHAN)
INTEGER AFD, FLAG, REQCHAN, FAR, NXC
RECORD (FDF)NAME F
FLAG = 0
REQCHAN = CHAN; !INITIALLY REQUESTED CHAN
NXC = REQCHAN
CYCLE
CHAN = NXC
UNLESS 0<=CHAN<=99 THEN FLAG = 164 ELSE START
UNLESS 0#CHAN#98 THEN CHAN = SSOWN_INDEFAULT
AFD = SSOWN_SSFDMAP(CHAN)
IF AFD=0 THEN FLAG = 151 ELSE START
F == RECORD(AFD)
FAR = F_ACCESSROUTE
IF FAR=1 THEN NXC = SSOWN_INDEFAULT C
ELSE IF FAR=2 THEN FLAG = 266 C
ELSE NXC = F_ASVAR
FINISH
FINISH
REPEAT UNTIL FLAG#0 OR 1#FAR#6
! We have now EITHER detected a failure OR got a
! channel which is NOT .IN and NOT mapped.
! The possible failures are indicated by non-zero
! values of FLAG, viz.:
! 164 - invalid channel number (not in range 0 to 99)
! 151 - channel not defined (SSOWN_SSFDMAP(CHAN)=0)
! 266 - tried to select .OUT
!
IF FLAG=0 THEN START
IF F_STATUS#0 THEN START ; ! Already open.
IF F_MODEOFUSE#1 THEN FLAG = 266 C
ELSE IF F_VALID ACTION&1=0 THEN FLAG = 171 C
ELSE IF FAR=8 AND ADDR(F)=ADDR(SSOWN_OUTF) THEN FLAG = 185
FINISH ELSE START
FLAG = OPEN(AFD,1)
IF FLAG=0 THEN START
IF F_ACCESSROUTE#8 THEN F_MODEOFUSE = 1 C
ELSE IF F_MODEOFUSE#1 THEN START
FLAG = 267
SSOWN_SSFNAME=F_IDEN
FINISH
FINISH
FINISH
FINISH
IF FLAG=0 THEN START
SSOWN_SSOPENUSED = 1
SSOWN_SSCOMREG(22) = REQCHAN
SSOWN_INF == F
FINISH ELSE START
SELECTOUTPUT(0)
PSYSMES(-71,FLAG)
FINISH
END ; !OF SELECTIN
ROUTINE SELECTOUT(INTEGER CHAN)
INTEGER AFD, FLAG, REQCHAN, FAR, NXC
RECORD (FDF)NAME F
FLAG = 0
REQCHAN = CHAN; !INITIALLY REQUESTED CHAN
NXC = REQCHAN
CYCLE
CHAN = NXC
UNLESS 0<=CHAN<=109 THEN FLAG = 164 ELSE START
IF CHAN=0 OR CHAN=99 OR CHAN=107 C
THEN CHAN = SSOWN_OUTDEFAULT
AFD = SSOWN_SSFDMAP(CHAN)
IF AFD=0 THEN FLAG = 151 ELSE START
F == RECORD(AFD)
FAR = F_ACCESSROUTE
IF FAR=2 THEN NXC = SSOWN_OUTDEFAULT C
ELSE IF FAR=1 THEN FLAG = 266 C
ELSE NXC = F_ASVAR
FINISH
FINISH
REPEAT UNTIL FLAG#0 OR 2#FAR#6
! We have now EITHER detected a failure OR got a
! channel which is NOT .OUT and NOT mapped.
! The possible failures are indicated by non-zero
! values of FLAG, viz.:
! 164 - invalid channel number (not in range 0 to 109)
! 151 - channel not defined (SSOWN_SSFDMAP(CHAN)=0)
! 266 - tried to select .IN
!
IF FLAG=0 THEN START
IF F_STATUS#0 THEN START ; ! Already open.
IF F_MODEOFUSE#1 THEN FLAG = 266 C
ELSE IF F_VALID ACTION&2=0 THEN FLAG = 171 C
ELSE IF FAR=8 AND ADDR(F)=ADDR(SSOWN_INF) THEN FLAG = 185
FINISH ELSE START
F_MODEOFUSE = 1
FLAG = OPEN(AFD,2)
IF FLAG=0 AND F_MODEOFUSE#1 THEN START
FLAG = 267
SSOWN_SSFNAME=F_IDEN
FINISH
FINISH
FINISH
IF FLAG=0 THEN START
SSOWN_SSOPENUSED = 1
SSOWN_SSCOMREG(23) = REQCHAN
SSOWN_OUTF == F
FINISH ELSE START
IF CHAN=91 THEN START
X20{DOPER} (0,SSOWN_SSOWNER. C
"Batch job fails - cannot open output file")
X30{DSTOP} (127)
FINISH
IF REQCHAN#0 AND REQCHAN#99 AND REQCHAN#107 THEN SELECTOUTPUT(0)
PSYSMES(-72,FLAG)
FINISH
END ; !OF SELECTOUT
!
IF EP=SSOWN_LASTEP THEN START
IF EP=SSOWN_LASTSWEP OR SSOWN_CONTROLMODE=0 THEN -> SW (EP)
-> SW (SSOWN_LASTSWEP)
FINISH
!
SW (0):
UNLESS 1 <= EP <= MAXEP THEN RESULT = -1; !INVALID EP
SW (11): ; ! WHAT WAS THE LAST CALL?
IF EP=11 THEN RESULT = SSOWN_LASTEP
SSOWN_LASTEP = EP
! %IF EP=1 %OR EP=2 %OR EP=4 %OR EP=6 %OR EP=10 %OR EP=18 %C
! %THEN READING = 1 %C
! %ELSE READING = 0
ACKBITS = ADDR (SSOWN_CKBITS)
*LDTB_32
*LDA_ACKBITS; ! DR now has a (scaled bound-checked) bit vector
! descriptor to CKBITS.
*LSS_(DR +EP)
*ST_READING
IF READING#0 AND SSOWN_CONTROLMODE#0 AND SSOWN_INF_DSNUM=90 C
THEN SSOWN_LASTSWEP = EP+MAXEP C
ELSE SSOWN_LASTSWEP = EP
-> SW(SSOWN_LASTSWEP)
!!
! CHARACTER INPUT CALLS
SW(MAXEP+4): ! AUXSW(4): !READCH
RES = MASTERCHARIN(1)
IF RES = SSOWN_LASTMASTERREADCH = EM THEN -> INEND
SSOWN_LASTMASTERREADCH = RES
RESULT = RES
SW(4):
IF SSOWN_INF_CUR<SSOWN_RCHLIM THEN START
RES = BYTE INTEGER (SSOWN_INF_CUR)
SSOWN_INF_CUR = SSOWN_INF_CUR + 1
RESULT = RES
FINISH
CYCLE
CHAD = SSOWN_INF_CUR
CHS LEFT = SSOWN_INF_END - CHAD
EXIT IF CHS LEFT>0
IF SSOWN_INF_CURSTATE#7 {end-of-file not detected} C
AND (SSOWN_INF_ACCESSROUTE=8 {file} C
OR SSOWN_INF_ACCESSROUTE=11 {*} C
OR (SSOWN_INF_ACCESSROUTE=9 C
AND SSOWN_ICRSA#0 {we've come to an EM from the console}) ) C
THEN START
SSOWN_INF_CURSTATE = 7 {eof detected}
RESULT = EM
FINISH
!
! We can only get here if SSOWN_INF_CURSTATE=7 (end-of-file detected by
! previous read) or if 8#SSOWN_INF_ACCESSROUTE#11 (not reading from file or *).
!
GET INPUT
! Calls CONSOLE for ACCESSROUTE 9, i.e. input from console.
! SIGNALs end-of-file for input from file, .NULL or *.
! Forces return from IOCP with %RESULT=EM for all other ACCESSROUTEs.
!
! Control can only arrive here for ACCESSROUTE 9 (console input):
IF SSOWN_INF_CURSTATE=7 {end-of-file already detected} THEN START
SSOWN_INF_CURSTATE = 2; ! Revert to whatever is normal for console input.
SIGNAL (2,140,0,FLAG)
FINISH
REPEAT
! IF ECHO IS ON +NEW INPUT LINE +
! INPUT IS FROM .IN THEN ECHO LINE TO .OUT
IF CHAD=SSOWN_INF_CURREC C
AND SSOWN_INF_DSNUM=SSOWN_INDEFAULT C
AND SSOWN_DATAECHO>0 C
AND (SSOWN_DATAECHO=2 C
OR SSOWN_PROMPTTEXT=COMMANDPROMPT) C
THEN PECHO
RES = BYTEINTEGER(CHAD)
SSOWN_INF_CUR = CHAD+1
IF RES = NL THEN SSOWN_INF_CURREC = SSOWN_INF_CUR ELSE START
! Locate next newline - this may allow subsequent calls
! of READCH to use the "short path".
ADFORLIM=ADDR(SSOWN_RCHLIM)
*LDTB_X'58000000'
*LDB_CHS LEFT
*LDA_CHAD
*MODD_1
*SWNE_L =DR ,0,10; ! %MASK=0, %REF=NL.
*CYD_0
*STUH_B
*LDTB_X'28000001'
*LDA_ADFORLIM
*ST_(DR ); ! Address of next NL (or just beyond last character in file).
FINISH
! **** **** What %IF RES=EM? **** ****
RESULT = RES
SW(MAXEP+18): ! AUXSW(18): !NEXTCH
RESULT = MASTERCHARIN(0)
SW(18):
IF SSOWN_INF_CUR>=SSOWN_INF_END THEN START
IF SSOWN_INF_ACCESSROUTE=9 AND SSOWN_ICRSA=0 THEN GETINPUT ELSE RESULT = EM
FINISH
RESULT = BYTEINTEGER(SSOWN_INF_CUR)
!SYMBOL INPUT CALLS
SW(MAXEP+1): ! AUXSW(1): !READSYMBOL
CYCLE
RES = MASTERCHARIN(1)
IF RES=EM THEN -> INEND
RES = CHTOSYM (RES)
REPEAT UNTIL RES#0
RESULT = RES
SW(1):
IF SSOWN_INF_CUR<SSOWN_RSYMLIM THEN START
RES = BYTE INTEGER (SSOWN_INF_CUR)
SSOWN_INF_CUR = SSOWN_INF_CUR + 1
RESULT = RES
FINISH
CYCLE
CHAD = SSOWN_INF_CUR
CHS LEFT = SSOWN_INF_END - CHAD
IF CHAD = SSOWN_INF_CURREC C
AND SSOWN_INF_DSNUM=SSOWN_INDEFAULT C
AND SSOWN_DATAECHO>0 C
AND (SSOWN_DATAECHO=2 C
OR SSOWN_PROMPTTEXT=COMMANDPROMPT) C
THEN PECHO
WHILE CHS LEFT>0 CYCLE
RES = BYTEINTEGER(CHAD)
! **** **** What %IF RES=EM? **** ****
RES = CHTOSYM(RES)
CHS LEFT = CHS LEFT - 1
CHAD = CHAD + 1
IF RES#0 THEN START
IF RES=NL THEN SSOWN_INF_CURREC = CHAD ELSE START
ADFORLIM=ADDR(SSOWN_RSYMLIM)
*LSS_XSP + 4; ! Gets address of XSP(0).
*LUH_256; ! Makes a bit vector descriptor.
*LDTB_X'18000000'
*LDB_CHS LEFT
*LDA_CHAD
*TCH_L =DR ; ! Find the next byte which will need more
! than simply passing out untranslated -
! i.e., NL or bytes which are translated to
! zero by CHTOSYM or bytes which are not
! translated into themselves.
*CYD_0
*STUH_B
*LDTB_X'28000001'
*LDA_ADFORLIM
*ST_(DR ); ! Save the address of that byte (or the address
! just beyond the end of the available text).
FINISH
SSOWN_INF_CUR = CHAD
RESULT = RES
FINISH
REPEAT
IF SSOWN_ICRSA=0 OR SSOWN_INF_ACCESSROUTE#9 THEN GETINPUT ELSE START
GETINPUT
SSOWN_INF_CURSTATE = 2
SIGNAL (2,140,0,FLAG)
FINISH
REPEAT
!
!
!
!
! The call *JLK_<MVTR> will move and translate PART LEN bytes
! from PART AD to TO, using the translation table whose address
! is at TRTAD. Those four variables must be set up before
! entry. On exit, PART AD will have been incremented by
! PART LEN: a copy of PART LEN will be in the B register:
! a (bounded scaled unsigned) byte vector descriptor to
! the translated bytes will be in DRH.
MVTR:
*LDTB_X'58000000'
*LB_PART LEN
*LDB_B
*LDA_PART AD
*CYD_0
*LDA_TO
*STD_DRH
*MV_L =DR
! Set PART AD = PART AD + PART LEN.
*ROT_32
*STUH_PART AD
! TTR PART LEN bytes at TO:
*LSS_TRTAD
*LUH_X'18000100'
*LD_DRH
*TTR_L =DR
*J_TOS
!
!
! If TO has the address, and the B register has the length,
! of a byte vector, and DR has a string descriptor for some bytes
! at the right-hand end of the vector, then *JLK_<CHOPATNL>
! will discard all but the first byte of the DR string - i.e.,
! it will reduce the value in B to include only the bytes from TO
! up to and including the first byte in the DR string. It
! will also reduce PART AD by the same amount. It will NOT
! reduce PART LEN. It also leaves the new value of PART AD
! in Acc.
CHOPATNL:
*STD_TOS
*LSS_TOS ; ! Get address of 'first byte'.
! Useless 'type-and-bound' word is still at TOS.
*SLB_TOS ; ! Now the original value of B is at TOS, and
! B has garbage in it - but the useless word
! has been cleared off the stack.
*ISB_TO
*IAD_1; ! Acc now has the new count of bytes.
*ST_B ; ! Now B has the corrected byte count.
*ISB_TOS ; ! Acc now has (New B - Old B).
*IAD_PART AD; ! Apply the same correction to PART AD.
*ST_PART AD
*J_TOS
!
!
! To call KILLZ, the address of a row of bytes must be
! held in TO, the length of the row must be in the B
! register, and the type of DR must be 'string'.
! The call *JLK_<KILLZ> will discard from the row all
! zero bytes, closing the rest of the bytes up towards
! the left. On exit, DR will have a zero length string
! descriptor pointing just after the last surviving byte.
! Acc will have a copy of the address from DR.
! B will have been overwritten.
KILLZ:
*LDB_B
*LDA_TO
SW6XL:
*SWNE_L =DR ,0,0; ! %MASK=0,%REF=0
*JCC_8,<SW6ZX>
*MODD_1
*CYD_0
*INCA_-1
*STD_TOS
*MV_L =DR
*LD_TOS
*J_<SW6XL>
!
SW6ZX:
*CYD_0
*STUH_B
*J_TOS
!
!
MARKNL:
! %IF NLF#0 %THEN %START
*LSS_NLF
*JAT_4,<NONL>
! Scan the surviving bytes repeatedly for NL.
! %IF NL found %THEN set SSOWN_OUTF_CURREC to point just
! beyond the last one found.
*LXN_ACURREC
*LD_DRH
*LDB_B
SCAN NL:
*SWNE_L =DR ,0,10; ! %MASK=0,%REF=NL
*JCC_8,<NONL>
*MODD_1
*CYD_0
*STUH_B
*ST_(XNB +0)
*J_<SCAN NL>
NONL:
! %FINISH
*J_TOS
!
!
SW(MAXEP+2): ! AUXSW(2): !NEXTSYMBOL
MCICNTRL = 0
CYCLE
IF MCICNTRL<=1 THEN START
NEXTRES = MASTERCHARIN (MCICNTRL)
MCICNTRL = MCICNTRL + 1
FINISH
IF NEXTRES = EM THEN -> INEND
RES = CHTOSYM (NEXTRES)
IF RES#0 THEN RESULT = RES ELSE NEXTRES = MASTERCHARIN (1)
REPEAT
SW(2):
IF SSOWN_INF_CUR<SSOWN_RSYMLIM THEN RESULT = BYTE INTEGER (SSOWN_INF_CUR)
CYCLE
WHILE SSOWN_INF_CUR<SSOWN_INF_END CYCLE
RES = CHTOSYM(BYTEINTEGER(SSOWN_INF_CUR))
IF RES # 0 THEN RESULT = RES
SSOWN_INF_CUR = SSOWN_INF_CUR+1
REPEAT
IF SSOWN_ICRSA=0 OR SSOWN_INF_ACCESSROUTE#9 THEN GETINPUT ELSE START
GETINPUT
SSOWN_INF_CURSTATE = 2
SIGNAL (2,140,0,FLAG)
FINISH
REPEAT
! SW(6): !READLINE FOR COMPILER
! SSOWN_EP6S = ""; !CLEAR STRING
! %CYCLE
! RES = IOCP(1,0); !RECURSIVE - READSYMBOL CALL
! SSOWN_EP6S = SSOWN_EP6S.TOSTRING(RES)
! %IF RES = NL %THEN %RESULT = ADDR(SSOWN_EP6S)
! !RESULT IS ADDRESS OF STRING
! ! CONTAING LINE
! %IF LENGTH(SSOWN_EP6S) = 254 %START
! !LONG LINE - PUT IN NL
! SSOWN_EP6S = SSOWN_EP6S.TOSTRING(NL)
! %RESULT = ADDR(SSOWN_EP6S)
! %FINISH
! %REPEAT
SW(MAXEP+6): ! AUXSW(6):
AEP6S = ADDR (SSOWN_EP6S)
BYTE INTEGER (AEP6S) = 255
TO = AEP6S + 1
EP6SEND = TO + 254; ! = AEP6S + 255
BYTE INTEGER (EP6SEND) = NL
CYCLE
CYCLE
RES = MASTERCHARIN (1)
IF RES=EM THEN -> IN END
RES = CH TO SYM (RES)
REPEAT UNTIL RES#0
BYTE INTEGER (TO) = RES
TO = TO + 1
REPEAT UNTIL RES=NL OR TO=EP6SEND
IF RES=NL THEN BYTE INTEGER (AEP6S) = TO - AEP6S - 1
RESULT = AEP6S
SW(6):
AEP6S = ADDR (SSOWN_EP6S)
BYTE INTEGER (AEP6S) = 255
TO = AEP6S + 1
EP6SEND = TO + 254; ! = AEP6S + 255
BYTE INTEGER (EP6SEND) = NL
TRTAD = ADDR (CHTOSYM(0))
ACURREC = ADDR (SSOWN_INF_CURREC)
RESIDUE LEN = 254
CYCLE
IF SSOWN_INF_END<=SSOWN_INF_CUR THEN START
IF 8<=SSOWN_INF_ACCESSROUTE<=11 C
THEN START
IF SSOWN_ICRSA=0 OR SSOWN_INF_ACCESSROUTE#9 THEN GET INPUT ELSE START
GET INPUT
SSOWN_INF_CURSTATE = 2
SIGNAL (2,140,0,FLAG)
FINISH
FINISH ELSE START
! Plant RESIDUE LEN copies of EM (25) at TO.
DRH = (LENGTHENI(X'18000000'!RESIDUE LEN)<<32) ! TO
*LD_DRH
*MVL_L =DR ,0,25; ! %MASK=0,%LIT=EM.
TO = TO + RESIDUE LEN
RESIDUE LEN = 0
FINISH
FINISH
IF SSOWN_INF_END>SSOWN_INF_CUR THEN START
IF SSOWN_INF_CUR=SSOWN_INF_CURREC C
AND SSOWN_INF_DSNUM=SSOWN_INDEFAULT C
AND SSOWN_DATAECHO>0 C
AND (SSOWN_DATAECHO=2 C
OR SSOWN_PROMPTTEXT=COMMANDPROMPT) C
THEN PECHO
PART AD = SSOWN_INF_CUR
PART LEN = SSOWN_INF_END - PART AD
IF PART LEN>RESIDUE LEN C
THEN PART LEN = RESIDUE LEN
!
! In the code below, SSOWN_INF_CUR is held temporarily in PART AD
! and PART LEN is held in the B register.
!
! MV PART LEN bytes from SSOWN_INF_CUR to TO, and
! translate them using CHTOSYM:
*JLK_<MVTR>
! Now PART AD has been incremented by PART LEN:
! the B register has a copy of PART LEN:
! and a descriptor to the translated byte
! vector is in DRH.
!
! Scan PART LEN bytes at TO for NL using SWNE:
*LD_DRH
*SWNE_L =DR ,0,10; ! %MASK=0,%REF=NL
*JCC_8,<SW6NLX>
!
! %IF NL found %THEN %START
! Reduce PART LEN and PART AD to include
! only bytes up to and including the NL
! Set SSOWN_INF_CURREC = PART AD
! %FINISH
*JLK_<CHOPATNL>
! Acc has the new value of PART AD, reduced to point
! just beyond the first NL. We will want to store this
! in SSOWN_INF_CURREC. The B register has also been reduced
! to count bytes from TO up to and including the first
! NL only.
*LXN_ACURREC
*ST_(XNB +0)
!
SW6NLX:
!
! Discard all zeros from PART LEN bytes at TO
*JLK_<KILLZ>
! Point TO just after the last surviving byte
*ST_TO
! RES = BYTE INTEGER (TO-1)
*INCA_-1
*LDB_1
*LSS_(DR +0)
*ST_RES
SSOWN_INF_CUR = PART AD
RESIDUE LEN = EP6SEND - TO
FINISH
REPEAT UNTIL RES=NL OR RESIDUE LEN<=0
IF RES=NL THEN BYTE INTEGER (AEP6S) = TO - AEP6S - 1
RESULT = AEP6S
!CHARACTER OUTPUT
SW(3): !PRINTSYMBOL
PARM = SYMTOCH(PARM&X'FF')
IF PARM = 0 THEN -> RESULTZERO; !IGNORE MARKED CHARACTER
SW(5): !PRINTCH
IF SSOWN_OUTF_CUR >= SSOWN_OUTF_END THEN PUTOUTPUT
BYTEINTEGER(SSOWN_OUTF_CUR) <- PARM
SSOWN_OUTF_CUR = SSOWN_OUTF_CUR+1
IF PARM = NL START ; !DEAL WITH NEWLINE
IF SSOWN_OUTF_ACCESSROUTE = 9 THEN PUTOUTPUT
SSOWN_OUTF_CURREC = SSOWN_OUTF_CUR; !POINT CURREC TO START OF NEW
! LINE
FINISH
-> RESULTZERO
!SYMBOL OUTPUT CALL
!PRINTSTRING
SW(7): !PRINTSTRING
SW(15): !RESPONSIBLE PRINTSTRING
FROM = PARM+1; !FIRST BYTE OF DATA
LEN = BYTEINTEGER(PARM)
SW15A: !ENTRY 23 COMES IN HERE
IF LEN>0 THEN START
!
! <<<< <<<< <<<<
PART AD = FROM
RESIDUE LEN = LEN
NLF = SSOWN_OUTF_ACCESSROUTE-9
! NLF=0 for console:
! #0 for anything else.
!
! In this section of code, I is set non-zero to indicate that
! PUT OUTPUT needs to be called, and I is zero when PUT OUTPUT
! is not needed.
!
ACURREC = ADDR (SSOWN_OUTF_CURREC)
TRTAD = ADDR (SYMTOCH(0))
WHILE RESIDUE LEN>0 CYCLE
TO = SSOWN_OUTF_CUR
PART LEN = SSOWN_OUTF_END - TO
IF PART LEN>0 THEN START
I = 0
IF PART LEN>RESIDUE LEN THEN PART LEN = RESIDUE LEN
! Move PART LEN bytes from PART AD to TO, and
! translate them using SYMTOCH:
*JLK_<MVTR>
! Now PART AD has been incremented by PART LEN:
! the B register has a copy of PART LEN:
! and a descriptor to the translated string
! is in DRH.
!
! %IF NLF=0 %THEN %START
*LSS_NLF
*JAF_4,<NOT END>
! For output to console:
! Use SWNE to scan PART LEN bytes at TO for NL.
! %IF NL found %THEN %START
! Reduce PART LEN and PART AD (which has already
! been incremented) to cover only the bytes up
! and including the NL, and set
! I = -1
! %FINISH
*LD_DRH
*SWNE_L =DR ,0,10; ! %MASK=0,%REF=NL
*JCC_8,<NOT END>
*JLK_<CHOPATNL>
! Now the B register has been reduced to count
! only the bytes up to and including the first
! NL, and PART AD has been reduced by the same
! amount (it was previously incremented by
! MVTR). PART LEN and DRH have not been
! adjusted.
*STB_PART LEN
!
! I = -1
*LSS_-1
*ST_I
NOT END:
! %FINISH
! Discard zeros from PART LEN bytes at TO.
! Set (new value of) TO to point just after the last surviving
! byte. Set OUT LEN (in B register) to give actual number of
! surviving bytes.
*JLK_<KILLZ>
*ST_B
*SBB_TO
*ST_TO
*JLK_<MARKNL>; ! does NOT update SSOWN_OUTF_CURREC if NLF=0, i.e. for console.
SSOWN_OUTF_CUR = TO
RESIDUE LEN = RESIDUE LEN - PART LEN
FINISH ELSE I = -1
IF I#0 THEN PUT OUTPUT
REPEAT
! >>>> >>>> >>>>
!
FINISH
-> RESULTZERO
! SELECTINPUT
SW(21): !ALGOL SELECTIN
IF PARM = ALGOLIN AND SSOWN_SSFDMAP(ALGOLIN) = 0 THEN PARM = 0
! CHANNEL (ALGOLIN) NOT DEFINED - USE DEFAULT
SW(8): !IMP SELECTINPUT
SSOWN_RSYMLIM = 0
SSOWN_RCHLIM = 0
SELECTIN(PARM)
-> RESULTZERO
!*
! SELECTOUTPUT
!*
SW(22): !ALGOL SELECTOUT
IF PARM = ALGOLOUT AND SSOWN_SSFDMAP(ALGOLOUT) = 0 THEN PARM = 0
!CHANNEL(ALGOLOUT) NOT DEFINED - USE DEFAULT OUTPUT STREAM
SW(9): !IMP SELECTOUTPUT
SELECTOUT(PARM)
-> RESULTZERO
! AUXSW(10):
! SW(10): !ISOCARD
! %WHILE SSOWN_INF_CUR # SSOWN_INF_CURREC %THEN C = IOCP(4,0)
! !SKIP REST OF CURRENT RECORD
! TOP = PARM+79; !ADDR OF LAST BYTE IN CARD ARRAY
! %FOR I=PARM,1,TOP %CYCLE
! C = IOCP(4,0)
! %IF C = NL %START; !SHORT LINE
! %FOR I=I,1,TOP %CYCLE
! BYTEINTEGER(I) = ' '
! %REPEAT
! -> RESULTZERO
! %FINISH
! BYTEINTEGER(I) = C
! %REPEAT
! C = IOCP(4,0) %UNTIL C = NL; !SKIP TILL NEWLINE
! -> RESULTZERO
SW(MAXEP+10): ! AUXSW(10):; ! ISO CARD
C = LAST CHAR COPY; ! This is NL at start of input.
! **** We should use the %EXTRINSIC %INTEGER LAST CHAR READ ****
! **** if linkage were practical. ****
TO = PARM
TOP = PARM + 80
I = 0
WHILE I<=1 CYCLE
WHILE C#NL CYCLE
RES = MASTERCHARIN (1)
IF RES=C=EM THEN -> INEND
C = RES
REPEAT
WHILE TO<TOP CYCLE
RES = MASTERCHARIN (1)
IF RES=C=EM THEN -> INEND
C = RES
IF C#NL THEN START
BYTE INTEGER (TO) = C
TO = TO + 1
FINISH ELSE START
! Fill bytes from TO to TOP-1 with spaces.
DRH = (LENGTHENI(X'18000000'!(TOP-TO))<<32) ! TO
*LD_DRH
*MVL_L =DR ,0,32; ! %MASK=0,%LIT=Space.
TO = TOP
FINISH
REPEAT
I = I + 1
REPEAT
-> RESULTZERO
SW(10):; ! ISO CARD
TO = PARM
RESIDUE LEN = 80
UNLESS 8<=SSOWN_INF_ACCESSROUTE<=11 THEN START
! It might be a good idea to plant RESIDUE LEN spaces
! at TO.
RESULT = EM
FINISH
ACURREC = ADDR (SSOWN_INF_CURREC)
CYCLE
IF SSOWN_INF_CURREC#SSOWN_INF_CUR<SSOWN_INF_END THEN I = RESIDUE LEN ELSE START
I = 0
WHILE SSOWN_INF_END<=SSOWN_INF_CUR CYCLE
IF (SSOWN_INF_ACCESSROUTE=8 {file} C
OR SSOWN_INF_ACCESSROUTE=11 {*} C
OR (SSOWN_INF_ACCESSROUTE=9 C
AND SSOWN_ICRSA#0) {we've come to an EM from the console} ) C
THEN START
SSOWN_INF_CURSTATE = 7 {eof detected}
FINISH
GET INPUT
! Calls CONSOLE for ACCESSROUTE 9, i.e. input from console.
! SIGNALs end-of-file for input from file, .NULL or *.
! Forces return from IOCP with %RESULT=EM for all other ACCESSROUTEs.
!
! Control can only arrive here for ACCESSROUTE 9 (console input):
IF SSOWN_INF_CURSTATE=7 {end-of-file already detected} THEN START
SSOWN_INF_CURSTATE = 2; ! Revert to whatever is normal for console input.
SIGNAL (2,140,0,FLAG)
FINISH
REPEAT
IF SSOWN_INF_DSNUM=SSOWN_INDEFAULT C
AND SSOWN_DATAECHO>0 C
AND (SSOWN_DATAECHO=2 C
OR SSOWN_PROMPTTEXT=COMMANDPROMPT) C
THEN PECHO
FINISH
PART AD = SSOWN_INF_CUR
PART LEN = SSOWN_INF_END - PART AD
IF PART LEN>RESIDUE LEN>I THEN PART LEN = RESIDUE LEN
! Scan PART LEN bytes at PART AD for NL using SWNE.
*LDTB_X'18000000'
*LDB_PART LEN
*LDA_PART AD
*STD_DRH
*SWNE_L =DR ,0,10; ! %MASK=0,%REF=NL
*CYD_0
*STUH_B
*ST_B ; ! Now ACS=(1 word), and Acc and B both have a
! pointer to the NL, if found, or to the first
! byte after the last one scanned.
! %IF NL found %THEN %START
*JCC_8,<SW10L1>
! RES = -1
! PART LEN = Number of bytes skipped by SWNE.
! Set SSOWN_INF_CUR = SSOWN_INF_CURREC = PART AD + PART LEN + 1
*ISB_PART AD; ! Compute count of bytes skipped,
! i.e., bytes before NL.
*ST_PART LEN
*OR_X'18000000'
*ST_DRH; ! Modify DRH for future reference.
! In the machine code version, the descriptor held
! in DRH holds the value of PART AD from here
! onwards, and PART AD itself is updated to give
! the new value of SSOWN_INF_CUR.
*ADB_1; ! Point to byte just beyond the NL.
*LXN_ACURREC
*STB_(XNB +0); ! Point SSOWN_INF_CURREC just beyond NL.
*LSS_-1; ! Remember NL was found.
*J_<SW10L2>
! %FINISH %ELSE %START
! RES = 0
! SSOWN_INF_CUR = PART AD + PART LEN
SW10L1:
*LSS_0; ! Remember NL not found.
! B register already points after last byte scanned.
! %FINISH
SW10L2:
! When we get here, Acc should have the new value for RES
! and the B register should have the new value for SSOWN_INF_CUR
*ST_RES
*STB_PART AD
SSOWN_INF_CUR = PART AD; ! In the machine code version, PART AD is overwritten
! here, and the value used in the IMP version can
! be found as the address in the descriptor in DRH.
IF RESIDUE LEN>I THEN START
! Construct a descriptor to PART LEN bytes at PART AD.
*LSD_DRH
! Construct a descriptor to RESIDUE LEN bytes at TO.
*LDTB_X'18000000'
*LDB_RESIDUE LEN
*LDA_TO
! Move the first lot onto the second, padding with
! spaces if necessary.
*MV_L =DR ,0,32; ! %MASK=0,%LIT=Space.
RESIDUE LEN = RESIDUE LEN - PART LEN
TO = TO + PART LEN
FINISH
REPEAT UNTIL RES#0=I
-> RESULTZERO
!
!
! SW(17): !PRINT N COPIES OF CHAR
! -> RESULTZERO %IF PARM <= 0
! HOLD = PARM&127; !HOLD IS THE SYMBOL TO BE PRINTED
! PARM = (PARM>>8)&255; !COUNTER
! %IF PARM > 0 %START
! %FOR I=1,1,PARM %CYCLE
! RES = IOCP(3,HOLD); !PRINTSYMBOL N TIMES
! %REPEAT
! %FINISH
! -> RESULTZERO
SW(17):
IF PARM>0 THEN START
HOLD = SYMTOCH (PARM&127)
RESIDUE LEN = (PARM>>8) & 255
IF RESIDUE LEN>0 AND HOLD>0 THEN START
IF SSOWN_OUTF_CUR>=SSOWN_OUTF_END THEN PUTOUTPUT
IF SSOWN_OUTF_ACCESSROUTE=9 AND HOLD=NL THEN START
FOR I=RESIDUE LEN,-1,1 CYCLE
BYTE INTEGER (SSOWN_OUTF_CUR) <- HOLD
SSOWN_OUTF_CUR = SSOWN_OUTF_CUR + 1
PUTOUTPUT
! SSOWN_OUTF_CURREC = SSOWN_OUTF_CUR
! That is done by PUTOUTPUT for SSOWN_OUTF_ACCESSROUTE=9.
REPEAT
FINISH ELSE START
CYCLE
PART AD = SSOWN_OUTF_CUR
PART LEN = SSOWN_OUTF_END - PART AD
IF PART LEN>RESIDUE LEN THEN PART LEN = RESIDUE LEN
! Move PART LEN copies of HOLD into consecutive bytes
! starting at PART AD.
*LDTB_X'18000000'
*LDB_PART LEN
*LDA_PART AD
*LB_HOLD
*MVL_L =DR
RESIDUE LEN = RESIDUE LEN - PART LEN
SSOWN_OUTF_CUR = PART AD + PART LEN
IF HOLD=NL THEN SSOWN_OUTF_CURREC = SSOWN_OUTF_CUR
IF RESIDUE LEN>0 THEN PUTOUTPUT
REPEAT UNTIL RESIDUE LEN<=0
FINISH
FINISH
FINISH
-> RESULTZERO
!
!
SW(12):; ! Clear 'INPUT ENDED' from console.
IF SSOWN_INF_ACCESSROUTE=9 AND SSOWN_INF_CUR=SSOWN_ICRSA#0 THEN START
SSOWN_INF_CURSTATE = 2
GETINPUT
FINISH
-> RESULTZERO
SW(13):
SW(14):
-> RESULTZERO
SW(16): !CLOSESTREAM(PARM)
! I expect this to be called only from CLOSE STREAM, and hence
! never to be called for a currently selected stream. Accordingly
! I will not bother to clear SSOWN_RCHLIM, etc.
AFD = SSOWN_SSFDMAP(PARM)
IF AFD # 0 THEN FLAG = CLOSE(AFD)
-> RESULTZERO
SW(19):; ! LONG OUTPUT REQUEST simulating PRINT CH.
! Parameter must be the address of a descriptor which points to
! the characters to be printed.
NLF = SSOWN_OUTF_ACCESSROUTE - 9; ! Zero for console, non-zero for anything else.
SENDNL = 0; ! No newline to be appended to the text.
PART AD = INTEGER (PARM+4)
RESIDUE LEN = INTEGER (PARM) & X'00FFFFFF'
-> LONG PRINT CH
!
SW(20): !INPOS AND OUTPOS
IF PARM = 0 THEN RESULT = SSOWN_INF_CUR-SSOWN_INF_CURREC
RESULT = SSOWN_OUTF_CUR-SSOWN_OUTF_CURREC; !OUTPOS
SW(23): !LONG OUTPUT REQUEST
!PARM IS ADDRESS OF DESCRIPTOR TO AREA
FROM = INTEGER(PARM+4)
LEN = INTEGER(PARM)&X'FFFFFF'
-> SW15A; !JOINS RESPONSIBLE PRINTSTRING
!
SW(24): !OVER-WRITE LAST OUTPUT CHAR WITH PARM
IF SSOWN_OUTF_ACCESSROUTE = 8 START ; !ONLY OUTPUT TO FILE
IF SSOWN_OUTF_CUR > SSOWN_OUTF_CONAD+INTEGER(SSOWN_OUTF_CONAD+4) START
!NOT AT START OF FILE
BYTEINTEGER(SSOWN_OUTF_CUR-1) <- PARM; !PARM TO OVERWRITE LAST CHARACTER
FINISH
FINISH
-> RESULTZERO
SW(25): !TERMINATE CURRENT LINE - ONLY MEANINGFUL ON INTERACTIVE TERMINAL
IF SSOWN_OUTF_ACCESSROUTE = 9 START
PUTOUTPUT
I = 0; ! Don't await reply from REQUEST OUTPUT.
CONSOLE(9,I,I)
FINISH
-> RESULTZERO
!
!
! Support SIM2 entry point 0, "read record".
SW(MAXEP+26): ! AUXSW(26):
TO = INTEGER (PARM)
C = MASTERCHARIN (0)
IF C=SSOWN_LAST MASTER READ CH=EM THEN -> INEND
I = 0
CYCLE
C = MASTERCHARIN (1)
BYTE INTEGER (TO+I) <- C
I = I + 1
REPEAT UNTIL C=NL OR I=160 OR C=EM
SSOWN_LAST MASTER READ CH = C
IF I>=160 THEN START
IF C#NL THEN I = 0
FINISH ELSE START
IF C=EM THEN START
BYTE INTEGER (TO + I) <- NL
I = I + 1
FINISH
FINISH
INTEGER (INTEGER(PARM+8)) = I
-> RESULTZERO
!
!
SW(26):
TO = INTEGER (PARM)
I = 0
IF 8<=SSOWN_INF_ACCESSROUTE<=11 THEN START
RESIDUE LEN = 160
PART AD = SSOWN_INF_CUR
PART LEN = SSOWN_INF_END - PART AD
IF PART LEN=0 AND SSOWN_INF_CURSTATE=7 THEN START
UNLESS 8#SSOWN_INF_ACCESSROUTE#11 THEN GET INPUT
IF SSOWN_INF_ACCESSROUTE=9 AND SSOWN_ICRSA#0 THEN START
GET INPUT
SSOWN_INF_CURSTATE = 2
SIGNAL (2,140,0,FLAG)
FINISH
FINISH
CYCLE
C = 0
WHILE PART LEN<=0=C CYCLE
IF (SSOWN_INF_ACCESSROUTE=8 C
OR SSOWN_INF_ACCESSROUTE=11 C
OR (SSOWN_INF_ACCESSROUTE=9 AND SSOWN_ICRSA#0)) C
AND SSOWN_INF_CURSTATE#7 C
THEN START
SSOWN_INF_CURSTATE = 7
C = EM
BYTE INTEGER (TO+I) <- EM
I = I + 1
FINISH ELSE START
GET INPUT
PART AD = SSOWN_INF_CUR
PART LEN = SSOWN_INF_END - PART AD
FINISH
REPEAT
IF C=0 THEN START
IF SSOWN_INF_CURREC=PART AD C
AND SSOWN_INF_DSNUM=SSOWN_INDEFAULT C
AND SSOWN_DATAECHO>0 C
AND (SSOWN_DATAECHO=2 C
OR SSOWN_PROMPTTEXT=COMMANDPROMPT) C
THEN PECHO
IF PART LEN>RESIDUE LEN THEN PART LEN = RESIDUE LEN
! Scan PART LEN bytes at PART AD for the first NL or EM.
! %IF found %THEN reduce PART LEN to count up to and
! including the first such byte and no further.
*LDTB_X'18000000'
*LDB_PART LEN
*LDA_PART AD
*STD_DRH
*LB_2; ! Try 2 values of reference byte.
! The first one: %MASK=0,%REF=NL:
*SWNE_L =DR ,0,10
*J_<S2E0L2>
S2E0L1:
! The second: %MASK=0,%REF=EM:
*LD_DRH
*SWNE_L =DR ,0,25
S2E0L2:
*JCC_8,<S2E0L3>; ! -> %IF reference byte not found.
! %IF reference byte found:
*CYD_0; !
*STUH_TOS ; ! Leaves ADDR(reference byte) in Acc.
*ISB_PART AD; ! Compute count of bytes skipped
! before reference byte.
*IAD_1; ! Count now includes reference byte.
*ST_PART LEN
*SLSS_TOS ; ! Ready to move it into DR - also
! clears garbage word off stack.
*LD_DRH; ! Restore type and address.
*LDB_TOS ; ! Get new bound.
*STD_DRH; ! Save new descriptor.
S2E0L3:
*DEBJ_<S2E0L1>; ! -> %IF there remains another
! reference byte to try.
!
! Move PART LEN bytes from PART AD to TO+I
*LD_DRH
*CYD_0; ! Acc now points to source string.
*LDA_TO
*INCA_I; ! DR now has TO+I in address field
! and points to destination string.
*MV_L =DR ; ! Move the bytes.
! Let C be the last character moved.
*INCA_-1; ! Point to the last byte moved.
*LDB_1
*LSS_(DR +0)
*ST_C
!
RESIDUE LEN = RESIDUE LEN - PART LEN
PART AD = PART AD + PART LEN
I = I + PART LEN
PART LEN = 0
SSOWN_INF_CUR = PART AD
FINISH
REPEAT UNTIL C=NL OR RESIDUE LEN=0 OR C=EM
IF C=NL THEN SSOWN_INF_CURREC = PART AD C
ELSE IF RESIDUE LEN<=0 THEN I=0 C
ELSE IF C=EM THEN START
BYTE INTEGER (TO+I) <- NL
I = I + 1
FINISH
INTEGER (INTEGER(PARM+8)) = I
FINISH
-> RESULTZERO
!
!
SW(27):; ! Support SIM2 entry point 1, "write record".
!
NLF = SSOWN_OUTF_ACCESSROUTE-9
! NLF=0 for console:
! #0 for anything else.
!
! In this section of code, I is set non-zero to indicate that
! PUT OUTPUT needs to be called, and I is zero when PUT OUTPUT
! is not needed.
!
IF NLF#0 THEN START
PART AD = INTEGER (PARM)
IF 12#BYTE INTEGER(PART AD)#13 THEN BYTE INTEGER(PART AD) = NL
RESIDUE LEN = INTEGER (PARM+4)
SENDNL = 0; ! No newline needed after the text.
FINISH ELSE START
PART AD = INTEGER (PARM) + 1
RESIDUE LEN = INTEGER (PARM+4) - 1
SENDNL = -1; ! Output a newline after the text.
FINISH
!
! Dispose of RESIDUE LEN bytes at FROM using (simulated) IOCP 5.
LONG PRINT CH:
!
ACURREC = ADDR (SSOWN_OUTF_CURREC)
WHILE RESIDUE LEN>0 CYCLE
TO = SSOWN_OUTF_CUR
PART LEN = SSOWN_OUTF_END - TO
IF PART LEN>0 THEN START
I = 0
IF PART LEN>RESIDUE LEN THEN PART LEN = RESIDUE LEN
*LDTB_X'58000000'
*LB_PART AD
*LDA_B
! %IF NLF=0 %THEN %START
*LSS_NLF
*JAF_4,<S2E1L2>
! For output to console:
! Use SWNE to scan PART LEN bytes at PART AD for NL.
! %IF NL found %THEN %START
! Reduce PART LEN to cover only the bytes up
! and including the NL, and set
! I = -1
! %FINISH
*LDB_PART LEN
*SWNE_L =DR ,0,10; ! %MASK=0,%REF=NL
*JCC_8,<S2E1L1>
*STD_TOS
*LDA_B
*SLB_TOS
*SBB_TOS
*ADB_1
*STB_PART LEN
*LSS_TOS
! Now the B register and PART LEN have been reduced to
! count only the bytes up to and including the first
! NL.
!
! I = -1
*LSS_-1
*ST_I
*J_<S2E1L3>
S2E1L1:
*LDA_B
S2E1L2:
*LB_PART LEN
S2E1L3:
*LDB_B
! %FINISH
! Move PART LEN bytes from PART AD to TO:
*CYD_0
*LDA_TO
*ST_DRH
*MV_L =DR
*ROT_32
*STUH_PART AD
! Now PART AD has been incremented by PART LEN:
! the B register has a copy of PART LEN:
! and a descriptor to the moved byte
! vector is in DRH.
!
!
! Set (new value of) TO to point just after the last byte in the
! output buffer. B register still gives actual number of
! bytes moved.
*CYD_0
*ROT_32
*STUH_TO
*JLK_<MARKNL>
SSOWN_OUTF_CUR = TO
RESIDUE LEN = RESIDUE LEN - PART LEN
FINISH ELSE I = -1
IF I#0 THEN PUT OUTPUT
REPEAT
IF SENDNL#0 THEN START
! Put out NL using simulated IOCP 5.
IF SSOWN_OUTF_CUR>=SSOWN_OUTF_END THEN PUT OUTPUT
BYTE INTEGER (SSOWN_OUTF_CUR) = NL
SSOWN_OUTF_CUR = SSOWN_OUTF_CUR + 1
PUT OUTPUT
FINISH
! -> RESULTZERO
!
!
RESULTZERO: !STANDARD EXIT
RESULT = 0
INEND: !SIGNAL INPUT ENDED
SIGNAL(2,140,0,FLAG)
END ; !OF IOCP
SYSTEMINTEGERFN JOBREADCH
!THIS IS REQUIRED BY THE JOB CONTROL TO PROVIDE TRUE READCH WHICH
!MUST NOT BE RE-ROUTED TO MASTERCHARIN. IT ACHIEVES THIS BY STATICISING
!SSOWN_CONTROLMODE, SETTING IT TO ZERO, CALLING READCH AND RE-SETTING SSOWN_CONTROLMODE
!THIS IS A HORRID MECHANISM AND MUST BE REPLACED
INTEGER HOLDCONTROLMODE, RES
HOLDCONTROLMODE = SSOWN_CONTROLMODE
SSOWN_CONTROLMODE = 0
READCH(RES)
SSOWN_CONTROLMODE = HOLDCONTROLMODE
RESULT = RES
END ; !OF JOBREADCH
SYSTEMINTEGERFN JOBNEXTCH
!SEE COMMENTS IN JOBREADCH ABOVE
INTEGER HOLDCONTROLMODE, RES
HOLDCONTROLMODE = SSOWN_CONTROLMODE
SSOWN_CONTROLMODE = 0
RES = NEXTCH
SSOWN_CONTROLMODE = HOLDCONTROLMODE
RESULT = RES
END ; !OF JOBNEXTCH
EXTERNALINTEGERFN INSTREAM
!RESULT IS STREAM NO
! CURRENTLY SELECTED FOR INPUT
INTEGER STREAM
STREAM = SSOWN_SSCOMREG(22)
IF STREAM = SSOWN_INDEFAULT THEN STREAM = 0
!STANDARD MAPPING
RESULT = STREAM
END ; !OF INSTREAM
EXTERNALINTEGERFN OUTSTREAM
INTEGER STREAM
STREAM = SSOWN_SSCOMREG(23)
IF STREAM = SSOWN_OUTDEFAULT THEN STREAM = 0
!STANDARD MAPPING
RESULT = STREAM
END ; !OF OUTSTREAM
EXTERNALINTEGERFN INPOS
!RESULT IS POSITION OF LAST CHARACTER READ FROM INPUT LINE
RESULT = IOCP(20,0)
END ; !OF INPOS
EXTERNALINTEGERFN OUTPOS
!RESULT IS POSITION OF LAST
! CHARACTER OUTPUT TO LINE
RESULT = IOCP(20,1); !OUTPOS ENTRY IN IOCP
END ; !OF OUTPOS
EXTERNALROUTINE TERMINATE
INTEGER DUMMY
DUMMY = IOCP(25,0)
END ; !OF TERMINATE
SYSTEMROUTINE SIM2(INTEGER EP, R1, R2, INTEGERNAME R3)
!PROVISIONAL SIM ROUTINE ONLY
! ACCEPTS CALLS ON EP 0 AND 1
! PROTEM
SWITCH SW(0 : 1)
INTEGER ARRAY IOCP PARM (1:3)
INTEGER DUMMY
! %INTEGER P, C
IF EP = 15 THEN -> SELECTIO; !ENTRY TO DO SELECTINPUT OR OUTPUT
UNLESS 0<=EP<=1 THEN START ; ! INVALID EP
R3 = -1
-> ERR
FINISH
-> SW(EP)
SW(0): !READ A RECORD FROM CURRENT
! STREAM INTO AREA AT R1
!RETURN LENGTH IN R3
! %FOR R3=0,1,159 %CYCLE
! C = IOCP(4,0); !READCH CALL ON IOCP
! BYTEINTEGER(R1+R3) = C; !PUT IT IN BUFFER
! %IF C = EM %START; !INPUT ENDED
! BYTEINTEGER(R1+R3+1) = NL; !ADD NEWLINE TO END
! R3 = R3+2
! -> ERR
! %FINISH
! %IF C = NL %THEN R3 = R3+1 %AND -> ERR
! !END OF RECORD
! %REPEAT
! !GOT HERE SO MUST BE LINE OF
! ! 160 CHAS
! R3 = 0; !TO INDICATE INCOMPLETE RECORD
! -> ERR
IOCP PARM (1) = R1
IOCP PARM (2) = R2
IOCP PARM (3) = ADDR (R3)
DUMMY = IOCP (26,ADDR(IOCP PARM(1)))
-> ERR
!
SW(1): !OUTPUT A RECORD AT R1 OF
! LENGTH R2
R3 = 0; !DEFAULT REPLY
! %IF SSOWN_OUTF_ACCESSROUTE = 9 %START
! !OUTPUT TO IT
! %IF R2 > 1 %THEN %START
! %FOR P=1,1,R2-1 %CYCLE
! DUMMY = IOCP(5,BYTEINTEGER(R1+P))
! !PRINTCH
! %REPEAT
! %FINISH
! DUMMY = IOCP(5,NL); !NEWLINE CALL
! %FINISH %ELSE %START; !OUTPUT TO FILE (OR SPOOLED
! ! DEVICE)
! %IF 12 # BYTEINTEGER(R1) # 13 %THEN BYTEINTEGER(R1) = NL
! !DEFAULT CONTROL CHARACTER
! %IF SSOWN_OUTF_CUR+R2 <= SSOWN_OUTF_END %START
! !ROOM IN FILE
! MOVE(R2,R1,SSOWN_OUTF_CUR)
! SSOWN_OUTF_CUR = SSOWN_OUTF_CUR+R2; !UPDATE POINTER
! -> ERR
! %FINISH
! %FOR P=0,1,R2-1 %CYCLE
! DUMMY = IOCP(5,BYTEINTEGER(R1+P))
! !PRINTCH
! %REPEAT
! %FINISH
IOCP PARM (1) = R1
IOCP PARM (2) = R2
IOCP PARM (3) = ADDR (R3)
DUMMY = IOCP (27,ADDR(IOCP PARM(1)))
-> ERR
SELECTIO: !SELECTINPUT OR OUTPUT
IF R1 = 0 THEN SELECTINPUT(R2) ELSE SELECTOUTPUT(R2)
R3 = 0; !WORKED OK IF GOT BACK HERE
!DOES NOT ALLOW FOR ERROR RECOVERY PROTEM
ERR:
END ; !OF SIM2
EXTERNALSTRINGFN INTERRUPT
!IF THERE IS AN OUTSTANDING
! MULTI-CHARACTER TERMINAL
! INTERRUPT IT
!RETURNS IT AND CLEARS IT-
! OTHERWISE RETURNS NULL STRING
INTEGER FLAG
STRING (15) RES
IF SSOWN_TTYPE # 2 THEN RESULT = ""; !NO MULTI-CHAR INTS FROM OPER
RES = SSOWN_IOSTAT_INTMESS
IF RES # "" THEN FLAG = X6{DCLEARINTMESSAGE}
RESULT = RES
END ; !OF INTERRUPT
EXTERNALROUTINE CLOSESTREAM(INTEGER CHAN)
INTEGER FLAG
IF 0<CHAN<=80 C
AND SSOWN_SSCOMREG(22)#CHAN#SSOWN_SSCOMREG(23) C
THEN FLAG = IOCP(16,CHAN)
!IGNORE IF INVALID OR CURRENT STREAM
END ; !OF CLOSESTREAM
EXTERNALROUTINE PROMPT(STRING (255) S)
SSOWN_PROMPTTEXT <- S
IF LENGTH(SSOWN_PROMPTTEXT) = 0 THEN START ; ! NULL PROMPT NOT ALLOWED BY COMMS - TEMP
LENGTH(SSOWN_PROMPTTEXT) = 1
CHARNO(SSOWN_PROMPTTEXT,1) = 127
FINISH
END ; !OF PROMPT
EXTERNALROUTINE FPRMPT(INTEGERNAME AD, LEN)
! %INTEGER I; ! Needed for all-IMP version.
LONG INTEGER DR; ! Needed for machine code version.
!***********************************************************************
!* *
!* This is the PROMPT routine for FORTRAN users. The call should be *
!* of the form: *
!* CALL FPRMPT('REPLY:',6) *
!* *
!***********************************************************************
IF LEN<=0 THEN START
LENGTH(SSOWN_PROMPTTEXT) = 1
CHARNO(SSOWN_PROMPTTEXT,1) = 127
!NULL PROMPT INVALID - TEMP
FINISH ELSE START
IF LEN>MAXPROMPTSIZE THEN LEN = MAXPROMPTSIZE
MOVE(LEN,ADDR(AD),ADDR(SSOWN_PROMPTTEXT)+1)
LENGTH(SSOWN_PROMPTTEXT) = LEN
! I = 1
! %WHILE I<=LEN %AND CHARNO(SSOWN_PROMPTTEXT,I)<128 %CYCLE
! I = I + 1
! %REPEAT
! %IF I<=LEN %THEN ETOI (ADDR(SSOWN_PROMPTTEXT)+1,LEN); ! This is a crude test to detect EBCDIC.
! Equivalent machine code using SWEQ:
DR = (LENGTHENI(X'18000000'!LEN)<<32) ! ADDR(AD)
*LD_DR
*SWEQ_L =DR ,127,0; ! %REF=0,%MASK=X'7F'.
*JAT_11,<NOBCDIC>; ! -> %IF residue length=0.
ETOI (ADDR(SSOWN_PROMPTTEXT)+1,LEN)
NOBCDIC:
FINISH
END ; !OF FPRMPT
!
INTEGER FN RQOUT (INTEGER T, AD)
CONST INTEGER GAP = 960
INTEGER TRIGGER, FLAG, R
IF T = AD THEN AD = -1
IF AD<0 THEN START
SSOWN_SSTTACT=1
R=X34{REQUESTOUTPUT} (T,AD)
SSOWN_SSTTACT=0
FINISHELSESTART
TRIGGER = T
CYCLE
TRIGGER = TRIGGER + GAP
IF TRIGGER>=SSOWN_IT_OUTLENGTH THEN TRIGGER = TRIGGER - SSOWN_IT_OUTLENGTH
IF TRIGGER>AD AND (AD>T OR TRIGGER<T+GAP) THEN TRIGGER = AD
SSOWN_SSTTACT = 1
R = X34{REQUESTOUTPUT} (T, TRIGGER)
SSOWN_SSTTACT = 0
REPEAT UNTIL SSOWN_SSTTKN#0 OR TRIGGER = AD
FINISH
IF SSOWN_SSTTKN#0 THEN START
CONSOLE (7,FLAG,FLAG)
SSOWN_SSTTKN = 0
FINISH
RESULT = R
END ; !OF RQOUT
!
SYSTEMROUTINE CONSOLE(INTEGER EP, INTEGERNAME START, LEN)
CONSTINTEGER MAXEP = 19
CONST INTEGER OPBIN = X'21'
SWITCH SW(1 : MAXEP)
INTEGER I, HOLD, FLAG, OPMESSAGELEN
STRING (255) S
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE # 0 START
BEGIN
STRING (15) IS, JS
IF BYTEINTEGER(ADDR(START)) # X'81' C
THEN IS = ITOS(START) ELSE IS = "UNASSIGNED"
IF BYTEINTEGER(ADDR(LEN)) # X'81' C
THEN JS = ITOS(LEN) ELSE JS = "UNASSIGNED"
NOTE("CONSOLE( ".ITOS(EP).", ".IS.", ".JS." )")
END ; !OF BEGIN - END BLOCK
FINISH
!**NOTEEND
FINISH
ROUTINE OPMESS(STRING (255) S)
TOJOURNAL(ADDR(S)+1,LENGTH(S)); !OUTPUT TO JOURNAL FILE
X20{DOPER}(SSOWN_OPERNO,S)
END ; !OF OPMESS
ROUTINE GETOPER
!GET INPUT FROM OPER CONSOLE
RECORDFORMAT PF(INTEGER DEST, SRCE, STRING (23) MESS)
RECORD (PF)P
STRINGNAME IN
BYTEINTEGERNAME LAST
IN == STRING(ADDR(SSOWN_INBUFF(0)))
IN = ""; !CLEAR IT OUT
IF SSOWN_PROMPTTEXT = COMMANDPROMPT C
THEN SSOWN_PROMPTTEXT = "Command:"
!NO NEWLINES ALLOWED IN OPER PROMPTS
X21{DOPERPROMPT}(SSOWN_OPERNO,SSOWN_PROMPTTEXT)
CYCLE
X23{DPOFF}(P)
IN = IN.P_MESS
LAST == BYTEINTEGER(ADDR(IN)+LENGTH(IN))
IF LAST = 133 THEN LAST = 10;!MAP TO IMP NEWLINE
EXIT IF LAST = NL
REPEAT
START = ADDR(SSOWN_INBUFF(1)); !START OF INPUT TEXT
LEN = SSOWN_INBUFF(0); !LENGTH OF INPUT TEXT
END ; !OF GETOPER
ROUTINE INITFEP
INTEGER FLAG, ISIZE
RECORD (RF)CONREC
RECORD (FRF) INFOREC
!CREATE INPUT AND OUTPUT
IF SSOWN_ITINLENGTH<320 THEN SSOWN_ITINLENGTH = 1024
IF SSOWN_ITOUTLENGTH<1024 THEN SSOWN_ITOUTLENGTH = 3072
SSOWN_IOSTAT == RECORD(SSOWN_AIOSTAT); !MAP OWN RECORD FOR INPUT STATUS
! BUFFER FILES
OUTFILE(ITFILENAME,SSOWN_ITINLENGTH+SSOWN_ITOUTLENGTH,0,8,SSOWN_AITBUFFER, C
FLAG)
IF FLAG#0 THEN START
FINFO (ITFILENAME,0,INFOREC,FLAG)
IF FLAG=0 THEN CONNECT (ITFILENAME,19,0,8,CONREC,FLAG)
IF FLAG # 0 THEN X30{DSTOP}(107)
!DISASTER CANNOT CREATE INPUT
! OUTPUT BUFFER
SSOWN_AITBUFFER = CONREC_CONAD
ISIZE = (INFOREC_SIZE*SSOWN_ITINLENGTH)//(SSOWN_ITINLENGTH+SSOWN_ITOUTLENGTH)
UNLESS 320<=ISIZE<=INFOREC_SIZE-1024 THEN ISIZE = INFOREC_SIZE>>2
SSOWN_ITINLENGTH = ISIZE
SSOWN_ITOUTLENGTH = INFOREC_SIZE - ISIZE
FINISH
SSOWN_IT == RECORD(SSOWN_AITBUFFER); !MAP CONTROL RECORD ONTO START OF BUFFER
SSOWN_IT = 0; !CLEAR RECORD
SSOWN_IT_INLENGTH = SSOWN_ITINLENGTH-64; !LEAVE ROOM FOR THE CONTROL RECORD
SSOWN_IT_OUTLENGTH = SSOWN_ITOUTLENGTH
SSOWN_IT_INBASE = SSOWN_AITBUFFER+64; !LENGTH OF CONTROL RECORD
SSOWN_IT_OUTBASE = SSOWN_IT_INBASE+SSOWN_IT_INLENGTH
!NOW ENABLE THE STREAMS
FLAG = X12{DENABLETERMINALSTREAM}(0,1,0,SSOWN_IT_INBASE,SSOWN_IT_INLENGTH, C
0)
IF FLAG # 0 THEN X30{DSTOP}(109)
FLAG = X12{DENABLETERMINALSTREAM}(1,1,0,SSOWN_IT_OUTBASE,SSOWN_IT_ C
OUTLENGTH,0)
IF FLAG # 0 THEN X30{DSTOP}(110)
INITJOURNAL
SSOWN_TTYPE = 2
END ; !OF INITFEP
ROUTINE TOBUFFER(INTEGER START, LEN, INTEGERNAME POS)
!PUTS DATA INTO OUTPUT BUFFER WRAPPING AROUND IF REQUIRED
!POS RETURNS THE POSITION OF THE NEXT FREE BYTE IN THE BUFFER
CONST INTEGER CR = 13
INTEGER HOLE, SIZE, TOAD, TOADLIM
INTEGER HOLDDRTB, HOLDDRA; ! These must stay together.
SIZE = LEN
HOLDDRTB = 0
TOAD = SSOWN_IT_OUTBASE+SSOWN_IT_OUTPOINTER
TOADLIM = SSOWN_IT_OUTBASE + SSOWN_IT_OUTLENGTH - 1
WHILE SIZE>0 CYCLE
IF SSOWN_OPMODE=OPTEXT AND SSOWN_FEPMODE=OPBIN THEN START
! CRs need inserting, but the FEP will not do it.
IF HOLDDRTB#0 THEN START
! Plant CR
! We can safely assume that TOAD<=TOADLIM
BYTE INTEGER (TOAD) = CR
IF TOAD=TOADLIM THEN TOAD = SSOWN_IT_OUTBASE ELSE TOAD = TOAD + 1
START = HOLDDRA
*LD_HOLDDRTB
*SWEQ_L =DR ,0,10; ! %MASK=0, %REF=NL
*J_<SCANL>
FINISH
*LDTB_X'18000000'
*LDA_START
*LDB_SIZE
SCANL: *SWNE_L =DR ,0,10; ! %MASK=0, %REF=NL
*STD_HOLDDRTB
LEN = HOLDDRA - START
FINISH
HOLE = TOADLIM - TOAD + 1
SIZE = SIZE - LEN
IF LEN <= HOLE START ; !ENOUGH ROOM
MOVE(LEN,START,TOAD)
IF LEN=HOLE THEN TOAD = SSOWN_IT_OUTBASE ELSE TOAD = TOAD + LEN
FINISH ELSE START
MOVE(HOLE,START,TOAD)
LEN = LEN-HOLE
MOVE(LEN,START+HOLE,SSOWN_IT_OUTBASE); !PUT REST AT START OF BUFFER
TOAD = SSOWN_IT_OUTBASE + LEN
FINISH
REPEAT
POS = TOAD - SSOWN_IT_OUTBASE
END ; !OF TOBUFFER
ROUTINE GETFEP
INTEGER I, INPOS, POS, FLAG
IF SSOWN_IOSTAT_INPOS = SSOWN_IT_INPOINTER START
!NO INPUT IN BUFFER
! SSOWN_IT_OUTBUSY = 1; !DONT PRINT OPER MESSAGE WHILE WAITING FOR INPUT
! **** **** We think that last line could come out **** ****
! **** **** when the TCP s/w is modified. **** ****
POS = SSOWN_IT_OUTPOINTER
TOBUFFER(ADDR(SSOWN_PROMPTTEXT)+1,LENGTH(SSOWN_PROMPTTEXT),POS)
SSOWN_SSTTACT = -1
FLAG = X33{REQUESTINPUT}(POS,SSOWN_IT_INPOINTER)
SSOWN_SSTTACT = 0
!GET INPUT CALL
IF FLAG # 0 THEN X30{DSTOP}(111)
FINISH
START = SSOWN_IT_INBASE+SSOWN_IT_INPOINTER
INPOS = SSOWN_IOSTAT_INPOS; !MUST FREEZE IT IN LOCAL
! VARIABLE TO AVOID CONFUSION
! IF IT CHANGES
IF INPOS > SSOWN_IT_INPOINTER START
!USE ALL INPUT - NO WRAPROUND
LEN = INPOS-SSOWN_IT_INPOINTER
SSOWN_IT_INPOINTER = INPOS
FINISH ELSE START ; !WRAP AROUND SO ONLY USE PART
! TO END OF BUFFER
LEN = SSOWN_IT_INLENGTH-SSOWN_IT_INPOINTER
SSOWN_IT_INPOINTER = 0
FINISH
IF LEN > 1 START
! **** What follows is a "scan for NL" and it would be
! **** quicker in machine code.
FOR I=0,1,LEN-2 CYCLE ; !ONLY RETURN ONE LINE AT ATIME
IF BYTEINTEGER(START+I) = NL START
LEN = I+1
SSOWN_IT_INPOINTER = START+LEN-SSOWN_IT_INBASE;!TO SHOW HOW MUCH WE'VE USED
EXIT ; !NEWLINE FOUND
FINISH
REPEAT
FINISH
SSOWN_IT_OUTBUSY = 0
! **** **** The final two statements of this routine **** ****
! **** **** can lead to the whole of OUTFEP being **** ****
! **** **** executed without any protection from **** ****
! **** **** asynchronous interrupts arriving. If a **** ****
! **** **** further INT:T or operator message should **** ****
! **** **** arrive, that could cause trouble. **** ****
FLAG = 0
IF SSOWN_IT_INTTWAITING # 0 THEN CONSOLE(12,FLAG,FLAG)
!INT:T WAITING
IF SSOWN_IT_OMWAITING # 0 THEN CONSOLE(6,FLAG,FLAG)
!PRINT MESSAGE THAT WAS WAITING
END ; !OF GETFEP
INTEGERFN FREESPACE
INTEGER RES
RES = SSOWN_IT_LASTFREE-SSOWN_IT_OUTPOINTER
IF RES <= 0 THEN RES = RES+SSOWN_IT_OUTLENGTH
RES = RES-MAXPROMPTSIZE
IF RES < 0 THEN RES = 0
RESULT = RES
END ; !OF FREESPACE
ROUTINE OUTFEP(INTEGER FROM, LEN)
INTEGER FREE, POS, FLAG, TRIGGER
RETURN IF LEN <= 0
IF SSOWN_SSTTHIDE=0 THEN START
SSOWN_IT_OUTBUSY = 1
IF EP # 10 THEN TOJOURNAL(FROM,LEN); !OUTPUT TO RECALL FILE
!UNLESS GRAPHICS OUTPUT
!UNLESS OP MESSAGE OR INT:T
CYCLE
FREE = FREESPACE; !HOW MUCH LEFT
EXIT IF LEN <= FREESPACE; !ENOUGH ROOM FOR IT ALL
IF 6 # EP # 12 THEN SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS
TOBUFFER(FROM,FREE,POS); !POS POINTS TO BYTE AFTER END OF INSERTED TEXT
TRIGGER = POS-SSOWN_IT_OUTLENGTH>>2; !SEND 3/4 OF BUFFER
IF TRIGGER < 0 THEN TRIGGER = TRIGGER+SSOWN_IT_OUTLENGTH
SSOWN_IT_OUTPOINTER = POS
LEN = LEN-FREE
FROM = FROM+FREE
IF 6 # EP # 12 THEN ALLOW INTERRUPTS; !EXCEPT WHEN PRINTING OPER MESSAGES
FLAG = RQOUT(POS,TRIGGER)
IF FLAG < 0 THEN X30{DSTOP}(115)
SSOWN_IT_LASTFREE = FLAG
EXIT IF SSOWN_SSTTHIDE#0
REPEAT
IF LEN > 0 AND SSOWN_SSTTHIDE=0 START ; !SOME LEFT
IF 6 # EP # 12 THEN SSOWN_SSINHIBIT = 1
TOBUFFER(FROM,LEN,POS)
SSOWN_IT_OUTPOINTER = POS
FLAG = RQOUT(POS,-1)
IF FLAG < 0 THEN X30{DSTOP}(115)
SSOWN_IT_LASTFREE = FLAG
IF 6 # EP # 12 THEN ALLOWINTERRUPTS
FINISH
SSOWN_IT_OUTBUSY = 0
FINISH
! **** **** The final two statements of this routine **** ****
! **** **** can lead to the whole of OUTFEP being **** ****
! **** **** executed without any protection from **** ****
! **** **** asynchronous interrupts arriving. If a **** ****
! **** **** further INT:T or operator message should **** ****
! **** **** arrive, that could cause trouble. **** ****
FLAG = 0
IF SSOWN_IT_OMWAITING # 0 AND EP # 6 C
THEN CONSOLE(6,FLAG,FLAG)
IF SSOWN_IT_INTTWAITING # 0 AND EP # 12 C
THEN CONSOLE(12,FLAG,FLAG)
END ; !OF OUTFEP
ROUTINE KILL INPUT
INTEGER FLAG, CURSOR
RETURN UNLESS SSOWN_TTYPE = 2
FLAG = X10{DDISABLETERMINALSTREAM1}(CURSOR,0,5)
!ABORT INPUT
IF FLAG # 0 THEN X30{DSTOP}(118)
FLAG = X12{DENABLETERMINALSTREAM}(0,SSOWN_FEPMODE,0,SSOWN_IT_INBASE,SSOWN_IT_ C
INLENGTH,0)
IF FLAG # 0 THEN X30{DSTOP}(119)
SSOWN_IT_INPOINTER = SSOWN_IOSTAT_INPOS
END ; !OF KILL INPUT
ROUTINE KILLOUTPUT
INTEGER FLAG, CURSOR
RETURN UNLESS SSOWN_TTYPE = 2
SSOWN_IT_OUTBUSY = 1; !TO IGNORE OPER MESSAGES
! DURING KILL OUTPUT
FLAG = X10{DDISABLETERMINALSTREAM1}(CURSOR,1,5)
!ABORT OUTPUT
IF FLAG # 0 THEN X30{DSTOP}(114)
FLAG = X12{DENABLETERMINALSTREAM}(1,SSOWN_FEPMODE,0,SSOWN_IT_OUTBASE,SSOWN_IT_ C
OUTLENGTH,0)
IF FLAG # 0 THEN X30{DSTOP}(116)
SSOWN_IT_OUTPOINTER = 0
SSOWN_IT_LASTFREE = 0
SSOWN_IT_OUTBUSY = 0; !OFF WE GO AGAIN
END ; !OF KILL OUTPUT
ROUTINE SETMODE(INTEGER START, LEN)
INTEGER FLAG, CURSOR
RETURN IF LEN <= 0
SSOWN_IT_OUTBUSY = 1; !TO HOLD OFF OPER MESSAGES
IF SSOWN_IT_OUTPOINTER # 0 START ; ! THIS IS RUBBISH, IF IT'S A TEST FOR AN EMPTY BUFFER.
FLAG = 0; !PROTEM - AWAITING A CORRECTION FROM BRIAN GILMORE
FLAG = RQOUT(SSOWN_IT_OUTPOINTER,SSOWN_IT_OUTPOINTER-1); ! BUT IF WE TAKE OUT
! THE TEST ABOVE, WE WILL NEED TO IMPROVE THIS.
!CLEAR OUTPUT BUFFER
IF FLAG < 0 THEN X30{DSTOP}(115)
FINISH
FLAG = X10{DDISABLETERMINALSTREAM1}(CURSOR,1,4); !DISABLE OUTPUT
IF FLAG # 0 THEN X30{DSTOP}(114)
FLAG = X12{DENABLETERMINALSTREAM}(1,X'31',0,SSOWN_IT_OUTBASE,SSOWN_IT_ C
OUTLENGTH,0)
!ENABLE FOR CONTROL OUTPUT
IF FLAG # 0 THEN X30{DSTOP}(116)
MOVE(LEN,START,SSOWN_IT_OUTBASE); !MOVE IN THE CONTROL MESSAGE
FLAG = RQOUT(LEN,LEN-1); !SEND OUTPUT AND AWAIT TERMINATION
IF FLAG < 0 THEN X30{DSTOP}(115)
FLAG = X10{DDISABLETERMINALSTREAM1}(CURSOR,1,4)
IF FLAG # 0 THEN X30{DSTOP}(114)
FLAG = X12{DENABLETERMINALSTREAM}(1,SSOWN_FEPMODE,0,SSOWN_IT_OUTBASE,SSOWN_IT_ C
OUTLENGTH,0)
!RE-ENABLE FOR NORMAL OUTPUT
IF FLAG # 0 THEN X30{DSTOP}(116)
SSOWN_IT_OUTPOINTER = 0
SSOWN_IT_LASTFREE = 0
SSOWN_IT_OUTBUSY = 0
END ; !OF SETMODE
UNLESS 1 <= EP <= MAXEP THEN -> ERR
!IGNORE INVALID EPS
-> SW(EP)
SW(1): !GET INPUT
SSOWN_SSTTHIDE = 0
IF SSOWN_TTYPE = 0 THEN GETOPER
IF SSOWN_TTYPE = 2 THEN GETFEP
TOJOURNAL(ADDR(SSOWN_PROMPTTEXT)+1,LENGTH(SSOWN_PROMPTTEXT))
!PROMPT TO JOURNAL FILE
TOJOURNAL(START,LEN); !INPUT TO JOURNAL FILE
-> ERR
SW(2): !PUT OUTPUT
IF LEN > 0 THEN START
IF LEN > 1 AND SSOWN_OUTBUFF(LEN) = NL THEN START
! REMOVE TRAILING SPACES UNLESS ONLY A NEWLINE OR NOT ENDING WITH NL
! **** We could use TRAILSPACES here instead of the %CYCLE,
! **** but it probably isn't worth it.
FOR I=LEN-1,-1,1 CYCLE ; !LOCATE LAST PRINTABLE CHAR ON LINE
IF SSOWN_OUTBUFF(I) # ' ' THEN EXIT
REPEAT
!I NOW POINTS TO HIGHEST PRINTABLE CHARACTER
IF I = 1 AND SSOWN_OUTBUFF(1) = ' ' THEN I = 0
!AMBIGUOUS VALUE
LEN = I+1
SSOWN_OUTBUFF(LEN) = NL
FINISH
I = 0
IF SSOWN_TTYPE=2 THEN START ; ! OUTFEP CAN TAKE ALL 73 CHAS
! IGNORE 1 CHAR LINES IF OPTION SELECTED
IF (LEN=1 AND SSOWN_OUTBUFF(1)#NL) OR LEN>SSOWN_SSNOBLANKLINES THEN START
OUTFEP(ADDR(SSOWN_OUTBUFF(1)),LEN)
FINISH
FINISH ELSE IF LEN>1 THEN START ; ! ALWAYS IGNORE BLANK LINES TO OPER
SSOWN_OUTBUFF(0) = LEN
OPMESS(STRING(ADDR(SSOWN_OUTBUFF(0))))
FINISH
FINISH
START = ADDR(SSOWN_OUTBUFF(1)); !START OF OUTPUT BUFFER
LEN = 133; !MAX LENGTH OF BUFFER
-> ERR
SW(3): !SELECT IT
-> ERR
SW(4): !SELECT OPER
SSOWN_OPERNO = START
!START CONTAINS SSOWN_OPERNO
SSOWN_AITBUFFER = GETSPACE(64)
SSOWN_IT == RECORD(SSOWN_AITBUFFER)
SSOWN_IT = 0
INITJOURNAL
-> ERR
SW(5): !SELECT FEP
INITFEP
-> ERR
SW(6): !PRINT OPERATOR MESSAGE
-> ERR UNLESS SSOWN_TTYPE = 2
!EITHER USING OPER CONSOLE OR
! NOT YET CONNECTED TO FEP OR
! BATCH JOB
IF START # 0 START ; !BROADCAST MESSAGE
IF SSOWN_BOPMESSSTART = 0 THEN SSOWN_BOPMESSSTART = START
!NONE OUTSTANDING
SSOWN_BOPMESSLEN = SSOWN_BOPMESSLEN+LEN
FINISH
-> ERR IF SSOWN_INHIBITMESSAGES # 0; !TEMPORARY INHIBIT
IF SSOWN_IT_OUTBUSY#0 THEN START
SSOWN_IT_OMWAITING = 1
-> ERR
FINISH
SSOWN_IT_OMWAITING=0; !STRAIGHT AWAY TO AVOID RACE WITH INT:T
BEGIN
RECORD FORMAT FHDRF (INTEGER NEXT FREE BYTE, C
TXT REL ST, MAX BYTES, ZERO, C
SEMA, DATE, NEXT CYCLIC, READ TO)
RECORD (FHDRF)NAME H1
INTEGER CONSEG, GAP, AVAILABLE, MOUT
BYTEINTEGERARRAY OPERBUFF(0 : 2001)
ROUTINE XNL (INTEGER NAME L)
INTEGER I, C, P
IF OPERBUFF(L)=NL THEN L = L - 1
IF 0<L<=72 THEN START
C = 0
FOR I=1,1,L CYCLE
IF OPERBUFF(I)=NL THEN START
P = I
C = C + 1
FINISH
REPEAT
IF C=1 THEN OPERBUFF (P) = ' '
FINISH
END
MOUT = 0
OPERBUFF(0) = NL
IF SSOWN_BOPMESSSTART # 0 START ; !BROADCAST MESSAGE WAITING
IF SSOWN_BROADCASTFILEBASE = 0 START ; !NOT YET CONNECTED
CONSEG = 0
GAP = 0
!NOTE USE OF X7{DCONNECT} HERE BECAUSE OTHERWISE WE
!MAY INTERRUPT A CONNECT SEQUENCE FOR ANOTHER FILE.
!THIS TEMPORARY ARRANGEMENT IS TO BE IMPROVED.
! (There would be no advantage in CONNECTing for sequential
! access).
FLAG = X7{DCONNECT}("VOLUMS","BROADCAST",-1,9,0,CONSEG, C
GAP)
IF FLAG=0 THEN SSOWN_BROADCASTFILEBASE = CONSEG<<SEGSHIFT
FINISH
IF SSOWN_BROADCASTFILEBASE#0 THEN START
H1 == RECORD (SSOWN_BROADCASTFILEBASE)
IF SSOWN_BOPMESSLEN>=0 THEN AVAILABLE = SSOWN_BOPMESSLEN ELSE START
AVAILABLE = H1_MAX BYTES - SSOWN_BOPMESSSTART
SSOWN_BOPMESSLEN = SSOWN_BOPMESSLEN + H1_MAX BYTES - H1_TXT REL ST
FINISH
MOVE (AVAILABLE, C
SSOWN_BROADCASTFILEBASE+SSOWN_BOPMESSSTART, C
ADDR(OPERBUFF(1)))
MOVE (SSOWN_BOPMESSLEN - AVAILABLE, C
SSOWN_BROADCASTFILEBASE+H1_TXT REL ST, C
ADDR(OPERBUFF(1))+AVAILABLE)
XNL (SSOWN_BOPMESSLEN)
OUTFEP(ADDR(OPERBUFF(0)),SSOWN_BOPMESSLEN+1)
MOUT = 1
FINISH
FINISH
CYCLE
OPMESSAGELEN = 2000; !MAXIMUM SPACE FOR MESSAGE
FLAG = X16{DMESSAGE2}(SSOWN_SSOWNER,OPMESSAGELEN,0,0,SSOWN_SSOWNFSYS, C
ADDR(OPERBUFF(1)))
IF OPMESSAGELEN = 0 OR FLAG # 0 THEN EXIT
!NO MESSAGE LEFT OR FAILURE
XNL (OPMESSAGELEN)
OUTFEP(ADDR(OPERBUFF(0)),OPMESSAGELEN+1)
MOUT = 1
REPEAT
IF MOUT#0 THEN OUTFEP (ADDR(OPERBUFF(0)),1)
SSOWN_BOPMESSSTART = 0
SSOWN_BOPMESSLEN = 0
END ; !OF BEGIN-END BLOCK
-> ERR
SW(7): !KILL OUTPUT
KILL OUTPUT
-> ERR
SW(8): !KILL INPUT
-> ERR UNLESS SSOWN_TTYPE = 2; !ONLY IF USING FEP
SSOWN_IT_INPOINTER = SSOWN_IOSTAT_INPOS
-> ERR
SW(9): !FORCE OUT OUTSTANDING OUTPUT
-> ERR UNLESS SSOWN_TTYPE = 2 AND SSOWN_IT_OUTPOINTER # 0
!NO CONSOLE
IF START=0 THEN I = -1 ELSE IF SSOWN_IT_OUTPOINTER = 0 THEN C
I = SSOWN_IT_OUTLENGTH - 1 ELSE I = SSOWN_IT_OUTPOINTER - 1
! That decides whether to await reply from REQUESTOUTPUT or not.
FLAG = RQOUT(SSOWN_IT_OUTPOINTER,I)
!PUT OUT ALL CURRENT OUTPUT
-> ERR
SW(10): !DIRECT OUTPUT CALL FOR GRAPHICS
! SW10: used to be here.
-> ERR UNLESS SSOWN_TTYPE = 2; !MUST BE OUTPUTING TO TELETYPE
OUTFEP(START,LEN)
-> ERR
SW(11): !DIRECT OUTPUT CALL FROM IOCP23
! NO LONGER USED.
! -> ERR %IF LEN <= 0
! %IF SSOWN_TTYPE = 2 %THEN -> SW10
! S = ""
! %FOR I=START,1,START+LEN-1 %CYCLE
! HOLD = BYTEINTEGER(I)
! S = S.TOSTRING(HOLD)
! %IF HOLD = 10 %OR LENGTH(S) = 255 %START
! OPMESS(S)
! S = ""
! %FINISH
! %REPEAT
-> ERR
SW(12): !INT:T
-> ERR UNLESS SSOWN_TTYPE = 2; !NOT FROM I.T.
IF SSOWN_IT_OUTBUSY#0 THEN START
SSOWN_IT_INTTWAITING = 1
-> ERR
FINISH
SSOWN_IT_INTTWAITING=0; !STRAIGHT AWAY - TO AVOID A RACE WITH OPER MESSAGE
S = "
T=".ITOS(INT(CPUTIME-SSOWN_OLDCPUTIME))." PT=".ITOS( C
PAGETURNS-SSOWN_OLDPAGETURNS)." U=".ITOS(INTEGER(AUSERS)-SYSPROCS)
!**FUNDSSTART
IF FUNDS ON#0 THEN START
IF SCARCEWORD&X'FF'>=SCARCEWORD>>24 START
! INTERACTIVE USERS >= SCARCE LIMIT
S=S." **Resources are Scarce."
FINISH
FINISH
!**FUNDSEND
S=S."
"
OUTFEP(ADDR(S)+1,LENGTH(S))
-> ERR
SW(13): !GET BUFFER AND IOSTAT ADDRESSES
IF SSOWN_TTYPE=2 C
AND SSOWN_INF_ACCESSROUTE=9=SSOWN_OUTF_ACCESSROUTE C
AND SSOWN_CONTROLMODE=0 C
THEN START
! ONLY IF RUNNING FROM INTERACTIVE TERMINAL
! AND BOTH CURRENT STREAMS POINT TO TERMINAL
START = SSOWN_AITBUFFER
LEN = SSOWN_AIOSTAT
FINISH ELSE START
START = 0
FINISH
-> ERR
SW(14): !RESET SSOWN_IT_JNBASE
IF SSOWN_AITBUFFER # 0 THEN SSOWN_IT_JNBASE = IMOD(SSOWN_IT_JNBASE)
-> ERR
SW(15): !SETMODE REQUEST
-> ERR UNLESS SSOWN_TTYPE = 2; !ONLY WORKS FOR INTERACTIVE TERMINAL
SETMODE(START,LEN)
-> ERR
SW(17): !NEW SETMODE REQUEST
-> ERR UNLESS SSOWN_TTYPE = 2; !ONLY WORKS FOR INTETACTIVE TERMINAL
SSOWN_FEPMODE = LEN
SETMODE(START+1,BYTEINTEGER(START))
-> ERR
SW(18): !SELECT OUTPUT MODE, 1=ISO, #1=BINARY
-> ERR UNLESS SSOWN_TTYPE = 2
IF START = 1 THEN I = OPTEXT ELSE I = OPBIN
IF I = SSOWN_OPMODE THEN -> ERR
SSOWN_OPMODE = I
IF SSOWN_FEPMODE=OPBIN THEN -> ERR
SSOWN_IT_OUTBUSY = 1
IF SSOWN_IT_OUTPOINTER # 0 THEN START
FLAG = 0; !TEMP
FLAG = RQOUT(SSOWN_IT_OUTPOINTER,SSOWN_IT_OUTPOINTER-1)
IF FLAG < 0 THEN X30{DSTOP}(115)
FINISH
FLAG = X10{DDISABLETERMINALSTREAM1}(HOLD,1,4)
IF FLAG # 0 THEN X30{DSTOP}(114)
FLAG = X12{DENABLETERMINALSTREAM}(1,OPBIN,0,SSOWN_IT_OUTBASE,SSOWN_IT_OUTLENGTH,0)
IF FLAG # 0 THEN X30{DSTOP}(116)
SSOWN_FEPMODE = OPBIN
SSOWN_IT_OUTPOINTER = 0
SSOWN_IT_LASTFREE = 0
SSOWN_IT_OUTBUSY = 0
-> ERR
SW(19):
KILL INPUT
-> ERR
ERR:
END ; !OF CONSOLE
SYSTEMROUTINE TOJOURNAL(INTEGER FROM, LEN)
INTEGER HOLE
RETURN IF SSOWN_IT_JNBASE <= 0 OR LEN <= 0; !NOJOURNAL OR NO TEXT
IF LEN > 4096 THEN LEN = 4096; !TRUNCATE LONG REQUESTS
CYCLE
HOLE = SSOWN_IT_JNMAX - SSOWN_IT_JNCUR
IF LEN<HOLE THEN HOLE = LEN
MOVE (HOLE, FROM, SSOWN_IT_JNCUR)
LEN = LEN - HOLE
EXIT IF LEN=0
SSOWN_IT_JNCUR = SSOWN_IT_JNBASE + 32
FROM = FROM + HOLE
REPEAT
SSOWN_IT_JNCUR = SSOWN_IT_JNCUR + HOLE
IF SSOWN_IT_JNCUR>=SSOWN_IT_JNMAX THEN SSOWN_IT_JNCUR = SSOWN_IT_JNBASE + 32
BYTEINTEGER(SSOWN_IT_JNCUR) = 255; !CURRENT END
END ; !OF TOJOURNAL
IF NOTES ON#0 THEN START
!**NOTESTART
SYSTEMROUTINE NOTE(STRING (255) S)
S = "
** ".S."
"
TOJOURNAL(ADDR(S)+1,LENGTH(S))
END ; !OF NOTE
!**NOTEEND
FINISH
!
!
! - END OF IOCP TEXT ]
!
! [ START OF EFILE TEXT -
SYSTEMINTEGERFN FDMAP(INTEGER CHAN)
!RETURNS THE ADDRESS OF THE
! REQUESTED FILE DESCRIPTOR -
! IF ANY
!OTHERWISE 0 IF NOT DEFINED
SSOWN_SSOPENUSED = 1; !TEMPORARY
RESULT = SSOWN_SSFDMAP(CHAN)
END ; !OF FDMAP
SYSTEMINTEGERFN DEVCODE(STRING (16) DEVICE)
!RETURNS -1 FOR INVALID DEVICE OTHERWISE DEVICE CODE
RECORD (RF)RR
INTEGER I, FLAG, SPECIAL
STRING (16) REST
STRING (147) ARRAYFORMAT DEVARRAYAF(1 : 254)
STRING (147) ARRAYNAME DEVARRAY
SPECIAL = 0; !NOT A SPECIAL DEVICE - DEFAULT
IF DEVICE="" OR CHARNO(DEVICE,1)#'.' THEN RESULT = 0
CHOPLDR (DEVICE,1)
!INVALID DEVICE CODE
UCTRANSLATE (ADDR(DEVICE)+1, LENGTH(DEVICE))
IF DEVICE = "LP" THEN RESULT = 127; !SPECIAL CASE - VERY COMMON
IF DEVICE = "TEMP" OR DEVICE = "NULL" THEN RESULT = 0
IF (DEVICE -> REST.("BPP") C
OR DEVICE -> REST.("SGP")) C
AND REST="" C
THEN START
CHOPLDR (DEVICE,1)
SPECIAL = X'100' {SMH}
FINISH
IF SSOWN_DEVARRAYBASE = 0 START ; !TRY AND CONNECT SPOOLR CONTROL FILE
CONNECT(SPOOLERCFILE,9,0,8,RR,FLAG); !CONNECT READ WITH WRITE ALLOWED ELSEWHER, PREVENT DISCONNECT
IF FLAG # 0 THEN RESULT = -FLAG
SSOWN_MAXDEVARRAY = INTEGER(RR_CONAD+24); !NO OF QUEUES
SSOWN_DEVARRAYBASE = RR_CONAD+RR_DATASTART
FINISH
DEVARRAY == ARRAY(SSOWN_DEVARRAYBASE,DEVARRAYAF)
FOR I=SSOWN_MAXDEVARRAY,-1,1 CYCLE
IF DEVARRAY(I) = DEVICE THEN RESULT = I!SPECIAL
REPEAT
RESULT = -1; !INVALID DEVICE
END ; !OF DEVCODE
SYSTEMSTRINGFN DEVNAME(INTEGER CODE)
STRING (147) ARRAYFORMAT DEVARRAYAF(1 : 254)
STRING (147) ARRAYNAME DEVARRAY
STRING (16) RES
INTEGER SPECIAL
SPECIAL = CODE&X'100'; {SMH} !IF SET MUST BE A SPECIAL DEVICE
CODE = CODE&X'FF' {SMH}
IF CODE = 127 THEN RESULT = ".LP"
IF 0 < CODE <= SSOWN_MAXDEVARRAY THEN START
DEVARRAY == ARRAY(SSOWN_DEVARRAYBASE,DEVARRAYAF)
RES = DEVARRAY(CODE)
IF SPECIAL # 0 START
IF LENGTH(RES)>=2 AND CHARNO(RES,2)='P' THEN START
IF CHARNO(RES,1)='G' THEN RES = "S".RES
IF CHARNO(RES,1)='P' THEN RES = "B".RES
FINISH
FINISH
RESULT = ".".RES
FINISH
RESULT = ""
END ; !OF DEVNAME
! The following %FUNCTION, %ROUTINEs and %MAP were added to allow the FORTRAN
! 77 OPEN and CLOSE statements access to the Subsystem FD table.
! Mike Brown October 1981.
!
SYSTEM ROUTINE SET OPEN USED
! Used when a file is opened, but not by OPEN. SSOWN_SSOPENUSED must be set,
! or else TIDYFILES is not called from AFTERCOMMAND to close open
! streams after the run of the compiled program.
SSOWN_SSOPENUSED = 1
END
!
SYSTEM INTEGER FN FDADDR
! Returns the address of the FD Subsystem FD table.
RESULT = ADDR(SSOWN_FD(1))
END
!
SYSTEM ROUTINE SETTOPFD (INTEGER FDNO)
! Allows a new entry in the FD table set from FORTRAN 77 OPEN to be the
! current top FD entry number. Required when TIDYFILES does a CLOSE.
IF FDNO>SSOWN_TOPFD THEN SSOWN_TOPFD = FDNO
END
!
SYSTEM INTEGER MAP MAPSSFD (INTEGER DSNUM)
! Allows two-way access to the SSOWN_SSFDMAP pointer table.
RESULT == SSOWN_SSFDMAP (DSNUM)
END
SYSTEMROUTINE DEFINE(INTEGER CHAN, C
STRING (31) IDEN, INTEGERNAME AFD, FLAG)
RECORD (DRF)DATADR
RECORD (FDF)NAME F
INTEGER I, DEVC
STRING (16) REST
FLAG = 0; !DEFAULT
UNLESS 0 < CHAN <= 99 THEN FLAG = 223 AND -> ERR
!INVALID CHANNEL
AFD = SSOWN_SSFDMAP(CHAN)
IF AFD # 0 START ; !CHANNEL ALREADY DEFINED
F == RECORD(AFD)
IF F_STATUS # 0 THEN FLAG = 265 AND -> ERR
!CHANNEL OPEN
FINISH ELSE START
FOR I=1,1,MAXFD CYCLE ; !LOOK FOR EMPTY RECORD
IF SSOWN_FD(I)_DSNUM = 0 START
!EMPTY CELL FOUND
AFD = ADDR(SSOWN_FD(I)_LINK)
SSOWN_SSFDMAP(CHAN) = AFD
F == SSOWN_FD(I)
IF I > SSOWN_TOPFD THEN SSOWN_TOPFD = I
!HIGHEST FD USED SO FAR
EXIT
FINISH
IF I = MAXFD THEN FLAG = 165 AND -> ERR
!TOO MANY DEFINITIONS
REPEAT
FINISH
F = 0; !CLEAR WHOLE RECORD
F_DSNUM = CHAN
F_IDEN = IDEN
F_RECTYPE = 2; !DEFAULT RECTYPE=V
F_MINREC = 1
F_MAXREC = 1024
F_MAXSIZE = SEGSIZE; !DEFAULT MAXSIZE
IF IDEN#"" AND CHARNO(IDEN,1)='.' THEN START
IF IDEN=".IN" THEN F_ACCESSROUTE = 1 C
ELSE IF IDEN=".OUT" THEN F_ACCESSROUTE = 2 C
ELSE IF IDEN=".TT" THEN START
UNLESS 90<=CHAN<=91 THEN START
FLAG = 264
-> CLEAR
FINISH
! ONLY ALLOW .TT FOR CHANS 90 AND 91 PROTEM
F_ACCESSROUTE = 9
F_MAXREC = 160; !MAX FOR STREAM OUTPUT BUFFER
! PROTEM
FINISH ELSE START
DEVC = DEVCODE(IDEN)
IF DEVC<0 THEN START ; ! INVALID DEVICE CODE
FLAG = 264
-> CLEAR
FINISH
IF IDEN->REST.(".LP") AND REST="" THEN F_FLAGS = F_FLAGS!16
!INTERPRET FE CHAS
IF DEVC#0 THEN START ; ! NOT .NULL OR .TEMP
F_MODEOFUSE = 1
F_MAXREC = 160
FINISH
F_DEVCODE = DEVC & 255
F_F4 = DEVC>>8
F_TEMPIDEN = "T#".NEXTTEMP
F_ACCESSROUTE = 8
IF IDEN=".NULL" THEN F_ACCESSROUTE = 10; ! SPECIAL CASE FOR ".NULL"
FINISH
FINISH ELSE START
IF IDEN = "*" START ; !ALIEN DATA
SUPPLYDATADESCRIPTOR(DATADR)
F_ACCESSROUTE = 11; !ALIEN DATA
F_DATASTART = DATADR_AD
F_MAXSIZE = DATADR_LENGTH&X'FFFFFF'
FINISH ELSE START ; !MUST BE A FILENAME
IF 'a'<=CHARNO(IDEN,1)<='z' C
OR 'A'<=CHARNO(IDEN,1)<='Z' C
THEN FLAG=CHECKFILENAME(IDEN,15) C
ELSE FLAG=220 {invalid filename}
-> CLEAR IF FLAG # 0
F_ACCESSROUTE = 8
FINISH
FINISH
F_MODE = 11; !PROTEM
F_VALIDACTION = 127; !ALLOW ALL ACTIONS
-> ERR
CLEAR:
F_DSNUM = 0
SSOWN_SSFDMAP(CHAN) = 0
ERR:
SSOWN_SSFNAME = IDEN
END ; !OF DEFINE
SYSTEM ROUTINE SET IO DEFAULT (INTEGER NAME D, INTEGER I)
INTEGER AFD, R
RECORD (FDF)NAME F
CYCLE
AFD = SSOWN_SSFDMAP (I)
RETURN IF AFD = 0
F == RECORD (AFD)
R = F_ACCESSROUTE
EXIT IF R#6
I = F_ASVAR
REPEAT
IF R=5 OR 8<=R<=10 THEN D = I
END
SYSTEMROUTINE TIDYFILES
STRING (11) BOUTPUT
RECORD (FDF)NAME F
RECORD (RF)RR
RECORD (DIRINFF)NAME DIRINF
INTEGER AFD, FLAG, I
IF SSOWN_TIDYFSTARTED = 0 START ; !INITIAL ENTRY
DIRINF == RECORD(SSOWN_SSADIRINF)
SSOWN_TIDYFSTARTED = 1; !TO SHOW WE'VE BEEN HERE
IF BATCHREASON#SSOWN_SSREASON#TESTREASON START ; !OPER OR FEP TERMINAL
DEFINE(90,".TT",AFD,FLAG)
DEFINE(91,".TT",AFD,FLAG)
FINISH
IF SSOWN_SSREASON=BATCHREASON THEN START ; !BATCH JOB
CONNECT(DIRINF_JOBDOCFILE,0,0,(SSOWN_SSOWNFSYS<<8)!X'80',RR, C
FLAG)
IF FLAG # 0 THEN X30{DSTOP}(128); !CANNOT CONNECT BATCH JOB FILE
!TO ENSURE WE CONNECT THE CONTROL FILE ON THE RIGHT FSYS
IF INTEGER(RR_CONAD+24) # 0 C
THEN SSOWN_CONTROLMODE = 0 ELSE SSOWN_CONTROLMODE = 1
!DETACH SETS BIT IN THIS WORD
!DETACHJOB AND CARD INPUT DO NOT
DEFINE(90,DIRINF_JOBDOCFILE,AFD,FLAG)
BOUTPUT = "JO#".SUBSTRING(DIRINF_JOBDOCFILE,8,LENGTH( C
DIRINF_JOBDOCFILE))
IF NEWCONNECT=0 THEN START
OUTFILE(BOUTPUT,K4,0,0,I,FLAG);!CHECK THAT WE CAN CREATE IT.
FINISH ELSE START
OUTFILE(BOUTPUT,K4,-1,0,I,FLAG);!CHECK THAT WE CAN CREATE IT
!BUT DON'T CONNECT IT.
FINISH
IF FLAG # 0 START
DEFINE(91,".LP",AFD,I)
SELECTOUTPUT(91)
PRINTSTRING("Batch Job ".DIRINF_JOBNAME. C
" Failure to create output file - ". C
FAILUREMESSAGE(FLAG))
BATCHSTOP(0)
FINISH
IF NEWCONNECT=0 THEN START
DISCONNECT (BOUTPUT, FLAG); ! Ensures that file is permanent
! and should survive a crash for
! SPOOLR to list any contents.
FINISH
DEFINE(91,BOUTPUT,AFD,FLAG)
F == RECORD(AFD)
F_MAXSIZE = X'100000'; !LARGE SIZE FOR BATCH OUTPUT FILE
SSOWN_BOUTPUTDEVICE = "LP"; !DOES NOT YET ALLOW FOR RE-ROUTE
FINISH
IF SSOWN_SSREASON=TESTREASON THEN START ; ! Test start for benchmark.
DEFINE (90,".NULL",AFD,I); !Only input comes from FSTARTFILE
DEFINE (91,".LP",AFD,I)
FINISH
FINISH ELSE START
SSOWN_INHIBITPSYSMES = 0; !IN CASE SET BY SSFOFF
FOR I=1,1,SSOWN_TOPFD CYCLE
IF SSOWN_FD(I)_LINK>=SSOWN_FDLEVEL THEN START
IF SSOWN_FD(I)_STATUS#0 THEN FLAG = CLOSE(ADDR(SSOWN_FD(I)_LINK))
IF SSOWN_FD(I)_F77FLAG=1 THEN START
SSOWN_SSFDMAP(SSOWN_FD(I)_DSNUM) = 0
SSOWN_FD (I) = 0
FINISH
FINISH
REPEAT
FINISH
IF SSOWN_FDLEVEL <= 1 START
SET IO DEFAULT (SSOWN_INDEFAULT,90)
SET IO DEFAULT (SSOWN_OUTDEFAULT,91)
FINISH
IF SSOWN_TEMPAVDSET # 0 START
SSOWN_AVD = SSOWN_HOLDAVD
SSOWN_TEMPAVDSET = 0
BDIRLIST; ! Rebuild loader search list NOW to release use count on T#DIR
FINISH
SELECTINPUT(0)
SELECTOUTPUT(0)
SSOWN_SSOPENUSED = 0
CONSOLE(14,FLAG,FLAG); !TO RESET JNBASE IN CASE RECALL OR RECAP CALLED **PROTEM
END ; !OF TIDYFILES
SYSTEMINTEGERFN OPEN(INTEGER AFD, MODE)
!*
!* MODE = 1 INPUT
!* 2 OUTPUT
!*
RECORD (DAHF)NAME HEAD
RECORD (RF)RR
RECORD (FDF)NAME F
INTEGER START, LEN, OUTCONAD, FLAG, OPENMODE
SSOWN_SSOPENUSED = 1; !TO INDICATE OPEN USED
F == RECORD(AFD)
F_LINK = SSOWN_FDLEVEL
IF MODE=1 THEN START ; !OPEN FOR READING
F_VALIDACTION = 109; !Exclude WRITE and ENDFILE
IF F_ACCESSROUTE=9 THEN START ; ! INTERACTIVE TERMINAL
F_CONAD = 0
F_CURREC = 0
F_CUR = 0
F_END = 0
F_VALIDACTION = 97; !Exclude WRITE, REWIND, BACKSPACE and ENDFILE
FINISH C
ELSE IF F_ACCESSROUTE=8 THEN START
CONNECT(F_IDEN,0,F_MAXSIZE,0,RR,FLAG); !{SEQ} ????
IF FLAG#0 THEN RESULT = FLAG
HEAD == RECORD(RR_CONAD); !MAP HEAD ONTO FILE HEAFDER
UNLESS SSCHARFILETYPE<=RR_FILETYPE<=SSDATAFILETYPE THEN START
IF NEWCONNECT#0 THEN START
DISCONNECT (LAST, FLAG)
FINISH
RESULT = 267; ! INVALID FILETYPE
FINISH
F_CURSIZE = HEAD_SIZE
IF RR_FILETYPE=SSCHARFILETYPE THEN START
F_RECTYPE = 4
F_MODEOFUSE = 1; !CHARACTER FILE ACCESS
FINISH ELSE START
F_MODEOFUSE = 2; !SQ FILE ACCESS
F_RECTYPE = HEAD_FORMAT&3; ! RECORD FORMAT 1=F 2=V
F_FLAGS = F_FLAGS!(HEAD_FORMAT&EBCDICBIT)
!INCLUDE EBCDIC BIT
F_MAXREC = HEAD_FORMAT>>16
IF F_RECTYPE=1 THEN START ; ! FIXED FORMAT
F_MINREC = F_MAXREC
F_RECSIZE = F_MAXREC
FINISH
FINISH
F_TRANSFERS = 0
F_CONAD = RR_CONAD
F_CURREC = RR_CONAD+RR_DATASTART
F_DATASTART = F_CURREC
F_CUR = F_CURREC
F_END = RR_CONAD+RR_DATAEND
FINISH C
ELSE IF F_ACCESSROUTE=5 THEN START ; !MAGNETIC TAPE
! The next line is allegedly not needed as the assignment
! is not always needed and is in any case done by DEFINEMT.
! It is removed by request of BRPM.
! F_RECTYPE = 255; !OBTAIN DCB INFO FROM TAPE PROTEM
MAGIO(AFD,9,FLAG); !OPEN FOR READING
IF FLAG#0 THEN RESULT = FLAG; !FAILURE TO OPEN MAG TAPE
F_VALIDACTION = X'3D'; !EXCLUDE WRITE
F_FLAGS = F_FLAGS!EBCDICBIT; !IBM TAPES ALWAYS EBCDIC
FINISH C
ELSE IF F_ACCESSROUTE=10 THEN START ; !.NULL
F_CUR = 0
F_END = 0
FINISH C
ELSE IF F_ACCESSROUTE=11 THEN START ; !ALIEN DATA
F_CUR = F_DATASTART
F_CURREC = F_CUR
F_END = F_CUR+F_MAXSIZE
F_MODEOFUSE = 1; !CHARACTER FILE TYPE INPUT
FINISH C
ELSE IF F_ACCESSROUTE#1 THEN RESULT = 266; !INCONSISTENT DEFINITION
! **** **** I think ACCESSROUTE=1 should be treated as **** ****
! **** **** a fault: if it can arise at all, then I do **** ****
! **** **** not think it should simply be ignored. **** ****
FINISH C
ELSE IF MODE=2 THEN START ; !OPEN FOR WRITING
F_VALIDACTION = 127
IF F_ACCESSROUTE=9 THEN START ; ! INTERACTIVE TERMINAL
LEN = 0
START = 0
CONSOLE(2,START,LEN); !TO GET ADDRESSES
F_CUR = START
F_CURREC = START
F_END = START+LEN
F_VALIDACTION = 119; !EXCLUDE BACKSPACE
FINISH C
ELSE UNLESS 8#F_ACCESSROUTE#10 THEN START
!FILE OR .NULL
IF F_FLAGS&8=0 START ; !NORMAL OPEN - NOT -MOD
NEWFILE: OUTFILE(F_IDEN,K4,F_MAXSIZE,0,OUTCONAD,FLAG); !{SEQ}
IF FLAG#0 THEN RESULT = FLAG
HEAD == RECORD(OUTCONAD)
IF F_MODEOFUSE=1 C
THEN HEAD_FILETYPE = SSCHARFILETYPE C
ELSE START
HEAD_FILETYPE = SSDATAFILETYPE
HEAD_FORMAT = (F_MAXREC<<16)!F_RECTYPE!(F_FLAGS&EBCDICBIT)
HEAD_RECORDS = 0
FINISH
F_CONAD = OUTCONAD
F_CUR = F_CONAD+32
F_TRANSFERS = 0
F_END = OUTCONAD+K4
F_CURSIZE = K4
FINISH ELSE START ; !OPEN -MOD
CONNECT(F_IDEN,3,F_MAXSIZE,0,RR,FLAG);!{SEQ} TRY AND CONNECT IT
IF FLAG=218 THEN -> NEWFILE; !FILE DOES NOT EXIST
IF FLAG#0 THEN RESULT = FLAG
HEAD == RECORD(RR_CONAD)
IF HEAD_FILETYPE=SSCHARFILETYPE C
THEN F_MODEOFUSE = 1 {CHAR FILE ACCESS} C
ELSE START
IF HEAD_FILETYPE#SSDATAFILETYPE THEN START
IF NEWCONNECT#0 THEN START
DISCONNECT (LAST, FLAG)
FINISH
RESULT = 266
FINISH
!INCONSISTENT FILE USE.
F_MODEOFUSE = 2; !DATA FILE ACCESS
F_FLAGS = F_FLAGS!(HEAD_FORMAT&EBCDICBIT)
F_MAXREC = HEAD_FORMAT>>16
F_RECTYPE = HEAD_FORMAT&3
IF F_RECTYPE=1 THEN F_MINREC = F_MAXREC
F_TRANSFERS = HEAD_RECORDS
FINISH
F_CONAD = RR_CONAD
F_CUR = RR_CONAD+RR_DATAEND
! **** **** In the next couple of lines, the **** ****
! **** **** current size of the file is found **** ****
! **** **** in HEAD_SIZE. This may not always **** ****
! **** **** be reliable: it would be better to **** ****
! **** **** use a call on FINFO. **** ****
F_END = F_CONAD+HEAD_SIZE
F_CURSIZE = HEAD_SIZE
FINISH
F_CURREC = F_CUR
F_DATASTART = F_CUR
F_RECSIZE = F_MAXREC; ! This is set in INREC for every
! record for variable length records, but remains
! constant for fixed length records.
FINISH C
ELSE IF F_ACCESSROUTE=5 THEN START ; !MAGNETIC TAPE
IF F_FLAGS&RINGNEEDED=0 THEN RESULT = 319
! NO WRITE RING REQUESTED
IF F_RECTYPE=255 THEN RESULT = 330
! NO FORMAT INFORMATION SUPPLIED FOR WRITING TAPE
IF F_FLAGS&8=0 THEN OPENMODE = 10 ELSE OPENMODE = 11
!NORMAL OR -MOD
MAGIO(AFD,OPENMODE,FLAG)
IF FLAG#0 THEN RESULT = FLAG
F_VALIDACTION = X'3F'; !INCLUDE WRITE
FINISH C
ELSE IF F_ACCESSROUTE#2 THEN RESULT = 266; !INCONSISTENT DEFINITION
FINISH
!*
IF NEWCONNECT=0 THEN START
IF F_ACCESSROUTE=8 THEN SETUSE (F_IDEN,1,0)
FINISH
F_STATUS = 3
F_CUR STATE = 1
RESULT = 0
END ; !OF OPEN
!*
SYSTEMROUTINE EXTEND(RECORD (FDF)NAME F, INTEGERNAME FLAG)
!THIS ROUTINE ATTEMPTS TO
! EXTEND AN OPEN OUTPUT FILE.
! IT TAKES THE
!FOLLOWING SIZES IN KBYTES:
!4,16,64,128,256,384.......
!THIS ALGORITHM CAN BE
! CHANGED IF THERE ARE
! PROBLEMS OF DISK FRAGMENTATION
INTEGER CURSIZE
INTEGER ARRAY SFINF (0:6)
CURSIZE = F_CURSIZE; !CURRENT FILE SIZE
IF CURSIZE>=F_MAXSIZE THEN {already big enough} FLAG = 1 ELSE START
IF CURSIZE<K16 THEN CURSIZE = K16 C
ELSE IF CURSIZE<K64 THEN CURSIZE = K64 C
ELSE CURSIZE = (CURSIZE+K128)&(-K128)
IF CURSIZE>F_MAXSIZE THEN CURSIZE = F_MAXSIZE
CHANGEFILESIZE(F_IDEN,CURSIZE,FLAG); !TRY AND CHANGE IT
IF FLAG=280 {total file limit exceeded} THEN START
FLAG = X28{DSFI} (SSOWN_CURFOWNER,SSOWN_CURFSYS,11,0,ADDR(SFINF(0)))
IF FLAG=0 C
THEN FLAG = X28{DSFI} (SSOWN_CURFOWNER,SSOWN_CURFSYS,30,0,ADDR(SFINF(1)))
IF FLAG#0 THEN FLAG = DIRTOSS (FLAG) ELSE START
CURSIZE = F_CURSIZE + SFINF (0) {max total space} C
- SFINF (2) {total disc kb} C
+ SFINF (6) {temp disc kb}
CHANGEFILESIZE (F_IDEN,CURSIZE,FLAG)
FINISH
FINISH
IF FLAG=0 THEN START
F_CURSIZE = CURSIZE
F_END = F_CONAD+CURSIZE; !ABS END OF EXTENDED FILE
INTEGER(F_CONAD+8) = CURSIZE
FINISH
FINISH
END ; !OF EXTEND
SYSTEMROUTINE ADDTOJOBOUTPUT(INTEGER START, LEN, C
INTEGERNAME FLAG)
!ROUTINE USED TO PUT FILE DESTINED FOR MAIN OUTPUT DEVICE INTO
!THE JOB OUTPUT FILE. ONLY USED BY BATCH JOBS - TO KEEP ALL OUTPUT
!FILES FROM THE SAME JOB TOGETHER
INTEGER CUR
RECORD (FDF)NAME F
FLAG = 0
RETURN IF LEN <= 0
LEN = LEN+3; !TO ALLOW FOR NEWPAGE+2 NLS
F == RECORD(SSOWN_SSFDMAP(91)); !FD FOR OUTPUT
WHILE F_CUR+LEN > F_END CYCLE ; !EXTEND AS NEC.
EXTEND(F,FLAG)
IF FLAG # 0 THEN RETURN
REPEAT
CUR = F_CUR-F_DATASTART; !CURRENT LENGTH OF JOB OUTPUT
MOVE(CUR,F_DATASTART,F_DATASTART+LEN); !MOVE IT UP THE FILE
MOVE(LEN-3,START,F_DATASTART); !MOVE IN THE FILE
F_DATASTART = F_DATASTART+LEN
BYTEINTEGER(F_DATASTART-3) = 12; !NEWPAGE
BYTEINTEGER(F_DATASTART-2) = NL
BYTEINTEGER(F_DATASTART-1) = NL
F_CUR = F_CUR+LEN
F_CURREC = F_CURREC+LEN
FLAG = 0
END ; !OF ADDTOJOBOUTPUT
EXTERNALROUTINE RETAINTAPE(STRING (255) S)
!THIS COMMAND SETS SSOWN_MTCLOSEMODE=7. THIS AFFECTS THE TAPE CLOSE
!MECHANISM SO THAT THE TAPE IS NOT UNLOADED AT CLOSE. IT WILL
!BE UNLOADED BY VOLUMS AT THE END OF THE JOB.
SSOWN_MTCLOSEMODE = 7; !CLOSE FILE BUT DO NOT RELEASE TAPE
END ; !OF RETAINTAPE
SYSTEMINTEGERFN CLOSE(INTEGER AFD)
RECORD (FDF)NAME F
RECORD (DAHF)NAME H
INTEGER FLAG
F == RECORD(AFD)
IF F_STATUS # 0 START ; !FILE IS OPEN
F_STATUS = 0; !TO PREVENT FAILURE LOOP
IF F_ACCESSROUTE = 5 START ; !MAGNETIC TAPE
MAGIO(AFD,SSOWN_MTCLOSEMODE,FLAG); !FULL CLOSE PROTEM
-> CLOSEEND
FINISH
IF CHARNO(F_IDEN,1) # '.' THEN SETUSE(F_IDEN,-1,0)
!CLEAR USE
IF F_ACCESSROUTE = 8 AND F_VALIDACTION&2 # 0 START
!OUTPUT FILE
IF F_CONAD # 0 START ; !FILE CONNECTED
H == RECORD(F_CONAD)
IF 13#F_MODEOFUSE#3 C
THEN H_DATAEND = F_CUR-F_CONAD C
ELSE F_DARECNUM = 0
!CORRECT LENGTH EXCEPT FOR DA FILES
IF F_MODEOFUSE = 2 THEN H_RECORDS = F_TRANSFERS
!CURRENT LENGTH
IF F_DEVCODE # 0 START
SENDFILE(F_IDEN,DEVNAME(F_DEVCODE!(F_F4<<8)),"OUTPUT". C
ITOS(F_DSNUM),0,0,FLAG) {SMH}
FINISH ELSE START
TRIM(F_IDEN,FLAG)
DISCONNECT(LAST,FLAG)
!SEND OR TRIM
FINISH
FINISH
FINISH
! DISCONNECT SMFILE IF CONNECTED IN WRITE MODE
IF F_ACCESSROUTE=3 AND F_VALIDACTION&2#0 THEN DISCONNECT(F_IDEN,FLAG)
IF F_ACCESSROUTE = 10 START ; !.NULL
DESTROY(F_IDEN,FLAG)
FINISH
FINISH
CLOSEEND:
F_CONAD = 0
F_CURSTATE = 0
RESULT = 0
!*
END ; ! CLOSE
EXTERNALROUTINE CLOSEF(INTEGERNAME CHAN)
!THIS ROUTINE IS PROVIDED TO ENABLE FORTRAN USERS TO CLOSE FILES
!NOTE THAT THE PARAMETER IS %INTEGERNAME
INTEGER AFD, FLAG
RECORD (FDF)NAME F
UNLESS 1 <= CHAN <= 80 THEN FLAG = 223 AND -> ERR
!INVALID CHANNEL NO
AFD = SSOWN_SSFDMAP(CHAN)
IF AFD = 0 THEN FLAG = 151 AND -> ERR; !CHANNEL NOT DEFINED
F == RECORD(AFD)
IF F_STATUS = 0 THEN FLAG = 0 AND -> ERR; ! File not open - ignore.
FLAG = CLOSE(AFD)
! FIOINIT (0) **** **** COMMENTED OUT **** ****
ERR:
IF FLAG # 0 THEN PSYSMES(-87,FLAG);!MESSAGE AND %MONITORSTOP
END ; !OF CLOSEF
!*
!*
!
SYSTEM INTEGER MAP FIO1FLAG
RESULT == SSOWN_INITFIO1
END
!
SYSTEM INTEGER MAP FIO2FLAG
RESULT == SSOWN_INITFIO2
END
!
!*
!*
!
SYSTEM ROUTINE DFDFIN C
(STRING (31) INFILE, INTEGER CHAN, INTEGER NAME FLAG)
INTEGER AFD
RECORD (FDF) NAME FD
IF SSOWN_DFDFINSDC=0 THEN SSOWN_DFDFINSDC = SSOWN_INDEFAULT
IF INFILE#"" THEN START
DEFINE (CHAN,INFILE,AFD,FLAG)
SET IO DEFAULT (SSOWN_INDEFAULT,CHAN)
FINISH ELSE START
IF SSOWN_DFDFINSDC#0 THEN SET IO DEFAULT (SSOWN_INDEFAULT,SSOWN_DFDFINSDC)
SSOWN_DFDFINSDC = 0
FINISH
SELECT INPUT (0)
END
SYSTEM ROUTINE DFDFOUT C
(STRING (31) OUTFILE, INTEGER CHAN, INTEGER NAME FLAG)
INTEGER AFD
RECORD (FDF) NAME FD
IF SSOWN_DFDFOUTSDC=0 THEN SSOWN_DFDFOUTSDC = SSOWN_OUTDEFAULT
IF OUTFILE#"" THEN START
IF LENGTH(OUTFILE)<5 C
OR SUBSTRING(OUTFILE,LENGTH(OUTFILE)-3,LENGTH(OUTFILE))#"-MOD" C
THEN DEFINE (CHAN,OUTFILE,AFD,FLAG) C
ELSE START
DEFINE (CHAN,SUBSTRING(OUTFILE,1,LENGTH(OUTFILE)-4),AFD,FLAG)
IF FLAG=0 THEN START
FD == RECORD (AFD)
FD_FLAGS = FD_FLAGS ! 8
FINISH
FINISH
SET IO DEFAULT (SSOWN_OUTDEFAULT,CHAN)
FINISH ELSE START
IF SSOWN_DFDFOUTSDC#0 THEN SET IO DEFAULT (SSOWN_OUTDEFAULT,SSOWN_DFDFOUTSDC)
SSOWN_DFDFOUTSDC = 0
FINISH
SELECT OUTPUT (0)
END
!
! - END OF EFILE TEXT ]
!
! [ START OF CONT CODE -
ROUTINE ICS; ! INIT CONTROL STREAM
SSOWN_ADCSL = ADDR (SSOWN_CSL {CONTROL STREAM LINE}) + 1
SSOWN_GL IOCP PARM (1) = SSOWN_ADCSL
SSOWN_GL IOCP PARM (3) = ADDR (SSOWN_GLSL)
END
STRING (255) MAP GCL (INTEGER NAME BLC, FLAG)
! Reads a line of text into a string and returns a pointer to it.
! The length of the string will indicate the number of bytes of text read.
! BLC will be a count of the number of blank lines skipped before
! GLC found the line which it is returning to the caller.
! FLAG= 0: success. Length>0.
! FLAG=+1: success, but end-of-file detected. Length>0. Don't call
! GETLINE again.
! FLAG=-1: end-of-file detected, no data available. Length=0.
! Don't call GETLINE again.
! The characters in the string -
! do not include the final newline which terminated the line:
! do not include the end-of-file character (decimal 25) when
! end-of-file is reported:
! include no 'trailing spaces'.
! In fact, all characters up to and including the final newline (or
! end-of-file) will have been read, even though they aren't all
! put in the string, so the next READ will start at the beginning
! of the next line. In particular, if there were more than 255
! characters on the line, then all the characters beyond the 255th.
! will disappear without warning. The length will be 255 (or less, if
! any trailing spaces were removed from the truncated line). The
! lost characters cannot be read or recovered by any means.
! Blank lines are skipped entirely (and without warning), so the string
! will not be empty (unless FLAG=-1).
! Reading always starts at the beginning of a line. If GETLINE is
! called when the last character read was not a newline, then all
! characters up to and including the next newline will be skipped
! without warning. Exception: this rule does NOT cause the first
! line of input to be skipped, so long as GETLINE starts reading
! at the beginning of the line.
!
! I have an old note which suggests that we might need
! to do FLAG = IOCP (12,0) here, but I don't know why.
!
! IOCP 20 gives (N-1) when the next character to be read is in position
! N on the input line.
IF IOCP (20,0)#0 THEN START ; ! if we are not at the start of a line:
READ CH (FLAG) UNTIL FLAG=NL OR FLAG=EM
IF FLAG=EM THEN START
FLAG = -1
BLC = 0
SSOWN_CSL {CONTROL STREAM LINE} = ""
RESULT == SSOWN_CSL {CONTROL STREAM LINE}
FINISH
FINISH
SSOWN_GL IOCP PARM (2) = ADDR (FLAG)
BLC = -1
CYCLE
CYCLE
BLC = BLC + 1
IF SSOWN_INF_CURSTATE=7 THEN START
SSOWN_CSL = ""
FLAG = -1
RESULT == SSOWN_CSL
FINISH
FLAG = IOCP (26,ADDR(SSOWN_GL IOCP PARM(1)))
IF SSOWN_GLSL#0 THEN START
IF SSOWN_GLSL>1 AND BYTE INTEGER (SSOWN_ADCSL-2+SSOWN_GLSL)=EM THEN START
FLAG = EM
SSOWN_GLSL = SSOWN_GLSL - 1
FINISH ELSE FLAG = NL
FINISH ELSE START
SSOWN_GLSL = 160
CYCLE
READ CH (FLAG)
IF SSOWN_GLSL<255 THEN BYTE INTEGER (SSOWN_ADCSL+SSOWN_GLSL) = FLAG
SSOWN_GLSL = SSOWN_GLSL + 1
REPEAT UNTIL FLAG=NL OR FLAG=EM
FINISH
SSOWN_GLSL = SSOWN_GLSL - 1
REPEAT UNTIL SSOWN_GLSL>0 OR FLAG=EM
IF SSOWN_GLSL>255 THEN SSOWN_GLSL = 255
IF SSOWN_GLSL>0 THEN SSOWN_GLSL = SSOWN_GLSL - TRAIL SPACES (SSOWN_ADCSL-1+SSOWN_GLSL,SSOWN_ADCSL,0)
IF FLAG#EM THEN FLAG = 0 C
ELSE IF SSOWN_GLSL=0 THEN FLAG = -1 C
ELSE FLAG = 1
REPEAT UNTIL SSOWN_GLSL>0 OR FLAG#0
LENGTH (SSOWN_CSL {CONTROL STREAM LINE}) = SSOWN_GLSL
RESULT == SSOWN_CSL {CONTROL STREAM LINE}
END ; ! of GCL
!
SYSTEM ROUTINE RCL (STRING NAME S, INTEGER BLANKS, INTEGER NAME R)
!
! This routine reads a line of text from the currently selected input
! stream and puts it in S. If you want to ignore blank lines, call it
! with BLANKS=0. Otherwise use BLANKS=1.
!
! The permitted values of BLANKS are
! -1 initialise the routine.
! 0 read text, ignore blank lines.
! 1 read text, return blank lines if found.
!
! The value of R after the call indicates the result:
! -1 end-of-file detected, no data available:
! S will be a null string, even if BLANKS=0.
! 0 line successfully read.
! 1 line successfully read but end-of-file detected:
! no more data available after this.
! 2 routine successfully initialised.
! 3 invalid parameters supplied by caller (i.e., BLANKS<-1 or BLANKS>1).
!
! The characters in the string -
! do not include the final newline which terminated the line:
! do not include the end-of-file character (decimal 25) when
! end-of-file is reported:
! include no 'trailing spaces'.
!
! Before you make calls on RCL to read input, you must call it at least
! once with BLANKS=-1. Once you have started reading text with RCL, you
! should not use BLANKS=-1 again except after SELECT INPUT for a different
! input stream.
!
! If you set BLANKS=1, then every line will be returned, including blank
! lines. If BLANKS=0 then RCL will return only non-blank lines (except
! when end-of-file is detected) and you will get no indication of any
! blank lines which have been skipped. Since RCL always removes trailing
! spaces from each line, a line which contains nothing but spaces will
! count as a blank line and will be "suppressed" if BLANKS=0.
!
! Just as the text supplied does not include a terminating NEWLINE symbol,
! so it does not include an end-of-file symbol (decimal 25) when
! end-of-file is detected. End-of-file normally produces S="" and R=-1,
! but it may give a non-null value for S with R=+1. If you use BLANKS=1,
! then you could get S="" with R=+1. If you use BLANKS=0, then S="" with
! R=-1 is the only way that you can get a null string returned by RCL.
!
! The length of the string will be the only indication of the number of
! characters in the line, and it is not possible to detect whether any
! trailing spaces were deleted. If there were more then 255 characters on
! the line, then all the characters beyond the 255th. will disappear
! without warning. The length will be 255 (or less, if any trailing
! spaces were removed from the truncated line). The lost characters
! cannot be read or recovered by any means.
!
! Reading always starts at the beginning of a line. If RCL is called when
! the last character read was not a newline, then all characters up to and
! including the next newline will be skipped without warning.
! Exception: this rule does NOT cause the first line of input to be
! skipped, so long as RCL starts reading at the beginning of the line.
!
! If you call other input routines as well as RCL, you need to know that
! on return from RCL the NEWLINE has in fact been read in, so that the
! next READ or READ SYMBOL (or any other input routine) will start at the
! first character of the next line. If you use BLANKS=0, this should
! cause no problems; you must simply remember that you cannot expect to
! find the NEWLINE with READ SYMBOL or READ CH. READ and READ STRING skip
! over newlines anyway, so it should make no difference to them. But if
! you use BLANKS=0, it is a bit more complicated than that: RCL reads as
! far as the NEWLINE which terminates a non-blank line, so after you have
! called RCL, even if you had BLANKS=1 and you got a blank line returned
! in S, then a READ would start at the beginning of the next line after a
! non-blank line. What this means is that you should not switch from RCL
! to other input routines unless the last call of RCL produced a non-blank
! line; or, if you want to make things even simpler, don't mix calls of
! RCL with other input routines.
!
! SSOWN_RCLB is the number of blank lines reported by RCL but not yet returned
! to the caller. If it is zero, then SSOWN_RCLH is the next thing to be returned.
! If SSOWN_RCLH has been returned to the caller, and RCL has not been called
! since, then SSOWN_RCLB is -1; that is SSOWN_RCLB=-1 means that RCL must be called before
! anything is returned to the caller (unless end-of-file has been detected).
!
! SSOWN_RCLF is zero unless end-of-file has been detected. RCL is the only thing
! that changes SSOWN_RCLF (apart from initialisation), and that sets SSOWN_RCLF non-zero if
! only if it detects end-of-file.
!
IF BLANKS<-1 OR BLANKS>1 THEN START
R = 3
RETURN
FINISH
IF BLANKS=-1 THEN START
SSOWN_RCLB = -1
SSOWN_RCLF = 0
R = 2
RETURN
FINISH
IF SSOWN_RCLB=-1 THEN START
IF SSOWN_RCLF=0 THEN SSOWN_RCLH = GCL (SSOWN_RCLB, SSOWN_RCLF) ELSE START
S = ""
R = SSOWN_RCLF
RETURN
FINISH
FINISH
IF BLANKS=0<SSOWN_RCLB THEN SSOWN_RCLB = 0
IF SSOWN_RCLB=0 THEN START
S = SSOWN_RCLH
SSOWN_RCLB = -1
R = SSOWN_RCLF
RETURN
FINISH ELSE START
S = ""
SSOWN_RCLB = SSOWN_RCLB - 1
R = 0
RETURN
FINISH
END
!
SYSTEM STRING (255) MAP CONTROL LINE (INTEGER NAME FLAG)
INTEGER I
RESULT == GCL (I, FLAG)
END ; !OF CONTROL LINE
!
SYSTEMINTEGERFN CHECKCOMMAND(STRING (255) COM)
INTEGER LEN
INTEGER I; ! not needed with machine code version.
LEN = LENGTH(COM)
UNLESS 1 <= LEN <= 31 THEN RESULT = 1; !WRONG LENGTH
UNLESS 'A'<=CHARNO(COM,1)<='Z' C
OR CHARNO(COM,1)='?' C
OR CHARNO(COM,1)='#' C
THEN RESULT = 1
IF LEN>1 THEN START
IF NEWLOADER=0 THEN START
! %FOR I=2,1,LEN %CYCLE
! %UNLESS 'A'<=CHARNO(COM,I)<='Z' %C
! %OR '0'<=CHARNO(COM,I)<='9' %C
! %THEN %RESULT = 1
! %REPEAT
!
! **** **** Machine code version follows: **** ****
!
*LDB_(COM)
*INCA_1
*MODD_1
*LSS_ACCEPT ALPHANUMERICS+4
*LUH_256
*TCH_L =DR
*JCC_8,<OK>
RESULT = 1
!
! **** **** End of machine code. **** ****
!
FINISH ELSE START
FOR I=2,1,LEN CYCLE
UNLESS 'A'<=CHARNO(COM,I)<='Z' C
OR '0'<=CHARNO(COM,I)<='9' C
OR CHARNO(COM,I)='.' OR CHARNO(COM,I)='_' C
THEN RESULT = 1
REPEAT
FINISH
FINISH
OK:
IF STUDENTSS=0 THEN START
RESULT = 0
FINISH ELSE START
IF SSOWN_ALLCOMMAND#0 THEN RESULT = 0
RESULT = ALLOWCOMMAND (COM)
FINISH
END ; !OF CHECKCOMMAND
!
SYSTEMROUTINE BCI
IF NEWLOADER=0 THEN START
CONST INTEGER ENTRYFLAG = 2
FINISH ELSE START
INTEGER ENTRYFLAG
FINISH
INTEGER SAVECOM44, SAVECOM36, SOFAR, MAXLEFT, NPT {NEWPAGETURNS}
INTEGER NDCPU,NKINS
LONGREAL NCP {NEWCPUTIME}
STRING (1) DUMMY
INTEGER EOF SEEN, AFD, FLAG, DR0, DR1, PC, LNB, TYPE, MACAD
!DR0 AND DR1 MUST STAY TOGETHER
RECORD (FDF) NAME FD
LONG INTEGER NAME DESC
STRING (255) COMMAND, PARAM, HOLDLINE, PART, INPFNAME, OPFNAME, RESTOFLINE
STRING (255) NAME LINE
INTEGER GLAPARM1
ROUTINE GC {GETCOMMAND} (STRINGNAME COMMAND, PARAM, INTEGERNAME FLAG)
INTEGER SHELL, NEWTEXT
!FLAG=0 OK
!FLAG=1 INPUT ENDED
!FLAG=2 INVALID COMMAND
!FLAG=3 PARAM TOO LONG
STRING (255) P1, P2, RCSTL
INTEGER I, MAXPARML, L, V, S, T
ROUTINE GETLINE; !SKIPS BLANK LINES AND LEADING SPACES
! The declarations for TABLE and AT are only needed if we want to discard
! all control characters as well as spaces at the start of the line.
CONST INTEGER ARRAY TABLE (0:7) = 0,X'7FFFFFFF',-1(6)
INTEGER CLL, AT
CYCLE
AT = ADDR (TABLE(0))
IF EOF SEEN=0 THEN LINE == GCL (CLL, FLAG) ELSE FLAG = -1
IF FLAG=-1 THEN START
FLAG = 1
*LLN_(LNB +0)
RETURN ; ! as if from GC {GETCOMMAND}.
FINISH ELSE START
IF FLAG=1 THEN START
EOF SEEN = -1
FLAG = 0
FINISH
FINISH
CLL = LENGTH (LINE)
GLAPARM1 = ADDR (LINE) + 1
!
! Discard leading spaces:
!
! The next lines are only needed if we intend to discard all control
! characters as well as spaces (i.e., all values less than or equal
! to 32 decimal).
*LDTB_256
*LDA_AT
*CYD_0
! End of code to discard control characters.
!
*LDTB_X'18000000'
*LDA_GLAPARM1
*LDB_CLL; ! Descriptor to characters in string.
*STD_TOS ; ! Save two copies on the stack.
*STD_TOS
!
! The next line is only used if we want to discard control characters as
! well as spaces. If we only want to discard spaces, we use instead the
! line which immediately follows it (commented out).
*TCH_L =DR
! *SWEQ_%L=%DR,0,32; ! %MASK=0,%REF=SP - i.e., skip over
! leading spaces.
! Now we have found the first non-space.
*CYD_0; ! Descriptor to string excluding spaces.
*USH_8; ! Discard TYPE byte.
*USH_-8; ! Leaves length (excluding leading
! spaces) in upper half of Acc.
*STUH_B ; ! B now has that length, Acc has address
! of first non-space.
*LDA_TOS ; ! DR now points to first byte of the
! original string, but its length
! is still reduced to exclude leading
! spaces.
*LUH_TOS ; ! Restores a sensible TYPE field to the
! descriptor in Acc. Its length
! actually includes leading spaces, but
! that is no problem - it is bound to be
! >= the length in DR, and that is all
! matters.
*MV_L =DR ; ! Move the bytes (excluding leading
! spaces) down.
*LD_TOS ; ! Restore descriptor to original string
! again. Note: its length cannot be 0.
*INCA_-1; ! Point to 'length byte'.
*STB_(DR +0); ! Store reduced length.
! Leading spaces removed.
!
REPEAT UNTIL LINE#""
END ; !OF GETLINE
ROUTINE ACT
STRING (255) Z, NC
STRING NAME PX
INTEGER W, CTRL, A, J, Q, SAVEMARK, SPARE BYTES, PFLAG
INTEGER FN FINDLAST (STRING NAME U, INTEGER I)
IF CTRL=0 C
OR (CTRL=1 AND STARTSWITH(U,COMMAND,0)#0) C
OR (CTRL=2 AND U->(COMMAND)) C
THEN PX == U
RESULT = 0
END
ROUTINE FORALL (INTEGER FN NAME J (STRING NAME U, INTEGER I))
INTEGER Q, V, N
IF SSOWN_BCIOLDEST#SSOWN_BCIBLANKS THEN START
Q = SSOWN_BCIOLDEST
N = 1
CYCLE
IF Q=SSOWN_BCIBLANKS THEN Q = 0
V = J (STRING(ADDR(SSOWN_PCHAR(Q))), N)
N = N + 1
Q = Q + SSOWN_PCHAR(Q) + 1
REPEAT UNTIL Q=SSOWN_BCIFREE OR V#0
FINISH
END
INTEGER FN PE (STRING NAME U, INTEGER I)
WRITE (I,4); SPACES (2); PRINT STRING (U); NEWLINE
RESULT = 0
END
ROUTINE SIMPLE (STRING NAME T)
RCSTL = T
END
ROUTINE REDO (INTEGER F, ROUTINE NAME K (STRING NAME T))
CTRL = F
PX == SSOWN_ACTD
FORALL (FINDLAST)
IF PX==SSOWN_ACTD THEN RCSTL = "" ELSE K (PX)
END
INTEGER FN CKN (STRING NAME U, INTEGER I)
IF I=W THEN START
RCSTL = U
RESULT = -1
FINISH ELSE RESULT = 0
END
ROUTINE REFIT (STRING NAME L)
STRING (255) A, B
RCSTL = ""
A = L
RCSTL = RCSTL.B.Z WHILE A -> B.(COMMAND).A
RCSTL = RCSTL.A
END
!
!
!
IF PIPER#0 THEN START
!
CYCLE
PARAM = ""
IF RESTOFLINE="" THEN START
I = IOCP (12,0); ! Clear 'input ended' if we've had CTRL Y from console.
GETLINE
P1 = LINE
HOLDLINE = ""
I = 1
CYCLE
IF P1->P1.("""").P2 THEN V = -1 ELSE V = 0
IF I#0 THEN UCTRANSLATE (ADDR(P1)+1, LENGTH(P1))
I = 1 - I
HOLDLINE = HOLDLINE.P1.""""
EXIT IF V=0
P1 = P2
REPEAT
LENGTH (HOLDLINE) = LENGTH (HOLDLINE) - 1
INPFNAME = ""
NEWTEXT = -1
FINISH ELSE START
HOLDLINE = RESTOFLINE
LINE == HOLDLINE
RESTOFLINE = ""
NEWTEXT = 0
UNLESS OPFNAME->INPFNAME.("-MOD") C
AND LENGTH(INPFNAME)+4=LENGTH(OPFNAME) C
THEN INPFNAME = OPFNAME
FINISH
IF CHARNO(LINE,1)#'*' THEN SHELL = -1 ELSE START
SHELL = 0
CHARNO (LINE,1) = LENGTH (LINE) - 1
LINE == STRING (ADDR(LINE)+1)
FINISH
IF SSOWN_SSLDELIM = ' ' THEN START ; !OPTION (NOBRACKETS)
IF SHELL#0 THEN START
IF LINE->LINE.("|").RESTOFLINE C
THEN OPFNAME = "T#PIPE".NEXTTEMP C
ELSE IF NOT LINE->LINE.(">").OPFNAME C
THEN OPFNAME = ""
IF INPFNAME="" AND LINE->LINE.("<").INPFNAME THEN START ; FINISH
FINISH
UNLESS LINE->COMMAND.(" ").PARAM THEN COMMAND = LINE
FINISH ELSE START ; !OPTION (BRACKETS)
IF LINE->COMMAND.("(").PARAM THEN START
IF SHELL#0 AND COMMAND->COMMAND.("|").RESTOFLINE THEN START
RESTOFLINE = RESTOFLINE."(".PARAM
PARAM = ""
OPFNAME = "T#PIPE".NEXTTEMP
IF INPFNAME="" AND COMMAND->COMMAND.("<").INPFNAME THEN START ; FINISH
FINISH ELSE START
RESTOFLINE = ""
L = 0; ! Count of unmatched open brackets
! within the PARAM string.
I = 0; ! Pointer into the PARAM string -
! 1 indicates first character, etc.
V = -1; ! Zero within double-quotes,
! non-zero outside.
MAXPARML = 255 - LENGTH (COMMAND) - 1
CYCLE
! Scan for brackets (ignoring anything in quotes):
WHILE I<LENGTH(PARAM) AND L>=0 CYCLE
I = I + 1
S = CHARNO (PARAM, I)
IF S='"' THEN V = -1-V C
ELSE IF V#0 THEN START
IF S=')' THEN L = L - 1 C
ELSE IF S='(' THEN L = L + 1
FINISH
REPEAT
! Now we have I=LENGTH(PARAM) or
! (L=-1 with S=')' and CHARNO(PARAM,I)=')').
IF L<0 THEN START
IF I<LENGTH(PARAM) AND SHELL#0 THEN START
PART = SUBSTRING (PARAM, I+1, LENGTH(PARAM))
IF PART->PART.("|").RESTOFLINE C
THEN OPFNAME = "T#PIPE".NEXTTEMP C
ELSE IF NOT PART->PART.(">").OPFNAME C
THEN OPFNAME = ""
IF INPFNAME="" AND PART->PART.("<").INPFNAME THEN START ; FINISH
FINISH
LENGTH (PARAM) = I - 1
FINISH ELSE START
T = MAXPARML - I
! Here we can test -
! T>0 for "more space left in PARAM string",
! S=',' for "line ended with comma",
! V=0 for "line ended within double quotes".
IF S#',' OR T=0 THEN S=')' ELSE START
PROMPT ("):")
GETLINE
IF T>LENGTH(LINE) THEN T = LENGTH (LINE)
LENGTH (PARAM) = LENGTH (PARAM) + T
MOVE (T, GLAPARM1, ADDR(PARAM)+I+1)
FINISH
FINISH
REPEAT UNTIL S=')'
FINISH
FINISH ELSE START
IF SHELL#0 THEN START
IF LINE->LINE.("|").RESTOFLINE C
THEN OPFNAME = "T#PIPE".NEXTTEMP C
ELSE IF NOT LINE->LINE.(">").OPFNAME C
THEN OPFNAME = ""
IF INPFNAME="" AND LINE->LINE.("<").INPFNAME THEN START ; FINISH
FINISH
COMMAND = LINE
FINISH
WHILE COMMAND -> P1.(" ").P2 CYCLE ; ! REMOVE EMBEDDED SPACES
COMMAND = P1.P2
REPEAT
FINISH
IF RESTOFLINE="" AND INPFNAME="" AND OPFNAME="" THEN SHELL=0 ELSE START
IF SHELL#0 AND LENGTH(OPFNAME)>1 AND CHARNO(OPFNAME,1)='>' C
THEN OPFNAME = SUBSTRING(OPFNAME,2,LENGTH(OPFNAME))."-MOD"
FINISH
! Translate command to upper case.
UCTRANSLATE (ADDR(COMMAND)+1,LENGTH(COMMAND))
CASTOUT (PARAM); ! Clear out spaces, translate to upper case -
! but allow for double quotes.
PFLAG = 0
IF NEWTEXT#0 THEN START
SAVEMARK = 0
IF SHELL#0 THEN START
IF STARTSWITH(COMMAND,"!-",-1)=0 THEN SAVEMARK = -1
FINISH ELSE START
IF COMMAND="!?" AND PARAM="" THEN START
FORALL (PE)
FLAG = 3
FINISH C
ELSE IF STARTSWITH (COMMAND,"!-",-1)=0 THEN START
IF COMMAND -> NC.("!").COMMAND THEN START
RCSTL = ""
IF COMMAND="" THEN REDO (0,SIMPLE) C
ELSE IF CHARNO(COMMAND,1)='!' THEN NC = NC."!".COMMAND C
ELSE IF COMMAND->COMMAND.("!").Z THEN START
IF Z="" THEN REDO(2,SIMPLE) ELSE START
IF CHARNO(Z,LENGTH(Z))='!' THEN LENGTH(Z) = LENGTH(Z) - 1
REDO (2,REFIT)
SAVEMARK = -1
FINISH
FINISH ELSE START
W = PSTOI (COMMAND)
IF W<=0 THEN REDO (1,SIMPLE) ELSE FORALL (CKN)
FINISH
IF RCSTL="" THEN FLAG = 3 ELSE START
IF RCSTL->COMMAND.(TOSTRING(160)).RCSTL THEN START
IF NC#"" THEN START
COMMAND = NC
SAVEMARK = -1
FINISH
IF PARAM="" THEN PARAM = RCSTL ELSE SAVEMARK = -1
FINISH ELSE START
COMMAND = RCSTL
SHELL = -1
PARAM = ""
FINISH
PFLAG = PFLAG ! 1
FINISH
FINISH ELSE SAVEMARK = -1
IF PFLAG&1#0 THEN START
PRINT STRING (COMMAND PROMPT)
PRINT STRING (COMMAND)
IF PARAM#"" THEN START
PRINT SYMBOL (SSOWN_SSLDELIM)
PRINT STRING (PARAM)
IF SSOWN_SSLDELIM#' ' THEN PRINT SYMBOL (')')
FINISH
NEWLINE
FINISH
IF SHELL=0 C
THEN HOLDLINE = COMMAND.TOSTRING(160).PARAM C
ELSE START
HOLDLINE = COMMAND
RESTOFLINE = COMMAND
COMMAND = ""
FINISH
FINISH
FINISH
IF SAVEMARK#0 THEN START
A = ADDR (SSOWN_PCHAR(0))
J = LENGTH (HOLDLINE) + 1
IF SSOWN_BCIOLDEST>SSOWN_BCIFREE C
THEN SPARE BYTES = SSOWN_BCIOLDEST - SSOWN_BCIFREE - 1 C
ELSE SPARE BYTES = PCHARLIM - SSOWN_BCIFREE
WHILE SPARE BYTES<J CYCLE
IF SSOWN_BCIOLDEST>SSOWN_BCIFREE AND SPARE BYTES+PCHARLIM-SSOWN_BCIBLANKS>=J THEN START
MOVE (SSOWN_BCIBLANKS-SSOWN_BCIOLDEST, A+SSOWN_BCIOLDEST, A+SSOWN_BCIOLDEST+PCHARLIM-BCIBLANKS)
SSOWN_BCIOLDEST = SSOWN_BCIOLDEST + PCHARLIM - SSOWN_BCIBLANKS
SPARE BYTES = SPARE BYTES + PCHARLIM - SSOWN_BCIBLANKS
SSOWN_BCIBLANKS = PCHARLIM
FINISH ELSE START
Q = SSOWN_PCHAR(SSOWN_BCIOLDEST) + 1
IF SSOWN_BCIOLDEST=0 THEN START
SSOWN_BCIFREE = 0
SPARE BYTES = -1
FINISH
SSOWN_BCIOLDEST = SSOWN_BCIOLDEST + Q
IF SSOWN_BCIOLDEST=SSOWN_BCIBLANKS THEN START
SSOWN_BCIOLDEST = 0
SSOWN_BCIBLANKS = SSOWN_BCIFREE
SPARE BYTES = PCHARLIM - SSOWN_BCIFREE
FINISH ELSE SPARE BYTES = SPARE BYTES + Q
FINISH
REPEAT
STRING (A+SSOWN_BCIFREE) = HOLDLINE
SSOWN_BCIFREE = SSOWN_BCIFREE + J
IF SSOWN_BCIFREE>SSOWN_BCIBLANKS THEN SSOWN_BCIBLANKS = SSOWN_BCIFREE
FINISH
FINISH
REPEAT UNTIL COMMAND#""
!
FINISH ELSE START
!
PARAM = ""
I = IOCP (12,0); ! Clear 'input ended' if we've had CTRL Y from console.
GETLINE
IF SSOWN_SSLDELIM = ' ' THEN START ; !OPTION (NOBRACKETS)
UNLESS LINE->COMMAND.(" ").PARAM THEN COMMAND = LINE
FINISH ELSE START ; !OPTION (BRACKETS)
UNLESS LINE->COMMAND.("(").PARAM THEN COMMAND = LINE
WHILE COMMAND -> P1.(" ").P2 CYCLE ; ! REMOVE EMBEDDED SPACES
COMMAND = P1.P2
REPEAT
IF PARAM#"" THEN START
L = 0; ! Count of unmatched open brackets
! within the PARAM string.
I = 0; ! Pointer into the PARAM string -
! 1 indicates first character, etc.
V = -1; ! Zero within double-quotes,
! non-zero outside.
MAXPARML = 255 - LENGTH (COMMAND) - 1
CYCLE
! Scan for brackets (ignoring anything in quotes):
WHILE I<LENGTH(PARAM) AND L>=0 CYCLE
I = I + 1
S = CHARNO (PARAM, I)
IF S='"' THEN V = -1-V C
ELSE IF V#0 THEN START
IF S=')' THEN L = L - 1 C
ELSE IF S='(' THEN L = L + 1
FINISH
REPEAT
! Now we have I=LENGTH(PARAM) or
! (L=-1 with S=')' and CHARNO(PARAM,I)=')').
IF L<0 THEN LENGTH (PARAM) = I - 1 ELSE START
T = MAXPARML - I
! Here we can test -
! T>0 for "more space left in PARAM string",
! S=',' for "line ended with comma",
! V=0 for "line ended within double quotes".
IF S#',' OR T=0 THEN S=')' ELSE START
PROMPT ("):")
GETLINE
IF T>LENGTH(LINE) THEN T = LENGTH (LINE)
LENGTH (PARAM) = LENGTH (PARAM) + T
MOVE (T, GLAPARM1, ADDR(PARAM)+I+1)
FINISH
FINISH
REPEAT UNTIL S=')'
FINISH
FINISH
! Translate command to upper case.
UCTRANSLATE (ADDR(COMMAND)+1,LENGTH(COMMAND))
CASTOUT (PARAM); ! Clear out spaces, translate to upper case -
! but allow for double quotes.
PFLAG = 0
SAVEMARK = 0
IF COMMAND="!?" AND PARAM="" THEN START
FORALL (PE)
FLAG = 3
FINISH C
ELSE IF STARTSWITH (COMMAND,"!-",-1)=0 THEN START
IF COMMAND -> NC.("!").COMMAND THEN START
RCSTL = ""
IF COMMAND="" THEN REDO (0,SIMPLE) C
ELSE IF CHARNO(COMMAND,1)='!' THEN NC = NC."!".COMMAND C
ELSE IF COMMAND->COMMAND.("!").Z THEN START
IF Z="" THEN REDO(2,SIMPLE) ELSE START
IF CHARNO(Z,LENGTH(Z))='!' THEN LENGTH(Z) = LENGTH(Z) - 1
REDO (2,REFIT)
SAVEMARK = -1
FINISH
FINISH ELSE START
W = PSTOI (COMMAND)
IF W<=0 THEN REDO (1,SIMPLE) ELSE FORALL (CKN)
FINISH
IF RCSTL="" THEN FLAG = 3 ELSE RCSTL -> COMMAND.(" ").RCSTL
IF NC#"" THEN START
COMMAND = NC
SAVEMARK = -1
FINISH
IF PARAM="" THEN PARAM = RCSTL ELSE SAVEMARK = -1
PFLAG = PFLAG ! 1
FINISH ELSE SAVEMARK = -1
FINISH
IF PFLAG&1#0 THEN START
PRINT STRING (COMMAND PROMPT)
PRINT STRING (COMMAND)
IF PARAM#"" THEN START
PRINT SYMBOL (SSOWN_SSLDELIM)
PRINT STRING (PARAM)
IF SSOWN_SSLDELIM#' ' THEN PRINT SYMBOL (')')
FINISH
NEWLINE
FINISH
IF SAVEMARK#0 THEN START
A = ADDR (SSOWN_PCHAR(0))
J = LENGTH (COMMAND) + LENGTH (PARAM) + 2
IF SSOWN_BCIOLDEST>SSOWN_BCIFREE C
THEN SPARE BYTES = SSOWN_BCIOLDEST - SSOWN_BCIFREE - 1 C
ELSE SPARE BYTES = PCHARLIM - SSOWN_BCIFREE
WHILE SPARE BYTES<J CYCLE
IF SSOWN_BCIOLDEST>SSOWN_BCIFREE AND SPARE BYTES+PCHARLIM-SSOWN_BCIBLANKS>=J THEN START
MOVE (SSOWN_BCIBLANKS-SSOWN_BCIOLDEST, A+SSOWN_BCIOLDEST, A+SSOWN_BCIOLDEST+PCHARLIM-SSOWN_BCIBLANKS)
SSOWN_BCIOLDEST = SSOWN_BCIOLDEST + PCHARLIM - SSOWN_BCIBLANKS
SPARE BYTES = SPARE BYTES + PCHARLIM - SSOWN_BCIBLANKS
SSOWN_BCIBLANKS = PCHARLIM
FINISH ELSE START
Q = SSOWN_PCHAR(SSOWN_BCIOLDEST) + 1
IF SSOWN_BCIOLDEST=0 THEN START
SSOWN_BCIFREE = 0
SPARE BYTES = -1
FINISH
SSOWN_BCIOLDEST = SSOWN_BCIOLDEST + Q
IF SSOWN_BCIOLDEST=SSOWN_BCIBLANKS THEN START
SSOWN_BCIOLDEST = 0
SSOWN_BCIBLANKS = SSOWN_BCIFREE
SPARE BYTES = PCHARLIM - SSOWN_BCIFREE
FINISH ELSE SPARE BYTES = SPARE BYTES + Q
FINISH
REPEAT
STRING (A+SSOWN_BCIFREE) = COMMAND." ".PARAM
SSOWN_BCIFREE = SSOWN_BCIFREE + J
IF SSOWN_BCIFREE>SSOWN_BCIBLANKS THEN SSOWN_BCIBLANKS = SSOWN_BCIFREE
FINISH
!
FINISH
END ; ! OF ACT
PROMPT(COMMANDPROMPT)
FLAG = 0; !DEFAULT
IF SSOWN_GCSTARTED<0 THEN START
! #VIEWER subsystems are only allowed one command
COMMAND="QUIT"
PARAM=""
->ERR
FINISH ELSE IF SSOWN_GCSTARTED=0 START
IF UINFS(7){Surname}="#VIEWER" THEN START
COMMAND=SSOWN_SSOWNER
PARAM=""
SSOWN_GCSTARTED=-1
->ERR
FINISH
COMMAND = "OBEY"
SSOWN_GCSTARTED = 1
IF SSOWN_STARTFILE#"" THEN START
PARAM = SSOWN_STARTFILE
-> ERR
FINISH
FINISH
! Test job terminates after FSTARTFILE.
ACT
IF FLAG=0 AND CHECKCOMMAND(COMMAND)#0 THEN FLAG = 2
!CHECK VALID CHAS IN COMMAND
ERR:
END ; !OF GC {GETCOMMAND}
!
!
IF NEWLOADER#0 THEN START
DESC==LONGINTEGER(ADDR(DR0))
FINISH
!
EOF SEEN = 0
IF PIPER#0 THEN START
RESTOFLINE = ""
INPFNAME = ""
OPFNAME = ""
FINISH
SAVECOM44 = SSOWN_SSCOMREG(44)
*STLN_SAVECOM36; ! STORE CURRENT LNB
NEXTCOM:
IF STUDENTSS#0 THEN START
IF SSOWN_SSJOURNAL=3 AND SSOWN_AITBUFFER#0 THEN SSOWN_IT_JNBASE = IMOD(SSOWN_IT_JNBASE)
! Force RECALL on again.
FINISH
IF NEWLOADER#0 THEN SSOWN_LOADLEVEL=1; ! In case ,e.g. INT:A out of RUN
SSOWN_CONTROLMODE=0; !TO ENSURE WE READ FROM CORRECT PLACE
SSOWN_SSFNAME = ""; !TEMPORARY
SSOWN_SSCOMREG(36) = SAVECOM36; ! PUT IT INTO COMREG(36)
IF SSOWN_SSAUXDR1 # 0 THEN SSOWN_SSCURAUX = INTEGER(SSOWN_SSAUXDR1)
!FOR RESTTING AUX STACK IN %STOP
! FOR RETURN HERE
SSOWN_SSCOMREG(34) = 1; !SET SIGLEVEL BACK TO 1
SSOWN_RRCTOP = 0; !CLEAR CONTINGENCY RE-ROUTE TABLE
IF SSOWN_SSREASON = BATCHREASON START
FLAG = X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,21,0,ADDR(SOFAR))
MAXLEFT = SSOWN_SESSKIC-SOFAR
IF MAXLEFT < KIPS THEN BATCHSTOP(1)
IF SSOWN_CURRKI > MAXLEFT THEN SSOWN_CURRKI = MAXLEFT
FINISH
IF SSOWN_SSOPENUSED # 0 THEN TIDYFILES; !CLOSE ANY AT CURRENT LEVEL
IF PIPER#0 THEN START
IF STARTSWITH(INPFNAME,"T#PIPE",0)#0 THEN DESTROY (INPFNAME,FLAG)
FINISH
!
IF NEWLOADER#0 THEN START
UNLOAD2(SSOWN_LOADLEVEL,0); ! Unload temp loaded material
FINISH ELSE START
IF SSOWN_SSUSTACKUSED # 0 THEN INUST
UNLOAD(SSOWN_SSCOMREG(38)); !TEMP
FINISH
!
IF OUTPOS # 0 THEN NEWLINE; !PUSH OUT REMAINING CHAS IN LINE
IF SSOWN_INTQ # 0 START ; !INT:Q HAS OCCURRED
SSOWN_INTQ = 0
IF SSOWN_FDLEVEL > 1 THEN RETURN ; !DURING OBEY FILE
FINISH
NPT {NEWPAGETURNS} = PAGETURNS
NCP {NEWCPUTIME} = CPUTIME
NDCPU=DCPUTIME
NKINS=KINS
! IF MORE THAN 1 PERCENT OF CURRENT CPULIMIT USED BY LAST COMMAND
! THEN GET SOME MORE TIME AND RESET BASE
IF NCP {NEWCPUTIME}-SSOWN_LASTCPUTIME>SSOWN_CURRKI/(100*KIPS) THEN START
FLAG=X27{DSETIC}(SSOWN_CURRKI)
SSOWN_LASTCPUTIME=NCP {NEWCPUTIME}
FINISH
IF SSOWN_SSMONITOR&1#0 THEN START ; !MONITOR CPU AND PAGE TURNS PER COMMAND
WRITE(INT((NCP {NEWCPUTIME}-SSOWN_OLDCPUTIME)*1000),1)
PRINTSTRING(" MS")
WRITE(NPT {NEWPAGETURNS}-SSOWN_OLDPAGETURNS,1)
PRINTSTRING(" PT")
WRITE(NDCPU-SSOWN_OLDDCPU,1)
PRINTSTRING(" DCPU")
WRITE(NKINS-SSOWN_OLDKINS,1)
PRINTSTRING(" KINS
")
FINISH
SSOWN_OLDCPUTIME = NCP {NEWCPUTIME}
SSOWN_OLDPAGETURNS = NPT {NEWPAGETURNS}
SSOWN_OLDDCPU=NDCPU
SSOWN_OLDKINS=KINS
!
IF SSOWN_INF_ACCESSROUTE=9 THEN EOF SEEN = 0
GC {GETCOMMAND}(COMMAND,PARAM,FLAG)
IF FLAG = 1 THEN START ; !INPUT ENDED DETECTED
IF SSOWN_SSREASON=TESTREASON THEN BATCHSTOP(0); ! End of TESTREASON session
IF SSOWN_FDLEVEL > 1 THEN RETURN ; !CALLED FROM OBEY
IF SSOWN_SSREASON=BATCHREASON THEN BATCHSTOP(0); !Input ended from batch job file
!END OF BATCH JOB
PRINTSTRING("Input Ended - ignored")
-> NEXTCOM
FINISH
IF FLAG = 2 START ; !ILLEGAL COMMAND
PRINTSTRING(COMMAND." not valid
")
-> NEXTCOM
FINISH
IF FLAG = 3 THEN -> NEXTCOM
IF STUDENTSS#0 THEN START
IF SSOWN_SSJOURNAL=3 AND SSOWN_AITBUFFER#0 THEN SSOWN_IT_JNBASE = -IMOD(SSOWN_IT_JNBASE)
! This switches off RECALL. It will get switched on again at
! NEXTCOM before the next command. The effect is that the
! RECALL journal only gets command lines, and not data nor output.
FINISH
!**FUNDSSTART
IF FUNDS ON#0 THEN START
IF SSOWN_SCARCITYFOUND=0 START
IF SCARCEWORD&X'FF'>=SCARCEWORD>>24 START
! INTERACTIVE USERS >= SCARCE LIMIT
PRINTSTRING("**Resources are Scarce.")
SSOWN_SCARCITYFOUND=1
IF UINFI(20)=0 THEN PRINTSTRING (" You are liable to pre-emption.")
NEWLINE
FINISH
FINISH
FINISH
!**FUNDSEND
IF PIPER#0 THEN START
IF INPFNAME#"" THEN START
DEFINE (83,INPFNAME,AFD,FLAG)
SET IO DEFAULT (SSOWN_INDEFAULT,83)
SELECT INPUT (0)
FINISH
IF OPFNAME#"" THEN START
IF LENGTH(OPFNAME)<5 C
OR SUBSTRING(OPFNAME,LENGTH(OPFNAME)-3,LENGTH(OPFNAME))#"-MOD" C
THEN DEFINE (84,OPFNAME,AFD,FLAG) C
ELSE START
DEFINE (84,SUBSTRING(OPFNAME,1,LENGTH(OPFNAME)-4),AFD,FLAG)
IF FLAG=0 THEN START
FD == RECORD (AFD)
FD_FLAGS = FD_FLAGS ! 8
FINISH
FINISH
SET IO DEFAULT (SSOWN_OUTDEFAULT,84)
SELECT OUTPUT (0)
FINISH
FINISH
SSOWN_INITFIO1 = 0
SSOWN_INITFIO2 = 0
PROMPT("Data:"); !PROTEM
IF LENGTH(COMMAND) > 31 THEN LENGTH(COMMAND) = 31
!TRUNCATE COMMAND IF NECESSARY
IF CHARNO(COMMAND,1)#'?' OR COMMAND="?" THEN SSOWN_QPARMF = 0 ELSE START
LENGTH(COMMAND) = LENGTH(COMMAND) - 1
MOVE (LENGTH(COMMAND),ADDR(COMMAND)+2,ADDR(COMMAND)+1)
SSOWN_QPARMF = -1
FINISH
IF CHARNO(COMMAND,1)='#' THEN START
LENGTH(COMMAND) = LENGTH(COMMAND) - 1
MOVE (LENGTH(COMMAND),ADDR(COMMAND)+2,ADDR(COMMAND)+1)
HASHCOMMAND(COMMAND,PARAM)
-> NEXTCOM
FINISH
IF NEWLOADER=0 THEN START
FINDENTRY(COMMAND,0,0,DUMMY,DR0,DR1,FLAG);!SEE IF IT IS ALREADY LOADED
IF FLAG # 0 START
LOAD(COMMAND,0,FLAG)
-> NOT FOUND IF FLAG # 0; !NOT FOUND
FINDENTRY(COMMAND,0,0,DUMMY,DR0,DR1,FLAG)
!SHOULD BE THERE NOW
-> NOT FOUND IF FLAG # 0; !JUST IN CASE
FINISH
FINISH ELSE START
TYPE=CODE!MACRO; ! Will accept either
DESC=LOADENTITY(COMMAND,TYPE,FLAG,SSOWN_LOADLEVEL)
IF TYPE>=0 THEN ENTRYFLAG = 2 ELSE START
ENTRYFLAG = 0
TYPE = TYPE & X'7FFFFFFF'
FINISH
IF DESC=0 THEN START
IF FLAG<0 THEN OBEYJOB(COMMAND) ELSE ->NOT FOUND
->NEXTCOM
FINISH
IF TYPE=MACRO THEN START
! This %START - %FINISH block contains code which allows macros
! to be called interactively. The technique is to construct a temporay
! file, T#DOMACRO, put the command line into it and call OBEYJOB on it.
! A bit crude, perhaps, but it works.
PRINTSTRING("Macro ".COMMAND." located in file ".CONFILE(DR1))
NEWLINE
OUTFILE("T#DOMACRO",X'1000',0,0,MACAD,FLAG)
IF FLAG#0 THEN PRINTSTRING( C
"*** Unable to create T#DOMACRO - cannot begin macro execution
") AND -> NOT FOUND
INTEGER(MACAD)=LENGTH(COMMAND)+LENGTH(PARAM)+34; ! 1 sp, 1 nl
INTEGER(MACAD+12)=SSCHARFILETYPE
MACAD=MACAD+32
MOVE(LENGTH(COMMAND),ADDR(COMMAND)+1,MACAD)
MACAD=MACAD+LENGTH(COMMAND)
BYTEINTEGER(MACAD)=' '
MACAD=MACAD+1
MOVE(LENGTH(PARAM),ADDR(PARAM)+1,MACAD)
MACAD=MACAD+LENGTH(PARAM)
BYTEINTEGER(MACAD)=X'0A'
OBEYJOB("T#DOMACRO,,N")
DESTROY("T#DOMACRO",FLAG); ! Ignore FLAG
->NEXTCOM
FINISH
FINISH
!IF CODE IN BASEFILE USE BASE STACK **** **** This is all very well as **** ****
! **** **** a comment, but where's **** ****
! **** **** the code to do it? **** ****
! Set up the CLI strings SSOWN_CLICOMM and SSOWN_CLIPARM so that user progs can
! interrogate them with %systemstringfns CILCOMMAND and CLIPARAM
SSOWN_CLICOMM=COMMAND
SSOWN_CLIPARM=PARAM
*JLK_3; !JUMP PAST NEXT INSTRUCTN
!LEAVING PC OF IT IN TOS
*J_<FAIL>
*LSS_TOS ; !TOS TO ACC
*ST_PC; !THEN TO INTEGER PC
*STLN_LNB; !LNB TO INTEGER LNB
SIGNAL(0,PC,LNB,FLAG)
ENTER(ENTRYFLAG,DR0,DR1,PARAM); !ENTER PASSING PARAMETER
-> NEXTCOM
FAIL:
*ST_DR0; !ACC CONTAINS DESCRIPTOR
SSOWN_SSCOMREG(36) = SAVECOM36; !TO ENSURE STOP TAKES US BACK TO COMMAND LEVEL
NDIAG(INTEGER(DR1+16),INTEGER(DR1+8),10,INTEGER(DR1))
!INT OF WT
-> NEXTCOM
NOTFOUND:
PSYSMES(47,FLAG)
IF COMMAND#SSOWN_SSFNAME THEN PRINTSTRING(COMMAND." not entered")
NEWLINE
IF NEWLOADER#0 THEN UNLOAD2(1,1); ! Load failed
-> NEXTCOM
END ; !OF BCI
!
SYSTEMSTRINGFN CLICOMMAND
RESULT =SSOWN_CLICOMM
END ; ! OF SSOWN_CLICOMMAND
!
!
SYSTEMSTRINGFN CLIPARAM
RESULT =SSOWN_CLIPARM
END ; ! OF CLIPARAM
!
!
SYSTEM ROUTINE QUERYPROMPTS (INTEGER I)
SSOWN_QPARMF = I
END
!
SYSTEMROUTINE BEFORECOMMAND; !CALLED FROM JOB CONTROL MODULE
INTEGER FLAG,SOFAR,NEWPAGETURNS,MAXLEFT,NDCPU,NKINS
LONGREAL NEWCPUTIME
SSOWN_SSCOMREG(10)=0; !CLEAR OUT MONITOR CALLED FLAG
SSOWN_SSFNAME=""; !TEMPORARY
IF SSOWN_SSAUXDR1#0 THEN SSOWN_SSCURAUX=INTEGER(SSOWN_SSAUXDR1)
SSOWN_SSCOMREG(34)=1; !SET SIGNAL LEVEL BACK TO 1
SSOWN_RRCTOP=0; !RESET CONTINGENCY RE-ROUTEING
IF SSOWN_SSREASON=BATCHREASON THEN START
FLAG = X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,21,0,ADDR(SOFAR))
MAXLEFT = SSOWN_SESSKIC-SOFAR
IF MAXLEFT<KIPS THEN BATCHSTOP(1)
IF SSOWN_CURRKI>MAXLEFT THEN SSOWN_CURRKI = MAXLEFT
FINISH
FLAG = X27{DSETIC}(SSOWN_CURRKI)
IF SSOWN_SSOPENUSED # 0 THEN TIDYFILES; !CLOSE ANY AT CURRENT LEVEL
NEWPAGETURNS = PAGETURNS
NEWCPUTIME = CPUTIME
NDCPU=DCPUTIME
NKINS=KINS
IF SSOWN_SSMONITOR&1#0 START ; !MONITOR CPU AND PAGE TURNS PER COMMAND
WRITE(INT((NEWCPUTIME-SSOWN_OLDCPUTIME)*1000),1)
PRINTSTRING(" MS")
WRITE(NEWPAGETURNS-SSOWN_OLDPAGETURNS,1)
PRINTSTRING(" PT")
WRITE(NDCPU-SSOWN_OLDDCPU,1)
PRINTSTRING(" DCPU")
WRITE(NKINS-SSOWN_OLDKINS,1)
PRINTSTRING(" KINS
")
FINISH
SSOWN_OLDCPUTIME = NEWCPUTIME
SSOWN_OLDPAGETURNS = NEWPAGETURNS
SSOWN_OLDDCPU=NDCPU
SSOWN_OLDKINS=KINS
SSOWN_CONTROLMODE=1; !TO ENSURE INPUT READ FROM MASTERCHARIN
END ; !OF BEFORECOMMAND
SYSTEMROUTINE AFTERCOMMAND
SSOWN_CONTROLMODE=0
IF NEWLOADER=0 THEN START
UNLOAD(SSOWN_SSCOMREG(38)); ! TEMP
IF SSOWN_SSUSTACKUSED#0 THEN INUST
FINISH ELSE START
UNLOAD2 (SSOWN_LOADLEVEL,0); ! TEMP Is this required at all?
FINISH
IF OUTPOS#0 THEN NEWLINE; !PUSH OUT REMAINING CHAS IN LINE
IF SSOWN_SSOPENUSED#0 THEN TIDYFILES; !MUST BE CALLED HERE FOR SELECT
SSOWN_DATAECHO=0; !FOR BOB EAGER?
END ; !OF AFTERCOMMAND
SYSTEMROUTINE CONTROL
INTEGER FLAG
LONG INTEGER DRH
RECORD (RF)RR
RECORD (DIRINFF)NAME DIRINF
STRING (31) MESSAGEFILE
STRING (63) JMESSAGE
ROUTINE CALLBCI
CONST INTEGER MAXNREC = 5
RECORD (FINDF) ARRAY FORINIT (1:MAXNREC)
INTEGER GOTINIT, III, NREC, BASEDIRENTRY, MASTERENTRY
STRING (6) MASTERNAME
STRING (72) MESS
INTEGER LNB, PC, CLASS, SUBCLASS, FAULT, FLAG, TYPE
INTEGER DR0,DR1
LONGINTEGERNAME DESC
STRING (31) DUMMY
*JLK_3
*J_ < CONTIN >
*LSS_ TOS
*ST_PC
!PC NOW CONTAINS RETURN PC
*STLN_LNB
DESC==LONGINTEGER(ADDR(DR0))
SIGNAL(1,1,0,FLAG); !CLEAR ALL LEVELS
SIGNAL(0,PC,LNB,FLAG)
X30{DSTOP}(200+FLAG) IF FLAG # 0
SSOWN_FDLEVEL = 1
IF SSOWN_SSAUXDR1 # 0 START ; !RESET AUX STACK
INTEGER(SSOWN_SSAUXDR1) = SSOWN_SSAUXDR1+32
INTEGER(SSOWN_SSAUXDR1+8) = SSOWN_SSMAXAUX
FINISH
TIDYFILES
IF NEWLOADER=0 THEN START
UNLOAD(SSOWN_SSCOMREG(38)); !UNLOAD ALL ON USER GLA
!COMREG 38 POINTS TO BASE OF USER GLA
FINISH ELSE START
UNLOAD2 (SSOWN_LOADLEVEL, 0)
FINISH
IF SSOWN_CALLBCISTARTED = 0 START ; !FIRST TIME ONLY
SSOWN_CALLBCISTARTED = 1
ALLOW INTERRUPTS; ! Able to accept interrupts from here on
IF STUDENTSS#0 THEN START
IF NEWLOADER=0 THEN START
SSOWN_AVD = ""; ! Make sure none of INITIALISE, ALLOWCOMMAND,
! ALLOWCONNECT get loaded via the student's own
! ACTIVE DIRECTORY.
SSOWN_DIRDISCON = 1
INITIALISE; ! Call routine supplied by course supervisor.
SSOWN_DIRDISCON = 1; ! Ensure reload of directories after first search.
SSOWN_AVD = SSOWN_HOLDAVD
!
! Now check that both entries are loaded. If not, SSOWN_ALLCOMMAND
! or SSOWN_ALLCONNECT should be set non-zero.
FINDENTRY ("S#ALLOWCOMMAND",0,0,DUMMY,DR0,DR1,SSOWN_ALLCOMMAND)
FINDENTRY ("S#ALLOWCONNECT",0,0,DUMMY,DR0,DR1,FLAG)
IF FLAG=0 THEN START
FLAG = ALLOWCONNECT (SSOWN_SSOWNER,"T"); ! Dummy call to make sure that
! all directories are
! connected.
SSOWN_ALLCONNECT = 0; ! From now on it is safe to call it within
! CONNECT.
FINISH
FINISH ELSE START
GOTINIT = 0
NREC = MAXNREC
III = FIND ("S#INITIALISE", NREC, ADDR(FORINIT(1)), CODE)
IF III=0#NREC THEN START
! Get the username of the supervisor, if any.
III = X28{DSFI}(SSOWN_SSOWNER, SSOWN_SSOWNFSYS, 44, 0, ADDR(MASTERNAME))
IF III=0 THEN START
BASEDIRENTRY = 0
MASTERENTRY = 0
III = 1
WHILE III<=NREC CYCLE
UNLESS 0#FORINIT(III)_DIRNO#-2 THEN BASEDIRENTRY=III C
ELSE IF FORINIT(III)_DIRNO>0 C
AND (MASTERNAME="" OR FORINIT(III)_FILE->(MASTERNAME.".")) C
THEN START
MASTERENTRY = III
EXIT
FINISH
III = III + 1
REPEAT
IF MASTERENTRY=0 AND NREC=1 THEN MASTERENTRY = BASEDIRENTRY
IF MASTERENTRY#0 THEN START
PRELOAD (FORINIT(MASTERENTRY)_FILE)
IF SSOWN_RCODE=0 THEN START
SSOWN_LLINFO (-1) = SSOWN_LLINFO (0)
INITIALISE; ! Call routine supplied by course supervisor.
!
! Now check that both entries are loaded. If not, SSOWN_ALLCOMMAND
! or SSOWN_ALLCONNECT should be set non-zero.
TYPE=CODE
IF LOOKLOADED("S#ALLOWCOMMAND",TYPE)#0 C
THEN SSOWN_ALLCOMMAND = 0 C
ELSE SSOWN_ALLCOMMAND = -1
IF LOOKLOADED("S#ALLOWCONNECT",TYPE)#0 C
THEN SSOWN_ALLCONNECT = 0 C
ELSE SSOWN_ALLCONNECT = -1
GOTINIT = -1
FINISH
FINISH
FINISH
FINISH
IF GOTINIT=0 THEN START
! We have failed to find an acceptable INITIALISE routine.
PRINTSTRING ("*** Access barred ***")
NEWLINE
ZSTOP ("")
FINISH
FINISH
SSOWN_INTINPROGRESS = 0; ! Allow INT:A during messages.
FLAG = 0; ! Because CONSOLE (6) will check its second parameter.
CONSOLE (6, FLAG, FLAG); ! Get any outstanding messages.
FINISH
FINISH
SSOWN_INTINPROGRESS = 0; !SAFE TO RECEIVE INT:A
ICS; ! INIT CONTROL STREAM
IF SSOWN_CONTROLMODE=0 OR SSOWN_SSREASON#BATCHREASON THEN BCI ELSE START
NEWLINES(2)
OBEYJOB(DIRINF_JOBDOCFILE)
BATCHSTOP(0)
FINISH
RETURN
CONTIN: !COME HERE AFTER CONTINGENCY
*ST_DR0; !ACC CONTAINS DESC. TO 18 WORD
! AREA
IF SSOWN_SSCOMREG(34)=0 THEN SSOWN_SSCOMREG(34)=1
! This peculiar line above is to ensure that there is always a trap
! present to get you to here.
! If you have done repeated SIGNAL(2, ) then this could be the
! last trap. If so and you get an interrupt during diagnostics then
! no traps left!!!
SELECTOUTPUT(0)
SELECTINPUT(0)
CLASS = INTEGER(DR1)
SUBCLASS = INTEGER(DR1+4)
!INTERRUPT OF WT
FAULT = 10; !INTERRUPT
IF CLASS=65 START ; ! INT:
IF 'V'<=SUBCLASS<='Y' START ; !FORCED TERMINATION
IF SSOWN_SSREASON = BATCHREASON THEN BATCHSTOP(2)
!TERMINATE BATCH JOB
SSOWN_FDLEVEL = 1; !IN CASE IN OBEYFILE
TIDYFILES
IF SUBCLASS<='X' START
CONSOLE(19,FLAG,FLAG); !KILL INPUT - IF NEC
CONSOLE(7,FLAG,FLAG); !KILL OUTPUT - IF NEC
NEWLINE
IF SUBCLASS='V' C
THEN PRINTSTRING ("***Session has now ended***") C
ELSE C
IF SUBCLASS = 'W' C
THEN PRINTSTRING ("***Session terminated due to inactivity") C
ELSE PRINTSTRING ("***Session terminated by operator***")
NEWLINE
ZSTOP("")
FINISH ELSE START ; !INTERACTIVE TERMINAL NOT AVAILABLE
MESS = "
***Interactive terminal disconnected - session terminated***
"
TOJOURNAL(ADDR(MESS)+1,LENGTH(MESS))
CLOSEJOURNAL
HALT; !CANNOT PRINT ANY OUTPUT SO MUST NOT CALL COMMAND QUIT
FINISH
FINISH
SSOWN_INTMESS(7) <- SUBCLASS; !FOR INT MESSAGE IN RECALL FILE
TOJOURNAL(ADDR(SSOWN_INTMESS(1)),9)
CLASS = 0
CONSOLE(7,FLAG,FLAG); !KILL OUTPUT
IF SUBCLASS = 'C' THEN CONSOLE(8,FLAG,FLAG)
!KILL INPUT FOR INT:C
IF SSOWN_SSREASON = DSTARTREASON THEN SSOWN_DATAECHO = 0
!IN CASE SET NON ZERO IN OBEY
IF NEWLOADER#0 THEN START
IF SSOWN_LOADINPROGRESS#0 THEN START
UNLOAD2 (1,1)
SSOWN_LOADINPROGRESS = 0
FINISH
FINISH
FINISH ELSE START
SELECTOUTPUT(0)
PRINTSTRING("Error detected in Subsystem: ")
PRINTMESS (WTFAULT(CLASS))
NEWLINE
PRINT STRING ( C
"The following diagnostics may be useful if you need
to refer this problem to Advisory:")
NEWLINE
PRINT STRING ("Class: ")
WRITE(CLASS,8)
PRINT STRING (" Subclass: ")
WRITE(SUBCLASS,8)
NEWLINE
! Reset SSOWN_SSINHIBIT to 0 so that user can INT:A diagnostics -
! it might be non zero since we can never be sure where we got here
! from.
ALLOWINTERRUPTS
! %IF SSOWN_LOADINPROGRESS#0 %THEN LOADDUMP(""); ! Fail during load
SSOWN_FULLDUMP=1; ! Make sure of all possible diagnostics
NDIAG(INTEGER(DR1+16),INTEGER(DR1+8),0,0)
FINISH
END ; !OF CALL BCI
USEOPTIONS; !EXTRACT INFO FROM OPTIONS FILE
TIDYFILES; !SETS UP INITIAL STREAMS
SSOWN_CURRKI = DEFCPL*KIPS; !DEFAULT COMMAND CPULIMIT
DIRINF == RECORD(SSOWN_SSADIRINF)
SSOWN_SSINHIBIT=1; ! Ensure interrupts held off after PRIME CONTINGENCY
! Tell Director where SSOWN_INHIBIT and _SSINTCOUNT are located.
FLAG = X3{DASYNCINH}(0,ADDR(SSOWN_SSINHIBIT))
! Give name of trap routine to Director.
FLAG = X31{PRIMECONTINGENCY}(DIRTRAP)
IF TESTREASON # SSOWN_SSREASON # BATCHREASON START ; !INTERACTIVE USE
IF SSOWN_SSREASON = DSTARTREASON START ; !STARTED FROM OPER
CONSOLE(4,SSOWN_SSOPERNO,FLAG); !SSOWN_SSOPERNO CONTAIN OPER NUMBER
FINISH ELSE START ; !STARTED FROM INTERACTIVE TERMINAL
IF SSOWN_SSREASON=DNEWSTARTREASON THEN START
SSOWN_ITINLENGTH = 1024
SSOWN_ITOUTLENGTH = 3072
FINISH
CONSOLE(5,FLAG,FLAG)
SSOWN_SSREASON = DSTARTREASON; !DISTINCTION BETWEEN OPER AND IT NO LONGER RELEVENT
FINISH
JMESSAGE = "
**** LOG-ON AT ".TIME." ON ".DATE." ****
"
TOJOURNAL(ADDR(JMESSAGE)+1,LENGTH(JMESSAGE))
!PUT START-UP MESSAGE IN RECALL FILE
MESSAGEFILE = FMESSAGE
SSOWN_DATAECHO = 0; !DO NOT ECHO IN FOREGROUND
FINISH ELSE START
SSOWN_DATAECHO = SSOWN_SSDATAECHO; !USE OPTION FILE SETTING FOR BATCH
SSOWN_SESSKIC = DIRINF_SESSICLIM+KIPS; !ALLOW
!ONE SECOND OVER USER REQUESTED
PRINTSTRING("***** BATCH JOB ".DIRINF_JOBNAME. C
" STARTED AT ".TIME." ON ".DATE." ********")
NEWLINES(2)
MESSAGEFILE = BMESSAGE
FINISH
PRINTSTRING(UINFS(16)." Service, ")
JMESSAGE = CONFILE (ABASEFILE)
IF STUDENTSS#0 THEN START
IF JMESSAGE=STUDBASE THEN PRINTSTRING ("Student ") C
ELSE IF JMESSAGE#DEFBASE THEN PRINTSTRING ("Test ")
FINISH ELSE START
IF JMESSAGE=DEFBASE THEN PRINTSTRING ("Standard ") C
ELSE IF JMESSAGE#STUDBASE THEN PRINTSTRING ("Test ")
FINISH
PRINTSTRING(VERSION)
NEWLINE
PRINTSTRING(DATE." ".TIME." Fsys=".ITOS(SSOWN_SSOWNFSYS)." ")
IF FUNDS ON=0 THEN PRINTSTRING("Users=".ITOS(NUSERS-SYSPROCS)." ")
IF SSOWN_UNSHAREDBGLA#0 THEN PRINTSTRING("** Unshared basegla
")
BDIRLIST
IF FUNDS ON#0 START
IF SSOWN_SSREASON#BATCHREASON START
NEWLINE
FUNDS("")
FINISH
FINISH
CONNECT(MESSAGEFILE,0,0,0,RR,FLAG)
IF FLAG=0 START
IF RR_DATAEND>RR_DATASTART START ; !FILE CONTAINS SOMETHING
! %FOR I=RR_CONAD+RR_DATASTART,1,RR_CONAD+RR_DATAEND-1 %C
! %CYCLE
! PRINTCH(BYTEINTEGER(I))
! %REPEAT
! Equivalent call on IOCP:
DRH = (LENGTHENI(RR_DATAEND - RR_DATASTART)<<32) C
! (RR_CONAD + RR_DATASTART)
FLAG = IOCP (19,ADDR(DRH))
! ADD NEWLINE TO END OF MESSAGE IF NEC.
! %IF BYTEINTEGER(I)#NL %THEN NEWLINE
IF BYTE INTEGER (RR_CONAD+RR_DATAEND-1)#NL THEN NEWLINE
FINISH
DISCONNECT(MESSAGEFILE,FLAG)
FINISH
IF SSOWN_SSREASON#BATCHREASON START
IF 30<SECSTOCLOSE<1200 AND DIRINF_PART CLOSE=0 THEN START
!CLOSING SOON
NEWLINE
PRINTSTRING("Warning - close in ".ITOS(SECSTOCLOSE//60). C
" minutes")
NEWLINE
FINISH
IF STUDENTSS=0 THEN START
FLAG = 0
CONSOLE(6,FLAG,FLAG); !PRINT ANY OUTSTANDING OPER MESSAGES
FINISH
FINISH
!
SSOWN_SSSTARTTIME = TIME
SSOWN_STARTSECS = SECSFRMN; !SECONDS FROM MIDNIGHT FOR METER
L1:
CALLBCI
-> L1
END ; !OF CONTROL
!
! - END OF CONT CODE ]
!
!
! [ START OF BASE TEXT -
!
!
! Mode bits recognised by Director:
! **** **** must be updated if Director facilities are enhanced **** ****
CONST INTEGER VALID MODE BITS = X'800003FF'
! For the significance of the bits, see comment in CONNECT.
!!*
!***END OF DECLARATIONS
!*
!*
!*
!
SYSTEMROUTINE MOVE(INTEGER LENGTH, FROM, TO)
INTEGER SUBL
IF LENGTH<=0 THEN RETURN
LENGTH = LENGTH & X'00FFFFFF'
CYCLE
*LDTB_X'18000000'
*LDB_LENGTH
*LDA_FROM
*CYD_0
*LDA_TO
*CHOV_L =DR
*JCC_13,<MOVEALL>
! %EXIT %IF no dangerous overlap.
*LSS_TO
*USB_FROM; ! Unsigned arithmetic to avoid overflow.
*ST_SUBL
WHILE LENGTH>SUBL CYCLE
LENGTH = LENGTH - SUBL
*LDTB_X'18000000'
*LDB_SUBL
*LDA_FROM
*INCA_LENGTH
*CYD_0
*INCA_SUBL
*MV_L =DR
REPEAT
REPEAT
MOVEALL:
*MV_L =DR
END ; !OF MOVE
!
SYSTEMROUTINE FILL(INTEGER LENGTH, FROM, FILLER)
*LB_LENGTH
*JAT_14,<L99>; !RETURN IF LENGTH<=0
*LDTB_X'18000000'
*LDB_B
*LDA_FROM
*LB_FILLER
*MVL_L =DR
L99:
END ; !OF FILL
!
SYSTEM INTEGER FN SAMEBYTES (INTEGER L, A1, A2)
! Compares L bytes at A1 with L bytes at A2. Returns count of
! bytes which match at start of the two areas: zero if the first
! bytes are not the same, and L if the two areas are exactly the
! same.
*LDTB_X'18000000'
*LDB_L
*LDA_A1
*CYD_0
*LDA_A2
*CPS_L =DR
*CYD_0
*STUH_B
*ISB_A2
*EXIT_-64
END
!
SYSTEM INTEGER FN STOREMATCH (INTEGER L, A1, A2)
! Compares L bytes at A1 with L bytes at A2. Returns non-zero if
! the two areas are the same, or zero if they differ.
*LDTB_X'18000000'
*LDB_L
*LDA_A1
*CYD_0
*LDA_A2
*CPS_L =DR
*JCC_8,<MF>
RESULT = 0
MF: RESULT = -1
END
!
EXTERNALSTRINGFN FROMSTRING(STRINGNAME S, INTEGER I, J)
INTEGER AH
STRING (255) HOLDS
IF I<1 OR I>J OR J>LENGTH(S) THEN PSYSMES(-105,35)
HOLDS = S; !MUST COPY IT TO AVOID
! ALTERING ORIGINAL
AH = ADDR(HOLDS)
BYTEINTEGER(AH+I-1) = J-I+1; !SET LENGTH
RESULT = STRING(AH+I-1)
END ; !OF FROMSTRING
!
SYSTEM STRING (255) FN SUBSTRING (STRING NAME S, INTEGER I, J)
STRING (255) HOLDS
IF I<1 OR I>J+1 OR J>LENGTH(S) THEN SIGNAL EVENT 5,7
! For strict compatibility with IMP 77, we should also %SIGNAL if
! I = LENGTH(S) + 1.
J = J - I + 1
LENGTH (HOLDS) = J
MOVE (J, ADDR(S)+I, ADDR(HOLDS)+1)
RESULT = HOLDS
END
!
SYSTEM ROUTINE UCTRANSLATE (INTEGER ADDRESS, LENGTH)
INTEGER P
P=INTEGER(ATRANS)+512
*LDTB_X'18000100'
*LDA_P
*CYD_0
*LDA_ADDRESS
*LDB_LENGTH
*TTR_L =DR
END
!
EXTERNAL STRING FN UCSTRING (STRING (255) S)
INTEGER P
P=INTEGER(ATRANS)+512
*LDTB_X'18000100'
*LDA_P
*CYD_0
*LDA_S+4
*LDB_(DR +0)
*INCA_1
*TTR_L =DR
RESULT = S
END
!
SYSTEMROUTINE ITOE(INTEGER AD, L)
INTEGER J
J = SSOWN_SSCOMREG(12); !ADDR OF ITOE TABLE IN PUBLIC SEGMENT
*LB_L
*JAT_14,<L99>
*LDTB_X'18000000'
*LDB_B
*LDA_AD
*LSS_J
*LUH_X'18000100'
*TTR_L =DR
L99:
END ; !OF ITOE
!
SYSTEMROUTINE ETOI(INTEGER AD, L)
INTEGER J
J = SSOWN_SSCOMREG(11); !ADDR OF ETOI TABLE IN PUBLIC SEGMENT
*LB_L
*JAT_14,<L99>
*LDTB_X'18000000'
*LDB_B
*LDA_AD
*LSS_J
*LUH_X'18000100'
*TTR_L =DR
L99:
END ; !OF ETOI
!
! %INTEGERFN TRAIL SPACES(%INTEGER END, FIRST, TRANS)
! !*DETERMINE NO OF TRAILING SPACES FROM END BACK TO FIRST
! %INTEGER SAVE END, SPACECHAR
! SAVE END = END
! %IF TRANS # 0 %THEN SPACECHAR = 64 %ELSE SPACECHAR = ' '
! !MAY BE EBCDIC FILE
! %WHILE BYTEINTEGER(END) = SPACECHAR %AND END >= FIRST %C
! %THEN END = END-1
! %RESULT = SAVE END-END
! %END; !OF TRAIL SPACES
! Here is a much faster machine code version, equivalent to
! the IMP code above:
SYSTEM INTEGER FN TRAIL SPACES (INTEGER LINE END, LINE START, TRANS)
INTEGER A
*LDTB_X'18000000'
*LB_LINE START
*LDA_B
*SLB_LINE END
*SBB_TOS
*ADB_1
*JAF_13,<ZERO>; ! if <=0 bytes to test.
*LDB_B
*LSS_TRANS
*JAT_4,<ISO>
*LB_64; ! EBCDIC space.
*J_<LOOP>
ISO:
*LB_32; ! ISO space.
LOOP:
*CYD_0
*SWEQ_L =DR
*JCC_8,<ALLSPACES>
*SWNE_L =DR
*JCC_7,<LOOP>
ZERO:
RESULT = 0
ALLSPACES:
*STUH_A
RESULT = A & X'00FFFFFF'
END
!
!
SYSTEM ROUTINE CHOPLDR (STRING NAME A, INTEGER I)
! This routine discards I bytes from the start of the string A, so that
! the length of A is reduced by A. I must be <= LENGTH(A) on entry.
! This is not checked.
*LB_(A)
*SBB_I
*STB_(DR +0)
*INCA_1
*LDB_B
*STD_TOS
*INCA_I
*CYD_0
*LD_TOS
*MV_L =DR
END
!
SYSTEM C
INTEGER FN STARTSWITH (STRING NAME A, STRING (255) B, INTEGER CHOP)
! This function returns zero if string A does not start with a copy
! of string B, and returns a non-zero value if string B is the same as
! the first characters of string A. If CHOP is zero, then that is
! the only effect of STARTSWITH. If CHOP is non-zero, then STARTSWITH
! also has the side effect of discarding the copy of B from the
! beginning of A, so that A is 'shortened' by LENGTH (B) bytes.
! The code below would work perfectly well if the second
! parameter were %STRING %NAME B, and a call would be significantly
! quicker, but it is a great nuisance not to be able to call
! STARTSWITH with a constant or literal string or an expression
! for the second parameter. I have therefore sacrificed speed
! to utility. Dedicated bit-twiddlers may however choose to
! exploit the following deplorable trick: you can put a %SPEC in
! your code for STARTSWITH with parameters
! (%STRING %NAME A, B, %INTEGER CHOP)
! and when you call it, it will actually work and even give you the
! extra speed. In fact, by giving two %SPECs and using the
! REDIRECT option in MODIFY, you could even use both forms of call
! to enter STARTSWITH.
*LB_(A) ; ! Get byte vector descriptor to the whole
! string (including length byte) into DR,
! and get a copy of the length byte into B.
*INCA_1 ; ! Point to the text of the string.
! The bound is wrong for the text - it is
! actually 'max. length + 1' - but that
! does not matter.
*CYD_0 ; ! Acc now has the descriptor for the
! text of A.
*SBB_(B) ; ! B now has LENGTH(A) - LENGTH(B).
! DR has descriptor to the whole of B.
*JAT_14,<NEQ> ; ! Branch if LENGTH(B)>LENGTH(A).
*LDB_(DR +0) ; ! Change bound in DR to LENGTH(B).
*JAT_11,<REQ> ; ! Branch if B is a null string.
*INCA_1 ; ! Point to text of B.
*CPS_L =DR ; ! Compare B with leading bytes of A.
*JCC_7,<NEQ> ; ! Branch if B does not match leading
! bytes of A.
!
! B matches leading bytes of A:
! Acc has descriptor to residual text
! of A (bound is too large, but that
! will not matter).
*SLB_CHOP ; ! Save LENGTH(A)-LENGTH(B),
! fetch CHOP.
*JAT_12,<REQ> ; ! Branch if CHOP=0.
*LB_TOS ; ! Restore LENGTH(A)-LENGTH(B).
*STB_(A) ; ! Make that the new length of A.
! DR now has a descriptor to the whole
! of A.
*INCA_1 ; ! Point at text of A.
*LDB_B ; ! Set bound = new length of text of A.
*MV_L =DR ; ! Copy residue of A into text of A.
REQ: RESULT = -1
NEQ: RESULT = 0
END
!
SYSTEM ROUTINE CAST OUT (STRING NAME PSTR)
INTEGER STREND, P
LONG INTEGER DR, PARTDR, RESIDR, TTDR
! Ensure TTDR is set up as a descriptor to the lower-to-upper-case
! translate table.
TTDR=X'1800010000000000'+INTEGER(ATRANS)+512
!
! Prepare a descriptor to the text of the string:
DR = (LENGTHENI(X'58000000'!LENGTH(PSTR))<<32)!(ADDR(PSTR)+1)
!
*LD_DR; ! Initialise - not done for subsequent iterations.
!
QUOTESCAN:
*STD_DR
*SWNE_L =DR ,0,34; ! %MASK=0,%REF='"'
*STD_RESIDR; ! Save descriptor to remainder of string,
! including and after the quote.
*LB_RESIDR+4; ! Pick up address of the 'quote' byte.
*SBB_DR+4; ! Subtract start address of text in original string -
! gives number of bytes before the quote symbol.
*LD_DR; ! Restore descriptor to original text.
*LDB_B ; ! Build descriptor to the bytes before the quote.
*STD_PARTDR
! PARTDR is a descriptor to the bytes before the quote:
! RESIDR is a descriptor to the bytes including and after the quote.
!
! Translate the bytes before the quote to upper case.
*LD_PARTDR
*LSD_TTDR
*TTR_L =DR
!
! Remove the spaces from the bytes before the quote.
CLEARSP:
*LD_PARTDR
*SWNE_L =DR ,0,32; ! %MASK=0,%REF=SP.
*JCC_8,<NOSP>; ! -> if no space found.
!
! Space has been found. DR points to it and the bytes beyond it.
*MODD_1; ! Skip the space byte - DR now points to the
! bytes after the space.
*CYD_0; ! Now Acc has a descriptor to them.
*INCA_-1; ! DR has a descriptor to the same number of bytes,
! but starting where the space byte is.
*STD_PARTDR; ! Save that descriptor for the next time round the loop.
*MV_L =DR ; ! Shift the bytes-beyond-the-space one position
! to the left, thus eliminating the space.
*J_<CLEARSP>; ! Go round again, to clear out the next space (if any).
!
! Spaces have now been eliminated from the string before the quote,
! and that part of the string has also been translated to upper case.
NOSP:
! Shift the bytes-after-the-quote to the left to lie just after the
! bytes-before-the-quote (from which spaces have already been eliminated),
! thus eliminating the quote itself.
!
! Since we have just done SWNE and failed to find a space, DR points
! just beyond the part from which spaces have been cleared.
*SLD_RESIDR; ! Stack that descriptor and restore the descriptor to
! the string including and after the quote.
*JAT_11,<DONE1>; ! -> if that is an empty row - i.e., no quote.
*MODD_1; ! Discard the quote.
*CYD_0; ! Acc descriptor points to the string-after-the-quote.
*LDA_TOS ; ! DR descriptor points to string of the same length,
! starting just after the part from which spaces have
! just been eliminated.
! Incidentally, if you look at the code carefully, you
! will see that we have left a single word X'58000000'
! on %TOS.
*STD_TOS ; ! Saved for future reference.
*MV_L =DR ; ! Shift the bytes down.
!
! Now we scan the bytes-after-the-quote for another quote.
*LD_TOS ; ! Recover descriptor to the bytes-after-the-quote in
! their new position.
CLOSESCAN:
*SWNE_L =DR ,0,34; ! %MASK=0,%REF='"'
*JCC_8,<DONE2>; ! -> if no closing quote found.
! DR now points to the closing quote and subsequent bytes.
*MODD_1; ! Point to the residue beyond the quote.
*JAT_11,<DONE3>; ! -> if no residue - task complete.
*CYD_0; ! Prepare to move residue down to eliminate the quote.
*INCA_-1; ! DR now points to new home for residue.
*STD_TOS ; ! Save it.
*MV_L =DR ; ! Move the residue down one place.
*LDTB_TTDR; ! Get a byte-vector type and non-zero bound.
*LDA_TOS ; ! Make a byte-vector descriptor to the residue in its
! new position.
*LB_(DR +0); ! Pick up first byte of residue.
*LDTB_TOS ; ! Restore string descriptor to residue in its new position.
*CPB_34; ! See if it was another quote.
*JCC_7,<QUOTESCAN>; ! If the residue doesn't start with a quote, we
! go back to scan for the next quote and to translate
! everything before the next quote to upper case and
! to discard all the spaces from it.
*MODD_1; ! Skip first byte of residue.
*J_<CLOSESCAN>; ! If the first byte IS a quote, we carry on scanning
! 'within quotes', because we have just seen two
! consecutive quotes. The first one has been discarded,
! and we have ensured that the second one will survive,
! because the next scan will start just beyond it.
!
!
DONE1:
*LSS_TOS
*J_<DONE4>
DONE3:
*INCA_-1
DONE2:
*CYD_0
*STUH_B
DONE4:
*ST_STREND
LENGTH (PSTR) = STREND - ADDR(PSTR) - 1
END
!
SYSTEM INTEGER FN SIZE OF (NAME X)
! Needed for 'straight' code:
! %CONST %BYTE %INTEGER %ARRAY BYTES (0:7) = 1(4),2,4,8,16
INTEGER I
*LSS_(LNB +5)
*ST_I
IF I&X'C2000000'#0 THEN RESULT = I&X'00FFFFFF'
! 'Straight' code:
! I = (I>>27) & 7
! %RESULT = BYTES (I)
! 'Bit-twiddling' equivalent:
RESULT = ((X'000000F0'<<((I>>27) & 7))>>11) + 1
END
!
SYSTEMSTRINGFN ITOS(INTEGER N)
!**********************************************************************
!* *
!* TURNS AN INTEGER INTO A STRING USES MACHINE CODE *
!* *
!**********************************************************************
STRING (16) S
INTEGER D0, D1, D2, D3
*LSS_N; *CDEC_0
*LD_S; *INCA_1; ! PAST LENGTH BYTE
*CPB_B ; ! SET CC=0
*SUPK_L =15,0,32; ! UNPACK 15 DIGITS SPACE FILL
*STD_D2; ! FINAL DR FOR LENGTH CALCS
*JCC_8,<WASZERO>; ! N=0 CASE
*LSD_TOS ; *ST_D0; ! SIGN DESCRIPTOR STKED BY SUPK
*LD_S; *INCA_1
*MVL_L =15,15,48; ! FORCE IN ISO ZONE CODES
IF N<0 THEN START
BYTEINTEGER(D1) = '-'
D1 = D1-1
FINISH
BYTEINTEGER(D1) = D3-D1-1
RESULT = STRING(D1)
WASZERO:
RESULT = "0"
END ; !OF ITOS
!
SYSTEMINTEGERFN PSTOI(STRING (63) S)
!CONVERT STRING CONTAINING
! POSITIVE INTEGER TO INTEGER
! RESULT
!RESULT = -1 IF INVALID
! STRING IN ANY RESPECT
INTEGER VALUE, J, K, L
VALUE = 0
L = LENGTH(S)
IF L = 0 THEN RESULT = -1
FOR K=1,1,L CYCLE
J = CHARNO(S,K)
UNLESS '0' <= J <= '9' THEN RESULT = -1
VALUE = 10*VALUE+J&15
REPEAT
RESULT = VALUE
!
! **** ****
! We could use PACK, etc., but the catch is in checking that the
! characters lie in the range '0' to '9'. We will need a few tables
! for TCH, generally accessible throughout the Subsystem, and then
! similar code could be simplified in quite a few places.
! **** ****
!
END ; ! PSTOI
!
! %STRINGFN S2(%INTEGER N)
! THIS FUNCTION RETURNS A TWO DIGIT DECIMAL VALUE FOR N
! %INTEGER TENS, UNITS
! TENS = N//10
! UNITS = N-10*TENS
! %RESULT = TOSTRING(TENS+'0').TOSTRING(UNITS+'0')
! %END; !OF S2
!
INTEGERFN I2(INTEGER AD)
!AD POINTS TO THE FIRST OF A PAIR OF DECIMAL CHARACTERS. THE RESULT
!IS THE NUMERIC VALUE OF THE CHAS
RESULT = 10*(BYTEINTEGER(AD)&X'F')+(BYTEINTEGER(AD+1)&X'F')
! I have tried
! %RESULT = 10*BYTEINTEGER(AD) + BYTEINTEGER(AD+1) - 11*'0'
! but, for reasons I don't understand, it takes the SAME space
! and MORE OCP time! (at IMP 9)
END ; !OF I2
!
ROUTINE DECWRITE2(INTEGER VALUE,AD)
!***********************************************************************
!* WRITES VALUE AS TWO DECIMAL ISO DIGITS INTO AD AND AD+1 *
!***********************************************************************
*LSS_VALUE; *IMDV_10
*USH_8; *IAD_TOS ; *IAD_X'3030'
*LDA_AD; *LDTB_X'58000002'
*ST_(DR )
END ; ! OF DECWRITE2
!
SYSTEMSTRING (8) FN HTOS(INTEGER VALUE, PLACES)
!**********************************************************************
!* *
!* TURNS AN INTEGER INTO A HEXADECIMAL STRING OF GIVEN LENGTH *
!* USES MACHINE CODE *
!* *
!**********************************************************************
STRING (8) S
INTEGER I
I = 64-4*PLACES
*LD_S; *LSS_PLACES; *ST_(DR )
*INCA_1; *STD_TOS ; *STD_TOS
*LSS_VALUE; *LUH_0; *USH_I
*MPSR_X'24'; ! SET CC=1
*SUPK_L =8
*LD_TOS ; *ANDS_L =8,0,15; ! THROW AWAY ZONE CODES
*LSS_HEX+4; *LUH_X'18000010'
*LD_TOS ; *TTR_L =8
RESULT = S
END ; !OF HTOS
!
SYSTEMROUTINE PHEX(INTEGER I)
PRINTSTRING(HTOS(I,8))
END ; !OF PHEX
!
!***********************************************************************
!* *
!* THESE FUNCTIONS ALL USE A PACKED FORMAT OF DATE AND TIME OF ONE OF *
!* THE FOLLOWING FORMS.BITS ARE NUMBERED FROM 31 (MOST SIGNIFICANT) TO *
!* 0 (LEAST SIGNIFICANT) *
!* OLD FORMAT *
!* BITS USE *
!* 31 ZERO FOR OLD FORMAT *
!* 30-26 YEAR-70 (VALID FOR 1970-2033) *
!* 25-22 MONTH *
!* 21-17 DAY *
!* 16-12 HOUR *
!* 11- 6 MINUTE *
!* 5- 0 SECOND *
!* *
!* NEW FORMAT *
!* BIT31 1 FOR NEW FORMAT *
!* ALL OTHER BITS HOLD DT AS SECS SINCE 0000HRS ON 1/1/70 *
!* CALCULATED AS PER CACM COLLECTER ALGORITHMS NO 199Z *
!* NB TO KEEP LEAP YEARS CORRECT ONE MUST USE THIS ALGORITH FROM *
!* 1ST JAN 1900 AND THEN CORRECT. THIS INVOLVES 64BIT ARITHMETIC *
!***********************************************************************
!
SYSTEM INTEGER FN CURRENT PACKED DT
!***********************************************************************
!* GIVES CURRENT DT IN NEW PACKED FORM *
!***********************************************************************
CONSTLONGINTEGER MILL=1000000
*RRTC_0; *USH_-1
*SHS_1; *USH_1
*IMDV_MILL
*ISB_SECS70; *STUH_B
*OR_X'80000000'
*EXIT_-64
END
!
SYSTEM INTEGER FN DTWORD (INTEGER S)
INTEGER Y,M
! Given a binary date and time in either the old or the new format,
! returns the equivalent new-format date-and-time word.
IF S<0 THEN RESULT = S
Y = (S>>26) + 70
M = (S>>22) & 15
! D = (S>>17) & 31
! HRS = (S>>12) & 31
! MINS = (S>>6) & 63
! SECS = S&63
IF M>2 THEN M = M-3 ELSE START
M = M + 9
Y = Y - 1
FINISH
! %RESULT = (((((1461*Y)//4 + (153*M+2)//5 + D + 58 - DAYS70) * 24 %C
! + HRS) * 60 + MINS) * 60 + SECS) ! X'80000000'
RESULT = (((((Y*1461)//4 C
+ (M*153+2)//5 C
+ ((S>>17)&31) - 25509) * 24 C
+ ((S>>12)&31)) * 60 + ((S>>6)&63)) * 60 + (S&63)) ! X'80000000'
END
!
! **** **** The following three routines replaced the **** ****
! **** **** old versions of PACKDATE and PACKDATEANDTIME **** ****
! **** **** when the new format was put into service. **** ****
!
INTEGERFN KDAY(INTEGER D,M,Y)
!***********************************************************************
!* RETURNS DAYS SINCE 1900 GIVEN DAY MONTH &YEAR(<=99) *
!***********************************************************************
IF M>2 THEN M = M-3 ELSE START
M = M+9
Y = Y-1
FINISH
RESULT =1461*Y//4+(153*M+2)//5+D+58
END
!
INTEGERFN PACKDATE(STRING (8) DATE)
INTEGER AD,I
AD = ADDR(DATE)
I=KDAY(I2(AD+1),I2(AD+4),I2(AD+7))-DAYS70
RESULT =I*SECSIN 24 HRS!X'80000000'
END ; !OF PACKDATE
!
SYSTEM INTEGERFN PACKDATEANDTIME(STRING (8) DATE, TIME)
INTEGER AT
AT = ADDR(TIME)
RESULT =PACKDATE(DATE)+3600*I2(AT+1)+60*I2(AT+4)+I2(AT+7)
END ; !OF PACKDATEANDTIME
!
! **** **** End of code for new format of date and time. **** ****
!
! **** **** Here are the old versions: **** ****
!
! %INTEGERFN PACKDATE(%STRING (8) DATE)
! %INTEGER AD
! AD = ADDR(DATE)
! %RESULT = ((I2(AD+7)-70)<<26)!(I2(AD+4)<<22)!(I2(AD+1)<<17)
! %END; !OF PACKDATE
!
! %SYSTEMINTEGERFN PACKDATEANDTIME(%STRING (8) DATE, TIME)
! %INTEGER AT
! AT = ADDR(TIME)
! %RESULT = PACKDATE(DATE)!(I2(AT+1)<<12)!(I2(AT+4)<<6)!(I2(AT+7))
! %END; !OF PACKDATEANDTIME
!
! **** **** end of old versions **** ****
!
SYSTEM STRING (8)FN UNPACK DATE(INTEGER P)
INTEGER D,M,Y,AD
STRING (8)S
AD=ADDR(S)
S="00/00/00"
IF P>0 THEN START ; ! OLD FORMAT
Y=P>>26+70
IF Y>99 THEN Y = Y - 100
M=P>>22&15
D=P>>17&31
FINISH ELSE START
P=(P&X'7FFFFFFF')//SECS IN 24 HRS
KDATE(D,M,Y,P+DAYS70)
FINISH
DECWRITE2(D,AD+1)
DECWRITE2(M,AD+4)
DECWRITE2(Y,AD+7)
RESULT =S
END
!
SYSTEM STRING (8)FN UNPACK TIME(INTEGER P)
INTEGER H,M,SECS,AT
STRING (8)S
AT=ADDR(S)
S="00.00.00"
IF P>0 START
H=P>>12&31
M=P>>6&63
SECS=P&63
FINISH ELSE START
*LSS_P; *USH_1; *USH_-1
*IMDV_60; *IMDV_60; *IMDV_24
*LSS_TOS ; *ST_H
*LSS_TOS ; *ST_M
*LSS_TOS ; *ST_SECS
FINISH
DECWRITE2(H,AT+1)
DECWRITE2(M,AT+4)
DECWRITE2(SECS,AT+7)
RESULT =S
END
!
ROUTINE KDATE(INTEGERNAME D,M,Y,INTEGER K)
!***********************************************************************
!* K IS DAYS SINCE 1ST JAN 1900 *
!* RETURNS D, M, Y 2 DIGIT Y ONLY *
!***********************************************************************
! %INTEGER W
! K=K+693902; ! DAYS SINCE CAESARS BDAY
! W=4*K-1
! Y=W//146097
! K=W-146097*Y
! D=K//4
! K=(4*D+3)//1461:
! D=4*D+3-1461*K
! D=(D+4)//4
! M=(5*D-3)//153
! D=5*D-3-153*M
! D=(D+5)//5
! Y=K
*LSS_K; *IAD_693902
*IMY_4; *ISB_1; *IMDV_146097
*LSS_TOS ; *IDV_4; *IMY_4; *IAD_3
*IMDV_1461; *ST_(Y)
*LSS_TOS ; *IAD_4; *IDV_4
*IMY_5; *ISB_3; *IMDV_153
*ST_(M); *LSS_TOS
*IAD_5; *IDV_5; *ST_(D)
IF M<10 THEN M=M+3 ELSE START
M=M-9
IF Y=99 THEN Y = 0 ELSE Y=Y+1
FINISH
END ; ! OF KDATE
!
EXTERNALINTEGERFN UINFI(INTEGER ENTRY)
CONSTINTEGER MAXENTRY = 26
INTEGER LNB, CT,RES
SWITCH SW(1 : MAXENTRY)
RECORD (DIRINFF)NAME DIRINF
UNLESS 1 <= ENTRY <= MAXENTRY THEN RESULT = 0
DIRINF == RECORD(SSOWN_SSADIRINF); !NEEDED FOR ENTRIES 7 - 9
-> SW(ENTRY)
SW(1): !OWN FSYS
RESULT = SSOWN_SSOWNFSYS
SW(2): !MODE 1=FOREGROUND
!2=BATCH
!3=FOREGROUND OBEYFILE
RES = SSOWN_SSREASON
IF RES=DSTARTREASON AND (SSOWN_FDLEVEL>1 OR SSOWN_CONTROLMODE#0) THEN RES = 3
! IN OBEY FILE OR OBEYJOB
RESULT = RES
SW(3): !NUMBER OF USERS
RESULT = NUSERS-SYSPROCS
SW(4): !CURRENT ACR LEVEL
*STLN_LNB; !CURRENT LNB
RESULT = (INTEGER(LNB+4)>>20)&X'F'; !ACR FROM STACK FRAME
SW(5): !CURRENT CPULIMIT - SECONDS
RESULT = SSOWN_CURRKI//KIPS
SW(6): !MAX FILE SIZE IN KBYTES - FOR DEFINE
RESULT = (SSOWN_SSMAXFSIZE>>KSHIFT)-1
SW(7): !SYNC1DEST
RESULT = DIRINF_SYNC1DEST
SW(8): !SYNC2DEST
RESULT = DIRINF_SYNC2DEST
SW(9): !ASYNCDEST
RESULT = DIRINF_ASYNCDEST
SW(10): !ADIRINF
RESULT = SSOWN_SSADIRINF
SW(11): !PROCNO
RESULT = DIRINF_PROCNO
SW(12): !SSOWN_FDLEVEL
RESULT = SSOWN_FDLEVEL
SW(13): !INCARNATION - AS AN INTEGER
RESULT = SSOWN_SSINVOCATION
SW(14): !AUXSTACKSIZE
RESULT = SSOWN_SSASTACKSIZE>>KSHIFT; !IN KBYTES
SW(15): !ITWIDTH
RESULT =SSOWN_SSITWIDTH
SW(16): !BRACKETS - 1 IF SET 0 IF NOBRACKETS
IF SSOWN_SSLDELIM='(' THENRESULT =1
RESULT =0
SW(17): !MAXPROMPTSIZE
RESULT =MAXPROMPTSIZE
SW(18): !#0 FOR JOB CONTROL MODE
RESULT =SSOWN_CONTROLMODE
SW(19): !#0 RESOURCES=SCARCE
IF FUNDS ON#0 THEN START
!**FUNDSSTART
IF SCARCEWORD&X'FF'>=SCARCEWORD>>24 THENRESULT =1; !RESOURCES ARE SCARCE
!**FUNDSEND
FINISH
RESULT =0
SW(20): !FUNDS LEFT - IN PENCE
RESULT = DIRINF_FUNDS//100; !RES IN PENCE/100
SW(21): !CHARGE FOR THIS SESSION IN PENCE
IF SSOWN_SSREASON=BATCHREASON THEN CT=0 ELSE START
CT=(SECSFRMN-SSOWN_STARTSECS)//60; !CONNECT TIME IN MINS
IF CT<0 THEN CT=CT+1440; !GONE PAST MIDNIGHT
FINISH
RESULT =CHARGE(CPUTIME,PAGETURNS,CT)
SW(22): ! Returns non-zero iff messages are inhibited.
RESULT = SSOWN_INHIBIT MESSAGES
SW(23): !TERMINAL TYPE
RESULT =SSOWN_SSTERMINALTYPE
SW(24): ! FEP software identification -
RESULT = DIRINF_DIDENT
SW(25): ! Stream identification -
RESULT = DIRINF_STREAM ID
SW(26): ! Loader version.
IF NEWLOADER=0 THEN START
RESULT = 0
FINISH ELSE START
RESULT = 1
FINISH
END ; !OF UINFI
!
EXTERNALSTRINGFN UINFS(INTEGER ENTRY)
CONST RECORD (COMF) NAME COM = X'80C00000'
RECORD (SCTF) NAME SCT
RECORD (DIRINFF) NAME DIRINF
CONSTINTEGER MAXENTRY = 16
SWITCH SW(1 : MAXENTRY)
STRING (255) RES
CONST STRING (4) ARRAY C
OCPTYPES (1:6) = C
"2950","2960","2970",
"2988","2972","2976"
INTEGER FLAG,PROCESSOR
UNLESS 1 <= ENTRY <= MAXENTRY THEN RESULT = ""
DIRINF == RECORD (SSOWN_SSADIRINF)
IF DIRINF_SCT BLOCK AD=0 THEN SCT==RECORD(X'00200000') ELSE C
SCT==RECORD(DIRINF_SCT BLOCK AD)
-> SW(ENTRY)
SW(1): !OWNER
RESULT = SSOWN_SSOWNER
SW(2): !DELIVERY INFO
FLAG = X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,1,0,ADDR(RES))
RESULT = RES
SW(3): !STARTTIME
RESULT = SSOWN_SSSTARTTIME
SW(4): !CURRENT PROMPT
RESULT = SSOWN_PROMPTTEXT
SW(5): !CURRENT ACTIVE DIR
RESULT = SSOWN_AVD
SW(6): !SUBSYSTEM VERSION
RESULT = VERSION
SW(7): !SURNAME
FLAG=X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,18,0,ADDR(RES))
RESULT =RES
SW(8): !OPTION CFAULTS=
RESULT =SSOWN_SSCFAULTS
SW(9): !FUNDS HELD BY
FLAG=X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,37,0,ADDR(RES))
RESULT =RES
SW(10): !OCPTYPE
RESULT =OCPTYPES(COM_OCPTYPE&X'000000FF')
SW(11): ! Batch job name.
IF DIRINF_REASON=BATCHREASON THEN RESULT = DIRINF_JOBNAME ELSE RESULT = ""
SW(12): ! Supervisor version.
RESULT = STRING(ADDR(COM_SUPVSN))
SW(13): ! Director version.
RESULT = SCT_FIXUPDATE
SW(14): ! Terminal address.
RESULT = DIRINF_ITADDR; ! What if SSOWN_SSREASON=2?
SW(15): !
RESULT ="UK.AC"
SW(16): !
IF MACHINE=2972 START
RESULT ="EDINBURGH.EMAS"
FINISH
IF MACHINE=2980 OR MACHINE=2988 THEN START
RESULT ="EDINBURGH.BUSH"
FINISH
IF MACHINE=2960 THEN START
RESULT ="UKC.EMAS"
FINISH
IF MACHINE=0 THEN START
PROCESSOR = COM_OCPTYPE & X'000000FF'
IF PROCESSOR=4 THEN START ; ! 2980 or 2988.
RESULT ="EDINBURGH.BUSH"
FINISH
IF PROCESSOR>4 THEN START ; ! 5 for 2972, 6 for 2976 (?).
RESULT ="EDINBURGH.EMAS"
FINISH
IF PROCESSOR=2 THEN START ; ! 2 for 2960.
RESULT ="UKC.EMAS"
FINISH
FINISH
END ; !OF UINFS
!
SYSTEM ROUTINE SET SS INHIBIT
SSOWN_SSINHIBIT = 1
END
!
SYSTEMROUTINE ALLOW INTERRUPTS
INTEGER I
! Make sure that ALLOW INTERRUPTS does not do anything if there
! are no traps available. This is important between the call of PRIME
! CONTINGENCY in CONTROL and setting the traps in CALLBCI. We are completely
! unprotected in that bit.
! Achieve the desired effect by only allowing interrupts if
! SSOWN_SSCOMREG(34) i.e. SIGLEVEL, #0
IF SSOWN_SSCOMREG(34)#0 THEN START
SSOWN_SSINHIBIT = 0; !TO ALLOW INTERRUPTS AGAIN
WHILE SSOWN_SSINTCOUNT>0 CYCLE ; ! TAKE ANY OUTSTANDING ONES
I = X3{DASYNCINH}(1,0)
REPEAT
FINISH
END ; !OF ALLOW INTERRUPTS
!
SYSTEMINTEGERFN DIRTOSS(INTEGER FLAG)
! **** ****
!
! Director will soon be changed so that its error messages will be
! more usable by subsystem, so we will have to translate fewer of
! them. Note particularly director error numbers 6, 10, 11, 18,
! 20, 32, 33, 37, 39. Also director error messages 28 and 29 might
! be used to amplify subsystem message 262 (VM full).
!
! **** ****
! Old version is retained below. New version would simply add 500
! to Director's error number to distinguish director-detected errors from
! subsystem errors. FAILUREMESSAGE can cope with this. The only problem
! with using Director's error messages is that they do not include anything
! equivalent to SSOWN_SSFNAME.
! %IF FLAG=0 %THEN %RESULT = 0 %ELSE %RESULT = FLAG + 500
!
! Result is subsystem fault number equivalent to the given director
! error number. Comments below assume FLAG is never <0.
CONSTINTEGER MAXDSS = 83
! DSS is a translation table of director error numbers to subsystem error
! numbers. To fit the values into single bytes, they are reduced by a constant
! value - entries <100 in this table are actually 500 too small, and entries
! between 100 and 255 are 100 too small. The necessary corrections have to
! be performed after the table look-up.
CONSTBYTEINTEGERARRAY DSS(1 : MAXDSS) = C
1, 2, 3, 4, 5, 173, 7, 8, 174, 175,
101, 12, 13, 14, 176, 119, 176, 120, 19, 173,
21, 22, 23, 24, 178, 26, 27, 162, 162, 30,
31, 118, 179, 34, 209, 176, 101, 38, 156, 178,
180, 178, 176, 44, 45, 46, 47, 48, 181, 182,
183, 52,53,54,55,56,57,58,59,60,
61,62,63,64,65,66,67,68,69,70,
71,72,73,74,75,76,77,78,79,80,
81,82,208
IF FLAG = 0 THEN RESULT = 0; !MOST LIKELY RESULT
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE#0 THEN NOTE("DIRECTOR FLAG = ".ITOS(FLAG))
!**NOTEEND
FINISH
SSOWN_SSLASTDFN = FLAG
IF 1 <= FLAG <= MAXDSS THEN START
FLAG = DSS(FLAG)
! This gives some number in the range 1 to 255 (since 0 never
! occurs as an entry in DSS).
IF FLAG < 100 THEN FLAG = FLAG+500 ELSE FLAG = FLAG+100
! This can produce numbers in the ranges 200-355 and 501-599.
FINISH ELSE FLAG = FLAG+500; ! This can give 501+MAXDSS and upwards.
RESULT = FLAG
END ; !OF DIRTOSS
!
SYSTEMINTEGERFN ROUNDUP(INTEGER N, ROUND)
! RESULT IS N ROUNDED UP TO
! MULTIPLE OF ROUND >=N
! N.B.: This will not work unless ROUND is a power of 2.
ROUND = ROUND-1
RESULT = (N+ROUND)&(¬ROUND); ! AND WITH NOT ROUND
END ; !OF ROUNDUP
!
SYSTEMROUTINE SIGNAL(INTEGER EP, P1, P2, INTEGERNAME FLAG)
RECORD (SIGDATAF)NAME D
INTEGERNAME SIGLEVEL
INTEGER LNB, AD18, PC, I
CONSTINTEGER MAXEP = 9
SWITCH SW(-1 : MAXEP)
FLAG = 0; !DEFAULT
SIGLEVEL == SSOWN_SSCOMREG(34)
UNLESS -1<=EP<=MAXEP THEN START
FLAG = 1
-> ERR
FINISH
-> SW(EP)
SW(-1):
SW(0):
SW(9): !MEANS THE SAME AS ENTRY 0
UNLESS 0<=SIGLEVEL<MAXSIGLEVEL THEN START
FLAG = 1
-> ERR
FINISH
!SIGNAL STACK FULL
SIGLEVEL = SIGLEVEL+1
D == SSOWN_SIGDATA(SIGLEVEL)
D_PC = P1; !PROGRAM COUNTER
D_LNB = P2; !LOCAL NAME BASE
-> ERR
SW(1): !UNSTACK
IF P1=0 THEN START
UNLESS 0<SIGLEVEL<=MAXSIGLEVEL THEN START
FLAG = 1
-> ERR
FINISH
SIGLEVEL = SIGLEVEL-1
FINISH ELSE SIGLEVEL = 0
-> ERR
SW(2): !SIGNAL ERROR AT CURRENT LLEVEL
IF MAXSIGLEVEL>=SIGLEVEL>0 THEN START
I = SIGLEVEL
SIGLEVEL = SIGLEVEL-1
FINISH ELSE X30{DSTOP}(101)
!SIGNAL STACK EMPTY
-> COMMON
SW(3):
IF SIGLEVEL<=0 THEN X30{DSTOP}(102)
!NO CONTS STACKED **** **** What is all this about? **** ****
I = 1; !SIGNAL AT OUTER LEVEL
COMMON:
D == SSOWN_SIGDATA(I)
SSOWN_LATEST = I; !POINTS TO LAST USED LEVEL
*STLN_LNB; !STORE LOCAL NAME BASE
D_CLASS = P1; !CLASS OF ERROR
D_SUBCLASS = P2
IF P1 > 70 START ; !SOFTWARE GEN FAULT
D_A(0) = INTEGER(LNB); !OLD LNB
D_A(2) = INTEGER(LNB+8); !OLD PC
FINISH
PC = D_PC
LNB = D_LNB
AD18 = ADDR(D_CLASS)
X26{DRESUME}(LNB,PC,AD18)
X30{DSTOP}(117); !SHOULD NEVER GET HERE
SW(4): !REPEAT LAST CONTINGENCY
UNLESS 0<SIGLEVEL<=MAXSIGLEVEL C
AND 0<SSOWN_LATEST<=MAXSIGLEVEL C
THEN X30{DSTOP} (101)
IF SIGLEVEL#SSOWN_LATEST C
THEN MOVE (80, C
ADDR(SSOWN_SIGDATA(SSOWN_LATEST)_CLASS), C
ADDR(SSOWN_SIGDATA(SIGLEVEL)_CLASS))
SIGLEVEL = SIGLEVEL-1
-> COMMON
SW(5):
MONITOR
STOP
SW(6):
INTEGER(P1) = SIGLEVEL
ERR:
END ; !OF SIGNAL
!
SYSTEMROUTINE DIRTRAP(INTEGER CLASS, SUBCLASS)
INTEGER RRCTYPE
CONST INTEGER SUBCLASSES = 9
CONST STRING (SUBCLASSES) SUBCLASS ID = "QWXYKTACV"; ! Should be (SUBCLASSES).
INTEGER I, FLAG, LNB, SC, XNB, SIGNALAT, OMSTART, OMLENGTH
INTEGER DO SIGNAL, SUBCLASS INDEX
LONGINTEGER DR
RECORD (RRCF)NAME RRC
INTEGERARRAY IDATA(0 : 17)
INTEGERNAME SIGLEVEL
RECORD (SIGDATAF)NAME D
INTEGER INCAR,LEN,TYPE,LC,LP
STRING (255) MESS
SWITCH SW(1:16) {CLASS 68 message handling, 16 meantime}
RECORD (DIRINFF)NAME DIRINF
IF CLASS=65 THEN START
IF SUBCLASS>255 THEN SUBCLASS = SUBCLASS - 255
IF 1<=SUBCLASS<=SUBCLASSES THEN SUBCLASS = CHARNO(STRING(ADDR(SUBCLASS ID)),SUBCLASS)
FINISH
IF SSOWN_RRCTOP#0=SSOWN_STOPPING START ; ! MAY HAVE TO RE-ROUTE
FOR I = SSOWN_RRCTOP,-1,1 CYCLE
RRC == RECORD(SSOWN_RRCBASE+(32*(I-1)))
RRCTYPE = RRC_TYPE
IF RRCTYPE>=4 OR CLASS=RRC_CLASS THEN START
IF RRCTYPE>1 THEN START
IF RRCTYPE<4 THEN SC = SUBCLASS ELSE SC = CLASS
IF (RRC_MASK>>(SC-((RRCTYPE&1)<<6)))&1=0 THEN CONTINUE
FINISH
! Makes a call on the nominated routine instead of on DIRTRAP.
! Passes on the same parameters CLASS and SUBCLASS.
XNB = RRC_XNB
DR = RRC_DR
*LXN_XNB
*LD_DR
*PRCL_4
*LSD_CLASS; ! Pass on both CLASS and SUBCLASS (they must be in
*ST_TOS ; ! consecutive words).
*RALN_7
*CALL_(DR )
! %RETURN not needed, since the called routine must
! use X26{DRESUME} to relinquish control. Perhaps it would
! be sensible to put in
-> INTEXIT
! to ensure that control gets to a X26{DRESUME} even if
! the routine does %RETURN.
FINISH
REPEAT
FINISH
!NO RE-ROUTEING REQUIRED CONTINUE HERE
SIGLEVEL == SSOWN_SSCOMREG(34)
UNLESS 0 < SIGLEVEL <= MAXSIGLEVEL THEN X30{DSTOP}(103)
FLAG = X32{READID}(ADDR(IDATA(0))); !READ INTERRUPT DATA
! NOW FRIG DISPLAY FOR THIS
! ROUTINE BECAUSE IT MIGHT BE
! USED
!BY ONCOND IN NDIAGS
*STLN_LNB; !CURRENT LNB
INTEGER(LNB+4) = X'E1000000'!(IDATA(1)&X'FFFFFF')
!CODE DESCRIPTOR WITH PART OF PSR
IF CLASS=68 THEN START
! Message between incarnations of the same process
INCAR=SUBCLASS>>24; ! Incarnation of calling process
TYPE=SUBCLASS&X'00FFFFFF'; ! Service required
DIRINF==RECORD(SSOWN_SSADIRINF)
->SW(TYPE)
SW(1): {INT:T to background process}
! Message will be 2 lines. The second will be the current command.
! Since 1 terminal line is no more than 80 chars, may have to trim parms.
MESS="Jobname=".DIRINF_JOBNAME." Doc=".SUBSTRING(DIRINF_JOBDOCFILE,10,13). C
": T=".ITOS(INT(CPUTIME-SSOWN_OLDCPUTIME))." PT=".ITOS(PAGETURNS-SSOWN_OLDPAGETURNS) C
." Invoc=".ITOS(SSOWN_SSINVOCATION)."
Comm="
LC=LENGTH(SSOWN_CLICOMM)
LP=LENGTH(SSOWN_CLIPARM)
IF LC>31 THEN MESS=MESS.SUBSTRING(SSOWN_CLICOMM,1,31)." " AND LC=31 C
ELSE MESS=MESS.SSOWN_CLICOMM." "
! Line <=80 and 6 already spoken for ("Comm=" and " ")
IF LC+LP>74 THEN MESS=MESS.SUBSTRING(SSOWN_CLIPARM,1,71-LC)."...
" ELSE MESS=MESS.SSOWN_CLIPARM."
"
! Send message to calling incarnation
LEN=LENGTH(MESS)
FLAG=X16{DMESSAGE2}(SSOWN_SSOWNER,LEN,1,INCAR,SSOWN_SSOWNFSYS,ADDR(MESS)+1)
IF 0#FLAG#61 THEN START
! Some failure or other
! But do what?
FINISH
->OUT
SW(*):
OUT:
DO SIGNAL=0
FINISH ELSE IF CLASS=66 START ; ! MESSAGE FROM OPERATOR
!IN THE CASE OF BROADCAST MESSAGES SUBCLASS CONTAINS (OFF1<<16)!OFF2
!WHERE OFF1 AND OFF2 ARE OFFSETS WITHIN A FILE VOLUMS.BROADCAST OF THE
!START AND END+1 OF THE MESSAGE.
OMSTART = SUBCLASS>>16
OMLENGTH = SUBCLASS&X'FFFF'-OMSTART; !LENGTH OF MESSAGE
IF SSOWN_STOPPING=0 THEN CONSOLE(6,OMSTART,OMLENGTH); ! CONSOLE OUTPUT REQUEST
DO SIGNAL = 0
FINISH ELSE START
IF SSOWN_STOPPING=0 THEN DO SIGNAL = -1 ELSE DO SIGNAL = 0
SIGNALAT = 2; !NORMALLY SIGNALAT CURRENT LEVEL
! IC OVERFLOW - GET 1 MIN NOW
IF CLASS=64 THEN FLAG = X27{DSETIC}(30000) C
ELSE IF CLASS=65 THEN START ; !INTERRUPT FROM USER
! For batch jobs, all user interrupts are treated as INT:X.
IF SSOWN_SSREASON=BATCHREASON C
THEN SUBCLASS = 'X' C
ELSE IF 'a'<=SUBCLASS<='z' C
THEN SUBCLASS = SUBCLASS-32
! LOWER CASE=UPPER CASE
IF 0<=SUBCLASS<=127 THEN START
I = ADDR (SUBCLASS ID)
*LDTB_X'18000000'
*LDB_SUBCLASSES
*LDA_I; ! Byte vector descriptor to string.
*INCA_1; ! Descriptor to characters.
*LB_SUBCLASS
*SWNE_L =DR
*JAF_11,<FOUND>
*LSS_0
*J_<STORE>
FOUND:
*CYD_0
*STUH_B
*ISB_I
STORE:
*ST_SUBCLASS INDEX
FINISH ELSE SUBCLASS INDEX = 0
! SUBCLASS INDEX now has 1 for subclass 'Q',
! 2 for 'W',
! 3 for 'X',
! 4 for 'Y',
! 5 for 'K',
! 6 for 'T',
! 7 for 'A',
! 8 for 'C',
! 9 for 'V',
! 0 for any other value.
IF SUBCLASS INDEX>0 THEN START
IF 2<=SUBCLASS INDEX<=4 OR SUBCLASS INDEX=9 THEN START ; ! for W, X, Y and V.
IF SSOWN_STOPPING#0 THEN X30{DSTOP} (113)
SSOWN_INT IN PROGRESS = 0
FINISH
IF SSOWN_INT IN PROGRESS=0=SSOWN_STOPPING THEN START
! We flag INT:Q because it needs special treatment in OBEY.
IF SUBCLASS='Q' THEN SSOWN_INTQ = 1 ELSE START
SSOWN_INT IN PROGRESS = 1
! Next we pick out W, X, Y, V, A and C.
! INT:Y is generated by an FEP to force log-off.
! All we do with these is SIGNAL them at the outermost level.
IF 'K'#SUBCLASS#'T' THEN START
SIGNALAT = 3
FINISH ELSE START
! Now we are left with K and T.
DO SIGNAL = 0
IF SUBCLASS#'K' C
THEN CONSOLE (12, FLAG, FLAG) C
ELSE START
IF SSOWN_SSTTHIDE=0 THEN START
IF SSOWN_SSTTACT#1 C
THEN CONSOLE (7, FLAG, FLAG) C
ELSE SSOWN_SSTTKN = -1
IF SSOWN_SSTTACT#-1 THEN SSOWN_SSTTHIDE = -1 ELSE START
FLAG = IOCP (7,ADDR(SSOWN_PROMPTTEXT))
FLAG = IOCP (25, 0)
FINISH
FINISH
FINISH
SSOWN_INT IN PROGRESS = 0
FINISH
FINISH
FINISH ELSE DO SIGNAL = 0
FINISH ELSE DO SIGNAL = 0
FINISH ELSE IF SSOWN_STOPPING#0 THEN X30{DSTOP} (113)
FINISH
IF DO SIGNAL#0 THEN START
IF SIGNALAT=2 START
D == SSOWN_SIGDATA(SIGLEVEL); !MOVE IDATA TO ARRAY
MOVE(72,ADDR(IDATA(0)),ADDR(D_A(0)))
MOVE(72,ADDR(IDATA(0)),ADDR(SSOWN_SAVEIDATA(0,SSOWN_SAVEIDPOINTER)))
!MOVE INTO SSOWN_SAVEIDATA
SSOWN_SAVEIDATA(-2,SSOWN_SAVEIDPOINTER) = CLASS
SSOWN_SAVEIDATA(-1,SSOWN_SAVEIDPOINTER) = SUBCLASS
MOVE(9,APTIME,ADDR(SSOWN_SAVEIDATA(18,SSOWN_SAVEIDPOINTER)))
!PUT TIME INTO RECORD
SSOWN_SAVEIDPOINTER = (SSOWN_SAVEIDPOINTER+1)&3
FINISH
SIGNAL(SIGNALAT,CLASS,SUBCLASS,FLAG)
FINISH
INTEXIT:
X26{DRESUME}(0,0,ADDR(IDATA(0))); !GO ON WHERE INTERRUPTED
!
!
END ; !OF DIRTRAP
SYSTEMROUTINE HALT
!CALL DIRECTOR STOP TO STOP
! PROCESS
X30{DSTOP}(100)
END ; !OF HALT
SYSTEMINTEGERFN CHECKFILENAME(STRING (31) FILE, INTEGER TYPE)
!CHECKS FILENAME ACCORDING TO
! TYPE
!2**0 OWN FILE - STD NAME
!2**1 ANY FILE - STD NAME
!2**2 ANY NAME (INCLUDING #)
!2**3 PD MEMBERNAME
!IF OK PUTS OWNER AND NAME
! BACK IN CUFOWNER,SSOWN_CURFNAME
! AND SSOWN_CURFILE
! WITH NO CHANCE OF CAPACITY
! EXCEEDED
! %INTEGER I, CHAR not needed for machine code version.
INTEGER LENN
STRING (40) HOLDSSFNAME
STRING (18) OWNER, NAME, MEMBER
IF FILE = LAST THEN RESULT = 0; !CURRENT FILE
HOLDSSFNAME = SSOWN_SSFNAME; !TO RESET SSFNAME IF FILENAME IS OK
UCTRANSLATE (ADDR(FILE)+1, LENGTH(FILE))
SSOWN_SSFNAME = FILE; !FOR ALL TYPES OF FAILURE
IF LENGTH(FILE) > 30 THEN RESULT = 220
!INVALID FILENAME
IF FILE -> FILE.("_").MEMBER START
! %IF PDFNFC#0 %THEN %START
! %IF FILE="" %THEN FILE=SSOWN_PDPREFIX
! %FINISH
!FILE INCLUDES MEMBERNAME
IF TYPE&8 = 0 THEN RESULT = 269
!ILLEGAL USE OF PDFILE MEMBER
! LENN = LENGTH(MEMBER)
! %UNLESS 1 <= LENN <= 11 %THEN %RESULT = 270
!INVALID MEMBER
! I = 0
! %WHILE I<LENN %CYCLE
! I = I+1
! CHAR = CHARNO(MEMBER,I)
! %UNLESS 'A' <= CHAR <= 'Z' %C
! %OR '0' <= CHAR <= '9' %THEN %RESULT = 270
! %REPEAT
!
! **** **** Machine code equivalent: **** ****
!
UNLESS 1<=LENGTH(MEMBER)<=11 THEN RESULT = 270
*LDB_(MEMBER)
*INCA_1
*LSS_ACCEPT ALPHANUMERICS+4
*LUH_256
*TCH_L =DR
*JCC_8,<MEMOK>
RESULT = 270
MEMOK:
!
! **** **** End of machine code **** ****
!
FINISH ELSE MEMBER = ""
IF LENGTH(FILE) > 18 THEN RESULT = 220
!INVALID FILENAME
UNLESS FILE -> OWNER.(".").NAME THEN START
OWNER = SSOWN_SSOWNER
NAME = FILE
FINISH
IF LENGTH(OWNER)#6 THEN RESULT = 201
!INVALID OWNER
LENN = LENGTH(NAME)
! T# NAME MUST HAVE PROC SUFFIX APPENDED -
IF 2<=LENN AND CHARNO(NAME,1)='T' AND CHARNO(NAME,2)='#' THEN START
NAME = NAME.SSOWN_SSSUFFIX
LENN = LENN+LENGTH(SSOWN_SSSUFFIX)
FINISH
! THIS AUTOMATICALLY DEALS WITH MULTIPLE LOG-ONS TO SAME USER
UNLESS 1<=LENN<=11 THEN RESULT = 220
!INVALID FILENAME
!INVALID NAME
IF TYPE&2=0 AND OWNER#SSOWN_SSOWNER THEN RESULT = 258
!NOT OWN FILE
IF TYPE&1=0 AND OWNER=SSOWN_SSOWNER THEN RESULT = 259
!OWN FILE NOT ALLOWED **** **** Why not? **** ****
! I = 0
! %WHILE I<LENN %CYCLE; !LOOK FOR VALID CHAS
! I = I+1
! CHAR = CHARNO(NAME,I)
! %UNLESS 'A'<=CHAR<='Z' %C
! %OR '0'<=CHAR<='9' %C
! %OR (TYPE&4#0 %AND CHAR='#' %AND I#1) %C
! %THEN %RESULT = 220
! !INVALID FILENAME
! %REPEAT
!
! **** **** Machine code equivalent: **** ****
!
*LDB_(NAME)
*INCA_1
CKL:
*LSS_ACCEPT ALPHANUMERICS+4
*LUH_256
*TCH_L =DR
*JCC_8,<NOK>
*LSS_TYPE
*AND_4
*JAT_4,<R220>
*CYD_0
*STUH_B
*ISB_NAME+4
*UCP_1
*JCC_8,<R220>
*SWEQ_L =DR ,0,35; ! %MASK=0,%REF='#'
*CYD_0
*STUH_TOS
*CPB_TOS
*JCC_7,<CKL>
R220:
RESULT = 220
!
NOK:
!
! **** **** End of machine code **** ****
!
SSOWN_CURFOWNER = OWNER
SSOWN_CURFNAME = NAME
SSOWN_CURFILE = OWNER.".".NAME; !RETURN FILE IN STANDARD FORM
SSOWN_CURMEMBER = MEMBER
IF SSOWN_CURFOWNER = SSOWN_SSOWNER THEN SSOWN_CURFSYS = SSOWN_SSOWNFSYS C
ELSE SSOWN_CURFSYS = -1
SSOWN_SSFNAME = HOLDSSFNAME
RESULT = 0
END ; !OF CHECKFILENAME
!
!
!
INTEGERFN HASHFN(STRING (31) NAME)
! RETURNS VALUE IN THE RANGE
! 0-MAXCONF FOR FINDING ENTRY IN THE
! CONNECTED FILE TABLE.
! MAXCONF should be ONE LESS than some prime number.
INTEGER A,J,W,L,A1,A2
A = ADDR(NAME) + 7
L = LENGTH(NAME) - 7
IF L>8 THEN START
! Close up last 4 to first 4
A1=A+5
A2=A+L-3
BYTEINTEGER(A1+J)=BYTEINTEGER(A2+J) FOR J=3,-1,0
FINISH ELSE NAME=NAME."<>#@!+&"
W=BYTEINTEGER(A+1)*71+BYTEINTEGER(A+2)*47+BYTEINTEGER(A+3)*97+ C
BYTEINTEGER(A+4)*79+BYTEINTEGER(A+5)*29+BYTEINTEGER(A+6)*37+ C
BYTEINTEGER(A+7)*53+BYTEINTEGER(A+8)*59
RESULT =W-(W//(MAXCONF+1))*(MAXCONF+1)
END ; !OF HASHFN
!
INTEGERFN FINDFN(STRING (31) FILE, INTEGERNAME POS)
! LOOK FOR FILE IN CONF. SET
! POS TO POSITION OR TO POSITION
! OF HOLE IF NOT FOUND.
! RESULT=0 IF FOUND
!IF FILENAME IS "EMPTY" THEN
! POSITION CAN BE RE-USED. IT HAS
!TO BE LEFT LIKE THIS TO
! PREVENT A SEARCH CHAIN
! BEING BROKEN
INTEGER EMPTY, STARTPOS
STRING (31) HOLDFILE
EMPTY = -1; !IMPOSSIBLE VALUE
UCTRANSLATE (ADDR(FILE)+1, LENGTH(FILE))
POS = HASHFN(FILE)
STARTPOS = POS
CYCLE
HOLDFILE = SSOWN_CONF(POS)_FILE
IF HOLDFILE = FILE THEN RESULT = 0
IF HOLDFILE = "" START ; !GOT TO END OF CHAIN
IF EMPTY#-1 THEN POS = EMPTY
RESULT = 1; !FILE NOT FOUND - POS POINTS
! TO FREE HOLE
FINISH
IF HOLDFILE="EMPTY" AND EMPTY=-1 THEN EMPTY = POS
!FIRST EMPTY CELL IN CHAIN
IF POS=MAXCONF THEN POS = 0 ELSE POS = POS + 1
!WRAP ROUND AT TOP OF SSOWN_CONF
IF POS = STARTPOS START ; !GONE RIGHT ROUND
IF EMPTY = -1 THEN RESULT = 309; !TOO MANY FILES CONNECTED
POS = EMPTY; !USE FIRST EMPTY HOLE FOUND
RESULT = 1; !FILE NOT CONNECTED
FINISH
REPEAT
END ; !OF FINDFN
!
ROUTINE CLEARFN(INTEGER POS)
!CLEARS OUT ENTRY POS IN ARRAY SSOWN_CONF. ALSO CLEARS ANY PRECEEDING
! "EMPTY" SLOTS IF THE NEXT ONE IS EMPTY. USED BY DISCONNECT AND DESTROY
RECORD (CONFF)NAME CUR
INTEGER NEXT
CUR == SSOWN_CONF(POS)
CUR = 0
IF POS=MAXCONF THEN NEXT = 0 ELSE NEXT = POS + 1
IF SSOWN_CONF(NEXT)_FILE = "" THEN START
CYCLE ; !NOW CLEAR ANY REMAINING
! "EMPTY" CELLS
IF POS=0 THEN POS = MAXCONF ELSE POS = POS - 1
!NEXT LOWER - WITH WRAP ROUND
EXIT IF SSOWN_CONF(POS)_FILE#"EMPTY"
SSOWN_CONF(POS) = 0; !NOW SAFE TO CLEAR IT OUT
REPEAT
FINISH ELSE CUR_FILE = "EMPTY"
!TO KEEP CHAIN TOGETHER
END ; !OF CLEARFN
!
!
STRINGFN PDFILE(INTEGER AD,CONAD,OFFSET,MEMNUMS)
! Fn returns member name within a pdfile which encompasses AD
INTEGER I,J,K,NOFFSET,NMEMNUMS,MEMSTART
STRING (15) MEMNAME
RESULT ="" IF MEMNUMS=0; ! No members
J=CONAD+OFFSET; ! Start of pdfile directory
FOR I=1,1,MEMNUMS CYCLE
K=J+(I-1)<<5; ! Addr of next directory record
MEMSTART=INTEGER(K)+CONAD
IF MEMSTART<=AD<MEMSTART+INTEGER(MEMSTART) THEN START
! AD is somewhere in this member
MEMNAME="_".STRING(K+4)
IF INTEGER(MEMSTART+12)=SSPDFILETYPE THEN START
! The member itself is a pdfile
NOFFSET=INTEGER(MEMSTART+24)
NMEMNUMS=INTEGER(MEMSTART+28)
RESULT =MEMNAME.PDFILE(AD,MEMSTART,NOFFSET,NMEMNUMS)
FINISH
RESULT =MEMNAME
FINISH
REPEAT
RESULT =""; ! In case AD turns out to be in admin bit of pdfile
END ; ! OF PDFILE
!
!
SYSTEMSTRINGFN CONFILE(INTEGER AD)
!RETURNS NAME OF FILE
! CONNECTED AT VIRTUAL
! ADDRESS "AD"
!ELSE NULL STRING
! Updated to give full pdfile member names when appropriate. CMcC.
STRING (255) RES
INTEGER P,OFFSET,MEMNUMS
RECORD (CONFF)NAME CUR
FOR P=0,1,MAXCONF CYCLE ; !CYCLE THROUGH CONNECTED FILE
! TABLE
CUR == SSOWN_CONF(P)
IF CUR_CONAD <= AD < CUR_CONAD+CUR_SIZE START
IF CUR_FILE = "EMPTY" THEN EXIT
RES = CUR_FILE; !THE NAME OF THE CONNECTED FILE
!TRUNCATE SUFFIX
IF LENGTH(RES)>8 C
AND SUBSTRING(RES,8,9)="T#" C
THEN LENGTH(RES) = LENGTH(RES)-1
IF CUR_CONAD+32>AD OR INTEGER(CUR_CONAD+12)#SSPDFILETYPE THEN RESULT = RES
! If here then found a pdfile - which member is it
OFFSET=INTEGER(CUR_CONAD+24)
MEMNUMS=INTEGER(CUR_CONAD+28)
RESULT =RES.PDFILE(AD,CUR_CONAD,OFFSET,MEMNUMS)
FINISH
REPEAT
RESULT = ""; !NO FILE THERE
END ; !OF CONFILE
!
!
SYSTEMROUTINE DISCONNECT(STRING (31) FILE, INTEGERNAME FLAG)
!
! This will disconnect members of PD files as well! It simply ignores
! SSOWN_CURMEMBER, and so it disconnects the PD file. Since connect-a-member
! is effectively a connection of the PD file itself, this all works
! tidily.
!
RECORD (CONFF)NAME CUR
INTEGER POS
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE # 0 THEN NOTE("DISCONNECT(".FILE.")")
!**NOTEEND
FINISH
FLAG = CHECKFILENAME(FILE,7); !ANY FILE
IF FLAG=0 THEN START
FLAG = FINDFN(SSOWN_CURFILE,POS)
IF FLAG#0 THEN FLAG = 256 ELSE START
CUR == SSOWN_CONF(POS)
IF NEWCONNECT=0 THEN START
IF INTEGER(CUR_CONAD+12) = SSOLDDIRFILETYPE THEN SSOWN_DIRDISCON = 1
! TO WARN LOADER THAT A DIRECTORY HAS BEEN DISCONNECTED
IF CUR_USE&X'3F'#0 THEN FLAG = 266 ELSE START
SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS
FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CONF(POS)_FSYS,0))
IF FLAG = 0 THEN CLEARFN(POS); !CLEAR IT OUT OF ARRAY SSOWN_CONF
ALLOW INTERRUPTS
FINISH
FINISH ELSE START
IF CUR_USE&X'3FFFFFFF'#0 THEN CUR_USE = CUR_USE - 1
IF CUR_USE&X'BFFFFFFF'=0 THEN START
IF INTEGER(CUR_CONAD+12) = SSOLDDIRFILETYPE THEN SSOWN_DIRDISCON = 1
! TO WARN LOADER THAT A DIRECTORY HAS BEEN DISCONNECTED
SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS
IF CUR_USE&X'40000000'#0 THEN START
! If the file was TEMP or VTEMP:
FLAG = -1
FINISH ELSE IF CUR_MODE&2#0 THEN START
FLAG = DIRTOSS (X4{DCHACCESS}( C
SSOWN_CURFOWNER,SSOWN_CURFNAME,CUR_FSYS,1))
IF FLAG=0 THEN CUR_MODE = 1
FINISH
IF FLAG#0 THEN START
FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,0))
IF FLAG = 0 THEN CLEARFN(POS); !CLEAR IT OUT OF ARRAY CONF
FINISH
ALLOW INTERRUPTS
FINISH
FINISH
FINISH
IF FLAG#0 THEN SSOWN_SSFNAME = SSOWN_CURFILE
FINISH
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE # 0 THEN NOTE("DISCONNECT FLAG = ".ITOS(FLAG))
!**NOTEEND
FINISH
END ; !OF DISCONNECT
!
SYSTEM ROUTINE SDISCONNECT C
(STRING (31) FILE, INTEGER FSYS, INTEGER NAME FLAG)
!***********************************************************************
!* *
!* SDISCONNECT provided for JOBBER and JOURNAL allows for *
!* disconnection of a particular file on a particular FSYS. It is *
!* used in conjunction with a facility in CONNECT which allows the *
!* user to specify the FSYS of the file he wishes to connect. *
!* *
!***********************************************************************
RECORD (CONFF)NAME CUR
INTEGER POS
IF NEWCONNECT=0 THEN START
FLAG = CHECKFILENAME(FILE,7); !ANY FILE
IF FLAG=0 THEN START
SSOWN_CURFSYS = FSYS; !USER SUPPLIES FSYS
DISCONNECT(LAST,FLAG); !TO ENSURE USE OF CORRECT SSOWN_CURFSYS
FINISH
FINISH ELSE START
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE # 0 THEN NOTE("DISCONNECT(".FILE.")")
!**NOTEEND
FINISH
FLAG = CHECKFILENAME(FILE,7); !ANY FILE
IF FLAG=0 THEN START
FLAG = FINDFN(SSOWN_CURFILE,POS)
SSOWN_CURFSYS = FSYS
IF FLAG#0 THEN FLAG = 256 ELSE START
CUR == SSOWN_CONF(POS)
IF CUR_USE&X'3FFFFFFF'#0 THEN START
CUR_USE = CUR_USE - 1
IF CUR_USE&X'BFFFFFFF'=0 THEN START
IF INTEGER(CUR_CONAD+12) = SSOLDDIRFILETYPE THEN SSOWN_DIRDISCON = 1
! TO WARN LOADER THAT A DIRECTORY HAS BEEN DISCONNECTED
SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS
FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,0))
IF FLAG = 0 THEN CLEARFN(POS); !CLEAR IT OUT OF ARRAY CONF
ALLOW INTERRUPTS
FINISH
FINISH
FINISH
IF FLAG#0 THEN SSOWN_SSFNAME = SSOWN_CURFILE
FINISH
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE # 0 THEN NOTE("DISCONNECT FLAG = ".ITOS(FLAG))
!**NOTEEND
FINISH
FINISH
END ; !OF SDISCONNECT
!
ROUTINE KDISCON (INTEGER POS, INTEGER NAME FLAG)
RECORD (CONFF)NAME CUR
STRING (18) OWNER, NAME
IF NEWCONNECT#0 THEN START
CUR == SSOWN_CONF(POS)
IF CUR_USE&X'BFFFFFFF'#0 THEN FLAG = 266 C
ELSE IF CUR_FILE->OWNER.(".").NAME THEN START
SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS
FLAG = DIRTOSS(X11{DDISCONNECT}(OWNER,NAME,CUR_FSYS,0))
IF FLAG = 0 THEN CLEARFN(POS); !CLEAR IT OUT OF ARRAY CONF
ALLOW INTERRUPTS
FINISH
FINISH
END ; ! OF KDISCON
!
ROUTINE RDISCON (STRING (31) FILE, INTEGER NAME F)
INTEGER POS, CLEAR, FLAG
IF NEWCONNECT#0 THEN START
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE # 0 THEN NOTE("DISCONNECT(".FILE.")")
!**NOTEEND
FINISH
CLEAR = LENGTH(FILE)
IF CLEAR>1 AND CHARNO(FILE,CLEAR)='*' C
THEN LENGTH(FILE) = CLEAR - 1 C
ELSE CLEAR = 0
FLAG = CHECKFILENAME(FILE,7); !ANY FILE
IF FLAG=0 THEN START
FLAG = FINDFN(SSOWN_CURFILE,POS)
IF FLAG#0 THEN FLAG = 256 ELSE START
IF CLEAR#0 THEN SSOWN_CONF(POS)_USE = SSOWN_CONF(POS)_USE & X'C0000000'
KDISCON (POS, FLAG)
FINISH
IF FLAG#0 THEN SSOWN_SSFNAME = SSOWN_CURFILE
FINISH
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE # 0 THEN NOTE("DISCONNECT FLAG = ".ITOS(FLAG))
!**NOTEEND
FINISH
FINISH
END
!
EXTERNALROUTINE ZDISCONNECT(STRING (255) S)
INTEGER FLAG, DUMMY, I
STRING (31) FILE
SETPAR(S)
FLAG = 0
CYCLE
FILE = SPAR(0)
EXIT IF FILE = ""; !END OF LIST
IF FILE = ".ALL" START ; !DISCONNECT ALL FILES POSSIBLE
FLAG = 0; !ALWAYS OK
FOR I=0,1,MAXCONF CYCLE
IF ""#SSOWN_CONF(I)_FILE#"EMPTY" THEN START
IF NEWCONNECT=0 THEN START
DISCONNECT(SSOWN_CONF(I)_FILE,DUMMY)
FINISH ELSE START
KDISCON (I, FLAG)
FINISH
!IGNORE FLAG
FINISH
REPEAT
EXIT
FINISH
IF NEWCONNECT=0 THEN START
DISCONNECT (FILE, FLAG)
FINISH ELSE START
RDISCON (FILE, FLAG)
FINISH
IF FLAG # 0 THEN PSYSMES(14,FLAG)
REPEAT
SSOWN_RCODE = FLAG
END ; ! of DISCONNECT command.
!
INTEGER FN DODCONN (STRING (6) USER, STRING (11) FILE, C
INTEGER FSYS, MODE, APF, INTEGER NAME SEG, GAP)
INTEGER Z
IF NEWCONNECT#0 THEN START
Z = X7{DCONNECT}(USER,FILE,FSYS,MODE,APF,SEG,GAP)
IF Z=28 OR Z=29 OR Z=35 THEN START
! CBT freelist empty, or
! No free CONLIST entries, or
! Segment in use or GAP too small.
ZDISCONNECT (".ALL")
Z = X7{DCONNECT}(USER,FILE,FSYS,MODE,APF,SEG,GAP)
FINISH
RESULT = DIRTOSS (Z)
FINISH
END
!
SYSTEMROUTINE CONNECT(STRING (31) FILE, C
INTEGER MODE, HOLE, PROT, RECORD (RF)NAME R, INTEGERNAME FLAG)
!
! Needed for student subsystem:
!
CONST INTEGER MAXALWAYS = 3
CONST STRING (6) ARRAY ALWAYS (1:MAXALWAYS) = "SUBSYS", "SPOOLR","MAILER"
!
! End of student subsystem specials.
!
RECORD (PDHF)NAME PDH
RECORD (PDF)NAME PD
RECORD (DPERMF) DPERM
INTEGER I, P, SIZE, CYMODE, CONAD, N
STRING (11) MEMBER
RECORD (HF)NAME H; !FILE HEADER
RECORD (CONFF)NAME CUR
RECORD (FRF)FR
INTEGER CONSEG, POS, REQMODE
!
! Mode bits are:
! X'00000001' read
! X'00000002' write
! X'00000004' execute
! X'00000008' accept shared write
! X'00000010' newcopy
! X'00000020' comms mode
! X'00000040' disc only
! X'00000080' new stack segment
! X'00000100' disallow DISCONNECT, CHANGE ACCESS, CHANGE SIZE
! X'00000200' sequential
! X'80000000' non-slaved segment
!
! Common valid combinations are (in decimal):
! 1 read
! 2 write {*}
! 3 read/write
! 4 execute {*}
! 5 read/execute
! 9 read (accept shared write)
! 10 write (accept shared write) {*}
! 11 read/write (accept shared write)
! 18 write newcopy {*}
! 19 read/write newcopy
! 513 read sequential
! 514 write sequential {*}
! 515 read/write sequential
! 521 read sequential (accept shared write)
! 522 write sequential (accept shared write) {*}
! 523 read/write sequential (accept shared write)
! 530 write newcopy sequential {*}
! 531 read/write newcopy sequential
! where {*} means that Director grants read access in addition
! to the requested modes.
!
!
ROUTINE FINFO AND CHOOSEMODE
FINFO(LAST,0,FR,FLAG); !GET FILEINFO TO GET SIZE
RETURN IF FLAG # 0; !FINFO FAILS
IF MODE&7=0 START ; !NO MODE REQUESTED - CHOOSE ONE
! If the user has READ permission, we will give him READ
! access only. Failing that, if he has WRITE permission
! we will give him WRITE access. If he has EXECUTE permission
! without either READ or WRITE, then we will give him
! EXECUTE access. We assume he has at least one of these
! permissions, since otherwise he would have failed to
! get beyond FINFO.
IF FR_RUP&1#0 THEN I = 1 C
ELSE IF FR_RUP&2#0 THEN I = 2 C
ELSE I = 4
MODE = MODE ! I
FINISH ELSE IF (¬FR_RUP)&MODE&7#0 THEN START
!REQUESTED ACCESS NOT ALLOWED
SSOWN_SSFNAME = SSOWN_CURFILE
FLAG = 303
FINISH
END
!
ROUTINE DOCONNECT
IF NEWCONNECT#0 THEN START
HOLE = HOLE>>SEGSHIFT
!HOLE IN SEGMENTS
IF NEWLOADER=0 THEN START
IF SSOWN_CURFNAME = "T#US".SSOWN_SSSUFFIX THEN MODE = MODE!X'80'
FINISH ELSE START
IF SSOWN_CURFNAME = "T#USTK".SSOWN_SSSUFFIX THEN MODE = MODE!X'80'
FINISH
!TEMP
IF PROT&8#0 THEN MODE = MODE ! X'0100'
! Tell Director "never disconnect".
FLAG = DODCONN(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,MODE,0,CONSEG,HOLE)
IF FLAG#0 THEN START
CLEARFN (POS)
SSOWN_SSFNAME = SSOWN_CURFILE
FINISH ELSE START
CUR_CONAD = CONSEG<<SEGSHIFT
!CONNECT ADDRESS
CUR_HOLE = HOLE<<SEGSHIFT
CUR_MODE = MODE ! 1; ! Because Director will grant READ mode if you ask
! for WRITE or EXECUTE.
IF PROT&8#0 THEN CUR_USE = X'80000001' ELSE CUR_USE = 1
FINISH
FINISH
END
!
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE#0 THEN START
IF FILE = LAST THEN HOLDFILE = SSOWN_CURFOWNER.".".SSOWN_CURFNAME C
ELSE HOLDFILE = FILE
NOTE("CONNECT(".HOLDFILE.",".ITOS(MODE).",".ITOS(HOLE). C
",".ITOS(PROT).")")
FINISH
!**NOTEEND
FINISH
REQMODE = MODE; !REQUESTED MODE
MODE = MODE & VALID MODE BITS; ! Ignore mode bits not recognised
! by Director.
IF MODE&X'12'=X'10' THEN START
! Reject NEWCOPY without WRITE.
! Should we also reject NEWCOPY on another user's file?
FLAG = 260; ! Invalid connect mode.
-> ERR
FINISH
FLAG = CHECKFILENAME(FILE,15); !ANY FILE NAME INCLUDING PD
! MEMBER
-> ERR IF FLAG # 0
IF STUDENTSS#0 THEN START
IF SSOWN_ALLCONNECT=0 THEN START ; ! Must check that process owner
! is allowed to access files
! belonging to this file's owner.
IF SSOWN_CURFOWNER#SSOWN_SSOWNER THEN START
I = 1
WHILE I<=MAXALWAYS AND ALWAYS(I)#SSOWN_CURFOWNER CYCLE
I = I + 1
REPEAT
IF I>MAXALWAYS AND ALLOWCONNECT(SSOWN_CURFOWNER,SSOWN_CURFNAME)#0 THEN START
FLAG = 218
-> ERR
FINISH
FINISH
FINISH
FINISH
IF SSOWN_CURMEMBER # "" START ; !MEMBER OF PDFILE
! HOLE is ignored for PD members.
IF MODE&2#0 THEN START ; ! ATTEMPT TO WRITE TO MEMBER OF PDFILE
FLAG = 271
-> ERR
FINISH
MEMBER = SSOWN_CURMEMBER
SSOWN_CURMEMBER = ""
CONNECT(LAST,0,0,PROT,R,FLAG); !CONNECT WITH PROTECTION
-> ERR IF FLAG # 0
IF R_FILETYPE#SSPDFILETYPE THEN START ; ! NOT A PD FILE
FLAG = 286
-> ERR
FINISH
PDH == RECORD(R_CONAD)
!NOW LOOK FOR REQUIRED MEMBER
I = 0
P = PDH_ADIR+R_CONAD; !START OF DIRECTORY
WHILE I<PDH_COUNT CYCLE
PD == RECORD(P+I*32)
IF PD_NAME = MEMBER THEN -> MEMBER FOUND
I = I+1
REPEAT
SSOWN_SSFNAME = MEMBER
FLAG = 288; !MEMBER NOT FOUND
-> ERR
MEMBER FOUND:
R_CONAD = R_CONAD+PD_START; !ABS ADDR OF MEMBER
R_DATASTART = INTEGER(R_CONAD+4)
R_DATAEND = INTEGER(R_CONAD)
R_FILETYPE = INTEGER(R_CONAD+12)
!TYPE
IF R_FILETYPE = 0 THEN R_FILETYPE = 3
-> ERR
FINISH
!LOOK IN TABLE OF CURRENTLY
! CONNECTED FILES
FLAG = FINDFN(SSOWN_CURFILE,POS); !0=FILE ALREADY CONNECTED
!0=CONNECTED,1=NOT CONNECTED, >1 FAILURE
IF FLAG>1 THEN START
SSOWN_SSFNAME = SSOWN_CURFILE
-> ERR
FINISH
CUR == SSOWN_CONF(POS)
HOLE = ROUNDUP (HOLE, SEGSIZE)
IF PROT&X'80' # 0 THEN SSOWN_CURFSYS = (PROT>>8)&X'FF'
!USER HAS SPECIFIED FILE SYSTEM
! Has the user specified a connect address?
IF PROT&X'40'=0 THEN CONSEG = 0 ELSE CONSEG = R_CONAD>>SEGSHIFT
SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS
IF FLAG # 0 START ; !FILE NOT CONNECTED SO CONNECT IT
FINFO AND CHOOSEMODE
-> ERR IF FLAG#0
IF HOLE#0 AND HOLE<FR_SIZE THEN HOLE = 0
IF NEWCONNECT=0 THEN START
HOLE = HOLE>>SEGSHIFT
!HOLE IN SEGMENTS
IF NEWLOADER=0 THEN START
IF SSOWN_CURFNAME = "T#US".SSOWN_SSSUFFIX THEN MODE = MODE!X'80'
FINISH ELSE START
IF SSOWN_CURFNAME = "T#USTK".SSOWN_SSSUFFIX THEN MODE = MODE!X'80'
FINISH
!TEMP
FLAG = DIRTOSS(X7{DCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,MODE,0,CONSEG,HOLE))
IF FLAG#0 THEN START
SSOWN_SSFNAME = SSOWN_CURFILE
-> ERR
FINISH
FINISH
CUR = 0
CUR_FILE = SSOWN_CURFILE
CUR_FSYS = SSOWN_CURFSYS
CUR_SIZE = FR_SIZE; !PHYSICAL SIZE FROM FINFO RECORD
IF NEWCONNECT=0 THEN START
CUR_CONAD = CONSEG<<SEGSHIFT
!CONNECT ADDRESS
CUR_HOLE = HOLE<<SEGSHIFT
CUR_MODE = MODE
FINISH ELSE START
DOCONNECT
-> ERR IF FLAG#0
! Mark TEMP or VTEMP.
IF FR_ARCH&X'0C'#0 THEN CUR_USE = CUR_USE ! X'40000000'
FINISH
FINISH ELSE START ; ! File is connected.
IF MODE&16#0 THEN START ; ! Newcopy.
IF NEWCONNECT=0 THEN START
IF CUR_USE&X'3F'#0 THEN START
FLAG = 266
-> ERR
FINISH
FINISH ELSE START
IF CUR_USE&X'BFFFFFFF'#0 THEN START
FLAG = 266
-> ERR
FINISH
FINISH
SIZE = CUR_SIZE
IF NEWCONNECT=0 THEN START
IF CONSEG=0 THEN CONAD=CUR_CONAD ELSE CONAD = R_CONAD
FINISH
FINFO (LAST, 0, FR, FLAG)
IF FLAG#0 THEN -> ERR
IF HOLE#0 AND HOLE<FR_SIZE THEN HOLE = 0
IF SSOWN_SSOWNER#SSOWN_CURFOWNER OR FR_RUP&2=0 THEN START
FLAG = 303
-> ERR
FINISH
IF NEWCONNECT=0 THEN START
HOLE = HOLE>>SEGSHIFT
!HOLE IN SEGMENTS
IF NEWLOADER=0 THEN START
IF SSOWN_CURFNAME = "T#US".SSOWN_SSSUFFIX THEN MODE = MODE!X'80'
FINISH ELSE START
IF SSOWN_CURFNAME = "T#USTK".SSOWN_SSSUFFIX THEN MODE = MODE!X'80'
FINISH
!TEMP
FINISH
FLAG = DIRTOSS(X22{DPERMISSION} C
(SSOWN_SSOWNER,SSOWN_SSOWNER,"",SSOWN_CURFNAME,SSOWN_SSOWNFSYS,4,ADDR(DPERM)))
IF FLAG#0 THEN -> ERR
FLAG = DIRTOSS (X11{DDISCONNECT}(SSOWN_SSOWNER,SSOWN_CURFNAME,SSOWN_SSOWNFSYS,1))
IF FLAG=0 OR FLAG=278 OR FLAG=283 THEN CLEARFN (POS)
-> ERR IF FLAG#0
FLAG = DIRTOSS C
(X8{DCREATE}(SSOWN_SSOWNER,SSOWN_CURFNAME,SSOWN_SSOWNFSYS,SIZE>>KSHIFT,(FR_ARCH>>2)&3))
IF FLAG#0 THEN START
IF NEWCONNECT#0 THEN START
CLEARFN (POS)
FINISH
-> ERR
FINISH
IF FR_ARCH&X'01'#0 THEN FSTATUS(SSOWN_CURFNAME,1,0,FLAG); ! SET CHERISH BIT
CYMODE = DPERM_OWNP&15
IF CYMODE#7 C
THEN FLAG = DIRTOSS(X22{DPERMISSION} C
(SSOWN_SSOWNER,SSOWN_SSOWNER,"",SSOWN_CURFNAME,SSOWN_SSOWNFSYS,0,CYMODE))
CYMODE = DPERM_EEP&7
IF CYMODE#0 C
THEN FLAG = DIRTOSS(X22{DPERMISSION} C
(SSOWN_SSOWNER,"","",SSOWN_CURFNAME,SSOWN_SSOWNFSYS,1,CYMODE))
N = (DPERM_BYTESRETURNED-16)//8; !NO. OF INDIVIDUAL PERMISSIONS
I = 0
WHILE I < N CYCLE
FLAG = DIRTOSS(X22{DPERMISSION} C
(SSOWN_SSOWNER,DPERM_PRMS(I)_USER,"",SSOWN_CURFNAME,SSOWN_SSOWNFSYS,2,DPERM_PRMS(I)_UPRM))
I = I+1
REPEAT
IF NEWCONNECT=0 THEN START
FLAG = DIRTOSS(X7{DCONNECT} C
(SSOWN_SSOWNER,SSOWN_CURFNAME,SSOWN_SSOWNFSYS,MODE,0,CONSEG,HOLE))
IF FLAG#0 THEN START
SSOWN_SSFNAME = SSOWN_CURFILE
-> ERR
FINISH
CUR_CONAD = CONSEG<<SEGSHIFT
!CONNECT ADDRESS
CUR_HOLE = HOLE<<SEGSHIFT
CUR_MODE = MODE
FINISH ELSE START
DOCONNECT
-> ERR IF FLAG#0
FINISH
FINISH ELSE START
I = 0
IF HOLE#0 AND HOLE<CUR_SIZE THEN HOLE = 0
IF HOLE<=CUR_HOLE AND (CONSEG=0 OR R_CONAD=CUR_CONAD) THEN START
IF NEWCONNECT=0 THEN START
IF MODE=CUR_MODE OR MODE=0 THEN I = -1 C
ELSE IF 1<=MODE<=5 THEN START
IF MODE=1 THEN MODE = 5; ! To ensure execute access
! for object files.
CHANGE ACCESS (LAST, MODE, FLAG)
-> ERR IF FLAG#0
I = -1
FINISH
FINISH ELSE START
IF (MODE!!CUR_MODE)&X'FE'=0 OR MODE=0 THEN START
! If the current MODE and the HOLE size are already correct,
! then there is nothing to do. MODE=0 means that the
! caller does not care what mode he gets.
I = -1
IF (¬CUR_USE)<<2#0 THEN CUR_USE = CUR_USE + 1
IF PROT&8#0 THEN CUR_USE = CUR_USE ! X'80000000'
FINISH ELSE IF 1<=MODE<=5 THEN START
! Either the MODE or the HOLE size needs changing.
! If the HOLE size is adequate, then we check the MODE.
! Some new MODEs can be reached by CHANGE ACCESS, so
! we use that routine if the MODE is acceptable. In
! all other cases, we DISCONNECT the file and reCONNECT
! it in the new MODE.
! **** **** The checks on MODE will have to be **** ****
! **** **** revised if CHANGE ACCESS becomes more **** ****
! **** **** versatile. **** ****
IF CUR_USE&X'BFFFFFFF'#0 THEN START
FLAG = 266
-> ERR
FINISH
FINFO(LAST,0,FR,FLAG)
IF (¬FR_RUP)&MODE&7#0 THEN START ; ! REQUESTED PERMISSION NOT ALLOWED.
FLAG = 303
-> ERR
FINISH
CUR_MODE = MODE ! 1
FLAG = DIRTOSS(X4{DCHACCESS}(SSOWN_CURFOWNER,SSOWN_CURFNAME,CUR_FSYS,MODE))
-> ERR IF FLAG # 0
I = -1
FINISH
FINISH
FINISH
IF I=0 THEN START
IF NEWCONNECT=0 THEN START
DISCONNECT (LAST, FLAG)
-> ERR IF FLAG#0
CONNECT (LAST, MODE, HOLE, PROT, R, FLAG)
-> ERR IF FLAG#0
FLAG = FINDFN (SSOWN_CURFILE,POS)
CUR == SSOWN_CONF(POS)
FINISH ELSE START
IF CUR_USE&X'BFFFFFFF'#0 THEN START
FLAG = 266
-> ERR
FINISH
FINFO AND CHOOSEMODE
-> ERR IF FLAG#0
IF INTEGER(CUR_CONAD+12) = SSOLDDIRFILETYPE THEN SSOWN_DIRDISCON = 1
! TO WARN LOADER THAT A DIRECTORY HAS BEEN DISCONNECTED
FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,0))
! If the file were VTEMP it would have disappeared now.
IF FLAG=0 AND FR_ARCH&8#0 THEN START
FLAG = DIRTOSS(X8{DCREATE} C
(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,CUR_SIZE>>KSHIFT,8))
IF FLAG#0 THEN CLEARFN (POS)
FINISH
IF FLAG=0 THEN DOCONNECT
-> ERR IF FLAG#0
FINISH
FINISH
FINISH
FINISH
! MODE AND HOLE OK - NOW MOVE
! INFO FROM CUR INTO RECORD R
R_CONAD = CUR_CONAD; !CONNECT ADDRESS
H == RECORD(CUR_CONAD); !MAP H ONTO FILE HEADER
R_FILETYPE = H_FILETYPE
R_FILETYPE = 3 IF H_FILETYPE = 0
R_DATASTART = H_DATASTART
R_DATAEND = H_DATAEND
IF NEWCONNECT=0 THEN START
CUR_USE = CUR_USE ! (PROT&X'3F')
FINISH
IF MODE&2#0 AND H_DATASTART>=32 THEN START
!EXPLICIT CONNECT IN WRITE MODE
!AND HEADER AT LEAST 32 BYTES
! LONG
H_DATETIME = CURRENTPACKEDDT
FINISH
ERR:
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE # 0 THEN NOTE("CONNECT(".HOLDFILE.") FLAG = ". C
ITOS(FLAG))
!**NOTEEND
FINISH
ALLOW INTERRUPTS; ! **** **** CONNECT is recursive. **** ****
! **** **** This cannot be right. **** ****
! **** **** In fact, on closer inspection, I don't think **** ****
! **** **** recursion in CONNECT can cause trouble with **** ****
! **** **** ALLOW INTERRUPTS: but what can easily occur **** ****
! **** **** is ALLOW INTERRUPTS being done when CONNECT **** ****
! **** **** has not set SSOWN_SSINHIBIT=1. Is this a problem? **** ****
! **** **** What if the caller has inhibited interrupts? **** ****
END ; !OF CONNECT
!
SYSTEMROUTINE OUTFILE(STRING (31) FILE, INTEGER FILESIZE, HOLE, C
PROT, INTEGERNAME CONAD, FLAG)
!
! HOLE<0 means "don't connect". CONAD will be set to zero.
!
! Note on PROT:
! bit 24 (X'00000080') non-zero means that (PROT>>8)&X'FF' gives FSYS:
! bit 25 (X'00000040') non-zero means that user nominates CONAD:
! bit 1 (X'40000000') non-zero means that a TEMP file is required -
! this can also be specified by nominating a file name whose
! first two characters are "T#":
! bit 2 (X'20000000') non-zero means that a VTEMP file is required -
! if both TEMP and VTEMP are specified, then the file will be
! be VTEMP:
! bits 26-31 (X'0000003F') are copied into the USE field of the the
! entry in the connected file table SSOWN_CONF. This represents a count
! of the number of current 'uses' which require the file to be
! connected. It is, for instance, incremented whenever the file
! is OPENed for use by the i/o routines, and decremented whenever
! it is CLOSEd. The file cannot be disconnected while USE is
! non-zero. Thus, by setting a 'large' initial value in USE
! (i.e., - conventionally - by putting 8 in the bottom end of
! PROT), you can prevent the file ever being disconnected until
! the end-of-session. Actually this mechanism is unreliable -
! although USE is simply incremented and decremented, it is
! not tested for being >0. The test is actually USE&X'3F'#0.
! This means that, if USE were incremented from 63 to 64, the
! file would appear to become 'unused'! I haven't figured
! out the reasons for that yet.
RECORD (FRF)FR
RECORD (DPERMF) DPERM
RECORD (HF)NAME H
INTEGER MODE, CONSEG, CRF, POS, CURSIZE, PSIZE, TYPE, ATLEAST, I, N, CYMODE
INTEGER XCON
RECORD (CONFF)NAME CUR
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE # 0 THEN NOTE("OUTFILE(".FILE.",".ITOS(FILESIZE). C
",".ITOS(HOLE).",".ITOS(PROT).")")
!**NOTEEND
FINISH
IF FILESIZE<0 THEN START
FILESIZE = -FILESIZE
ATLEAST = 1
FINISH ELSE ATLEAST = 0
!NEGATIVE SIZE MEANS CREATE AT LEAST THIS SIZE
FLAG = CHECKFILENAME(FILE,5); !OWN FILE ANY NAME
-> ERR IF FLAG # 0
UNLESS 'A'<=CHARNO(SSOWN_CURFNAME,1)<='Z'THEN START ; ! INVALID NEW FILENAME.
FLAG=220
-> ERR
FINISH
PSIZE = ROUNDUP(FILESIZE,FILESIZEALLOC)
IF HOLE>0 THEN START
IF HOLE<FILESIZE THEN HOLE = FILESIZE
HOLE = ROUNDUP (HOLE, SEGSIZE)
FINISH
!PHYSICAL SIZE
IF PROT&TEMPMARKER#0 C
OR (LENGTH(SSOWN_CURFNAME)>=2 C
AND CHARNO(SSOWN_CURFNAME,1)='T' C
AND CHARNO(SSOWN_CURFNAME,2)='#') C
THEN TYPE = 1 C
ELSE TYPE = 0
!TYPE=1 IS TEMP FILE
IF PROT&VTEMPMARKER#0 THEN TYPE = 2
!TYPE=2 IS VTEMP FILE
FLAG = FINDFN(SSOWN_CURFILE,POS)
CUR == SSOWN_CONF(POS)
IF NEWCONNECT#0 THEN START
XCON = 0
FINISH
FINFO(LAST,0,FR,I)
IF FLAG=0 THEN START ; ! i.e., if the file is already connected.
IF NEWCONNECT=0 THEN START
IF TYPE=0 AND CUR_USE&X'3F'#0 THEN START ; ! PERM. FILE IN USE.
FLAG = 266
-> ERR
FINISH
FINISH ELSE START
! We used to allow a fresh OUTFILE on a temporary file even if it
! had a non-zero use count. But not now:
IF CUR_USE&X'BFFFFFFF'#0 THEN START
FLAG = 266
-> ERR
FINISH
XCON = -1
FINISH
CRF = -1
FINISH ELSE START
IF I=0 THEN START ; ! I was set by FINFO.
! This tests whether the file exists.
CURSIZE = FR_SIZE
IF CURSIZE<PSIZE OR (CURSIZE>PSIZE AND {TYPE=}0=ATLEAST) C
THEN CRF = -1 ELSE CRF = 0
!MUST CHANGE SIZE BECAUSE EITHER TOO SMALL OR
!(TOO BIG AND PERMANENT AND PRECISE SIZE REQUESTED)
! I have now stopped allowing temporary files to be
! too big if the user does not request "AT LEAST".
! Such files may be NEWGENed or otherwise made
! permanent, e.g. by the EDITor.
FINISH ELSE CRF = -2
FINISH
! Now we have:
! CRF = 0: existing file is the right size, not connected.
! Needs connecting only.
! CRF = -1: existing file is connected, or is wrong size. Since
! this is OUTFILE, i.e., "create a new file", we will want to
! connect it NEWCOPY, and so there is no need to write out
! existing pages. The cheapest thing to do is simply to
! DESTROY and re-CREATE the file, thus avoiding any DISCONNECT
! or CHANGE FILE SIZE that might invoke the writing out of old
! pages. In this case, XCON#0 if and only if the file is
! connected.
! CRF = -2: - no such file exists. We must simply CREATE and CONNECT
! it.
IF CRF=0 THEN FLAG = 0 ELSE START
IF CRF=-1 THEN START
! I was set by FINFO.
IF I=0 AND TYPE=0 THEN I = DIRTOSS(X22{DPERMISSION} C
(SSOWN_SSOWNER,SSOWN_SSOWNER,"",SSOWN_CURFNAME,SSOWN_SSOWNFSYS,4,ADDR(DPERM)))
IF I#0 THEN START
FLAG = I
-> ERR
FINISH
IF NEWCONNECT=0 THEN START
DESTROY (LAST, FLAG)
-> ERR IF FLAG#0
FINISH ELSE START
IF XCON#0 THEN START ; ! CURRENTLY CONNECTED - USE DESTROY
! OPTION IN DISCONNECT.
SSOWN_SSINHIBIT = 1
! DISCONNECT+DESTROY
FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,1))
IF FLAG=278 OR FLAG=283 THEN CLEARFN(POS); !CLEAR RECORD IN TABLE
! 283 is 'no DESTROY permission', but the file will still
! be disconnected. Similarly 278 is 'file connected in
! another VM'.
ALLOW INTERRUPTS
FINISH ELSE START ; !NOT CONNECTED
FLAG = DIRTOSS(X9{DDESTROY}(SSOWN_CURFOWNER,SSOWN_CURFNAME,"",SSOWN_CURFSYS,0))
FINISH
IF FLAG # 0 THEN START
SSOWN_SSFNAME = SSOWN_CURFILE
-> ERR
FINISH
FINISH
FINISH
FLAG = DIRTOSS(X8{DCREATE}(SSOWN_SSOWNER,SSOWN_CURFNAME,SSOWN_SSOWNFSYS,PSIZE>>KSHIFT,TYPE))
IF FLAG#0 THEN START
IF NEWCONNECT#0 THEN START
IF XCON#0 THEN CLEARFN (POS)
FINISH
-> ERR
FINISH
IF CRF=-1 AND TYPE=0 THEN START
IF FR_ARCH&X'01'#0 THEN FSTATUS(SSOWN_CURFNAME,1,0,FLAG); ! SET CHERISH BIT
CYMODE = DPERM_OWNP&15
IF CYMODE#7 THEN FLAG = DIRTOSS(X22{DPERMISSION} C
(SSOWN_SSOWNER,SSOWN_SSOWNER,"",SSOWN_CURFNAME,SSOWN_SSOWNFSYS,0,CYMODE))
CYMODE = DPERM_EEP&7
IF CYMODE#0 THEN FLAG = DIRTOSS(X22{DPERMISSION} C
(SSOWN_SSOWNER,"","",SSOWN_CURFNAME,SSOWN_SSOWNFSYS,1,CYMODE))
N = (DPERM_BYTESRETURNED-16)//8; !NO. OF INDIVIDUAL PERMISSIONS
I = 0
WHILE I < N CYCLE
FLAG = DIRTOSS(X22{DPERMISSION} C
(SSOWN_SSOWNER,DPERM_PRMS(I)_USER,"",SSOWN_CURFNAME,SSOWN_SSOWNFSYS,2,DPERM_PRMS(I)_UPRM))
I = I+1
REPEAT
FINISH
FINISH
IF HOLE<0 THEN CONAD = 0 ELSE START
IF NEWCONNECT=0 THEN START
FLAG = FINDFN (SSOWN_CURFILE, POS)
! I don't know whether that is strictly necessary - the only
! thing in OUTFILE which might have made CUR unusable is the
! call on DESTROY. Anyway, I do assume that this call on
! FINDFN cannot fail.
CUR == SSOWN_CONF (POS)
FINISH
HOLE = HOLE>>SEGSHIFT
!HOLE IN SEGMENTS
IF NEWLOADER=0 THEN START
IF SSOWN_CURFNAME = "T#US".SSOWN_SSSUFFIX THEN MODE =X'93' ELSE MODE = X'13'
FINISH ELSE START
IF SSOWN_CURFNAME = "T#USTK".SSOWN_SSSUFFIX THEN MODE = X'93' ELSE MODE = X'13'
FINISH
!TEMP
IF PROT&X'40'#0 THEN CONSEG = CONAD>>SEGSHIFT ELSE CONSEG = 0
IF NEWCONNECT=0 THEN START
FLAG = DIRTOSS (X7{DCONNECT} C
(SSOWN_SSOWNER,SSOWN_CURFNAME,SSOWN_SSOWNFSYS,MODE,0,CONSEG,HOLE))
FINISH ELSE START
IF PROT&8#0 THEN MODE = MODE ! X'0100'
! Tell Director "never disconnect".
FLAG = DODCONN(SSOWN_SSOWNER,SSOWN_CURFNAME,SSOWN_SSOWNFSYS,MODE,0,CONSEG,HOLE)
FINISH
IF FLAG#0 THEN START
IF NEWCONNECT#0 THEN START
IF XCON#0 THEN CLEARFN (POS)
FINISH
SSOWN_SSFNAME = SSOWN_CURFILE
-> ERR
FINISH
CUR = 0
CUR_FILE = SSOWN_CURFILE
CUR_FSYS = SSOWN_SSOWNFSYS
CUR_SIZE = PSIZE
CONAD = CONSEG<<SEGSHIFT
CUR_CONAD = CONAD
!CONNECT ADDRESS
CUR_HOLE = HOLE<<SEGSHIFT
CUR_MODE = MODE
!READ-WRITE-NEWCOPY
!MUST BE RIGHT ONE
IF NEWCONNECT#0 THEN START
IF PROT&8#0 THEN CUR_USE = X'80000001' ELSE CUR_USE = 1
IF TYPE#0 THEN CUR_USE = CUR_USE ! X'40000000'
FINISH ELSE START
! Although there is a comment above about using the bottom bits
! of the PROT field to set use counts so that files are never disconnected
! the use count field is never set. This means you can, for example,
! disconnect T#IT at command level and get thrown off the machine.
! Also when the new loader is checking if segments are free to connect
! a bound file it will attempt to disconnect anything it finds such
! as T#WRK with disastrous results. The new loader will protect anything
! it has loaded but not some of the system files which, incidentally,
! usually have PROT set to 8 in the OUTFILE call. For this reason I
! am introducing (reinstating?) the same code for setting the use count
! as is found in CONNECT.
! CMcC. 21/03/83.
CUR_USE=CUR_USE!(PROT&X'3F')
FINISH
H == RECORD(CONAD)
H = 0; !CLEAR IT OUT
H_DATAEND = 32; !DEFAULT
H_DATASTART = 32
H_FILESIZE = PSIZE
H_DATETIME = PACKDATEANDTIME(STRING(APDATE),STRING(APTIME))
FINISH
ERR:
IF NOTES ON#0 THEN START
!**NOTESTART
IF SSOWN_SSNOTE # 0 THEN NOTE("OUTFILE(".FILE.") CONAD,FLAG = ". C
ITOS(CONAD).",".ITOS(FLAG))
!**NOTEEND
FINISH
END ; !OF OUTFILE
!
SYSTEMSTRINGFN SEGSINUSE(INTEGERNAME FIRSTSEG,LASTSEG, INTEGER SEGSTART)
! This function returns the name of the file which owns the segment
! SEGSTART and its first and last claimed segments or a null string.
! File structure does not matter as in CONFILE, we just want to know the name in CONF.
! CMcC 23/03/83
RECORD (CONFF)NAME CUR
STRING (31) RES
INTEGER I,AD
AD=SEGSTART<<18
FOR I=MAXCONF,-1,0 CYCLE
CUR==SSOWN_CONF(I)
IF CUR_CONAD<=AD<CUR_CONAD+CUR_HOLE THEN START
EXIT IF CUR_FILE="EMPTY"
RES=CUR_FILE
FIRSTSEG=CUR_CONAD>>18
LASTSEG=(CUR_CONAD+CUR_HOLE-1)>>18
IF LENGTH(RES)>8 AND CHARNO(RES,8)='T' AND CHARNO(RES,9)='#' C
THEN LENGTH(RES)=LENGTH(RES)-1
RESULT =RES
FINISH
REPEAT
RESULT =""
END ; ! OF SEGSINUSE
!
SYSTEMROUTINE SETUSE(STRING (31) FILE, INTEGER MODE, VALUE)
RECORD (CONFF)NAME CUR
INTEGER POS, FLAG
FLAG = CHECKFILENAME(FILE,15); !ANY INCLUDING PD MEMBER
-> ERR IF FLAG#0; !INVALID FILENAME
FLAG = FINDFN(SSOWN_CURFILE,POS)
-> ERR IF FLAG#0; !NOT CONNECTED
CUR == SSOWN_CONF(POS)
IF NEWCONNECT=0 THEN START
!***********************************************************************
!* *
!* This routine is used to modify the USE field in the CONNECT record: *
!* Mode=0 Set use to value *
!* Mode=1 Add 1 to use *
!* Mode=-1 Subtract 1 from use *
!* *
!***********************************************************************
IF MODE=0 C
THEN CUR_USE = VALUE {USE VALUE PROVIDED} C
ELSE IF MODE=1 C
THEN CUR_USE = CUR_USE+1 {ADD ONE} C
ELSE IF MODE=-1 AND CUR_USE>0 C
THEN CUR_USE = CUR_USE-1 {SUBTRACT ONE}
FINISH ELSE START
!***********************************************************************
!* *
!* This routine is used to modify the USE field in the CONNECT record: *
!* Mode=0 Set top bit of USE if VALUE#0, else clear top bit *
!* Mode=1 Add 1 to USE count *
!* Mode=-1 Subtract 1 from USE count *
!* *
!***********************************************************************
IF MODE>0 THEN START
IF (¬CUR_USE)<<2#0 THEN CUR_USE = CUR_USE + 1
FINISH ELSE IF MODE<0 THEN START
IF CUR_USE<<2#0 THEN START
CUR_USE = CUR_USE - 1
IF CUR_USE&X'BFFFFFFF'=0 C
AND INTEGER(CUR_CONAD+12) = SSOLDDIRFILETYPE C
THEN SSOWN_DIRDISCON = 1
! TO WARN LOADER THAT A DIRECTORY HAS BEEN DISCONNECTED
FINISH
FINISH ELSE CUR_USE = CUR_USE ! X'80000000'
! That actually stops anyone from ever clearing the "fixed connection" bit.
! To make the routine perform according to the specification comment above,
! replace that last line by the two following lines.
! %FINISH %ELSE %IF VALUE#0 %THEN CUR_USE = CUR_USE ! X'80000000'
! %ELSE CUR_USE = CUR_USE & X'7FFFFFFF'
FINISH
ERR:
END ; !OF SETUSE
!
SYSTEMROUTINE DESTROY(STRING (31) FILE, INTEGERNAME FLAG)
INTEGER POS
RECORD (CONFF)NAME CUR
FLAG = CHECKFILENAME(FILE,5); !ANY OWN FILE
-> ERR1 IF FLAG # 0
FLAG = FINDFN(SSOWN_CURFILE,POS)
IF FLAG=0 THEN START ; ! CURRENTLY CONNECTED - USE DESTROY
! OPTION IN DISCONNECT.
CUR == SSOWN_CONF(POS)
IF NEWCONNECT=0 THEN START
IF CUR_USE&X'3F'#0 THEN FLAG = 266 ELSE START
SSOWN_SSINHIBIT = 1
! DISCONNECT+DESTROY
FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,1))
IF FLAG=0 OR FLAG=278 OR FLAG=283 THEN CLEARFN(POS); !CLEAR RECORD IN TABLE
! 283 is 'no DESTROY permission', but the file will still
! be disconnected. Similarly 278 is 'file connected in
! another VM.
ALLOW INTERRUPTS
FINISH
FINISH ELSE START
IF CUR_USE&X'BFFFFFFF'#0 THEN FLAG = 266 ELSE START
SSOWN_SSINHIBIT = 1
! DISCONNECT+DESTROY
FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,1))
IF FLAG=0 OR FLAG=278 OR FLAG=283 THEN CLEARFN(POS); !CLEAR RECORD IN TABLE
! 283 is 'no DESTROY permission', but the file will still
! be disconnected. Similarly 278 is 'file connected in
! another VM.
ALLOW INTERRUPTS
FINISH
FINISH
FINISH ELSE START ; !NOT CONNECTED
FLAG = DIRTOSS(X9{DDESTROY}(SSOWN_CURFOWNER,SSOWN_CURFNAME,"",SSOWN_CURFSYS,0))
FINISH
IF FLAG # 0 THEN SSOWN_SSFNAME = SSOWN_CURFILE
ERR1: !SSOWN_SSFNAME ALREADY SET
END ; !OF DESTROY
!
SYSTEMROUTINE RENAME(STRING (31) FILE, NEWFILE, INTEGERNAME FLAG)
STRING (11) NEWNAME
INTEGER POS
FLAG = CHECKFILENAME(NEWFILE,5)
!CHECK NEWNAME FIRST
-> ERR IF FLAG # 0
NEWNAME = SSOWN_CURFNAME; !HOLD NEWNAME
FLAG = CHECKFILENAME(FILE,5); !NOW CHECK OLD NAME
-> ERR IF FLAG # 0
IF NEWCONNECT#0 THEN START
FLAG = FINDFN (SSOWN_CURFILE, POS)
IF FLAG=0 THEN KDISCON (POS, FLAG)
IF FLAG=0 THEN FLAG = DIRTOSS(X24{DRENAME} C
(SSOWN_CURFOWNER,SSOWN_CURFNAME,NEWNAME,SSOWN_CURFSYS))
FINISH ELSE START
DISCONNECT (LAST, FLAG)
FLAG = DIRTOSS (X24{DRENAME}(SSOWN_CURFOWNER,SSOWN_CURFNAME,NEWNAME,SSOWN_CURFSYS))
FINISH
ERR:
END ; !OF RENAME
!
SYSTEM ROUTINE NEWGEN (STRING (31) FILE, NEWFILE, INTEGER NAME FLAG)
RECORD (FRF)FR
STRING (11) NEWNAME
FLAG = CHECKFILENAME(NEWFILE,5)
!CHECK NEWNAME FIRST
-> ERR IF FLAG # 0
IF STUDENTSS#0 THEN START
IF SSOWN_CURFNAME="SS#JOURNAL" THEN X30{DSTOP}(200)
! To stop breakers editing the RECALL file.
FINISH
IF NEWCONNECT=0 THEN START
DISCONNECT (LAST, FLAG)
FINISH ELSE START
RDISCON(LAST,FLAG); !TRY AND DISCONNECT - IGNORE FLAG
FINISH
NEWNAME = SSOWN_CURFNAME; !HOLD NEWNAME
FLAG = CHECKFILENAME(FILE,5)
-> ERR IF FLAG # 0
IF NEWCONNECT=0 THEN START
DISCONNECT (LAST, FLAG)
FINISH ELSE START
RDISCON(LAST,FLAG); !MUST DISCONNECT IF CONNECTED
FINISH
-> ERR UNLESS FLAG = 0 OR FLAG = 256
!OK OR NOT CONNECTED
FLAG = X17{DNEWGEN}(SSOWN_CURFOWNER,NEWNAME,SSOWN_CURFNAME,SSOWN_CURFSYS)
! Director's flag for "File does not exist" is 32.
! Subsystem's flag for it is 218.
IF FLAG=32 THEN START ; ! One of the files did not exist.
FINFO (LAST, 0, FR, FLAG)
! If SSOWN_CURFNAME doesn't exist, then this will set copy SSOWN_CURFILE into
! SSOWN_SSFNAME and set FLAG=218.
IF FLAG#218 THEN START
! It must have been NEWNAME that did not exist.
FLAG = 218
SSOWN_SSFNAME = NEWNAME
FINISH
FINISH ELSE FLAG = DIRTOSS (FLAG)
ERR:
END ; !OF NEWGEN
!
SYSTEM ROUTINE CHANGEACCESS (STRING (31) FILE, C
INTEGER MODE, INTEGER NAME FLAG)
INTEGER POS
RECORD (HF)NAME H
RECORD (CONFF)NAME CUR
RECORD (FRF)FR
MODE = MODE & VALID MODE BITS & X'FFFFFFEF'; ! Ignore NEWCOPY bit.
FLAG = CHECKFILENAME(FILE,7); !ANY FILE
RETURN IF FLAG # 0
FLAG = FINDFN(SSOWN_CURFILE,POS); !FIND IT IN CONNECTED FILE TABLE
IF FLAG#0 THEN START ; ! NOT CONNECTED.
FLAG = 256
-> ERR
FINISH
CUR == SSOWN_CONF(POS)
IF CUR_MODE=MODE THEN -> ERR; !CURRENT MODE OK
FINFO(LAST,0,FR,FLAG)
IF (¬FR_RUP)&MODE&7#0 THEN START ; ! REQUESTED PERMISSION NOT ALLOWED.
FLAG = 303
-> ERR
FINISH
IF NEWCONNECT#0 THEN START
IF CUR_USE&X'BFFFFFFF'#1 THEN START
FLAG=266; ! CONFLICTING USE
->ERR
FINISH
FINISH
!
! Check that MODE is acceptable to Director for X4{DCHACCESS}:
! **** **** This check must be updated as Director **** ****
! **** **** becomes more versatile. **** ****
MODE = MODE ! 1
UNLESS 1<=MODE<=5 THEN START
FLAG = 260
-> ERR
FINISH
FLAG = DIRTOSS(X4{DCHACCESS}(SSOWN_CURFOWNER,SSOWN_CURFNAME,CUR_FSYS,MODE))
-> ERR IF FLAG # 0
IF MODE&2#0 AND CUR_MODE&2=0 START ; !CHANGE TO WRITE MODE - UPDATE "LAST ALTERED"
H == RECORD(CUR_CONAD)
IF H_DATASTART >= 32 THEN H_DATETIME = CURRENTPACKEDDT
FINISH
CUR_MODE = MODE
ERR:
IF FLAG#0 THEN SSOWN_SSFNAME = SSOWN_CURFILE
END ; ! of CHANGEACCESS
!
SYSTEM ROUTINE CHANGEFILESIZE (STRING (31)FILE, INTEGER NEWSIZE, C
INTEGER NAME FLAG)
! N.B. This does NOT update the FILE SIZE field in the file header.
INTEGER NEWKSIZE, POS
RECORD (CONFF)NAME CUR
RECORD (FRF)FR
NEWSIZE = ROUNDUP(NEWSIZE,FILESIZEALLOC)
NEWKSIZE = NEWSIZE>>KSHIFT; !NUMBER OF KBYTES TO ALTER
!NEW SIZE IN KB
FLAG = CHECKFILENAME(FILE,5); !ANY OWN FILE
-> ERR IF FLAG # 0
IF NEWCONNECT#0 THEN START
FLAG = FINDFN(SSOWN_CURFILE,POS); !FIND POS IN TABLE
IF FLAG=0 THEN START ; ! File is connected.
CUR == SSOWN_CONF(POS)
IF NEWSIZE=CUR_SIZE THEN -> ERR; ! Size does not need changing.
FINISH ELSE START
POS = -1
FINFO(LAST,0,FR,FLAG)
-> ERR IF FLAG # 0
IF NEWSIZE = FR_SIZE THEN -> ERR
!SIZE OK - RETURN
FINISH
IF POS#-1 THEN START ; ! CONNECTED
! FLAG = 0 - this is already true.
IF NEWSIZE>CUR_HOLE THEN START ; ! HOLE TOO SMALL.
IF CUR_USE&X'BFFFFFFF'=0 THEN START
SSOWN_SSINHIBIT = 1
FLAG = X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,0)
! If the file were VTEMP, that would DESTROY it!
IF FLAG=0 THEN CLEARFN (POS) ELSE FLAG = 261
ALLOW INTERRUPTS
FINISH ELSE FLAG = 261; ! VM hole too small.
FINISH ELSE IF NEWSIZE<CUR_SIZE AND CUR_USE&X'BFFFFFFF'#0 THEN FLAG = 266
-> ERR IF FLAG#0
FINISH
SSOWN_SSINHIBIT = 1
FLAG = DIRTOSS(X5{DCHSIZE}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,NEWKSIZE))
IF FLAG#0 AND POS#-1 THEN CUR_SIZE = NEWSIZE
FINISH ELSE START
FINFO(LAST,0,FR,FLAG)
-> ERR IF FLAG # 0
IF NEWSIZE = FR_SIZE THEN -> ERR
!SIZE OK - RETURN
IF FR_CONAD # 0 START ; ! CONNECTED
FLAG = FINDFN(SSOWN_CURFILE,POS); !FIND POS IN TABLE
CUR == SSOWN_CONF(POS)
IF NEWSIZE>CUR_HOLE THEN START ; ! HOLE TOO SMALL.
FLAG = 261
-> ERR
FINISH
FINISH
SSOWN_SSINHIBIT = 1
FLAG = DIRTOSS(X5{DCHSIZE}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,NEWKSIZE))
IF FLAG=0 AND FR_CONAD # 0 THEN CUR_SIZE = NEWSIZE
FINISH
ALLOW INTERRUPTS
ERR:
END ; !OF CHANGEFILESIZE
!
IF NEWCONNECT#0 THEN START
SYSTEM ROUTINE TRIM (STRING (31) FILE, INTEGER NAME FLAG)
RECORD (CONFF) NAME CUR
RECORD (RF) RR
INTEGER SIZE, POS, DOCH
CONNECT (FILE, 0, 0, 0, RR, FLAG)
IF FLAG#0 THEN -> ERR
FLAG = FINDFN (SSOWN_CURFILE, POS)
CUR == SSOWN_CONF (POS)
SIZE = ROUNDUP (RR_DATAEND, FILESIZEALLOC)
DOCH = 0
IF SIZE#CUR_SIZE THEN START
IF INTEGER (RR_CONAD+12)<16 THEN START
CHANGEACCESS (LAST, 3, FLAG)
IF FLAG=0 THEN START
INTEGER (RR_CONAD+8) = SIZE
DOCH = -1
FINISH
FINISH ELSE DOCH = -1; ! OLD OBJECT FILES EXCEPTED
! DONT ALTER 3RD WORD OF OBJECT FILES PROTEM
FINISH
DISCONNECT (LAST, FLAG)
IF FLAG=0 AND DOCH#0 THEN CHANGEFILESIZE (LAST, SIZE, FLAG)
ERR:
END ; ! of TRIM
FINISH ELSE START
SYSTEMROUTINE TRIM(STRING (31) FILE, INTEGERNAME FLAG)
RECORD (RF)RR
INTEGER SIZE
CONNECT(FILE,3,0,0,RR,FLAG)
-> ERR IF FLAG # 0
SIZE = RR_DATAEND
CHANGEFILESIZE(FILE,SIZE,FLAG)
-> ERR IF FLAG # 0
IF INTEGER(RR_CONAD+12) < 16 C
THEN INTEGER(RR_CONAD+8) = ROUNDUP(SIZE,FILESIZEALLOC)
!OLD OBJECT FILES EXCEPTED
!DONT ALTER 3RD WORD OF
! OBJECT FILES PROTEM
ERR:
END ; !OF TRIM
FINISH
!
SYSTEM ROUTINE MODPDFILE (INTEGER EP, C
STRING (31) PDFILE, STRING (11) MEMBER, C
STRING (31) INFILE, INTEGER NAME FLAG)
!THIS ROUTINE PROVIDES
! SERVICES FOR MODIFYING PD FILES
! EP=1 INSERT
! EP=2 REMOVE
! EP=3 RENAME
! EP=4 CREATE PDFILE
INTEGER I, FLC {file length}, BASE, NEWSIZE, ADIR, OLDSIZE, OLDLENGTH
INTEGER LEN, NEWSTART, NEWLENGTH, POS
STRING (6) OWNER
SWITCH SW(1 : 4)
RECORD (RF)PDR, FR
RECORD (PDF)NAME PD
RECORD (PDHF)NAME PDH
INTEGERFN CHECKMEMBERNAME(STRING (11) S)
!CHECKS THAT MEMBER HAS
! STANDARD NAME
! %INTEGER I not needed for machine code version.
SSOWN_SSFNAME = S; !FOR FAILURE MESSAGE
RESULT = 270 UNLESS 1<=LENGTH(S)<=11 AND 'A'<=CHARNO(S,1)<='Z'
! I = 1
! %WHILE I<LENGTH(S) %CYCLE
! I = I+1
! %RESULT = 270 %UNLESS 'A'<=CHARNO(S,I)<='Z' %OR '0'<=CHARNO(S,I)<='9'
! %REPEAT
!
! **** **** Machine code equivalent: **** ****
!
IF LENGTH(S)>1 THEN START
*LDB_(S)
*INCA_1
*MODD_1
*LSS_ACCEPT ALPHANUMERICS+4
*LUH_256
*TCH_L =DR
*JCC_8,<MOK>
RESULT = 270
MOK:
FINISH
!
! **** **** End of machine code **** ****
!
RESULT = 0; !O.K.
END ; !OF CHECKMEMBERNAME
BASE = 0
UNLESS 1<=EP<=4 THEN START
FLAG = -1
-> ERR
FINISH
! Should we UCTRANSLATE (ADDR(PDFILE)+1,LENGTH(PDFILE))?
SSOWN_SSFNAME = PDFILE
UCTRANSLATE (ADDR(MEMBER)+1, LENGTH(MEMBER))
IF EP <= 3 START
!NOW CONNECT PD FILE IN WRITE
! MODE
IF PDFILE->OWNER.(".").PDFILE AND OWNER#SSOWN_SSOWNER START
FLAG = 258; !ILLEGAL USE OF ANOTHER'S FILE.
-> ERR
FINISH
CONNECT(PDFILE,3,0,0,PDR,FLAG)
-> ERR IF FLAG # 0
BASE = PDR_CONAD
IF PDR_FILETYPE#SSPDFILETYPE THEN START ; ! NOT A PD FILE.
FLAG = 286
-> ERR
FINISH
FLAG = FINDFN(SSOWN_CURFILE,POS); !FIND CURRENT USE
IF NEWCONNECT=0 THEN START
IF SSOWN_CONF(POS)_USE&X'3F'#0 THEN START ; ! FILE ALREADY IN USE.
FLAG = 266
-> ERR
FINISH
FINISH ELSE START
IF SSOWN_CONF(POS)_USE&X'BFFFFFFF'#1 THEN START ; ! FILE ALREADY IN USE.
FLAG = 266
-> ERR
FINISH
FINISH
PDH == RECORD(BASE)
ADIR = PDH_ADIR+BASE; !ABS ADDR OF DIRECTORY
FINISH
-> SW(EP)
SW(1): ! INSERT FILE
FLAG = CHECKMEMBERNAME(MEMBER)
-> ERR IF FLAG # 0
! CHECK THAT MEMBER NOT
! ALREADY THERE
I = 0
WHILE I<PDH_COUNT CYCLE
PD == RECORD(ADIR+I*32)
IF PD_NAME=MEMBER THEN START ; ! ALREADY THERE.
FLAG = 287
-> ERR
FINISH
I = I+1
REPEAT
CONNECT(INFILE,0,0,0,FR,FLAG)
!CONNECT FILE TO BE INSERTED
IF FLAG # 0 THEN -> ERR
FLC = (FR_DATAEND+7)&X'FFFFF8' {file length}
!DW ALIGN
IF FLC < 16 THEN FLC = 16
!MINIMUM LENGTH
OLDLENGTH = PDR_DATAEND
OLDSIZE = ROUNDUP(OLDLENGTH,FILESIZEALLOC)
NEWLENGTH = ROUNDUP(PDH_ADIR,16)+FLC+32*(PDH_COUNT+1)
!THIS ENSURES ROOM FOR
!NEW MEMBER TO BE QUAD WORD ALIGNED
!ALLOW FOR NEW FILE AND DIR ENTRY
IF NEWLENGTH>OLDSIZE THEN START ; !GREATER THAN PHYSICAL SIZE
IF NEWCONNECT=0 THEN START
CONNECT(PDFILE,3,NEWLENGTH,0,PDR,FLAG)
!RE-CONNECT - IN CASE NEEDS
!MORE ROOM
-> ERR IF FLAG # 0
CHANGEFILESIZE(PDFILE,NEWLENGTH,FLAG)
-> ERR IF FLAG # 0
NEWSIZE = ROUNDUP(NEWLENGTH,FILESIZEALLOC)
!NEW PHYSICAL SIZE
BASE = PDR_CONAD
PDH == RECORD(BASE); !RE-MAP - MIGHT HAVE MOVED
PDH_SIZE = NEWSIZE; !NEW PHYSICAL SIZE
ADIR = PDH_ADIR+BASE
FINISH ELSE START
CHANGEFILESIZE(PDFILE,NEWLENGTH,FLAG)
IF FLAG=261 THEN START ; ! VM hole too small -
DISCONNECT (LAST, FLAG)
BASE = 0
CHANGEFILESIZE (LAST,NEWLENGTH,FLAG)
CONNECT (LAST,3,0,0,PDR,FLAG)
-> E1 IF FLAG#0
BASE = PDR_CONAD
PDH == RECORD(BASE); !RE-MAP - MIGHT HAVE MOVED
ADIR = PDH_ADIR+BASE
FINISH ELSE IF FLAG#0 THEN -> E1
NEWSIZE = ROUNDUP(NEWLENGTH,FILESIZEALLOC)
!NEW PHYSICAL SIZE
PDH_SIZE = NEWSIZE; !NEW PHYSICAL SIZE
FINISH
FINISH
NEWSTART = ROUNDUP(ADIR,16); !QUAD WORD ALIGN
SSOWN_SSINHIBIT = 1
PDH_DATAEND = NEWLENGTH
MOVE(32*PDH_COUNT,ADIR,NEWSTART+FLC)
ADIR = NEWSTART+FLC
PDH_ADIR = ADIR-BASE
MOVE(FLC,FR_CONAD,NEWSTART)
! INTEGER (NEWSTART+8) = FLC would put actual member size in member's header.
!MOVE IN FILE
PD == RECORD(ADIR+32*PDH_COUNT)
!NEW DIRECTORY RECORD
PD = 0; !CLEAR IT
PD_NAME = MEMBER
PD_START = NEWSTART-BASE; !OFFSET OF START
PDH_COUNT = PDH_COUNT+1; !INCREMENT COUNTER
E1:
IF NEWCONNECT#0 THEN START
DISCONNECT (INFILE, FLAG)
FINISH
-> ERR
SW(2): !DELETE MEMBER
I = 0
SSOWN_SSINHIBIT = 1
WHILE I<PDH_COUNT CYCLE
PD == RECORD(ADIR+I*32)
IF PD_NAME = MEMBER THEN -> MEMBER FOUND
I = I+1
REPEAT
SSOWN_SSFNAME = MEMBER
FLAG = 288; !MEMBER NOT FOUND
-> ERR
MEMBER FOUND:
FLC = (INTEGER(BASE+PD_START)+7)&X'FFFFF8' {file length}
IF FLC < 16 THEN FLC = 16
!DW ROUND
I = I+1
WHILE I<PDH_COUNT CYCLE
PD == RECORD(ADIR+I*32)
LEN = (INTEGER(BASE+PD_START)+7)&X'FFFFF8'
IF LEN < 16 THEN LEN = 16; !MINIMUM LENGTH OF FILE
MOVE(LEN,BASE+PD_START,BASE+PD_START-FLC)
PD_START = PD_START-FLC
MOVE(32,ADIR+I*32,ADIR+(I-1)*32)
!MOVE RECORD DOWN A PLACE
I = I+1
REPEAT
PDH_COUNT = PDH_COUNT-1
MOVE(32*PDH_COUNT,ADIR,ADIR-FLC)
!MOVE DIR BACK
PDH_ADIR = PDH_ADIR-FLC
IF NEWCONNECT#0 THEN START
I = PDH_DATAEND - (FLC+32)
PDH_DATAEND = I
! TRIM
I = ROUNDUP (I, FILESIZEALLOC)
IF I#PDH_SIZE THEN START
FLAG = DIRTOSS (X5{DCHSIZE}(SSOWN_SSOWNER,SSOWN_CURFNAME,SSOWN_SSOWNFSYS,I>>KSHIFT))
IF FLAG=0 THEN START
SSOWN_CONF(POS)_SIZE = I
PDH_SIZE = I
FINISH
FINISH
FINISH ELSE START
PDH_DATAEND = PDH_DATAEND - (FLC+32)
TRIM (PDFILE,FLAG)
FINISH
-> ERR
SW(3): !RENAME (MEMBER,FILE)
FLAG = CHECKMEMBERNAME(INFILE)
-> ERR IF FLAG # 0
I = 0
WHILE I<PDH_COUNT CYCLE
PD == RECORD(ADIR+I*32)
IF PD_NAME=INFILE THEN START
FLAG = 290
-> ERR
FINISH
I = I+1
REPEAT
I = 0
WHILE I<PDH_COUNT CYCLE
PD == RECORD(ADIR+I*32)
IF PD_NAME=MEMBER THEN START
PD_NAME = INFILE
-> ERR
FINISH
I = I+1
REPEAT
SSOWN_SSFNAME = MEMBER
FLAG = 288; !MEMBER NOT FOUND
-> ERR
SW(4): !CREATE EMPTY PDFILE
OUTFILE(PDFILE,4096,4096,0,BASE,FLAG)
-> ERR IF FLAG # 0
PDH == RECORD(BASE)
PDH_FILETYPE = 6; !TYPE=PARTITIONED
PDH_ADIR = 32; !START OF DIRECTORY
PDH_COUNT = 0; !NO MEMBERS
-> ERR
ERR:
ALLOW INTERRUPTS
IF BASE # 0 THEN DISCONNECT(PDFILE,BASE); !IGNORE FLAG
END ; ! of MODPDFILE
!
!
!
!
SYSTEMROUTINE FINFO(STRING (31) FILE, INTEGER MODE, C
RECORD (FRF)NAME FR, INTEGERNAME FLAG)
RECORD (DFF) DF
FLAG = CHECKFILENAME(FILE,7); !ANY FILENAME
IF FLAG=0 THEN START
FR = 0; !CLEAR WHOLE RECORD
IF MODE = 1 THEN CONNECT(LAST,0,0,0,FR,FLAG); ! MUST CONNECT - ANY MODE
IF FLAG=0 THEN START
FLAG = DIRTOSS(X14{DFINFO}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,ADDR(DF)))
IF FLAG#0 THEN SSOWN_SSFNAME = SSOWN_CURFILE ELSE START
!FILL IN INFO FROM X14{DFINFO} CALL
SSOWN_CURFSYS = DF_FSYS
FR_SIZE = DF_NKB<<KSHIFT; !PHYSICAL SIZE IN BYTES
FR_RUP = DF_RUP; !REQUESTING USERS PERMISSION
FR_EEP = DF_EEP; !EVERYONE ELSE'S PERMISSION
FR_APF = DF_APF; !CONNECT MODE
FR_CONAD = DF_CONSEG<<SEGSHIFT
!CONNECT ADDRESS
FR_USERS = DF_USE
FR_ARCH = (DF_ARCH&X'80')!((DF_CODES&X'10')>>4)!(DF_CODES&X'0C')
! X'80': archive
! X'08': very temporary
! X'04': temporary
! X'01': cherished
FR_TRAN = DF_TRAN; !ON OFFER TO
FINISH
FINISH
FINISH
ERR:
END ; !OF FINFO
!
!
SYSTEMROUTINE FSTATUS(STRING (31)FILE, INTEGER ACT, VALUE C
INTEGERNAME FLAG)
FLAG = CHECKFILENAME(FILE,5); !ANY OWN FILE
-> ERR IF FLAG # 0
FLAG = DIRTOSS(X15{DFSTATUS}(SSOWN_SSOWNER,SSOWN_CURFNAME,SSOWN_SSOWNFSYS,ACT,VALUE))
IF FLAG # 0 THEN SSOWN_SSFNAME = SSOWN_CURFNAME
ERR:
END ; !OF FSTATUS
!
!
! FILL SYSTEM CALLS (now called FSC) and SSINIT have been moved into the
! INFREQUENT CODE module.
!
SYSTEMINTEGERFN GETSPACE(INTEGER BYTES)
! Gets space from BGLA - returns 0 if not enough room.
INTEGER RES
RES = (SSOWN_SSMAXBGLA-BYTES) & (-8); ! Rounded down to double-word boundary.
IF SSOWN_SSCURBGLA>RES THEN RESULT = 0
SSOWN_SSMAXBGLA = RES
RESULT = RES
END ; !OF GETSPACE
!
!
SYSTEMROUTINE SETWORK(INTEGERNAME AD, FLAG)
!ON ENTRY AD CONTAINS LENGTH REQUIRED
INTEGER CONAD, H
! ADDRESS IN AD
IF AD < SSOWN_SSINITWORKSIZE THEN AD = SSOWN_SSINITWORKSIZE
!MINIMUM SIZE
IF AD > SSOWN_SSMAXFSIZE THEN AD = SSOWN_SSMAXFSIZE
!MAX SIZE
IF AD <= SSOWN_CURLENGTH START
AD = SSOWN_SSCOMREG(14)
INTEGER(AD) = 32
! FILL IN HEADER AGAIN LEST IT HAS BEEN CORRUPTED
! but this is a rather odd header ... I don't know why it shouldn't
! be a regular data file header.
INTEGER(AD+4) = 32
INTEGER(AD+8) = SSOWN_CURLENGTH
INTEGER(AD+12) = 0
FLAG = 0
FINISH ELSE IF SSOWN_CURLENGTH#0 AND AD<=SSMAXWORKSIZE THEN START
CHANGE FILE SIZE ("T#WRK", AD, FLAG)
IF FLAG=0 THEN START
SSOWN_CURLENGTH = AD
AD = SSOWN_SSCOMREG(14)
INTEGER(AD) = 32
! FILL IN HEADER AGAIN LEST IT HAS BEEN CORRUPTED
! but this is a rather odd header ... I don't know why it shouldn't
! be a regular data file header.
INTEGER(AD+4) = 32
INTEGER(AD+8) = SSOWN_CURLENGTH
INTEGER(AD+12) = 0
FINISH ELSE SSOWN_SSCOMREG(14) = 0
FINISH ELSE START
IF AD<=SSMAXWORKSIZE THEN H = SSMAXWORKSIZE ELSE H = AD
! *** The code of SETWORK assumes implicitly that once created
! *** T#WRK will always be around so set PROT field to 1
! *** CMcC. 22/03/83.
IF NEWCONNECT=0 THEN START
IF SSOWN_CURLENGTH#0 THEN SETUSE ("T#WRK",0,0)
OUTFILE("T#WRK",AD,H,TEMPMARKER!1,CONAD,FLAG)
FINISH ELSE START
IF SSOWN_CURLENGTH#0 THEN SETUSE ("T#WRK",-1,0)
OUTFILE("T#WRK",AD,H,TEMPMARKER,CONAD,FLAG)
FINISH
!UNIQUE NAME FOR THIS PROCESS
IF FLAG=0 START
SSOWN_SSCOMREG(14) = CONAD
SSOWN_CURLENGTH = AD
AD = CONAD
FINISH ELSE SSOWN_SSCOMREG(14) = 0
FINISH
END ; !OF SETWORK
!
!
INTEGERFN KINS
INTEGER RES, INSTRUCTIONS, NET, ADD
*LSS_(6); !GET IMAGE STORE 6 - INS. COUNTER
*ST_INSTRUCTIONS
NET = SSOWN_ICREVS-(INSTRUCTIONS>>24)&1; !SUBTRACT 1 REV IF GUARD BIT SET
IF NET >= 0 THEN ADD = NET<<14 ELSE ADD = -((-NET)<<14)
RESULT = SSOWN_KINSTRS+SSOWN_PREVIC-(ADD+INSTRUCTIONS<<8>>18);!K INS.
END ; ! OF KINS
!
!
SYSTEMLONGREALFN CPUTIME
RESULT = KINS/KIPS; !TIME IN SECONDS
END ; !OF CPUTIME
EXTERNALINTEGERFN PAGETURNS
RESULT = INTEGER(SSOWN_APAGETURNS)
END ; !OF PAGETURNS
SYSTEMINTEGERMAP COMREG(INTEGER I)
RESULT == SSOWN_SSCOMREG(I)
END ; !OF COMREG
EXTERNALSTRINGFN DATE
RESULT = STRING(APDATE)
END ; !OF DATE
EXTERNALSTRINGFN TIME
RESULT = STRING(APTIME)
END ; !OF TIME
SYSTEMSTRINGFN NEXTTEMP
! SSOWN_SEQ = SSOWN_SEQ+1
! %RESULT = TOSTRING(HEX((SSOWN_SEQ>>8)&X'F')).TOSTRING(HEX((SSOWN_SEQ>>4)& %C
! X'F')).TOSTRING(HEX(SSOWN_SEQ&X'F'))
INTEGER W,A,SEQC
LONG INTEGER DRH
W = ADDR (W) + 1
A = ADDR (HEX(0)) - 240
SEQC=SSOWN_SEQ+1
SSOWN_SEQ=SEQC
*LSS_SEQC
*UCP_0; ! to set CC#0.
*USH_20
*LDTB_X'58000003'
*LDA_W
*STD_DRH
*SUPK_L =DR
*LSS_A
*LUH_X'18000100'
*LD_DRH
*TTR_L =DR
BYTE INTEGER (ADDR(W)) = 3
RESULT = STRING (ADDR(W))
END ; !OF NEXTTEMP
!
SYSTEMROUTINE SENDFILE(STRING (31) FILE, C
STRING (16) DEVICE, STRING (24) NAME, C
INTEGER COPIES, FORMS, INTEGERNAME FLAG)
RECORD (PF)P
STRING (16) HOLD DEVICE
RECORD (RF)RR
INTEGER LEN, DATALENGTH
STRING (255) MESSAGE
STRING (8) REST
!
ROUTINE CVP; ! CONVERT PAPER TAPE
!CONVERTS CHARACTER FILE TO PAPER TAPE FILE WITH EVEN PARITY
!AND WITH CR INSERTED WHERE NEC.
CONSTBYTEINTEGERARRAY PARITY(0 : 127) = C
0,129,130,3,132,5,6,135,136,9,10,139,12,141,142,15,
144,17,18,147,20,149,150,23,24,153,154,27,156,29,30,159,
160,33,34,163,36,165,166,39,40,169,170,43,172,45,46,175,
48,177,178,51,180,53,54,183,184,57,58,187,60,189,190,63,
192,65,66,195,68,197,198,71,72,201,202,75,204,77,78,207,
80,209,210,83,212,85,86,215,216,89,90,219,92,221,222,95,
96,225,226,99,228,101,102,231,232,105,106,235,108,237,238,111,
240,113,114,243,116,245,246,119,120,249,250,123,252,125,126,255
RECORD (RF)RR
STRING (11) TEMPFILE
INTEGER INP, IN, OUTP, X, OUTCONAD, LASTCH
CONNECT(FILE,0,0,0,RR,FLAG)
-> ERR IF FLAG # 0
IF NEWCONNECT#0 THEN START
SETUSE (LAST, -1, 0)
FINISH
LEN = RR_DATAEND-RR_DATASTART
IF LEN = 0 THEN -> ERR; !EMPTY FILE WILL BE DESTROYED LATER
TEMPFILE = "T#PP".NEXTTEMP
OUTFILE(TEMPFILE,LEN*2,0,0,OUTCONAD,FLAG)
-> ERR IF FLAG # 0
OUTP = OUTCONAD+32
INTEGER(OUTCONAD+4) = 32
LASTCH = 0
FOR INP=RR_CONAD+RR_DATASTART,1,RR_CONAD+RR_DATAEND-1 CYCLE
IN = BYTEINTEGER(INP)&127; !ONLY THE BOTTOM 7 BITS USED
! Before a NL character (10), we will put out a CR (13).
IF IN=NL THEN X = 13 ELSE X = IN
! In the cycle below, we plant characters in the output
! area until we have planted a copy of the input character.
CYCLE
! Avoid planting redundant CR characters:
IF X#13 OR NL#LASTCH#13 THEN START
BYTE INTEGER (OUTP) = PARITY (X)
OUTP = OUTP + 1
FINISH
LASTCH = X
X = NL
REPEAT UNTIL LASTCH = IN
REPEAT
INTEGER(OUTCONAD) = OUTP-OUTCONAD
IF NEWCONNECT#0 THEN START
SETUSE (LAST, -1, 0)
FINISH
DESTROY(FILE,FLAG)
FILE = TEMPFILE
ERR:
END ; !OF CONVERT PAPER TAPE
!
HOLDDEVICE = DEVICE
IF LENGTH(DEVICE)>=1 AND CHARNO(DEVICE,1)='.' THEN START
CHOPLDR (DEVICE,1)
FINISH
IF DEVICE -> REST.("PP") THEN START
IF REST="" THEN START
CVP; ! CONVERT PAPER TAPE
-> ERR IF FLAG # 0
FINISH ELSE IF REST="B" THEN CHOPLDR (DEVICE,1)
FINISH
FLAG = CHECKFILENAME(FILE,5); !ANY OWN FILE
-> ERR IF FLAG # 0
CONNECT(LAST,0,0,0,RR,FLAG); !TO GET LENGTH
-> ERR IF FLAG # 0
IF NEWCONNECT#0 THEN START
SETUSE (LAST, -1, 0)
FINISH
DATALENGTH = RR_DATAEND-RR_DATASTART
IF DATALENGTH<=0 THEN START ; ! EMPTY FILE.
DESTROY(LAST,FLAG)
-> ERR
FINISH
IF DEVICE=SSOWN_BOUTPUTDEVICE C
AND COPIES=0=FORMS C
AND SSOWN_DELIVERYCHANGED=0 C
THEN START
!IF MULTIPLE COPIES OR SPECIAL FORMS DO NOT INCLUDE
ADDTOJOBOUTPUT(RR_DATASTART+RR_CONAD,DATALENGTH,FLAG)
!TRY TO APPEND TO FRONT OF JOB JOURNAL
IF FLAG=0 THEN START
DESTROY(FILE,FLAG)
-> ERR
FINISH
FINISH
IF NEWCONNECT#0 THEN START
RDISCON (FILE, FLAG)
FINISH ELSE START
DISCONNECT (FILE, FLAG)
FINISH
-> ERR IF FLAG#0
IF DEVICE->REST.("SGP") AND REST="" THEN START
CHOPLDR (DEVICE,1)
FORMS = 1
FINISH
MESSAGE = "DOCUMENT SRCE=".SSOWN_CURFNAME.",DEST=".DEVICE. C
",START=".ITOS(RR_DATASTART).",LENGTH=".ITOS(DATALENGTH)
IF NAME # "" THEN MESSAGE = MESSAGE.",NAME=".NAME
IF FORMS # 0 THEN MESSAGE = MESSAGE.",FORMS=".ITOS(FORMS)
IF COPIES # 0 THEN MESSAGE = MESSAGE.",COPIES=".ITOS( C
COPIES)
LEN = LENGTH(MESSAGE)
IF SSOWN_INHIBITSPOOLER = 0 START
FLAG = X29{DSPOOL}(P,LEN,ADDR(MESSAGE)+1)
IF 100>FLAG#0 THEN START ; ! if Director couldn't pass the
! request on to Spooler:
FLAG = DIRTOSS (FLAG)
FINISH ELSE IF P_P1#0 START
IF 203<=P_P1<=204 THEN FLAG = 331 {QUEUE FULL} C
ELSE IF P_P1=210 THEN START
FLAG = 335
SSOWN_SSFNAME = HOLDDEVICE
FINISH ELSE IF P_P1=202 THEN START
FLAG = 264
SSOWN_SSFNAME = HOLDDEVICE
FINISH ELSE FLAG = 1000+P_P1; ! VERY UNLIKELY FAILURE!
FINISH
FINISH ELSE START
PRINTSTRING(MESSAGE)
FLAG = 1001
FINISH
ERR:
END ; !OF SENDFILE
!
! - END OF BASE TEXT ]
!
IF NEWLOADER#0 THEN START
!
! Tempcode required to handle old style directories
!
!
!***********************************************************************
!* *
!* Temporary Routines required while old directories still extant. *
!* *
!***********************************************************************
!
!
INTEGERFN OLDHASH(STRING (31) NAME, INTEGER HASHCONST)
INTEGER RES, A, B, C, D, E, F, G, H, I, J, K
!A-K ALL NEEDED
STRING(ADDR(A)) = NAME."<>12ABXY89*"
RES = A!!B>>4!!C
RESULT = (RES-RES//HASHCONST*HASHCONST)
END ; !OF HASH
!
!
ROUTINE MAKEDIR(STRING (31) FILE, C
INTEGER HASHCONST, PLENGTH, INTEGERNAME FLAG)
RECORD (DHF)NAME DH
INTEGER LEN, CONAD
PLENGTH = PLENGTH+4; !TO ALLOW FOR LENGTH WORD
LEN = 32+4+HASHCONST*20+PLENGTH
OUTFILE(FILE,LEN,LEN,0,CONAD,FLAG)
-> ERR IF FLAG # 0
IF NEWCONNECT#0 THEN START
SETUSE (LAST, -1, 0)
FINISH
FILL(LEN-32,CONAD+32,0); !FILL WITH ZEROS
FSTATUS(FILE,1,0,FLAG); !CHERISH FILE
DH == RECORD(CONAD); !MAP DH ONTO START OF FILE
DH_DATAEND = LEN
DH_DATASTART = 32
DH_FILETYPE = SSOLDDIRFILETYPE; !TYPE=DIRECTORY
DH_PSTART = 32+4+HASHCONST*20
INTEGER(CONAD+DH_DATASTART) = HASHCONST
INTEGER(CONAD+DH_PSTART) = PLENGTH
ERR:
SSOWN_DIRDISCON = 1; !TO ENSURE NEW DIRECTORY RE-CONNECTED
END ; !OF MAKEDIR
!
!
SYSTEMROUTINE MODDIRFILE(INTEGER EP, C
STRING (31) DIRFILE, ENTRY, FILENAME, C
INTEGER TYPE, DR0, DR1, INTEGERNAME FLAG)
STRING (31) DUMMY1, DUMMY2
INTEGER CONMODE,DESCTYPE
CONSTINTEGER MAXEP = 10
SWITCH SW(1 : MAXEP)
INTEGER HASHBASE, HSTART, PSTART, HASHCONST, I, POINT
INTEGER LBASE, P, OBJCONAD
RECORD (RF)RR
INTEGERARRAYFORMAT BASEAF(1 : 7)
INTEGERARRAYNAME BASE
INTEGERARRAYFORMAT LDATAAF(0 : 16)
INTEGERARRAYNAME LDATA
RECORD (SNF)ARRAYFORMAT HAF(0 : 100000)
!V HIGH LIMIT
RECORD (SNF)ARRAYNAME H
RECORD (SNF)NAME HH
RECORD (DHF)NAME DH; !MAP ONTO HEADER
RECORD (LEF) NAME LE; !NEW FORMAT
RECORD (LDF)NAME LD
INTEGERFN STUFF(INTEGER START, STRING (255) NAME)
INTEGER TOP, LENN, P, BP
!FIRST SEARCHES FOR NAME
! ALREADY IN LIST, IF NOT IN
! PUTS IT IN
!RETURNS ADDRESS OR -1 IF
! LIST FULL
TOP = START+INTEGER(START); !FIRST INTEGER IN LIST
! CONTAINS LENGTH OF LIST
LENN = LENGTH(NAME)
!FIRST LOOK FOR NAEE
P = START+4
WHILE STRING(P) # "" CYCLE
IF STRING(P) = NAME THEN RESULT = P-START
!NAME FOUND
P = P+BYTEINTEGER(P)+1
REPEAT
!NOT FOUND SO LOOK FOR
! SUITABLE HOLE AND PUT IT IN
P = START+4
WHILE STRING(P) # "" CYCLE
IF BYTEINTEGER(P+1) = 255 START
! If the first text byte of a non-null string is X'FF',
! then it is 'unused' and the space may be used to store
! another bit of text.
BP = BYTEINTEGER(P)
IF LENN = BP THEN STRING(P) = NAME C
AND RESULT = P-START
!EXACT FIT
IF LENN+2 <= BP START
!MUST BE AT LEAST 2 BYTES SPARE
STRING(P) = NAME
BYTEINTEGER(P+LENN+1) = BP-LENN-1
!LENGTH OF DUMMY STRING
BYTEINTEGER(P+LENN+2) = 255
!TO INDICATE THAT IT IS A DUMMY
RESULT = P-START
FINISH
FINISH
P = P+BYTEINTEGER(P)+1
REPEAT
!NO HOLE FOUND SO ADD IT TO
! END OF LIST
IF TOP-P >= LENN+2 START ; !IF THERE IS ENOUGH ROOM
STRING(P) = NAME
BYTEINTEGER(P+LENN+1) = 0; !TO TERMINATE LIST
RESULT = P-START
FINISH
RESULT = -1; !LIST FULL
END ; ! OF STUFF
INTEGERFN TEMPLOCATE(INTEGER START, STRING (255) NAME)
! LOCATE NAME IN LIST AND
! RETURN OFFSET OR -1 IF NOT
! FOUND
! This routine works its way through a packed sequence of strings,
! assuming that the first string starts four bytes after the
! address supplied, and that the sequence is terminated by a null
! string (i.e., a zero byte).
INTEGER P
P = START+4
WHILE STRING(P) # "" CYCLE
IF STRING(P) = NAME THEN RESULT = P-START
!NAME LOCATED
P = P+BYTEINTEGER(P)+1
REPEAT
RESULT = -1
END ; !OF TEMPLOCATE
ROUTINE TEMPADDENTRY(STRING (31) ENTRY, C
INTEGER TYPE, DR0, DR1, INTEGERNAME FLAG)
!ADD ONE ENTRY TO HASH TABLE
! AND PUT VALUE INTO H_POINT -
!THIS MIGHT BE A PACKED
! DESCRIPTOR OR A TRUE
! POINTER TO A FILENAME
!IN THE PLIST
INTEGER LENE, INITP, P, EMPTY, POINT
LENE = LENGTH(ENTRY)
FLAG = 0; !DEFAULT REPLY
INITP = OLDHASH(ENTRY,HASHCONST)
P = INITP
EMPTY = -1; !IMPOSSIBLE INITIAL VALUE
IF LENE <= 10 START ; !SHORT NAME
BEGIN ; !TO ALLOW FOR MORE DECLARATIONS
RECORD (SNF)ARRAYFORMAT HAF(0 : HASHCONST-1)
RECORD (SNF)ARRAYNAME H
H == ARRAY(HASHBASE,HAF)
!MAP H ONTO HASH TABLE
CYCLE
IF H(P)_NAME = "" START
!GOT TO END OF LIST
IF EMPTY # -1 THEN P = EMPTY
!USE FIRST EMPTY HOLE FOUND
H(P)_POINT = DR0; !POINTER OR FIRST WORD OF
! DESCRIPTOR
H(P)_DR1 = DR1; !ZERO OR SECOND WORD OF
! DESCRIPTOR
H(P)_NAME = ENTRY
H(P)_TYPE = TYPE
EXIT
FINISH
IF (H(P)_TYPE=TYPE OR H(P)_TYPE=2) C
AND H(P)_NAME=ENTRY C
THEN START
IF EP=9 OR EP=3 THEN START
FLAG = 290
SSOWN_SSFNAME = ENTRY
EXIT
FINISH
FINISH
!ENTRY ALREADY IN DIRECTORY
IF H(P)_NAME = ".EMPTY" AND EMPTY = -1 C
THEN EMPTY = P
!NOTE FIRST EMPTY HOLE
P = P+1
IF P = HASHCONST THEN P = 0
IF P = INITP THEN START
!GONE RIGHT ROUND
IF EMPTY = -1 THEN FLAG = 291 AND EXIT
!NO EMPTY HOLES LEFT
P = EMPTY
H(P)_NAME = ""; !TO FORCE USE OF THIS HOLE
FINISH
REPEAT
END
FINISH ELSE START ; !LONG NAMES
BEGIN
RECORD (LNF)ARRAYFORMAT HAF(0 : HASHCONST-1)
RECORD (LNF)ARRAYNAME H
STRING (6) SENTRY; !FIRST 6 CHAS OF ENTRY
STRING (26) REST
H == ARRAY(HASHBASE,HAF)
!MAP H ONTO HASH TABLE
SENTRY = SUBSTRING(ENTRY,1,6); !FIRST 6 CHAS OF ENTRY
REST = SUBSTRING(ENTRY,7,LENE)
!REST OF ENTRY
TYPE = TYPE!X'80'; !TO SHOW IT IS A LONG NAME
CYCLE
IF H(P)_NAME = "" START
IF EMPTY # -1 THEN P = EMPTY
!USE FIRST AVAILABLE EMPTY HOLE
H(P)_POINT = DR0; !POINTER OR FIRST WORD OF
! DESCRIPTOR
H(P)_DR1 = DR1; !ZERO OR SECOND WORD OF
! DESCRIPTOR
POINT = STUFF(PSTART,REST)
IF POINT < 0 THEN FLAG = 292 AND EXIT
!POINTER LIST FULL
H(P)_REST = POINT
!POINTER TO REST OF ENTRY NAME
H(P)_TYPE = TYPE
H(P)_NAME = SENTRY
!FIRST 6 CHAS OF ENTRY
EXIT ; !SUCCESS
FINISH
IF (H(P)_TYPE=TYPE OR H(P)_TYPE=X'82') C
AND H(P)_NAME=SENTRY C
AND STRING(PSTART+H(P)_REST)=REST C
THEN START
IF EP=9 OR EP=3 THEN START
FLAG = 290
SSOWN_SSFNAME = ENTRY
EXIT
FINISH
FINISH
IF H(P)_NAME = ".EMPTY" AND EMPTY = -1 C
THEN EMPTY = P
P = P+1
IF P = HASHCONST THEN P = 0
!WRAP ROUND
IF P = INITP START
!BEEN RIGHT ROUND
IF EMPTY = -1 THEN FLAG = 291 AND EXIT
!TOO MANY ENTRIES
P = EMPTY; !USE FIRST EMPTY HOLE
H(P)_NAME = ""; !CLEAR OUT NAME
FINISH
REPEAT
END
FINISH
END ; !OF TEMPADDENTRY
INTEGERFN LOADSTART(STRING (31) FILE, INTEGERNAME FLAG)
CONNECT(FILE,0,0,0,RR,FLAG)
!CONNECT OBJECT FILE READ+EXECUTE
IF FLAG=0 THEN START
IF NEWCONNECT#0 THEN START
SETUSE (LAST, -1, 0)
FINISH
OBJCONAD = RR_CONAD; !CONNECT ADDRESS OF OBJECT FILE
IF RR_FILETYPE=SSOBJFILETYPE C
THEN RESULT = RR_CONAD+INTEGER(RR_CONAD+24) C
ELSE START
!INVALID FILETYPE
FLAG = 267
SSOWN_SSFNAME = FILE
FINISH
FINISH
RESULT = 0; !FUNCTION MUST HAVE A RESULT
END ; !OF LOADSTART
CONMODE=0; !Current connect mode
UNLESS 1 <= EP <= MAXEP THEN FLAG = -1 AND -> ERR
IF EP = 10 THEN -> SW(10)
IF DIRFILE = "" THEN -> SW(1)
IF 2#EP THEN CONMODE=3; !WRITE mode except for REMOVE
CONNECT(DIRFILE,CONMODE,0,0,RR,FLAG)
IF FLAG=218 THEN START ; ! CREATE NEWDIRECTORY
MAKEDIR(DIRFILE,160,856,FLAG)
CONNECT(DIRFILE,CONMODE,0,0,RR,FLAG);!TRY AGAIN
FINISH
-> ERR IF FLAG # 0
IF NEWCONNECT#0 THEN START
SETUSE (LAST, -1, 0)
FINISH
DH == RECORD(RR_CONAD)
IF DH_FILETYPE#SSOLDDIRFILETYPE THEN START ; ! INVALID FILETYPE
SSOWN_SSFNAME = DIRFILE
FLAG = 267
-> ERR
FINISH
HSTART = RR_CONAD+DH_DATASTART; !START OF HASH TABLE
HASHBASE = HSTART+4
HASHCONST = INTEGER(HSTART)
PSTART = DH_PSTART+RR_CONAD
!START OF POINTED LIST
UNLESS FILENAME = "" OR FILENAME -> DUMMY1.(".").DUMMY2 C
OR CHARNO(FILENAME,1) = '=' C
THEN FILENAME = SSOWN_SSOWNER.".".FILENAME
-> SW(EP)
SW(9): !ADD ALIAS
IF FILENAME # "" START ; !FILENAME TYPE ENTRY
DR1 = 0; !DR1 NOT USED
POINT = STUFF(PSTART,FILENAME)
!PUT FILENAME IN PLIST
IF POINT < 0 THEN FLAG = 292 AND RETURN
!PLIST FULL
FINISH ELSE POINT = DR0; !PACKED DESRIPTOR
TEMPADDENTRY(ENTRY,TYPE,POINT,DR1,FLAG)
-> ERR
SW(2): !REMOVE ENTRY
SW(6): !REMOVE ENTRIES - LEAVE
! FILENAME IN
POINT = TEMPLOCATE(PSTART,FILENAME)
IF POINT < 0 THEN FLAG = 257 AND SSOWN_SSFNAME = FILENAME C
AND -> ERR
CONMODE=3
CHANGEACCESS(DIRFILE,CONMODE,FLAG); !Change to WRITE mode if INSERTED
IF FLAG#0 THEN -> ERR
H == ARRAY(HASHBASE,HAF)
FOR I=0,1,HASHCONST-1 CYCLE ; ! %CYCLE THROUGH HASH TABLE
! CLEARING ENTRIES
IF H(I)_POINT = POINT THEN H(I)_NAME = ".EMPTY"
REPEAT
IF EP = 2 THEN BYTEINTEGER(PSTART+POINT+1) = 255
!MARK FILENAME AS UNUSED
-> ERR
SW(3): !ADD ALL ENTYRIES IN FILE
! (NOT LOADED)
LBASE = LOADSTART(FILENAME,FLAG)
!GET ADDRESS OF LOADDATA
-> ERR IF FLAG # 0
POINT = TEMPLOCATE(PSTART,FILENAME)
IF POINT < 0 START ; !FIRST INSERTION OF THIS FILE
POINT = STUFF(PSTART,FILENAME)
!PUT FILENAME IN POINTED LIST
IF POINT < 0 THEN FLAG = 292 AND -> ERR
FINISH ELSE START
H == ARRAY(HASHBASE,HAF)
FOR I=0,1,HASHCONST-1 CYCLE ; !CLEAR OUT ANY CURRENT ENTRIES
IF H(I)_POINT = POINT THEN H(I)_NAME = ".EMPTY"
REPEAT
FINISH
LDATA == ARRAY(LBASE,LDATAAF); !MAP LDATA ONTO LOAD DATYA
!FIRST PUT IN CODE ENTRIES
P = LDATA(1)
WHILE P # 0 CYCLE
LE == RECORD(OBJCONAD+P)
IF LE_IDEN # "S#GO" START ; !TO AVOID DUPLICATE NAMES
TEMPADDENTRY(LE_IDEN,0,POINT,0,FLAG)
-> ERR IF FLAG # 0
FINISH
P = LE_LINK
REPEAT
!NOW PUT IN DATA ENTRIES
P = LDATA(4); !LIST HEAD OF DATA ENTRIES
WHILE P # 0 CYCLE
LD == RECORD(OBJCONAD+P)
TEMPADDENTRY(LD_IDEN,1,POINT,0,FLAG)
-> ERR IF FLAG # 0
P = LD_LINK
REPEAT
-> ERR
SW(10): !NEW DIRECTORY CALL
MAKEDIR(DIRFILE,DR0,DR1,FLAG)
-> ERR
SW(1): !ADD SINGLE ENTRY
SW(4): !ADD ALL ENTRIES IN FILE
SW(7): !ADD ONLY PROCEDURE ENTRIES
SW(5): !UNLOAD CALL - CURGLA IN TYPE
SW(8): !REPLACE VALUE OF DR0
PRINTSTRING("Illegal call on MODDIRFILE
")
FLAG=1001
ERR:
IF CONMODE#0 THEN CHANGEACCESS(DIRFILE,1,CONMODE); !Change back to READ - ignore flag
END ; !OF MODDIRFILE
!
!
!***********************************************************************
!* *
!* End of temporary routines *
!* *
!***********************************************************************
!
! End of tempcode required to handle old style directories
FINISH
!
IF PDFNFC#0 THEN START
!
EXTERNALROUTINE PD(STRING (255) S)
RECORD (RF) RR
STRING (7) TMPL
INTEGER FLAG
TMPL="PDFILE"
SSOWN_RCODE=0
IF S="?" THEN PRINTSTRING(SSOWN_PDPREFIX) AND RETURN
UCTRANSLATE (ADDR(S)+1,LENGTH(S))
FILPS(TMPL,S)
S = SPAR (1)
IF S#"" THEN START
CONNECT(S,1,0,0,RR,FLAG)
IF FLAG#0 THEN ->ERR
IF NEWCONNECT#0 THEN START
SETUSE (LAST, -1, 0)
FINISH
IF RR_FILETYPE#SSPDFILETYPE THEN FLAG=267 AND ->ERR
FINISH
SSOWN_PDPREFIX=S
RETURN
ERR:
PRINTSTRING("PD fails - ".FAILUREMESSAGE(FLAG))
SSOWN_RCODE=FLAG
RETURN
END ; ! OF PD
!
!
FINISH
!
ENDOFFILE