! **** **** 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.02l" FINISH FINISH ELSE START IF NEWLOADER=0 THEN START CONSTSTRING (9) VERSION = "SS 2.14s" FINISH ELSE START CONSTSTRING (9) VERSION = "SS 3.02ls" 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 * !* * !*********************************************************************** ! EXTERNALINTEGERFNSPEC ALLOW COMMAND ALIAS "S#ALLOWCOMMAND" (STRING (31) COMMAND) EXTERNALINTEGERFNSPEC ALLOW CONNECT ALIAS "S#ALLOWCONNECT" (STRING (6) USER, STRING (11) FILE) EXTERNALINTEGERFNSPEC CURSTACK ALIAS "S#CURSTACK" EXTERNALINTEGERFNSPEC LAST CHAR COPY ALIAS "S#LASTCHARCOPY" EXTERNALINTEGERFNSPEC MASTERCHARIN ALIAS "S#MASTERCHARIN"(INTEGER MODE) ! IF NEWLOADER#0 THEN START EXTERNAL INTEGER FN SPEC FIND ALIAS "S#FIND" C (STRING (31) ENTRY, INTEGER NAME NREC, INTEGER ADDR, TYPE) EXTERNAL ROUTINE SPEC PRELOAD (STRING (255) FILE) EXTERNALLONGINTEGERFNSPEC LOADENTITY ALIAS "S#LOADENTITY"(STRING (31) ENTRY, INTEGERNAME TYPE,FLAG, INTEGER LOADLEVEL) EXTERNALLONGINTEGERFNSPEC LOADEP ALIAS "S#LOADEP"(STRING (31) ENTRY, INTEGERNAME TYPE,FLAG, INTEGER LOADLEVEL) EXTERNALLONGINTEGERFNSPEC LOOKLOADED ALIAS "S#LOOKLOADED"(STRING (31) ENTRY, INTEGERNAME TYPE) EXTERNAL ROUTINE SPEC BDIRLIST ALIAS "S#BDIRLIST" FINISH ! EXTERNALROUTINESPEC ENTER ALIAS "S#ENTER"(INTEGER MODE, DR0, DR1, STRING (255) PARAM) EXTERNALROUTINESPEC EXAMINEMACRO ALIAS "S#EXAMINEMACRO"(STRINGNAME M, C, C INTEGER B, A, S, INTEGERNAME FLAG) IF NEWLOADER=0 THEN START EXTERNALROUTINESPEC FINDENTRY ALIAS "S#FINDENTRY"(STRING (32) ENTRY, C INTEGER TYPE, DAD, STRINGNAME FILE, C INTEGERNAME DR0, DR1, FLAG) {Old loader} FINISH EXTERNALROUTINESPEC FDIAG ALIAS "S#FDIAG" (INTEGER LNB, PC, MODE, DIAG, ASIZE, C INTEGER NAME FIRST, NEWLNB) EXTERNALROUTINESPEC INITCLIVARS ALIAS "S#INITCLIVARS" EXTERNALROUTINESPEC INITDYNAMICREFS ALIAS "S#INITDYNAMICREFS" EXTERNALROUTINESPEC INITIALISE ALIAS "S#INITIALISE" IF NEWLOADER#0 THEN START EXTERNALROUTINESPEC INITLOADER ALIAS "S#INITLOADER"(INTEGERNAME FLAG) FINISH IF NEWLOADER=0 THEN START EXTERNALROUTINESPEC INUST ALIAS "S#INUST" {Old loader} EXTERNALROUTINESPEC LOAD ALIAS "S#LOAD"(STRING (31) ENTRY, INTEGER TYPE, INTEGERNAME FLAG) {Old loader} FINISH EXTERNALROUTINESPEC MACOPEN ALIAS "S#MACOPEN" EXTERNALROUTINESPEC MAGIO ALIAS "S#MAGIO"(INTEGER AFD,OP,INTEGERNAME FLAG) IF NEWLOADER=0 THEN START EXTERNALROUTINESPEC MODDIRFILE ALIAS "S#MODDIRFILE"(INTEGER EP, STRING (31) DIRFILE, C STRING (32) ENTRY, FILENAME, C INTEGER TYPE, DR0, DR1, INTEGERNAME FLAG) FINISH EXTERNALROUTINESPEC SUPPLYDATADESCRIPTOR ALIAS "S#SUPPLYDATADESCRIPTOR"(RECORD (DRF)NAME DR) IF NEWLOADER=0 THEN START EXTERNALROUTINESPEC UNLOAD ALIAS "S#UNLOAD"(INTEGER CURGLA) {Old loader} FINISH IF NEWLOADER#0 THEN START EXTERNALROUTINESPEC UNLOAD2 ALIAS "S#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 ] ! EXTERNAL ROUTINE SETSESSIONMONITOR ALIAS "S#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 ; !OF CXDUMP EXTERNAL ROUTINE NCODE ALIAS "S#NCODE" (INTEGER START, FINISH, CA) END ; !OF NCODE EXTERNAL ROUTINE DUMP ALIAS "S#DUMP" (INTEGER START, LEN) END ; !OF DUMP EXTERNAL ROUTINE HASHCOMMAND ALIAS "S#HASHCOMMAND" (STRING (255) COM, PAR) END ; !OF HASHCOMMAND 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 ! EXTERNALROUTINE DUMP ALIAS "S#DUMP"(INTEGER START, FINISH) CXDUMP (START, FINISH, 3) END ; ! OF DUMP !* 31/07/81 !* !********************************************* !* * !* THIS ROUTINE RECODES FROM HEX INTO NEW * !* RANGE ASSEMBLY CODE. * !* * !********************************************* EXTERNALROUTINE NCODE ALIAS "S#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; !OF PHEX ! ! **** **** 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 ; !OF PHEX !* !* 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 ; !OF DCD1 !*********************************************************************** !* 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 ; !OF DCD2 !*********************************************************************** !* 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 ; !OF DCD3 !*********************************************************************** !* 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 ; !OF DECOMPILE EXTERNALROUTINE HASHCOMMAND ALIAS "S#HASHCOMMAND"(STRING (255) COMMAND, PARAM) RECORD (FRF) FR STRING (31) S1, S2, OUTF INTEGER I, FLAG, LNB CONSTINTEGER MAXCOM = 28 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","STEXT" 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) MOVE(LENGTH(S)+1,ADDR(S),I) END ; ! SSTRING ROUTINE STEXT INTEGER I STRING (63) S GETNUM(I,FLAG) RETURN IF FLAG # 0 S = SPAR(2) MOVE(LENGTH(S),ADDR(S)+1,I) END ; ! STEXT 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 CSW(28): ! STEXT STEXT ->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 ! EXTERNALROUTINE SSINIT ALIAS "S#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 ! EXTERNALROUTINE USEOPTIONS ALIAS "S#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 = MAXUSERSTACKSIZE !I can't see the point of ever using a smaller stack. There is no command !to set or interrogate the USTK field of the option file. Formerly the code was !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 ! EXTERNALROUTINE BATCHSTOP ALIAS "S#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 ! EXTERNALROUTINE REROUTECONTINGENCY ALIAS "S#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 ! EXTERNALROUTINE INITJOURNAL ALIAS "S#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 ! EXTERNALROUTINE CLOSEJOURNAL ALIAS "S#CLOSEJOURNAL" RETURN IF SSOWN_IT_JNBASE <= 0 INTEGER(SSOWN_IT_JNBASE) = SSOWN_IT_JNCUR-SSOWN_IT_JNBASE; !OFFSET OF END END ; !OF CLOSEJOURNAL ! EXTERNAL ROUTINE JOURNAL OFF ALIAS "S#JOURNALOFF" 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 ; !OF JOURNAL OFF ! EXTERNALROUTINE GETJOURNAL ALIAS "S#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 ! ! EXTERNALROUTINE OFFER ALIAS "S#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 ! EXTERNALROUTINE ACCEPT ALIAS "S#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 EXTERNALROUTINE ARCHIVEPERMIT ALIAS "S#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 EXTERNALROUTINE PERMIT ALIAS "S#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 ! ! EXTERNALINTEGERFN GIVEREGS ALIAS "S#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 ! EXTERNALSTRINGFN FAILUREMESSAGE ALIAS "S#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 EXTERNALROUTINE PRINTMESS ALIAS "S#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 EXTERNALROUTINE SSERR ALIAS "S#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 EXTERNALROUTINE PSYSMES ALIAS "S#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 EXTERNALROUTINE SETFNAME ALIAS "S#SETFNAME"(STRING (40) NAME) !ALLOWS SSOWN_SSFNAME TO BE SET FROM EXTERNAL PROCEDURE - E.G. EDITOR SSOWN_SSFNAME = NAME END ; !OF SETFNAME EXTERNALROUTINE SSMESS ALIAS "S#SSMESS"(INTEGER N) SSOWN_SSFNAME = "" PRINTSTRING(FAILUREMESSAGE(N)) NEWLINES(2) END ; ! SSMESS !* EXTERNALROUTINE SSMESSA ALIAS "S#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 ; !OF TRANS 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 ; !OF PRHEX 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 ; !OF ASSDUMP 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 ; !OF ONCOND !* !* 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" CONSTSTRING (8)ARRAY LD(7:15) = "S#PDIAG","S#SDIAG",""(2),"S#CDIAG", C ""(3),"S#EPDIAG" 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 ; !OF CALL DIAGS ! ! EXTERNALROUTINE NDIAG ALIAS "S#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:15) CONSTINTEGER MAXLANGUAGE = 15 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 LF#7 AND LF#8 AND LF#11 AND LF#15 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 OR LF = 11 OR LF = 15 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. LGE(11):; ! C LGE(15):; ! PASCAL(E) 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. !! EXTERNALROUTINE INDIAG ALIAS "S#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 ; !OF QSORT !* 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 ; !OF CKREC 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 ; !OF PLOCALS 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 ; !OF PSCALAR 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 * !*********************************************************************** !form values ! = 0 free format ! # 0 fixed format !when # 0 may be size of item for strings or records or array elements. Can !not assume that 1 is only alternative to zero 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 IF FORM = 0 THEN J = 1 ELSE J = 13 WRITE(K,J) 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 IF FORM = 0 THEN J = 1 ELSE J = 13 WRITE(INTEGER(VADDR),J) UNLESS LANG=ALGOL OR FORM#0 OR -255<=INTEGER(VADDR)<=255 START PRINTSTRING(" (X'") PRHEX(INTEGER(VADDR)); PRINTSTRING("')") FINISH RETURN INTV(3): ! 8 BIT INTEGER IF FORM = 0 THEN J = 1 ELSE J = 13 WRITE(BYTEINTEGER(VADDR),J); 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 ; !OF XDP 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 ; !OF DDV 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 ; !OF WTFAULT 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 !* EXTERNALROUTINE MLIBERR ALIAS "S#MLIBERR"(INTEGER N) INTEGER I *STLN_I NDIAG(0,INTEGER(I),N,0) END ; ! MLIBERR !* !%EXTERNALINTEGERFNSPEC WRITE JS VAR %ALIAS "S#WRITEJSVAR"(%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 ! !* EXTERNALROUTINE ICL MATHS ERROR ROUTINE ALIAS "S#ICLMATHSERRORROUTINE"( 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 EXTERNALROUTINE PPROFILE ALIAS "S#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 ; !OF PPROFILE ! ! ! - 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. ! **** **** ! ! ! ! ! EXTERNALROUTINE SETPAR ALIAS "S#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 ! EXTERNALINTEGERFN PARMAP ALIAS "S#PARMAP" !RETURNS AN INTEGER SHOWING ! WHICH PARAMETERS ARE ! NON-NULL. BIT 2**0= !PARAM 1 ETC. RESULT = SSOWN_PMAP END ; !OF PARMAP EXTERNALSTRINGFN SPAR ALIAS "S#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 EXTERNAL ROUTINE ANALYSE PARAMETERS ALIAS "S#ANALYSEPARAMETERS"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 ; !OF ANALYSE PARAMETERS ! ! 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 ! EXTERNAL ROUTINE FILPS ALIAS "S#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) IF R # 0 THEN START OOUTST = OUTSTREAM SELECTOUTPUT(0) IF R & 64 # 0 THEN PRINTSTRING("Wrap-around in parameter specifications. ") IF R & 32 # 0 THEN PRINTSTRING("Two values supplied for some parameter. ") IF R & 16 # 0 THEN PRINTSTRING("Unrecognised keyword ") IF R & 8 # 0 THEN PRINTSTRING("Keyword too long ") IF R & 135 # 0 THEN START PRINTSTRING("Bad template:parameter analysis flag ") PRINTSTRING(ITOS(R & X'7FFFFFFF')." ") N = 0 FINISH IF R < 0 THEN N = 0 SELECTOUTPUT(OOUTST) FINISH 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 ; !OF FILPS 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 ; !OF LIST PARAMETERS FINISH ! EXTERNALLONGREALFN ZCPUTIME EXTERNALLONGREALFNSPEC CPUTIME ALIAS "S#CPUTIME" RESULT = CPUTIME END ; !OF CPUTIME EXTERNAL STRING (255) FN PRINTPARMS ALIAS "S#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 ! EXTERNALROUTINE CONSOURCE ALIAS "S#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 IF UINFI(20)=0 THEN PRINTSTRING(" You are liable to pre-emption.") C ELSE PRINTSTRING(" **Resources are Scarce.") 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) EXTERNALROUTINESPEC NEWGEN ALIAS "S#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 OPTIONBODY ALIAS "S#OPTIONBODY"(STRING (255) S, STRING (31)OPTFILE) ! **** **** There should be a NOCFAULTS option. ! EXTERNALROUTINESPEC NEWGEN ALIAS "S#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 ROUTINE PURGE(STRINGNAME S,STRING (1)T) !strips a string of a character STRING (255)L,R S = L.R WHILE S->L.(T).R END ; !OF PURGE ! ! PURGE(S," ") !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(OPTFILE,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(OPTFILE,4096,0,0,CONAD,FLAG) -> ERR IF FLAG # 0 FSTATUS(OPTFILE,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 = OPTFILE -> 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(OPTFILE,FLAG); !IGNORE FLAG - ENSURE WE GET LATEST COPY FINISH ELSE START DISCONNECT (OPTFILE, FLAG) FINISH OUTFILE(TEMPOPTIONS,4096,0,0,CONAD,FLAG) -> ERR IF FLAG # 0 IF NEWCONNECT#0 THEN START SETUSE (LAST, -1, 0) FINISH CONNECT(OPTFILE,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 (OPTFILE,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 32>=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,OPTFILE,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 OPTIONBODY ! EXTERNALROUTINE OPTION(STRING (255)S) OPTIONBODY(S,SSOWN_OPTIONSFILE) 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) EXTERNALROUTINESPEC RENAME ALIAS "S#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 IF NEW -> NEW.("_").NEWMEMBER THEN START IF NEW # "" AND NEW # OLD THEN START FLAG = 297 {inconsistent parameters} -> ERR FINISH FINISHELSE NEWMEMBER = NEW 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 ; !OF MONITORSESSION 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) IF FUNDS ON#0 THEN START IF SCARCEWORD&x'FF'>=SCARCEWORD>>24 THENSTART ! INTERACTIVE USERS > SCARCITY LIMIT SSOWN_SCARCITYFOUND=1 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) PRINTSTRING(" **Resources are Scarce.") 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) !* !* EXTERNALROUTINE READ ALIAS "S#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 ; !OF READ CONSTLONGREAL DZ=0 EXTERNALLONGREALFN FRACPT ALIAS "S#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 ; !OF FRACTPT ROUTINESPEC PRINTFL(LONGREAL X,INTEGER N) EXTERNALROUTINE PRINT ALIAS "S#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 EXTERNALROUTINE WRITE ALIAS "S#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 !* EXTERNALROUTINE PRINTFL ALIAS "S#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 EXTERNALROUTINE FPRINTFL ALIAS "S#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 ! EXTERNALINTEGERFN INT ALIAS "S#INT"(LONGREAL X) RESULT =INTPT(X+0.5) END ; !OF INT INTEGERFN FIX(LONGREAL X) RESULT =INTPT(X) END ; !OF FIX EXTERNALINTEGERFN INTPT ALIAS "S#INTPT"(LONGREAL X) RESULT =FIX(X) END ; !OF INTPT ! 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 - !* !* EXTERNALINTEGERFN IOCP ALIAS "S#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 EXTERNALINTEGERFN JOBREADCH ALIAS "S#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 EXTERNALINTEGERFN JOBNEXTCH ALIAS "S#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 EXTERNALROUTINE SIM2 ALIAS "S#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 = 4096 INTEGER TRIGGER, FLAG, R, HOLDFREE IF T = AD THEN AD = -1 IF AD<0 THEN START SSOWN_SSTTACT=1 HOLDFREE = SSOWN_IT_LASTFREE R=X34{REQUESTOUTPUT} (T,AD) IF R<0 THEN X30{DSTOP}(115) ELSE IF R>SSOWN_IT_OUTLENGTH THEN R = SSOWN_IT_OUTLENGTH IF T<R THEN START IF R<HOLDFREE OR HOLDFREE<=T THEN R = HOLDFREE FINISH ELSE IF R<HOLDFREE<=T THEN R = HOLDFREE SSOWN_SSTTACT=0 FINISHELSESTART TRIGGER = T HOLDFREE = SSOWN_IT_LASTFREE 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)) OR (AD>T AND TRIGGER<T+GAP) THEN TRIGGER = AD IF TRIGGER=T THEN START IF T=0 THEN TRIGGER = SSOWN_IT_OUTLENGTH - 1 ELSE TRIGGER = TRIGGER - 1 FINISH IF HOLDFREE>T>=TRIGGER OR TRIGGER>=HOLDFREE>T OR T>=TRIGGER>=HOLDFREE THEN START SSOWN_SSTTACT = 1 R = X34{REQUESTOUTPUT} (T, TRIGGER) IF R<0 THEN X30{DSTOP}(115) ELSE IF R>SSOWN_IT_OUTLENGTH THEN R = SSOWN_IT_OUTLENGTH IF T<R THEN START IF R<HOLDFREE OR HOLDFREE<=T THEN R = HOLDFREE FINISH ELSE IF R<HOLDFREE<=T THEN R = HOLDFREE HOLDFREE = R SSOWN_SSTTACT = 0 FINISH 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 ! EXTERNALROUTINE CONSOLE ALIAS "S#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 INTEGER HOLE, TOAD TOAD = SSOWN_IT_OUTBASE + SSOWN_IT_OUTPOINTER HOLE = SSOWN_IT_OUTLENGTH - SSOWN_IT_OUTPOINTER IF LEN <= HOLE START ; !ENOUGH ROOM MOVE(LEN,START,TOAD) IF LEN=HOLE THEN POS = 0 ELSE POS = SSOWN_IT_OUTPOINTER + LEN FINISH ELSE START MOVE(HOLE,START,TOAD); ! No effect if HOLE=0. LEN = LEN-HOLE; ! No effect if HOLE=0. MOVE(LEN,START+HOLE,SSOWN_IT_OUTBASE); !PUT REST AT START OF BUFFER POS = LEN FINISH END ; !OF TOBUFFER ROUTINE PMTBFR(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 PMTBFR 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 PMTBFR(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 START IF RES=-SSOWN_IT_OUTLENGTH C THEN RES = SSOWN_IT_OUTLENGTH C ELSE RES = RES+SSOWN_IT_OUTLENGTH FINISH RES = RES-MAXPROMPTSIZE IF RES<0 THEN RES = 0 RESULT = RES END ; !OF FREESPACE ROUTINE OUTFEP(INTEGER FROM, LEN) CONST INTEGER CR = 13 INTEGER SIZE INTEGER HOLDDRTB, HOLDDRA; ! These must stay together. INTEGER FREE, POS, FLAG, TRIGGER BYTE INTEGER CRBYTE RETURN IF LEN <= 0 IF SSOWN_SSTTHIDE=0 THEN START CRBYTE = CR SSOWN_IT_OUTBUSY = 1 IF EP # 10 THEN TOJOURNAL(FROM,LEN); !OUTPUT TO RECALL FILE !UNLESS GRAPHICS OUTPUT !UNLESS OP MESSAGE OR INT:T HOLDDRTB = 0 WHILE LEN>0 CYCLE IF SSOWN_OPMODE#OPTEXT OR SSOWN_FEPMODE#OPBIN C THEN SIZE = LEN ELSE START ! CRs need inserting, but the FEP will not do it. IF HOLDDRTB#0 THEN START FROM = HOLDDRA *LD_HOLDDRTB *SWEQ_L =DR ,0,10; ! %MASK=0, %REF=NL *J_<SCANL> FINISH *LDTB_X'18000000' *LDA_FROM *LDB_LEN SCANL: *SWNE_L =DR ,0,10; ! %MASK=0, %REF=NL *STD_HOLDDRTB SIZE = HOLDDRA - FROM FINISH LEN = LEN - SIZE ! If LEN#0, we have to plant a CR in the output buffer ! after the SIZE bytes from the data supplied by the caller. CYCLE FREE = FREESPACE; !HOW MUCH LEFT EXIT IF SIZE<FREE OR (SIZE=FREE AND LEN=0); !ENOUGH ROOM FOR IT ALL IF FREE=0 THEN POS = SSOWN_IT_OUTPOINTER ELSE START IF 6 # EP # 12 THEN SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS TOBUFFER(FROM,FREE,POS); !POS POINTS TO BYTE AFTER END OF INSERTED TEXT SSOWN_IT_OUTPOINTER = POS SIZE = SIZE-FREE FROM = FROM+FREE IF 6 # EP # 12 THEN ALLOW INTERRUPTS; !EXCEPT WHEN PRINTING OPER MESSAGES FINISH ! The next two lines would be WRONG if MAXPROMPTSIZE were greater ! than a quarter of IT_OUTLENGTH, but that is hardly likely. TRIGGER = POS-SSOWN_IT_OUTLENGTH>>2; !SEND 3/4 OF BUFFER IF TRIGGER < 0 THEN TRIGGER = TRIGGER+SSOWN_IT_OUTLENGTH FLAG = RQOUT(POS,TRIGGER) SSOWN_IT_LASTFREE = FLAG EXIT IF SSOWN_SSTTHIDE#0 REPEAT IF (SIZE>0 OR LEN#0) AND SSOWN_SSTTHIDE=0 START ; !SOME LEFT IF 6 # EP # 12 THEN SSOWN_SSINHIBIT = 1 IF SIZE>0 THEN START TOBUFFER(FROM,SIZE,POS) SSOWN_IT_OUTPOINTER = POS FINISH IF LEN#0 THEN START TOBUFFER (ADDR(CRBYTE),1,POS) SSOWN_IT_OUTPOINTER = POS FINISH FLAG = RQOUT(POS,-1) SSOWN_IT_LASTFREE = FLAG IF 6 # EP # 12 THEN ALLOWINTERRUPTS FINISH REPEAT 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 FREESPACE#SSOWN_IT_OUTLENGTH-MAXPROMPTSIZE THEN START ; ! TEST FOR AN EMPTY BUFFER. FLAG = 0; !PROTEM - AWAITING A CORRECTION FROM BRIAN GILMORE CURSOR = SSOWN_IT_OUTPOINTER-1 IF CURSOR=-1 THEN CURSOR = SSOWN_IT_OUTLENGTH - 1 FLAG = RQOUT(SSOWN_IT_OUTPOINTER,CURSOR) !CLEAR OUTPUT BUFFER 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 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 ; !OF XNL 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 FREESPACE#SSOWN_IT_OUTLENGTH-MAXPROMPTSIZE ! NO CONSOLE, OR BUFFER EMPTY. 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) SSOWN_IT_LASTFREE = FLAG !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 FREESPACE#SSOWN_IT_OUTLENGTH-MAXPROMPTSIZE THEN START FLAG = 0; !TEMP I = SSOWN_IT_OUTPOINTER-1 FLAG = RQOUT(SSOWN_IT_OUTPOINTER,I) 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 EXTERNALROUTINE TOJOURNAL ALIAS "S#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 EXTERNALROUTINE NOTE ALIAS "S#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 - EXTERNALINTEGERFN FDMAP ALIAS "S#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 EXTERNALINTEGERFN DEVCODE ALIAS "S#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 EXTERNALSTRINGFN DEVNAME ALIAS "S#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. ! EXTERNAL ROUTINE SET OPEN USED ALIAS "S#SETOPENUSED" ! 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 ; !OF SET OPEN USED ! EXTERNAL INTEGER FN FDADDR ALIAS "S#FDADDR" ! Returns the address of the FD Subsystem FD table. RESULT = ADDR(SSOWN_FD(1)) END ; !OF FDADDR ! EXTERNAL ROUTINE SETTOPFD ALIAS "S#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 ; !OF SETTOPFD ! EXTERNAL INTEGER MAP MAPSSFD ALIAS "S#MAPSSFD" (INTEGER DSNUM) ! Allows two-way access to the SSOWN_SSFDMAP pointer table. RESULT == SSOWN_SSFDMAP (DSNUM) END ; !OF MAPSSFD EXTERNALROUTINE DEFINE ALIAS "S#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 EXTERNAL ROUTINE SET IO DEFAULT ALIAS "S#SETIODEFAULT"(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 ; !OF SET IO DEFAULT EXTERNALROUTINE TIDYFILES ALIAS "S#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) IF SSOWN_OUTF_ACCESSROUTE = 9 THEN SSOWN_OUTF_F77UFD = 0 SSOWN_SSOPENUSED = 0 CONSOLE(14,FLAG,FLAG); !TO RESET JNBASE IN CASE RECALL OR RECAP CALLED **PROTEM END ; !OF TIDYFILES EXTERNALINTEGERFN OPEN ALIAS "S#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 !* EXTERNALROUTINE EXTEND ALIAS "S#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 EXTERNALROUTINE ADDTOJOBOUTPUT ALIAS "S#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 EXTERNALINTEGERFN CLOSE ALIAS "S#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 !* !* ! EXTERNAL INTEGER MAP FIO1FLAG ALIAS "S#FIO1FLAG" RESULT == SSOWN_INITFIO1 END ; !OF FI01FLAG ! EXTERNAL INTEGER MAP FIO2FLAG ALIAS "S#FIO2FLAG" RESULT == SSOWN_INITFIO2 END ; !OF FI02FLAG ! !* !* ! EXTERNAL ROUTINE DFDFIN ALIAS "S#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 ; !OF DFDFIN EXTERNAL ROUTINE DFDFOUT ALIAS "S#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 ; !OF DFDFOUT ! ! - 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 ; !OF ICS 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 ! EXTERNAL ROUTINE RCL ALIAS "S#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 ; !OF RCL ! EXTERNAL STRING (255) MAP CONTROL LINE ALIAS "S#CONTROLLINE" (INTEGER NAME FLAG) INTEGER I RESULT == GCL (I, FLAG) END ; !OF CONTROL LINE ! EXTERNALINTEGERFN CHECKCOMMAND ALIAS "S#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 ! EXTERNALROUTINE BCI ALIAS "S#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 ; !OF FINDLAST 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 ; !OF FORALL INTEGER FN PE (STRING NAME U, INTEGER I) WRITE (I,4); SPACES (2); PRINT STRING (U); NEWLINE RESULT = 0 END ; !OF PE ROUTINE SIMPLE (STRING NAME T) RCSTL = T END ; !OF SIMPLE 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 ; !OF REDO INTEGER FN CKN (STRING NAME U, INTEGER I) IF I=W THEN START RCSTL = U RESULT = -1 FINISH ELSE RESULT = 0 END ; !OF CKN 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 ; !OF REFIT ! ! ! 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 SAVEMARK = -1 IF Z="" THEN REDO(2,SIMPLE) ELSE START IF CHARNO(Z,LENGTH(Z))='!' THEN LENGTH(Z) = LENGTH(Z) - 1 REDO (2,REFIT) FINISH FINISH ELSE START SAVEMARK = -1 W = PSTOI (COMMAND) IF W<=0 THEN REDO (1,SIMPLE) ELSE FORALL (CKN) FINISH IF RCSTL="" THEN START PFLAG = PFLAG!3 FLAG = 3 FINISH ELSE START IF RCSTL->COMMAND.(TOSTRING(160)).RCSTL THEN START IF NC#"" THEN START SAVEMARK = -1 COMMAND = NC 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 IF PFLAG&2 # 0 THEN PRINTSTRING(" not recognised") 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 SAVEMARK = -1 IF Z="" THEN REDO(2,SIMPLE) ELSE START IF CHARNO(Z,LENGTH(Z))='!' THEN LENGTH(Z) = LENGTH(Z) - 1 REDO (2,REFIT) FINISH FINISH ELSE START SAVEMARK = -1 W = PSTOI (COMMAND) IF W<=0 THEN REDO (1,SIMPLE) ELSE FORALL (CKN) FINISH IF RCSTL="" THEN START PFLAG = PFLAG!3 FLAG = 3 FINISH ELSE START RCSTL -> COMMAND.(" ").RCSTL FINISH 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 IF PFLAG&2 # 0 THEN PRINTSTRING(" not recognised") 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 ! EXTERNALSTRINGFN CLICOMMAND ALIAS "S#CLICOMMAND" RESULT =SSOWN_CLICOMM END ; ! OF SSOWN_CLICOMMAND ! ! EXTERNALSTRINGFN CLIPARAM ALIAS "S#CLIPARAM" RESULT =SSOWN_CLIPARM END ; ! OF CLIPARAM ! ! EXTERNAL ROUTINE QUERYPROMPTS ALIAS "S#QUERYPROMPTS" (INTEGER I) SSOWN_QPARMF = I END ; !OF QUERYPROMPTS ! EXTERNALROUTINE BEFORECOMMAND ALIAS "S#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 EXTERNALROUTINE AFTERCOMMAND ALIAS "S#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 EXTERNALROUTINE CONTROL ALIAS "S#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)." ") !EXTRA LINE 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 !* !* !* ! EXTERNALROUTINE MOVE ALIAS "S#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 ! EXTERNALROUTINE FILL ALIAS "S#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 ! EXTERNAL INTEGER FN SAMEBYTES ALIAS "S#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 ; !OF SAMEBYTES ! EXTERNAL INTEGER FN STOREMATCH ALIAS "S#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 ; !OF STOREMATCH ! 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 ! EXTERNAL STRING (255) FN SUBSTRING ALIAS "S#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 ; !OF SUBSTRING ! EXTERNAL ROUTINE UCTRANSLATE ALIAS "S#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 ; !OF UCTRANSLATE ! 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 ; !OF UCSTRING ! EXTERNALROUTINE ITOE ALIAS "S#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 ! EXTERNALROUTINE ETOI ALIAS "S#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: EXTERNAL INTEGER FN TRAIL SPACES ALIAS "S#TRAILSPACES" (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 ; !OF TRAILSPACES ! ! EXTERNAL ROUTINE CHOPLDR ALIAS "S#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 ; !OF CHOPLDR ! EXTERNAL C INTEGER FN STARTSWITH ALIAS "S#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 ; !OF STARTSWITH ! EXTERNAL ROUTINE CAST OUT ALIAS "S#CASTOUT" (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 ; !OF CAST OUT ! EXTERNAL INTEGER FN SIZE OF ALIAS "S#SIZEOF" (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 ; !OF SIZE OF ! EXTERNALSTRINGFN ITOS ALIAS "S#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 ! EXTERNALINTEGERFN PSTOI ALIAS "S#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 ! EXTERNALSTRING (8) FN HTOS ALIAS "S#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 ! EXTERNALROUTINE PHEX ALIAS "S#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 * !*********************************************************************** ! EXTERNAL INTEGER FN CURRENT PACKED DT ALIAS "S#CURRENTPACKEDDT" !*********************************************************************** !* 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 ; !OF CURRENT PACKED DT ! EXTERNAL INTEGER FN DTWORD ALIAS "S#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 ; !OF DTWORD ! ! **** **** 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 ; !OF KDAY ! 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 ! EXTERNAL INTEGERFN PACKDATEANDTIME ALIAS "S#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 **** **** ! EXTERNAL STRING (8)FN UNPACK DATE ALIAS "S#UNPACKDATE"(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 ; !OF UNPACK DATE ! EXTERNAL STRING (8)FN UNPACK TIME ALIAS "S#UNPACKTIME"(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 ; !OF UNPACK TIME ! 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 ! EXTERNAL ROUTINE SET SS INHIBIT ALIAS "S#SETSSINHIBIT" SSOWN_SSINHIBIT = 1 END ; !OF SET SS INHIBIT ! EXTERNALROUTINE ALLOW INTERRUPTS ALIAS "S#ALLOWINTERRUPTS" 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 ! EXTERNALINTEGERFN DIRTOSS ALIAS "S#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 ! EXTERNALINTEGERFN ROUNDUP ALIAS "S#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 ! EXTERNALROUTINE SIGNAL ALIAS "S#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 ! EXTERNALROUTINE DIRTRAP ALIAS "S#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 EXTERNALROUTINE HALT ALIAS "S#HALT" !CALL DIRECTOR STOP TO STOP ! PROCESS X30{DSTOP}(100) END ; !OF HALT EXTERNALINTEGERFN CHECKFILENAME ALIAS "S#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 ! ! EXTERNALSTRINGFN CONFILE ALIAS "S#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 ! ! EXTERNALROUTINE DISCONNECT ALIAS "S#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 we really want to disconnect PD members, the "7" should be "15" 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 ! EXTERNAL ROUTINE SDISCONNECT ALIAS "S#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 ; !OF RDISCON ! 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 ; !OF DODCONN ! EXTERNALROUTINE CONNECT ALIAS "S#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 ; !OF FINFO AND CHOOSEMODE ! 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 ; !OF DDCONNECT ! 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 ! EXTERNALROUTINE OUTFILE ALIAS "S#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 ! EXTERNALSTRINGFN SEGSINUSE ALIAS "S#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 ! EXTERNALROUTINE SETUSE ALIAS "S#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 ! EXTERNALROUTINE DESTROY ALIAS "S#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 ! EXTERNALROUTINE RENAME ALIAS "S#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 IF '0' <= CHARNO(NEWNAME,1) <= '9' THEN START !file not allowed to start with a number SSOWN_SSFNAME = NEWNAME FLAG = 220 -> ERR FINISH 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 ! EXTERNAL ROUTINE NEWGEN ALIAS "S#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 ! EXTERNAL ROUTINE CHANGEACCESS ALIAS "S#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 ! EXTERNAL ROUTINE CHANGEFILESIZE ALIAS "S#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 EXTERNAL ROUTINE TRIM ALIAS "S#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 EXTERNALROUTINE TRIM ALIAS "S#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 ! EXTERNAL ROUTINE MODPDFILE ALIAS "S#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 IF '0' <= CHARNO(INFILE,1) <= '9' THEN START !filename not allowed to start with number SSOWN_SSFNAME = INFILE FLAG = 270 {invalid membername} -> ERR FINISH 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 ! ! ! ! EXTERNALROUTINE FINFO ALIAS "S#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 ! ! EXTERNALROUTINE FSTATUS ALIAS "S#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. ! EXTERNALINTEGERFN GETSPACE ALIAS "S#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 ! ! EXTERNALROUTINE SETWORK ALIAS "S#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 ! ! EXTERNALLONGREALFN CPUTIME ALIAS "S#CPUTIME" RESULT = KINS/KIPS; !TIME IN SECONDS END ; !OF CPUTIME EXTERNALINTEGERFN PAGETURNS RESULT = INTEGER(SSOWN_APAGETURNS) END ; !OF PAGETURNS EXTERNALINTEGERMAP COMREG ALIAS "S#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 EXTERNALSTRINGFN NEXTTEMP ALIAS "S#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 ! EXTERNALROUTINE SENDFILE ALIAS "S#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 ! ! EXTERNALROUTINE MODDIRFILE ALIAS "S#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