Œ Œ ! **** **** 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 = -1; ! Zero to suppress generation of FUNDS code, ! non-zero to include FUNDS. %CONSTINTEGER MACHINE=0; ! 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.02h" %FINISH %FINISH %ELSE %START %IF NEWLOADER=0 %THEN %START %CONSTSTRING(9) VERSION = "SS 2.14s" %FINISH %ELSE %START %CONSTSTRING(9) VERSION = "SS 3.02hs" %FINISH %FINISH ! %INCLUDE "ERCC16.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, %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 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 %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=4; ! 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'0108000000000000';!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(21) FMESSAGE = "SUBSYS.FMESSAGE" %CONSTSTRING(4) ITFILENAME = "T#IT" %CONSTSTRING(4) LAST = "}{|~"; !UNLIKELY PATTERN %CONSTSTRING(12) SPOOLERCFILE = "SPOOLR.CFILE" %CONSTSTRING(10) SSPERMJNAME = "SS#JOURNAL" %CONSTSTRING(5) SSTEMPJNAME = "T#JN" ! %CONSTSTRING(10)%ARRAY LT (0 : 10) = %C " !???! ", " IMP ", " FORTRAN ", "IMPS ", %C " ASMBLR ", " ALGOL(E) ", " OPTCODE ", %C " PASCAL ", " SIMULA ", " BCPL ", "FORTRAN 77" ! ! NEW PARMS FOR FORTRAN 77 ADDED AUGUST 1983 - MIKE BROWN ! %CONSTSTRING(10)%ARRAY PARMS (0:MAXPARMS) = %C "", "I8", "L8", "R8", %C {! COMREG(28) "OPTEXT", "NOCOMMENTS", "NOWARNINGS", "STRICT", %C "MAXDICT", "", "", "", %C "", "", "MINSTACK", "", %C "", "", "", "", %C "OPT1", "OPT2", "OPT3", "OPT4", %C "", "", "", "", %C "", "", "", "", %C "QUOTES", "NOLIST", "NODIAG", "STACK", %C {! COMREG(27) "NOCHECK", "NOARRAY", "NOTRACE", "PROFILE", %C "IMPS", "INHIBIOF", "ZERO", "XREF", %C "LABELS", "LET", "CODE", "ATTR", %C "OPT", "MAP", "DEBUG", "FIXED", %C "DYNAMIC", "", "EBCDIC", "NOLINE", %C "", "", "PARMZ", "PARMY", %C "PARMX", "MISMATCH", "", "" %CONSTSTRING(12)%ARRAY ROOTNAME (1 : MAXROOT) = %C "ACCEPT","TELL","ARCHIVE","ASSEMBLE","CHERISH", "CLOSE","CONCAT","CONNECT","COPY","CREATEFILE", "DELETEJOB","DESTROY","DETACH","DISCONNECT","INSERTMACRO", "ANALYSE","SMADDR","FINDFILE","FINDJOB","FILES", "FORTE","HAZARD","IMP","IMPS","INSERT", "CLOSESM","DISCARD","LINK","LIST","OFFER", "OPEN","PERMIT","CHANGESM","PRELINK","TIDYDIR", "REMOVE","REMOVELIB","RENAME","RUN","SEND", "NEWDIRECTORY","CLEAR","DEFINE","NEWSMFILE","EXTEND", "OBEY","Load","ALGOL","OPENSQ","CLOSESQ","NEWPDFILE", "PRELOAD","CPULIMIT","CONVERT","USERS", "QUEUES","METER","RECALL","EDIT", "PARM","NEWGEN","DELIVER","PASSWORDS","PROJECT", "RESTORE","ARCHLIST","OPTION","HELP","SUGGESTION","ALERT", "SELECTINPUT","SELECTOUTPUT","ECCE","SHOW","RECAP","SETMODE", "ALIAS","LOOK","OPENDA","CLOSEDA","WRITEDA","READDA","WRITESQ","READSQ", "READLSQ","CALL","CLOSEF","MESSAGES","PUTSQ","GETSQ","REWINDSQ", "PUTDA","GETDA","TIDYDIR","RELAY","DOCUMENTS","DELETEDOC", "PASCAL","SIMULA","DEFINEMT","DONATEFUNDS","FORT77","IMP80", "IBMIMP","FROMSTRING","GECCE","DATASPACE","ALIASENTRY","LOADPARM", "IOPT" ! !*********************************************************************** !* * !* DIRECTOR and SUPERVISOR Routine/fn/map spec * !* * !*********************************************************************** ! %EXTERNALINTEGERFNSPEC X2{DTRANSFER}(%STRING (31) FILEOWNER, PROCOWNER, OLDNAME, NEWNAME, %C %INTEGER OLDFSYS, NEWFSYS, TYPE) %EXTERNALINTEGERFNSPEC X3{DASYNCINH}(%INTEGER MODE, ATW) %EXTERNALINTEGERFNSPEC X4{DCHACCESS}(%STRING (6) USER, %C %STRING (11) FILE, %INTEGER FSYS, NEWMODE) %EXTERNALINTEGERFNSPEC X5{DCHSIZE}(%STRING (6) USER, %C %STRING (11) FILE, %INTEGER FSYS, NEWSIZE KB) %EXTERNALINTEGERFNSPEC X6{DCLEARINTMESSAGE} %EXTERNALINTEGERFNSPEC X7{DCONNECT}(%STRING (6) USER, %C %STRING (11) FILE, %INTEGER FSYS, MODE, APF, %C %INTEGERNAME SEG, GAP) %EXTERNALINTEGERFNSPEC DCPUTIME %EXTERNALINTEGERFNSPEC X8{DCREATE}(%STRING (6) USER, %C %STRING (11) FILE, %INTEGER FSYS, NKB, TYPE) %EXTERNALINTEGERFNSPEC X9{DDESTROY}(%STRING (6) USER, %C %STRING (11) FILE, %STRING (6) DATE, %INTEGER FSYS, TYPE) %EXTERNALINTEGERFNSPEC X10{DDISABLETERMINALSTREAM1}( %C %INTEGERNAME CURSOR, %INTEGER STREAM, MODE) %EXTERNALINTEGERFNSPEC X11{DDISCONNECT}(%STRING (6) USER, %C %STRING (11) FILE, %INTEGER FSYS, DESTROYMODE) %EXTERNALINTEGERFNSPEC X12{DENABLETERMINALSTREAM}( %C %INTEGER STREAM, MODE, LEVEL, ADDRESS, LEN, CURSOR) %EXTERNALINTEGERFNSPEC X14{DFINFO}(%STRING (6) USER, %C %STRING (11) FILE, %INTEGER FSYS, ADDR) %EXTERNALINTEGERFNSPEC X15{DFSTATUS}(%STRING (6) USER, %C %STRING (11) FILE, %INTEGER FSYS, ACT, VALUE) %EXTERNALINTEGERFNSPEC X16{DMESSAGE2}(%STRING (6) USER, %C %INTEGERNAME LEN, %INTEGER ACT, INVOC, FSYS, ADR) %EXTERNALINTEGERFNSPEC X17{DNEWGEN}(%STRING (6) USER, %C %STRING (11) FILE, NFILE, %INTEGER FSYS) %EXTERNALINTEGERFNSPEC X18{DNEWOUTWARDCALL}( %C %INTEGER ACR, EMAS, SEG, DR0, DR1, %C %INTEGERNAME I, J) %EXTERNALINTEGERFNSPEC X19{DOFFER}(%STRING (6) USER, TO, %C %STRING (11) FILE, %INTEGER FSYS) %EXTERNALINTEGERFNSPEC X22{DPERMISSION}( %C %STRING (6) OWNER, USER, %STRING (8) DATE, %C %STRING (11) FILE, %INTEGER FSYS, TYPE, AD) %EXTERNALINTEGERFNSPEC X24{DRENAME}(%STRING (6) USER, %C %STRING (11) OLD, NEW, %INTEGER FSYS) %EXTERNALINTEGERFNSPEC X27{DSETIC}(%INTEGER KI) %EXTERNALINTEGERFNSPEC X28{DSFI}(%STRING (6) USER, %C %INTEGER FSYS, TYPE, SET, ADR) %EXTERNALINTEGERFNSPEC X29{DSPOOL}(%RECORD(PF)%NAME P,%INTEGER LEN,ADR) %EXTERNALINTEGERFNSPEC X31{PRIMECONTINGENCY}(%ROUTINE R) %EXTERNALINTEGERFNSPEC X32{READID}(%INTEGER AD) %EXTERNALINTEGERFNSPEC X33{REQUESTINPUT}(%INTEGER T, AD) %EXTERNALINTEGERFNSPEC X34{REQUESTOUTPUT}(%INTEGER T, AD) %EXTERNALSTRINGFNSPEC X44{DERRS} (%INTEGER N) ! ! The next 2 routines are actually synonyms for DSTOP and DPRINTSTRING ! which have been renamed to ensure that they head the system call table regardless of ! any other changes. Thus we can guarantee a controlled stop when we find ! a shareable basegla with a mismatching system call table. %EXTERNALROUTINESPEC AAASTOP(%INTEGER I) {Synonym for DSTOP} %EXTERNALROUTINESPEC AABPRINTSTRING(%STRING(255) S) {Synonym for DPRINTSTRING} %EXTERNALROUTINESPEC X1{CHANGECONTEXT} %EXTERNALROUTINESPEC X20{DOPER}(%INTEGER OPERNO, %STRING (255) S) %EXTERNALROUTINESPEC X21{DOPERPROMPT}(%INTEGER OPERNO, %C %STRING (23) PROMPT) %EXTERNALROUTINESPEC X23{DPOFF}(%RECORD(PF)%NAME P) ! %EXTERNALROUTINESPEC DPRINTSTRING(%STRING(255) S) %EXTERNALROUTINESPEC X26{DRESUME}(%INTEGER LNB, PC, AD) %EXTERNALROUTINESPEC X30{DSTOP}(%INTEGER R) ! !*********************************************************************** !* * !* %SYSTEM Routine/fn/map spec * !* * !*********************************************************************** ! %SYSTEMINTEGERFNSPEC ALLOW COMMAND (%STRING (31) COMMAND) %SYSTEMINTEGERFNSPEC ALLOW CONNECT (%STRING (6) USER, %STRING (11) FILE) %SYSTEMINTEGERFNSPEC CURSTACK %SYSTEMINTEGERFNSPEC LAST CHAR COPY %SYSTEMINTEGERFNSPEC MASTERCHARIN(%INTEGER MODE) ! %IF NEWLOADER#0 %THEN %START %SYSTEM %INTEGER %FN %SPEC FIND %C (%STRING (31) ENTRY, %INTEGER %NAME NREC, %INTEGER ADDR, TYPE) %EXTERNAL %ROUTINE %SPEC PRELOAD (%STRING (255) FILE) %SYSTEMLONGINTEGERFNSPEC LOADENTITY(%STRING(31) ENTRY, %INTEGERNAME TYPE,FLAG, %INTEGER LOADLEVEL) %SYSTEMLONGINTEGERFNSPEC LOADEP(%STRING(31) ENTRY, %INTEGERNAME TYPE,FLAG, %INTEGER LOADLEVEL) %SYSTEMLONGINTEGERFNSPEC LOOKLOADED(%STRING(31) ENTRY, %INTEGERNAME TYPE) %SYSTEM %ROUTINE %SPEC BDIRLIST %FINISH ! %SYSTEMROUTINESPEC ENTER(%INTEGER MODE, DR0, DR1, %STRING (255) PARAM) %SYSTEMROUTINESPEC EXAMINEMACRO(%STRINGNAME M, C, %C %INTEGER B, A, S, %INTEGERNAME FLAG) %IF NEWLOADER=0 %THEN %START %SYSTEMROUTINESPEC FINDENTRY(%STRING (32) ENTRY, %C %INTEGER TYPE, DAD, %STRINGNAME FILE, %C %INTEGERNAME DR0, DR1, FLAG) {Old loader} %FINISH %SYSTEMROUTINESPEC FDIAG (%INTEGER LNB, PC, MODE, DIAG, ASIZE, %C %INTEGER %NAME FIRST, NEWLNB) %SYSTEMROUTINESPEC INITCLIVARS %SYSTEMROUTINESPEC INITDYNAMICREFS %SYSTEMROUTINESPEC INITIALISE %IF NEWLOADER#0 %THEN %START %SYSTEMROUTINESPEC INITLOADER(%INTEGERNAME FLAG) %FINISH %IF NEWLOADER=0 %THEN %START %SYSTEMROUTINESPEC INUST {Old loader} %SYSTEMROUTINESPEC LOAD(%STRING (31) ENTRY, %INTEGER TYPE, %INTEGERNAME FLAG) {Old loader} %FINISH %SYSTEMROUTINESPEC MACOPEN %SYSTEMROUTINESPEC MAGIO(%INTEGER AFD,OP,%INTEGERNAME FLAG) %IF NEWLOADER=0 %THEN %START %SYSTEMROUTINESPEC MODDIRFILE(%INTEGER EP, %STRING (31) DIRFILE, %C %STRING (32) ENTRY, FILENAME, %C %INTEGER TYPE, DR0, DR1, %INTEGERNAME FLAG) %FINISH %SYSTEMROUTINESPEC SUPPLYDATADESCRIPTOR(%RECORD(DRF)%NAME DR) %IF NEWLOADER=0 %THEN %START %SYSTEMROUTINESPEC UNLOAD(%INTEGER CURGLA) {Old loader} %FINISH %IF NEWLOADER#0 %THEN %START %SYSTEMROUTINESPEC UNLOAD2(%INTEGER LOADLEVEL,FAIL) %FINISH ! !*********************************************************************** !* * !* External/internal routine/fn/map specs * !* * !*********************************************************************** ! %IF FUNDS ON#0 %THEN %START %EXTERNALROUTINESPEC FUNDS(%STRING (255) S) %FINISH ! %EXTERNALROUTINESPEC LOADDUMP(%STRING(255) S) %EXTERNALROUTINESPEC OBEYJOB(%STRING (255) S) ! %INTEGERFNSPEC CHECKFILENAME(%STRING (31) FILE, %INTEGER TYPE) %INTEGERFNSPEC CHECKCOMMAND(%STRING (255) S) %INTEGERFNSPEC CLOSE(%INTEGER AFD) %INTEGERFNSPEC CURRENT PACKED DT %INTEGERFNSPEC DEVCODE(%STRING (16) S) %INTEGERFNSPEC DIRTOSS(%INTEGER FLAG) %INTEGERFNSPEC FINDFN (%STRING (31) FILE, %INTEGERNAME POS) %INTEGERFNSPEC GETSPACE(%INTEGER BYTES) %INTEGERFNSPEC INSTREAM %INTEGERFNSPEC IOCP(%INTEGER EP, PARM) %INTEGERFNSPEC KINS %INTEGERFNSPEC OPEN(%INTEGER AFD, MODE) %INTEGERFNSPEC OUTPOS %INTEGERFNSPEC OUTSTREAM %INTEGERFNSPEC PACKDATEANDTIME(%STRING (8) DATE, TIME) %INTEGERFNSPEC PAGETURNS %INTEGERFNSPEC PSTOI(%STRING (63) S) %INTEGERFNSPEC ROUNDUP (%INTEGER N, ROUND) %INTEGERFNSPEC STARTSWITH (%STRING %NAME A, %STRING (255) B, %INTEGER CHOP) %INTEGERFNSPEC STOREMATCH (%INTEGER L, A1, A2) %INTEGERFNSPEC TRAIL SPACES (%INTEGER LINE END, LINE START, TRANS) %INTEGERFNSPEC UINFI(%INTEGER I) ! %LONGREALFNSPEC CPUTIME ! %ROUTINESPEC ADDTOJOBOUTPUT(%INTEGER START, LEN, %INTEGERNAME FLAG) %ROUTINESPEC ALLOW INTERRUPTS %ROUTINESPEC BATCHSTOP(%INTEGER REASON) %ROUTINESPEC BCI %ROUTINESPEC CAST OUT (%STRING %NAME PSTR) %ROUTINESPEC CHANGEFILESIZE(%STRING (31)FILE, %INTEGER NEWSIZE, %C %INTEGERNAME FLAG) %ROUTINESPEC CHANGEACCESS(%STRING (31) FILE, %INTEGER MODE, %INTEGERNAME FLAG) %ROUTINESPEC CHOPLDR (%STRING %NAME A, %INTEGER I) %ROUTINESPEC CONNECT(%STRING (31) FILE, %C %INTEGER MODE, HOLE, PROT, %RECORD(RF)%NAME R, %INTEGERNAME FLAG) %ROUTINESPEC CONSOLE(%INTEGER EP, %INTEGERNAME P1, P2) %ROUTINESPEC CONTROL %ROUTINESPEC DECWRITE2(%INTEGER VALUE,AD) %ROUTINESPEC DEFINE(%INTEGER CHAN, %STRING (31) IDEN, %C %INTEGERNAME AFD, FLAG) %ROUTINESPEC DEFINFO(%INTEGER CHAN,%STRINGNAME FILE,%C %INTEGERNAME STATUS) %ROUTINESPEC DESTROY(%STRING (31) FILE, %INTEGERNAME FLAG) %ROUTINESPEC DIRTRAP (%INTEGER CLASS, SUBCLASS) %ROUTINESPEC DISCONNECT(%STRING (31) FILE, %INTEGERNAME FLAG) %ROUTINESPEC ETOI(%INTEGER AD, L) %ROUTINESPEC EXTEND(%RECORD(FDF)%NAME R, %INTEGERNAME F) %ROUTINESPEC FILL(%INTEGER LENGTH, FROM, FILLER) %ROUTINESPEC FINFO(%STRING (31) FILE, %INTEGER MODE, %C %RECORD(FRF)%NAME FR, %INTEGERNAME FLAG) %ROUTINESPEC FPRINTFL(%LONGREAL X, %INTEGER N, T) %ROUTINESPEC FSTATUS(%STRING (31)FILE, %INTEGER ACT, VALUE %C %INTEGERNAME FLAG) %ROUTINESPEC HALT %ROUTINESPEC HASHCOMMAND(%STRING (255) COM, PARAM) %ROUTINESPEC INITJOURNAL %ROUTINESPEC ITOE(%INTEGER AD, L) %ROUTINESPEC KDATE (%INTEGER %NAME D, M, Y, %INTEGER K) %ROUTINESPEC METER(%STRING (255) S) %IF NEWLOADER#0 %THEN %START %ROUTINESPEC MODDIRFILE(%INTEGER EP, %STRING (31) DIRFILE, %C %STRING (32) ENTRY, FILENAME, %C %INTEGER TYPE, DR0, DR1, %INTEGERNAME FLAG) %FINISH %ROUTINESPEC MODPDFILE(%INTEGER EP, %C %STRING (31) PDFILE, %STRING (11) MEMBER, %C %STRING (31) INFILE, %INTEGERNAME FLAG) %ROUTINESPEC MOVE(%INTEGER LENGTH, FROM, TO) %ROUTINESPEC NCODE(%INTEGER S, F, CA) %ROUTINESPEC NDIAG(%INTEGER A, B, C, D) %IF NOTES ON#0 %THEN %START %ROUTINESPEC NOTE (%STRING (255) S) %FINISH %ROUTINESPEC OUTFILE(%STRING (31) FILE, %INTEGER FILESIZE, HOLE, PROT, %C %INTEGERNAME CONAD, FLAG) %ROUTINESPEC PHEX(%INTEGER I) %ROUTINESPEC PRINTMESS(%INTEGER N) %ROUTINESPEC PROMPT(%STRING (255) S) %ROUTINESPEC PSYSMES(%INTEGER ROOT, FLAG) %ROUTINESPEC RDISCON (%STRING (31) FILE, %INTEGER %NAME F) %ROUTINESPEC SENDFILE(%STRING (31) FILE, %C %STRING (16) DEVICE, %STRING (24) NAME, %C %INTEGER COPIES, FORMS, %INTEGERNAME FLAG) %ROUTINESPEC SET IO DEFAULT (%INTEGER %NAME D, %INTEGER I) %ROUTINESPEC SETPAR(%STRING (255) S) %ROUTINESPEC SETUSE(%STRING (31) FILE, %INTEGER MODE, VALUE) %ROUTINESPEC SETWORK(%INTEGERNAME AD, FLAG) %ROUTINESPEC SIGNAL(%INTEGER EP, P1, P2, %INTEGERNAME FLAG) %ROUTINESPEC SSERR(%INTEGER N) %ROUTINESPEC SSMESS(%INTEGER N) %ROUTINESPEC TIDYFILES %ROUTINESPEC TOJOURNAL(%INTEGER A, L) %ROUTINESPEC TRIM(%STRING (31) FILE, %INTEGERNAME FLAG) %ROUTINESPEC UCTRANSLATE (%INTEGER ADDR,L) %ROUTINESPEC USEOPTIONS %ROUTINESPEC ZSTOP(%STRING (255) S) ! %STRINGFNSPEC CONFILE (%INTEGER AD) %STRINGFNSPEC DATE %STRINGFNSPEC DEVNAME(%INTEGER CODE) %STRINGFNSPEC FAILUREMESSAGE(%INTEGER MESS) %STRING(8)%FNSPEC HTOS(%INTEGER N, P) %STRINGFNSPEC ITOS(%INTEGER N) %STRINGFNSPEC NEXT TEMP %STRINGFNSPEC SPAR(%INTEGER N) %STRINGFNSPEC SUBSTRING (%STRINGNAME S, %INTEGER I, J) %STRINGFNSPEC TIME %STRINGFNSPEC UINFS(%INTEGER N) %STRING(8)%FNSPEC UNPACK TIME (%INTEGER P) %STRING(8)%FNSPEC UNPACK DATE(%INTEGER P) ! %STRING(255)%MAPSPEC GCL (%INTEGER %NAME BLC, FLAG) ! !*********************************************************************** !* * !* Own variables * !* * !*********************************************************************** ! ! %OWNBYTEINTEGERARRAY INBUFF (0 : 255) ! %OWNBYTEINTEGERARRAY INTMESS(1 : 9) = %C ! 10,10,'I','N','T',':','A',10,10 ! %OWNBYTEINTEGERARRAY OUTBUFF (0 : 133); !ALLOW ROOM FOR ADDED NL ! %OWNBYTEINTEGERARRAY PARSTRING(0 : 255) ! %OWNBYTEINTEGERARRAY PCHAR (0:PCHARLIM-1) ! %OWNBYTEINTEGERARRAY PINDEX (1 : PRMLIM); !MAX LIKELY NO OF PARAMS ! %OWNBYTEINTEGERARRAY RPS (0:RPLIM) ! ! ! %OWNINTEGER ABGLA; !START OF BGLA ! %OWNINTEGER ACTIVE=0; ! CHECKS FOR LOOPS ! %OWNINTEGER ADCSL ! %OWNINTEGER AIOSTAT ! %OWNINTEGER AITBUFFER ! %OWNINTEGER ALLCOMMAND ! %OWNINTEGER ALLCONNECT = 1; ! Hold off checking until routine can be loaded. ! %OWNINTEGER APAGETURNS ! %OWNINTEGER BCIBLANKS = 0 ! %OWNINTEGER BCIFREE = 0 ! %OWNINTEGER BCIOLDEST = 0 ! %OWNINTEGER BOPMESSSTART ! %OWNINTEGER BOPMESSLEN; !FOR BROADCAST OPER MESSAGES ! %OWNINTEGER BROADCASTFILEBASE ! %OWNINTEGER CALLBCISTARTED ! %OWNINTEGER CKBITS = X'6A202020'; ! Bits set for displacement 1,2,4,6,10,18,26. ! %OWNINTEGER CONTROLMODE ! %OWNINTEGER CURFSYS ! %OWNINTEGER CURLENGTH = 0 ! %OWNINTEGER CURPAR ! %OWNINTEGER CURRKI ! %OWNINTEGER DATAECHO; !FOR INPUT ECHO IN OBEY AND BATCH ! %OWNINTEGER DELIVERYCHANGED ! %OWNINTEGER DEVARRAYBASE ! %OWNINTEGER DFDFINSDC = 0 ! %OWNINTEGER DFDFOUTSDC = 0 ! %OWNINTEGER FDLEVEL ! %OWNINTEGER FEPMODE = OPTEXT ! %OWNINTEGER FIRST; ! 1 while printing first stack frame, ! ! some other value for subsequent frames. ! %OWNINTEGER GCSTARTED {in GETCOMMAND} ! %OWNINTEGER GLOBPTR ! %OWNINTEGER GLSL ! %OWNINTEGER ICRSA = 0 ! %OWNINTEGER ICRSE ! %OWNINTEGER INHIBITMESSAGES ! %OWNINTEGER INHIBITPSYSMES ! %OWNINTEGER INHIBITSPOOLER ! %OWNINTEGER INITFIO1 ! %OWNINTEGER INITFIO2 ! %OWNINTEGER INTINPROGRESS = 1 ! %OWNINTEGER INTQ ! %OWNINTEGER ITINLENGTH ! %OWNINTEGER ITOUTLENGTH ! %OWNINTEGER LASTEP = 0 ! %OWNINTEGER LASTMASTERREADCH ! %OWNINTEGER LASTSWEP = 0 ! %OWNINTEGER LATEST; !IMPOSSIBLE VALUE {What is?} ! %OWNINTEGER LOCATE PRMS ! %OWNINTEGER MAXDEVARRAY ! %OWNINTEGER MTCLOSEMODE = 8; !FULL UNLOAD BY DEFAULT ! %OWNINTEGER OLDPAGETURNS ! %OWNINTEGER OPERNO; ! NO OF OPER IN USE. INITIAL VALUE MUST BE VALID FOR 'OR'ING FOR DPON. ! %OWNINTEGER OPMODE = OPTEXT ! %OWNINTEGER PCOUNT ! %OWNINTEGER PMAP ! %OWNINTEGER QPARMF ! %OWNINTEGER RCHLIM = 0 ! %OWNINTEGER RCLB = -1 ! %OWNINTEGER RCLF = 0 ! %OWNINTEGER RPTR = 0 ! %OWNINTEGER RRCBASE ! %OWNINTEGER RRCTOP ! %OWNINTEGER RSYMLIM = 0 ! %OWNINTEGER SAVEIDPOINTER ! %OWNINTEGER SEQ = 0 {in NEXTTEMP} ! %OWNINTEGER SESSKIC ! %OWNINTEGER SSADIRINF ! %OWNINTEGER SSARRAYDIAG ! %OWNINTEGER SSDATAECHO ! %OWNINTEGER SSINITWORKSIZE ! %OWNINTEGER SSINVOCATION ! %OWNINTEGER SSITWIDTH ! %OWNINTEGER SSJOURNAL ! %OWNINTEGER SSLASTDFN; ! Last non-zero director error number translated by DIRTOSS. ! %OWNINTEGER SSLDELIM ! %OWNINTEGER SSMONITOR ! %OWNINTEGER SSNOBLANKLINES; !WHEN SET TO 1 SUPPRESS BLANK LINES ON I.T. ! %OWNINTEGER SSNOTE ! %OWNINTEGER SSOPERNO; !NO OF OPER STARTED FROM ! %OWNINTEGER SSOWNFSYS; !FSYS FOR THIS USER ! %OWNINTEGER SSRDELIM ! %OWNINTEGER SSREASON; !REASON FOR STARTING ! ! 0=INTERACTIVE ! !1=STARTED FROM OPER. 2=BATCH ! %OWNINTEGER SSTERMINALTYPE ! %OWNINTEGER SSTTHIDE = 0, SSTTACT = 0, SSTTKN = 0; ! Used for INT:K control - must stay ! ! together and in this order. ! %OWNINTEGER STARTSECS ! %OWNINTEGER TIDYFSTARTED=0 ! %OWNINTEGER TOPFD = 1; ! HIGHEST FD USED SO FAR THIS SESSION. ! %OWNINTEGER TTYPE ! %OWNINTEGER UNASSPATTERN = X'81' ! %OWNINTEGER USEOPTSTARTED=0 ! ! ! %OWNINTEGERARRAY GL IOCP PARM (1:3) ! %OWNINTEGERARRAY GLOBAD(0:20) ! %OWNINTEGERARRAY PAPTR (1:PRMLIM) ! %OWNINTEGERARRAY SAVEIDATA (-2:20,0:3) ! %OWNINTEGERARRAY SSFDMAP (1:99) ! ! ! %OWNINTEGERNAME ICREVS ! %OWNINTEGERNAME KINSTRS ! %OWNINTEGERNAME PREVIC ! %OWNINTEGERNAME RCODE; !POINTS TO COMREG(24) RETURN CODE ! ! ! %OWNLONGINTEGER SSINITPARMS; !INITIAL PARMS OPTION ! ! ! %OWNLONGREAL LASTCPUTIME = -1000000; ! Ensures X27{DSETIC} called first time. { in BCI} ! %OWNLONGREAL OLDCPUTIME ! ! ! %OWNRECORD(CONFF)%ARRAY CONF (0 : MAXCONF) ! %OWNRECORD(FDF)%ARRAY FD (1 : MAXFD) ! %OWNRECORD(SIGDATAF)%ARRAY SIGDATA (1 : MAXSIGLEVEL) ! ! ! %OWNRECORD(FDF)%NAME INF ! %OWNRECORD(IOSTATF)%NAME IOSTAT; !STATUS OF INPUT FROM FEP ! %OWNRECORD(ITF)%NAME IT ! %OWNRECORD(FDF)%NAME OUTF ! ! ! %OWNSTRING(1) ACTD = "0" ! %OWNSTRING(31) BASEFILE ! %OWNSTRING(8) BOUTPUTDEVICE ! %OWNSTRING(255) CLICOMM ! %OWNSTRING(255) CLIPARM ! %OWNSTRING(255) CSL; ! CONTROL STREAM LINE ! %OWNSTRING(6) CURFOWNER ! %OWNSTRING(18) CURFILE ! %OWNSTRING(11) CURFNAME ! %OWNSTRING(11) CURMEMBER ! %OWNSTRING(255) EP6S; !STRING FOR ENTRY POINT 6 - ! ! COMPILER INPUT ! %OWNSTRING(11) HOLDAVD ! %OWNSTRING(50) LASTNAME="" ! %OWNSTRING(1) NULP = "" ! %OWNSTRING(31) PDPREFIX="" ! %OWNSTRING(MAXPROMPTSIZE) PROMPTTEXT ! %OWNSTRING(255) RCLH ! %OWNSTRING(18) SESSMONFILE ! %OWNSTRING(11) SSCFAULTS; !COMPILER FAULTS OPTION ! %OWNSTRING(8) SSSTARTTIME ! %OWNSTRING(3) SSSUFFIX; !ADDED TO NAMES OF TEMP FILES ! %OWNSTRING(31) STARTFILE ! ! !*********************************************************************** !* * !* Extrinsic variables * !* * !*********************************************************************** ! %IF NEWLOADER#0 %THEN %START ! %EXTRINSICINTEGER LOADINPROGRESS ! %EXTRINSICINTEGER LOADLEVEL ! %EXTRINSICINTEGER MONFILEAD ! %EXTRINSICINTEGER MONFILETOP ! %EXTRINSICINTEGER NOWARNINGS {1 if no loader warning messages to be generated} ! %EXTRINSICINTEGER PERMISTK ! %EXTRINSICINTEGER USTB ! ! %EXTRINSICRECORD(LLINFOF)%ARRAY LLINFO(-1:31) {perm ISTK field can be updated by OPTION} ! ! %EXTRINSICSTRING(31) MONFILE %FINISH ! !*********************************************************************** !* * !* External variables * !* * !*********************************************************************** ! ! %EXTERNALINTEGER DIRDISCON = 1; !SET TO 1 WHEN DIRECTORY DISCONNECTED ! %EXTERNALINTEGER INDEFAULT ! %EXTERNALINTEGER INITSTACKSIZE ! %EXTERNALINTEGER LOADMONITOR ! %EXTERNALINTEGER OUTDEFAULT %IF FUNDS ON#0 %THEN %START ! %EXTERNALINTEGER SCARCITYFOUND; ! **** Used by SEPRTNS but not by LOAD**** %FINISH ! %EXTERNALINTEGER SSADEFOPT; !ADDRESS OF DEFAULT OPTION FILE IN BASEFILE %IF NEWLOADER=0 %THEN %START ! %EXTERNALINTEGER SSASESSDIR %FINISH ! %EXTERNALINTEGER SSASTACKSIZE %IF NEWLOADER=0 %THEN %START ! %EXTERNALINTEGER SSATEMPDIR; !ADDRESS OF TEMPORARY DIRECTORY %FINISH ! %EXTERNALINTEGER SSAUXDR0 ! %EXTERNALINTEGER SSAUXDR1 ! %EXTERNALINTEGER SSCURAUX ! %EXTERNALINTEGER SSCURBGLA; !CURRENT TOP OF BGLA %EXTERNALINTEGER SSDATELINKED; !THIS GETS FILLED IN BY THE !COMMAND 'MAKEBASEFILE' WITH THE LINK DATE OF THE CURRENT !SYSTEM CALL TABLE %IF NEWLOADER#0 %THEN %START ! %EXTERNALINTEGER SSDIRAD %FINISH ! %EXTERNALINTEGER SSINHIBIT, SSINTCOUNT; !THESE TWO MUST STAY TOGETHER ! %EXTERNALINTEGER SSMAXAUX ! %EXTERNALINTEGER SSMAXBGLA; !LAST BYTE OF BGLA ! %EXTERNALINTEGER SSMAXFSIZE; !MAXIMUM FILE SIZE ALLOWED ! %EXTERNALINTEGER SSOPENUSED %IF NEWLOADER=0 %THEN %START ! %EXTERNALINTEGER SSSCCOUNT ! %EXTERNALINTEGER SSSCTABLE; !ADDRESS OF SCTABLE ! %EXTERNALINTEGER SSUSTACKUSED %FINISH ! %EXTERNALINTEGER SSUSTACKSIZE ! %EXTERNALINTEGER STOPPING ! %EXTERNALINTEGER TEMPAVDSET; !USED BY PLU PACKAGES ! ! %EXTERNALINTEGERARRAY SSCOMREG(0:60) ! ! %EXTERNALSTRING(11) AVD; ! Active directory. **** N.B. Also used by SEPRTNS **** ! %EXTERNALSTRING(31) OPTIONSFILE = "SS#OPT" ! %EXTERNALSTRING(40) SSFNAME; !NAME FOR PSYSMES ! %EXTERNALSTRING(6) SSOWNER ! !*********************************************************************** !* * !* End of declarations * !* * !*********************************************************************** ! !* ! - END OF GLOBAL TEXT ] ! %SYSTEM %ROUTINE SETSESSIONMONITOR (%STRING (18) FILE) SSOWN_SESSMONFILE <- FILE %END; ! of SETSESSIONMONITOR. ! ! [ START OF HASH CODE - ! %IF STUDENTSS#0 %THEN %START %ROUTINE CXDUMP (%INTEGER START, N, DF) %END %SYSTEM %ROUTINE NCODE (%INTEGER START, FINISH, CA) %END %SYSTEM %ROUTINE DUMP (%INTEGER START, LEN) %END %SYSTEM %ROUTINE HASHCOMMAND (%STRING (255) COM, PAR) %END %FINISH %ELSE %START %ROUTINE CXDUMP(%INTEGER START, N, DF) ! DF=1 for a character dump, DF=2 for a hex dump, DF=3 for both. %STRING (64) WKS %INTEGER I, J, PERLINE, COUNT, BYTES, STAGE, FILLER %IF DF=1 %THEN %START %IF SSOWN_SSITWIDTH > 80 %THEN PERLINE = 64 %ELSE PERLINE = 32 BYTES = PERLINE FILLER = ' ' %FINISH %ELSE %IF DF=2 %THEN %START %IF SSOWN_SSITWIDTH > 90 %THEN PERLINE = 8 %ELSE PERLINE = 4 BYTES = PERLINE*4 ! FILLER not used. %FINISH %ELSE %START PERLINE = 8 BYTES = 32 FILLER = '_' %FINISH ! ROUTINE ACCEPTS PARAMS AS START,N OR AS START,LENGTH %IF N !! PRINTSTRING(" INACCESSIBLE AREA TO BE DUMPED - ") PHEX(START) PRINTSTRING(" TO ") PHEX(N) %RETURN OKADDR: LENGTH (WKS) = BYTES COUNT = 0 %CYCLE NEWLINE %IF COUNT # 0 %THEN %START %IF DF=3 %THEN WRITE (COUNT,50) %ELSE WRITE (COUNT,16) PRINTSTRING(" line(s) as above") COUNT = 0 %FINISH %ELSE %START STAGE = DF %CYCLE %IF DF=3 %THEN PRINT SYMBOL ('*') %IF STAGE>=3 %THEN %START FILL (BYTES,ADDR(WKS)+1,FILLER) %FOR I=BYTES,-1,1 %CYCLE J = BYTE INTEGER (START+I-1) %IF 32<=J<127 %THEN CHARNO (WKS,I) = J %REPEAT PRINT STRING (WKS) %FINISH %ELSE %START %IF DF=3 %THEN SPACES (2) PRINT SYMBOL ('(') PHEX(START) PRINTSTRING(") ") %FINISH STAGE = 5 - STAGE %REPEAT %UNTIL STAGE&1#0 %IF DF=1 %THEN START = START + BYTES %ELSE %START %FOR I=PERLINE,-1,1 %CYCLE PHEX(INTEGER(START)) SPACES (DF-1) START = START+4 %EXIT %IF START>N %REPEAT %FINISH %WHILE START+BYTES<=N %AND STOREMATCH (BYTES, START, START-BYTES)#0 %CYCLE COUNT = COUNT+1 START = START+BYTES %REPEAT %FINISH ! %IF DF=2 %THEN NEWLINE %REPEAT %UNTIL START>N %IF DF#2 %THEN NEWLINE %END; !OF CXDUMP ! %SYSTEMROUTINE DUMP(%INTEGER START, FINISH) CXDUMP (START, FINISH, 3) %END; ! OF DUMP !* 31/07/81 !* !********************************************* !* * !* THIS ROUTINE RECODES FROM HEX INTO NEW * !* RANGE ASSEMBLY CODE. * !* * !********************************************* %SYSTEMROUTINE NCODE(%INTEGER START, FINISH, CA) %ROUTINESPEC DCD1; ! PRIMARY DECODE %ROUTINESPEC DCD2; ! SECONDARY DECODE %ROUTINESPEC DCD3; ! TERTIARY DECODE %ROUTINESPEC DECOMPILE %STRING (60) S %CONSTSTRING (4) %ARRAY OPS(0 : 127) = %C " ","JCC ","JAT ","JAF ","TEST"," ","CLR*","SET*", "VAL ","CYD ","INCA","MODD","PRCL","J ","JLK ","CALL", "ADB ","SBB ","DEBJ","CPB ","SIG ","MYB ","VMY ","CPIB", "LCT ","MPSR","CPSR","STCT","EXIT","ESEX","OUT ","ACT ", "SL ","SLSS","SLSD","SLSQ","ST ","STUH","STXN","IDLE", "SLD ","SLB ","TDEC","INCT","STD ","STB ","STLN","STSF", "L ","LSS ","LSD ","LSQ ","RRTC","LUH ","RALN","ASF ", "LDRL","LDA ","LDTB","LDB ","LD ","LB ","LLN ","LXN ", "TCH ","ANDS","ORS ","NEQS","EXPA","AND ","OR ","NEQ ", "PK ","INS ","SUPK"," ","COMA","DDV ","DRDV","DMDV", "SWEQ","SWNE","CPS ","TTR ","FLT ","IDV ","IRDV","IMDV", "MVL ","MV ","CHOV"," ","FIX ","RDV ","RRDV","RDVD", "UAD ","USB ","URSB","UCP ","USH ","ROT ","SHS ","SHZ ", "DAD ","DSB ","DRSB","DCP ","DSH ","DMY ","DMYD","CBIN", "IAD ","ISB ","IRSB","ICP ","ISH ","IMY ","IMYD","CDEC", "RAD ","RSB ","RRSB","RCP ","RSC ","RMY ","RMYD"," " %INTEGER I, K, KP, KPP, N, OPCODE %INTEGER INSL, DEC,LITERAL,JUMP %INTEGER H, Q, INS, KPPP %INTEGER PC %INTEGER SIGN,ILLEGAL %INTEGER ALL ! ! **** **** HX is not needed with the machine code version of PHX **** **** ! %CONSTSTRING(1)%ARRAY HX(0 : 15) = %C ! "0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F" !* !************************************* !* ! %ROUTINE PHX(%INTEGER N,PLACES,SIGN) ! %INTEGER SYM ,LEADING ZEROES ! %IF 0<=N<=9 %START ! %IF SIGN#0 %THEN S=S." -" %ELSE S=S." " ! S=S.ITOS(N) ! %RETURN ! %FINISH ! %IF SIGN#0 %THEN S=S."-X'" %ELSE S=S." X'" ! LEADING ZEROES=0 ! %WHILE PLACES>0 %CYCLE ! PLACES=PLACES-1 ! SYM=(N>>((PLACES)*4))&15 ! S=S.HX(SYM) %UNLESS (SYM=0 %AND LEADING ZEROES=0) ! LEADING ZEROES=1 %IF SYM#0 %OR PLACES=1 ! %REPEAT ! S=S."'" ! %END ! ! **** **** MACHINE CODE VERSION OF PHX FOLLOWS: **** **** ! %ROUTINE PHX(%INTEGER N,PLACES,SIGN) %INTEGER P, L %LONG %INTEGER RW, DH %IF 0<=N<=9 %START %IF SIGN#0 %THEN S=S." -" %ELSE S=S." " LENGTH (S) = LENGTH (S) + 1 CHARNO (S, LENGTH(S)) = N + '0' %RETURN %FINISH L = LENGTH(S) +4 S = S." X''''''''''" %IF SIGN#0 %THEN CHARNO(S,L-3) = '-' %IF PLACES<=0 %THEN P = 0 %ELSE %START %IF PLACES<8 %THEN N = (N & (\((-1)<<(PLACES<<2)))) *LSS_N *LUH_0 *FLT_0 *STUH_RW %IF N=0 %THEN P = 0 %ELSE P = BYTE INTEGER (ADDR(RW)) - 64 DH = (LENGTHENI(X'18000000'!P)<<32) ! (ADDR(S)+L) LENGTH (S) = LENGTH (S) + P *LD_DH *LSD_RW *USH_8 *UCP_0 *SUPK_%L=%DR *LSS_HEX+4 *ISB_240 *LUH_X'18000100' *LD_DH *TTR_%L=%DR %FINISH LENGTH (S) = L + P %END !* !* PC = 0 %IF (START!!FINISH)>>18#0 %THEN %START I = START START = (FINISH>>18)<<18; ! FROM START OF SEGMENT CA = CA + I - START %FINISH ALL = FINISH-START !! !! VALIDATE CODE AREA TO BE DUMPED !! I = X'18000000'!ALL *LDTB_I *LDA_START *VAL_(%LNB+1) *JCC_3, !! %WHILE PC < ALL %CYCLE NEWLINE ILLEGAL=0 H = 0 LITERAL=0 JUMP=0 DEC = 0 MOVE(4,START+PC,ADDR(INS)) OPCODE = INS>>25<<1 %IF OPCODE=0 %OR OPCODE=254 %OR 8<=OPCODE<=14 %THEN %START INSL = 16 ILLEGAL = 1 %FINISH %ELSE %IF 2<=OPCODE<=8 %C %THEN DCD3 %C %ELSE %IF X'8'<=OPCODE>>4<=X'B' %AND OPCODE&X'F'<7 %C %THEN DCD2 %C %ELSE DCD1 JUMP=1 %IF X'1A'<=OPCODE<=X'1E' %OR OPCODE=X'24' DECOMPILE PC = PC+(INSL>>3) %REPEAT NEWLINE %RETURN BADADDR: PRINTSTRING(" INACCESSIBLE CODE AREA PASSED TO NCODE FOR PRINTING - ") PHEX(START) PRINTSTRING(" TO ") PHEX(FINISH) NEWLINES(2) !*********************************************************************** !* ROUTINE TO INTERPRET PRIMARY FORMAT INSTRUCTION %ROUTINE DCD1; ! PRIMARY DECODE DEC = 1 K = INS<<7>>30 N = INS<<9>>25 %UNLESS K = 3 %THEN %START LITERAL=1 %IF K=0 INSL = 16 %RETURN %FINISH KP = INS<<9>>30 KPP = INS<<11>>29 LITERAL=1 %IF KP=0 %AND KPP=0 %IF KPP < 6 %THEN INSL = 32 %AND N = INS&X'3FFFF' %C %ELSE %START %UNLESS INS&X'30000'=0 %THEN ILLEGAL=1 ;! RES. FIELD NON ZERO INSL = 16 %FINISH %END !*********************************************************************** !* ROUTINE TO INTERPRET SECONDARY FORMAT INSTRUCTIONS %ROUTINE DCD2; ! SECONDARY DECODE DEC=2 H = INS<<7>>31 Q = INS<<8>>31 N = INS<<9>>25 %IF Q = 1 %THEN INSL = 32 %ELSE INSL = 16 %END !*********************************************************************** !* ROUTINE TO INTERPRET TERTIARY FORMAT INSTRUCTIONS %ROUTINE DCD3; ! TERTIARY DECODE DEC = 3 KPPP = INS<<11>>29 %IF KPPP > 5 %THEN INSL = 16 %ELSE INSL = 32 N = INS&X'3FFFF' %IF INSL=16 %AND (INS>>16)&3#0 %THEN ILLEGAL=1 ;! 2 LS BITS # 0 %END !*********************************************************************** !* ROUTINE TO INTERPRET CURRENT INSTRUCTION %ROUTINE DECOMPILE %INTEGER I, J %CONSTSTRING (12) %ARRAY PREFPOP(0 : 31) = %C "","*** ","(LNB","(XNB", "(PC","(CTB","TOS ","B ", "(DR","*** ","(DR+(LNB","(DR+(XNB", "(DR+(PC","(DR+(CTB","(DR+TOS) ","(B", "IS LOC N ","*** ","((LNB","((XNB", "((PC","((CTB","(TOS) ","(DR) ", "IS LOC B ","*** ","((LNB","((XNB", "((PC","((CTB","(TOS+B) ","(DR+B) " %CONSTSTRING(8) %ARRAY SUFPOP(0:31) = %C "","",") ",") ", ") ",") ","","", ") ","",")) ",")) ", ")) ",")) ","",")* ", "","",")) ",")) ", ")) ",")) ","","", "","",")+B) ",")+B) ", ")+B) ",")+B) ","","" %CONSTSTRING (8) %ARRAY TOP(0 : 7) = %C "","(DR+","(LNB+","(XNB+","(PC+","(CTB+","(DR) ","(DR+B) " %CONSTSTRING(7) %ARRAY JAS(0:15)= %C "FACC=0","FACC>0","FACC<0"," ? ","ACC=0","ACC>0","ACC<0", " ? ","DACC=0","DACC>0","DACC<0","DRLEN=0", " B=0 "," B>0 "," B<0 ","OV SET" !%CONSTSTRING(7) %ARRAY BINS(0:15)= %C !"B'0000'","B'0001'","B'0010'","B'0011'","B'0100'", !"B'0101'","B'0110'","B'0111'","B'1000'","B'1001'", !"B'1010'","B'1011'","B'1100'","B'1101'", !"B'1110'","B'1111'" !* SIGN=0 J = (PC + CA)&X'3FFFF' %FOR I=4,-1,0 %CYCLE PRINTSYMBOL(HEX((J>>(I<<2))&15)) %REPEAT SPACES(4) ! %FOR I=3,-1,0 %CYCLE ! J=(INS>>(8*I))&X'FF' ! %IF 32<=J<=123 %THEN PRINTSYMBOL(J) %ELSE PRINTSYMBOL('.') ! %EXIT %IF I=2 %AND INSL=16 ! %REPEAT %IF INSL = 16 %START SPACES(6) %FOR J=28,-4,16 %CYCLE PRINTSYMBOL(HEX((INS>>J)&15)) %REPEAT %FINISH %ELSE %START SPACES(2) PHEX(INS) %FINISH S=" " -> END %IF ILLEGAL#0 %OR OPS(OPCODE//2)=" " %OR INS=X'81818181' S=S.OPS((OPCODE>>1))." " %IF DEC = 1 %THEN %START; ! PRIMARY FORMAT %IF OPCODE=X'3A' %C %OR OPCODE=X'4E' %C %OR OPCODE=X'12' %C %OR OPCODE=X'EE' %C %OR OPCODE=X'DE' %C %THEN -> END; ! NO OPERANDS %IF LITERAL=0 %THEN S=S." " %IF K<3 %THEN %START SIGN = 0 %IF K=1 %THEN S = S."(LNB +" %C %ELSE %IF K=2 %THEN S = S."((LNB +" %C %ELSE %IF K=0 %AND N>>6=1 %THEN %START N = -(N!X'FFFFFF80') SIGN = 1 %FINISH PHX (N&X'7F',2,SIGN) %UNLESS JUMP=1 %AND LITERAL=1 %IF K=1 %THEN S=S.") " %C %ELSE %IF K=2 %THEN S=S.")) " %FINISH %ELSE %START S = S.PREFPOP(KP*8+KPP) %IF INSL=32 %THEN %START SIGN = 0 %IF (KP=0 %AND KPP=0) %OR KPP=4 %THEN %START %IF (N>>16)>1 %THEN %START N = -(N!X'FFFC0000') SIGN = 1 %FINISH %IF KPP=4 %THEN %START %IF SIGN=1 %THEN S=S." -" %ELSE %IF SIGN=0 %THEN S=S." +" %FINISH %FINISH %ELSE S=S." +" PHX(N&X'3FFFF',5,0) %UNLESS LITERAL#0 %AND JUMP#0 S=S.SUFPOP(KP*8+KPP) %FINISH N=-N %IF SIGN#0 %IF KP=0 %AND KPP=4 %THEN %START S=S."[AT" PHX((PC+CA+(N*2))&X'3FFFF',5,0) S=S."]" %FINISH %FINISH %IF LITERAL#0 %AND IMOD(N)>9 %AND JUMP=0 %START S=S." " %UNTIL LENGTH(S)>=27 S=S."[" %IF SIGN#0 %THEN S=S."-" S=S.ITOS(N)."]" %FINISH %IF LITERAL#0 %AND JUMP#0 %START N=-N %IF SIGN#0 %AND N>0 S=S." TO " PHX((PC+CA+(N*2))&X'3FFFF',5,0) %FINISH %FINISH %ELSE %IF DEC=2 %THEN %START; ! SECONDARY FORMAT PHX((INS>>16)&X'7F',2,0) %IF H=0 %IF INSL=32 %THEN %START S = S." MASK=X'".TOSTRING(HEX((INS>>8)&15))."' LIT.=" PHX (INS,2,0) %FINISH %FINISH %ELSE %IF DEC=3 %THEN %START; ! TERTIARY FORMAT S=S.TOP(KPPP) %IF INSL = 32 %THEN %START SIGN=0 %IF (KPPP=0 %OR KPPP=4) %AND (N>>16)>1 %THEN %START N = -(N!X'FFFC0000') SIGN = 1 %FINISH %IF KPPP#0 %THEN PHX(N&X'3FFFF',5,SIGN) %ELSE %START N = -N %IF SIGN#0 S = S." TO " PHX((PC+CA+(N*2))&X'3FFFF',5,0) %FINISH %IF 1<=KPPP<=5 %THEN S=S.")" %IF 4<=OPCODE<=6 %C %THEN S=S." ON ".JAS((INS>>21)&15) %C %ELSE S=S." MASK=X'".TOSTRING(HEX((INS>>21)&15))."'" %FINISH %FINISH END: PRINTSTRING(S) %END %END %SYSTEMROUTINE HASHCOMMAND(%STRING (255) COMMAND, PARAM) %RECORD(FRF) FR %STRING (31) S1, S2, OUTF %INTEGER I, FLAG, LNB %CONSTINTEGER MAXCOM = 27 %CONSTSTRING (8) %ARRAY COM(1 : MAXCOM) = %C "SNAP","HEX","DEC","PCOM","SCOM","SBYTE","SWORD","SSTRING", "SETBASE","CONNECT", "SNAPCH","SSTOP","N","SNAPCODE","LISTFD", "MONITOR","PVM","DUMPFILE","REGS","MON","QUIT","PMESS", "DUMP","ACR","MONLOAD","NOTE","LQUIET" %SWITCH CSW(1 : MAXCOM) %ROUTINE PVM !PRINT VM TABLE %INTEGER I, SEG %RECORD(CONFF)%NAME CUR %INTEGERARRAY POINT(LVM : UVM); !TO HOLD POINTERS TO SSOWN_CONF %FOR I=LVM,1,UVM %CYCLE POINT(I) = -1 %REPEAT %FOR I=0,1,MAXCONF %CYCLE SEG = SSOWN_CONF(I)_CONAD>>SEGSHIFT %IF LVM <= SEG <= UVM %THEN POINT(SEG) = I %REPEAT PRINTSTRING(" SEG HOLE CONAD MODE USE K FSYS FILE ") %FOR SEG=LVM,1,UVM %CYCLE %IF POINT(SEG)>=0 %START CUR == SSOWN_CONF(POINT(SEG)) WRITE(SEG,3) WRITE(CUR_HOLE>>SEGSHIFT,4) SPACES(2) PHEX(SEG<<18) WRITE(CUR_MODE&X'FFFFFDFF',5); ! discard "permanent connection" bit. WRITE(CUR_USE&X'3FFFFFFF',4) %IF CUR_USE<0 %THEN PRINT SYMBOL ('*') %ELSE SPACE WRITE(CUR_SIZE>>KSHIFT,4); !SIZE IN KBYTES WRITE(CUR_FSYS,5) SPACES(3) PRINTSTRING(CUR_FILE) NEWLINE %FINISH %REPEAT NEWLINES(2) %END; !OF PVM %ROUTINE GETNUM(%INTEGERNAME I, FLAG) %INTEGER J, K, L, SIGN %STRING (80) S S = SPAR(0) -> ERR %IF S = ""; !NO PARAM L = LENGTH(S) I = 0 J = CHARNO(S,1) %IF J='X' %THEN %START %IF L>9 %THEN -> ERR %FOR K=2,1,L %CYCLE J = CHARNO(S,K) - '0' %IF J>9 %THEN J = J + '0' - 'A' + 10 %UNLESS 0<=J<=15 %THEN -> ERR I = (I<<4)!J %REPEAT %FINISH %ELSE %START %IF J='-' %THEN %START SIGN = 13 K = 2 %FINISH %ELSE %START SIGN = 15 K = 1 %FINISH L = L - K + 1 %IF L>0 %THEN %START %IF L>10 %THEN -> ERR K = ADDR (S) + K *LDTB_X'18000000' *LDB_L *LDA_K *STD_%TOS *LSS_ACCEPT DIGITS+4 *LUH_256 *TCH_%L=%DR *JCC_7, *LD_%TOS *LB_SIGN *LSQ_%B *PK_%L=%DR *CBIN_0 *ST_%TOS *USH_32 *ISH_-32 *UCP_%TOS *JCC_7, *STUH_%B *ST_(I) %FINISH %FINISH FLAG = 0 %RETURN ERR: FLAG = 1 %END; ! GETNUM ! %ROUTINE REGS %INTEGER P, FLAG %ROUTINE OUTLINE(%STRING (8) NAME, %INTEGER I) NEWLINE PRINTSTRING(NAME.": ") PHEX(SSOWN_SAVEIDATA(I,P)) %END; !OF OUTLINE NEWLINE P = 0 %IF PARAM # "" %THEN GETNUM(P,FLAG) %UNLESS -3 <= P <= 0 %THEN P = 0 P = (SSOWN_SAVEIDPOINTER+P-1)&3 %IF SSOWN_SAVEIDATA(18,P) = 0 %THEN PRINTSTRING("NO INFO. ") %C %AND %RETURN PRINTSTRING("CONTINGENCY AT ".STRING(ADDR(SSOWN_SAVEIDATA(18,P)))) NEWLINE OUTLINE("CLASS",-2) OUTLINE("SUBCLASS",-1) OUTLINE("LNB",0) OUTLINE("PSR",1) OUTLINE("PC",2) OUTLINE("SSR",3) OUTLINE("SF",4) OUTLINE("IT",5) OUTLINE("IC",6) OUTLINE("CTB",7) OUTLINE("XNB",8) OUTLINE("B",9) OUTLINE("DR",10) SPACE PHEX(SSOWN_SAVEIDATA(11,P)) OUTLINE("ACC",12) SPACE PHEX(SSOWN_SAVEIDATA(13,P)) SPACE PHEX(SSOWN_SAVEIDATA(14,P)) SPACE PHEX(SSOWN_SAVEIDATA(15,P)) OUTLINE("FPC",16) OUTLINE("SPARE",17) NEWLINE %END; !OF REGS ! %ROUTINE OUTHEX %INTEGER I GETNUM(I,FLAG) %RETURN %IF FLAG # 0 PRINTSTRING("X=") PHEX(I); NEWLINE %END; !OF OUTHEX %ROUTINE DEC %INTEGER I GETNUM(I,FLAG) %RETURN %IF FLAG # 0 PRINTSTRING("N=") WRITE(I,1); NEWLINE %END; !OF DEC %ROUTINE PRINTFD %INTEGER AFD %RECORD(FDF)%NAME F %ROUTINE OUTLINE(%STRING (12) S, %INTEGER N) %IF N = 0 %THEN %RETURN PRINTSTRING(S.":") SPACES(13-LENGTH(S)) PHEX(N) SPACES(2) WRITE(N,8) NEWLINE %END; !OF OUTLINE GETNUM(AFD,FLAG) %RETURN %UNLESS FLAG = 0 %AND 1 <= AFD <= 99 AFD = SSOWN_SSFDMAP(AFD) %IF AFD # 0 %THEN %START F == RECORD(AFD) OUTLINE("LINK",F_LINK) OUTLINE("DSNUM",F_DSNUM) OUTLINE("STATUS",F_STATUS) OUTLINE("ACCESS ROUTE",F_ACCESSROUTE) OUTLINE("VALID ACTION",F_VALIDACTION) OUTLINE("CUR STATE",F_CUR STATE) OUTLINE("MODE OF USE",F_MODEOFUSE) OUTLINE("MODE",F_MODE) OUTLINE("FILE ORG",F_FILEORG) OUTLINE("DEV CODE",F_DEVCODE) OUTLINE("RECTYPE",F_RECTYPE) OUTLINE("FLAGS",F_FLAGS) OUTLINE("ASVAR",F_ASVAR) OUTLINE("AREC",F_AREC) OUTLINE("RECSIZE",F_RECSIZE) OUTLINE("MINREC",F_MINREC) OUTLINE("MAXREC",F_MAXREC) OUTLINE("MAXSIZE",F_MAXSIZE) OUTLINE("LASTREC",F_LASTREC) OUTLINE("CONAD",F_CONAD) OUTLINE("CURREC",F_CURREC) OUTLINE("CUR",F_CUR) OUTLINE("END",F_END) OUTLINE("TRANSFERS",F_TRANSFERS) OUTLINE("DARECNUM",F_DARECNUM) OUTLINE("CURSIZE",F_CURSIZE) OUTLINE("DATASTART",F_DATASTART) PRINTSTRING("IDEN: ".F_IDEN) NEWLINE %FINISH %END; !OF PRINTFD %ROUTINE PCOM %INTEGER I GETNUM(I,FLAG) %RETURN %IF FLAG # 0 PRINTSTRING("SSCOMREG(") WRITE(I,1); PRINTSTRING(")=") I = SSOWN_SSCOMREG(I); PHEX(I); NEWLINE %END; !OF PCOM %ROUTINE SCOM %INTEGER I, J GETNUM(I,FLAG) %RETURN %IF FLAG # 0 GETNUM(J,FLAG) %IF FLAG # 0 %THEN %RETURN SSOWN_SSCOMREG(I) = J %END; ! SCOM %ROUTINE SNAP(%INTEGER MODE) !MODE=2 FOR SNAP MODE=1 FOR SNAPCH %INTEGER START, N GETNUM(START,FLAG) %RETURN %IF FLAG # 0 GETNUM(N,FLAG) %RETURN %IF FLAG # 0 CXDUMP (START, N, MODE) %END; !OF SNAP ! %ROUTINE OUTDUMP ! #DUMP ADDR,LEN,OUT %INTEGER START, LEN, AFD %STRING (31) OUT GETNUM(START,FLAG) %RETURN %IF FLAG # 0 GETNUM(LEN,FLAG) %RETURN %IF FLAG # 0 OUT = SPAR(3) %IF OUT = "" %THEN OUT = ".LP" DEFINE(82,OUT,AFD,FLAG) SELECTOUTPUT(82) CXDUMP(START,LEN,3) SELECTOUTPUT(0) %END; !OF OUTDUMP %ROUTINE SNC {SNAPCODE} %STRING (31) OUT %INTEGER START, FINISH, N, AFD, FLAG GETNUM(START,FLAG) %RETURN %IF FLAG # 0 GETNUM(N,FLAG) %RETURN %IF FLAG # 0 OUT = SPAR(3) %IF OUT#"" %START DEFINE(82,OUT,AFD,FLAG) %IF FLAG = 0 %THEN SELECTOUTPUT(82) %FINISH START = START&X'FFFFFFFC' FINISH = START+N NCODE(START,FINISH,START) SELECTOUTPUT(0) %END; !OF SNAPCODE %ROUTINE SBYTE %INTEGER I, J GETNUM(I,FLAG) %RETURN %IF FLAG # 0 GETNUM(J,FLAG) %RETURN %IF FLAG # 0 BYTEINTEGER(I) = J %END; ! SBYTE %ROUTINE SWORD %INTEGER I, J GETNUM(I,FLAG) %RETURN %IF FLAG # 0 GETNUM(J,FLAG) %RETURN %IF FLAG # 0 %IF I&3 # 0 %THEN %START PRINTSTRING(" WORD ALIGN IT! ") %RETURN %FINISH INTEGER(I) = J %END; ! SWORD %ROUTINE SSTRING %INTEGER I %STRING (63) S GETNUM(I,FLAG) %RETURN %IF FLAG # 0 S = SPAR(2) ! MUST BE IN DOUBLE QUOTES - REMOVE THEM %RETURN %UNLESS LENGTH(S)>=2 %AND CHARNO(S,1)='"'=CHARNO(S,LENGTH(S)) BYTE INTEGER (I) = LENGTH (S) - 2 MOVE (LENGTH(S) - 2, ADDR (S) + 2, I + 1) %END; ! SSTRING %ROUTINE CON %STRING(5)SMODE %STRING (63) S %RECORD (RF)R %INTEGER I, J I = 0 L2: S = SPAR(0) %RETURN %IF S = "" CONNECT(S,3,0,0,R,J) %IF J = 0 %THEN SMODE="WRITE" %AND -> L1 CONNECT(S,0,0,0,R,J) %IF J # 0 %THEN %START PSYSMES(8,J) %FINISH %ELSE %START SMODE="READ" L1: I = R_CONAD PRINTSTRING(S." CONNECTED IN ".SMODE." MODE AT ") PHEX(I); NEWLINE %FINISH -> L2 %END; ! CON %ROUTINE DUMPFILE %RECORD(FDF)%NAME F %RECORD (RF)R %STRING (32) FILE, OUT %INTEGER OFFSET, LEN, AFD, DUMMY, J ! #DUMPFILE FILE,OFFSET,LENGTH,OUT FILE = SPAR(0) GETNUM(OFFSET,FLAG) %RETURN %IF FLAG # 0 %IF OFFSET < 0 %THEN FLAG = 1 %AND %RETURN GETNUM(LEN,FLAG) %RETURN %IF FLAG # 0 %IF LEN <= 0 %THEN LEN = 16 CONNECT(FILE,0,0,0,R,J) %IF J # 0 %START PSYSMES(8,J) %RETURN %FINISH DUMMY = FINDFN (SSOWN_CURFILE, J) %IF OFFSET+LEN-SSOWN_CONF(J)_SIZE>0 %THEN %START PRINTSTRING(" INVALID OFFSET OR LENGTH ") %IF NEWCONNECT#0 %THEN %START DISCONNECT (LAST, J) %FINISH %RETURN %FINISH OUT = SPAR(4) %IF OUT = "" %THEN OUT = ".LP" DEFINE(82,OUT,AFD,FLAG) F==RECORD(AFD) F_MAXSIZE=X'100000'; !ALLOW 1 MBYTE FILE SELECTOUTPUT(82) PRINTSTRING(" DUMP FROM FILE ".FILE." ") CXDUMP(R_CONAD+OFFSET,LEN,3) %IF NEWCONNECT#0 %THEN %START DISCONNECT (FILE,J) %FINISH SELECTOUTPUT(0) %END; !OF DUMPFILE %IF LENGTH(COMMAND) > 8 %THEN LENGTH(COMMAND) = 8 !TRUNCATE IF NEC FLAG = 0; !DEFAULT SETPAR(PARAM); !FOR ANALYSIS BY SPAR %FOR I=MAXCOM,-1,1 %CYCLE %IF COMMAND = COM(I) %THEN -> CSW(I) %REPEAT PRINTSTRING("#".COMMAND." NOT VALID") NEWLINE -> EXIT CSW(1): !SNAP SNAP(2) -> EXIT CSW(2): !HEX OUTHEX -> EXIT CSW(3): !DEC DEC -> EXIT CSW(4): !PCOM PCOM -> EXIT CSW(5): !SCOM SCOM -> EXIT CSW(6): !SBYTE SBYTE -> EXIT CSW(7): !SWORD SWORD -> EXIT CSW(8): !SSTRING SSTRING -> EXIT CSW(9): !SETBASE %UNLESS PARAM -> S1.(".").S2 %OR PARAM = "" %C %THEN PARAM = SSOWN_SSOWNER.".".PARAM FLAG = X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,0,1,ADDR(PARAM));!SET BASEFILE IN SFI -> EXIT CSW(10): !CONNECT CON -> EXIT CSW(11): !SNAPCH SNAP(1) -> EXIT CSW(12): !SSTOP -INHIBIT SPOOLER SSOWN_INHIBITSPOOLER = 1 -> EXIT CSW(13): !N - SWITCH OFF SPECIALS SSOWN_INHIBITSPOOLER = 0 SSOWN_SSMONITOR = 0 SSOWN_SSNOTE=0 SSOWN_NOWARNINGS=0 SSOWN_LOADMONITOR=0 %IF SSOWN_MONFILE#"" %THEN %START SETUSE(SSOWN_MONFILE,-1,0) SSOWN_MONFILE="" SSOWN_MONFILEAD=0 SSOWN_MONFILETOP=0 %FINISH -> EXIT CSW(14): !SNAPCODE SNC -> EXIT CSW(15): ! #LISTFD(CHANNEL) PRINTFD -> EXIT CSW(16): !MONITOR %MONITOR -> EXIT CSW(17): !PVM PVM -> EXIT CSW(18): !DUMPFILE DUMPFILE -> EXIT CSW(19): !REGS REGS -> EXIT CSW(20): !MON SSOWN_SSMONITOR = SSOWN_SSMONITOR!1; !SET MON CPU AND PAGETURNS BIT -> EXIT CSW(21): !QUIT HALT CSW(22): !PMESS GETNUM(I,FLAG) %IF FLAG = 0 %THEN SSMESS(I) -> EXIT CSW(23): !DUMP OUTDUMP -> EXIT CSW(24): *STLN_LNB; !CURRENT LNB PRINTSTRING("ACR =") WRITE((INTEGER(LNB+4)>>20)&X'F',1) NEWLINE -> EXIT CSW(25): !LMON (N) %IF SPAR(1)="?" %THEN %START %IF SSOWN_LOADMONITOR#0 %THEN %START PRINTSTRING("Load monitor setting X") PHEX(SSOWN_LOADMONITOR) NEWLINE %IF SSOWN_MONFILE#"" %THEN %START PRINTSTRING("Output to file ".SSOWN_MONFILE) %IF SSOWN_MONFILEAD#0 %THEN PRINTSTRING(" - X") %AND PHEX(SSOWN_MONFILEAD-32) %C %AND PRINTSTRING(" Bytes written") %FINISH %ELSE PRINTSTRING("Output to console") %FINISH %ELSE PRINTSTRING("Load monitoring off") NEWLINE ->EXIT %FINISH ! Not a query if here ! Check for legal number for first param GETNUM(I,FLAG) %IF FLAG=0 %THEN SSOWN_LOADMONITOR=I %ELSE %START SSOWN_LOADMONITOR=0 %IF SPAR(1)#"" %THEN PRINTSTRING("Illegal integer ".SPAR(1)." ") %FINISH %IF SSOWN_LOADMONITOR=0 %THEN %START %IF SSOWN_MONFILE#"" %THEN %START SETUSE(SSOWN_MONFILE,-1,0) SSOWN_MONFILE="" SSOWN_MONFILEAD=0 SSOWN_MONFILETOP=0 %FINISH ->EXIT %FINISH ! O.K. so far. Now check if new MONFILE set OUTF=SPAR(2) %IF OUTF#"" %THEN %START %IF SSOWN_MONFILE#"" %THEN %START ! One currently defined SETUSE(SSOWN_MONFILE,-1,0) SSOWN_MONFILEAD=0 SSOWN_MONFILETOP=0 SSOWN_MONFILE="" %FINISH FLAG=CHECKFILENAME(OUTF,5); ! Check valid own filename %IF OUTF->S1.(".").S2 %THEN OUTF=S2 %UNLESS 'A'<=CHARNO(OUTF,1)<='Z' %AND FLAG=0 %THEN %C PRINTSTRING("Invalid own filename ".SPAR(2)." ") %AND ->EXIT ! Check that OUTF doesn't exist FINFO(OUTF,0,FR,FLAG) %IF FLAG#218 %THEN PRINTSTRING(OUTF." already exists ") %ELSE SSOWN_MONFILE=OUTF %FINISH ->EXIT CSW(26): !#NOTE GETNUM(I,FLAG) %IF FLAG=0 %THEN SSOWN_SSNOTE=I %ELSE SSOWN_SSNOTE=0 ->EXIT CSW(27): ! LQUIET SSOWN_NOWARNINGS=1 ->EXIT EXIT: %END; !OF HASHCOMMAND %FINISH ! ! - END OF HASH CODE ] ! ! [ START OF INFREQUENT CODE - ! ! %ROUTINE FSC(%INTEGER SCTABLE, COUNT); ! FILL SYSTEM CALLS !*********************************************************************** !* * !*THIS VERSION CHANGED 17.8.78 FOR NEW FORMAT OBJECT FILES * !* THIS ROUTINE FILLS IN THE SYSTEM CALL DESCRIPTORS IN THE BGLA * !* USING INFORMATION IN A TABLE AT SCTABLE. THE INFORMATION * !* CONSISTS OF AN I AND J VALUE FOR EACH OF THE DIRECTOR ROUTINES * !* WHICH CAN BE ACCESSED BY SYSTEM CALL. * !* * !*********************************************************************** %RECORDFORMAT TABF(%STRING (31) NAME, %INTEGER I, J) %RECORD(TABF)%ARRAYFORMAT TABLEF(1 : COUNT) %RECORD(TABF)%ARRAYNAME TABLE %RECORDFORMAT EPREFF(%INTEGER LINK, REFLOC, %STRING (31) IDEN) %RECORD(EPREFF)%NAME EPREF %INTEGER LD, LOC, LINK, P ! %INTEGER ABGLA used to be declared, but I think we can use the %OWN of ! the same name in the surrounding environment. ! SSOWN_ABGLA = ABASEFILE+((INTEGER(ABASEFILE)+X'3FFFF')& %C ! X'FFFC0000') ! BASEGLA STARTS AT FIRST FREE SEG BEYOND BASEFILE ! That method of calculating SSOWN_ABGLA has been superseded (see first few lines ! of SSINIT), but in any case since we are no longer using a local SSOWN_ABGLA we ! don't need to assign a value to it. TABLE == ARRAY(SCTABLE,TABLEF); !MAP ARRAY TABLE ONTO THE TABLE LD = ABASEOBJ+INTEGER(ABASEOBJ+24); !START OF BASE LOAD DATA LINK = INTEGER(LD+28); !TOP OF EPREF LIST %WHILE LINK#0 %CYCLE EPREF == RECORD(LINK+ABASEOBJ); !MAP EACH REF ONTO EPREF %FOR P=COUNT,-1,1 %CYCLE; !LOOK THROUGH SCTABLE %IF TABLE(P)_NAME = EPREF_IDEN %START LOC = (EPREF_REFLOC&X'FFFFFF')+SSOWN_ABGLA; !ASSUME IN GLA (NOT PLT) INTEGER(LOC) = X'E3000000'!TABLE(P)_I !SYS CALL DESCRIPTOR INTEGER(LOC+4) = TABLE(P)_J !SECOND WORD %EXIT %FINISH %REPEAT LINK = EPREF_LINK %REPEAT %END; !OF FIL SYSTEM CALLS ! %SYSTEMROUTINE SSINIT(%INTEGER MARK, ADIRINF) !THIS IS THE INITIALISATION ! ROUTINE FOR THE SUBSYSTEM. ! IT IS ENTERED !ONCE FROM SSLDR AT THE START ! OF A SESSION %INTEGER FLAG, I, POS, BH, BGLALEN, AOFM,GLAAD %IF NEWLOADER#0 %THEN %START %INTEGER SSSCTABLE, SSSCCOUNT %FINISH %RECORD(DIRINFF)%NAME DIRINF %RECORD(CONFF)%NAME CUR %RECORD (RF)RR %ROUTINE CALL CONTROL %INTEGER LNB *STLN_LNB; !PUT LNB FOR THIS ROUTINE INTO I SSOWN_SSCOMREG(36) = LNB; !AND STORE IN COMREG 36 CONTROL; !CALL SS CODE !IF FAILURE THEN EFFECTIVELY ! RETURN FROM THIS ROUTINE %END; !OF CALL CONTROL ! SSOWN=0; ! Initialise SSOWN record to 0 ! ! Initialise all the subsystem globals which are not 0 (or ""). ! SSOWN_INTMESS(I)=INITVAL INTMESS(I) %FOR I=9,-1,1 ! SSOWN_ALLCONNECT=INITVAL ALLCONNECT SSOWN_CKBITS=INITVAL CKBITS SSOWN_FEPMODE=INITVAL FEPMODE SSOWN_INTINPROGRESS=INITVAL INTINPROGRESS SSOWN_MTCLOSEMODE=INITVAL MTCLOSEMODE SSOWN_OPMODE=INITVAL OPMODE SSOWN_RCLB=INITVAL RCLB SSOWN_TOPFD=INITVAL TOPFD SSOWN_UNASSPATTERN=INITVAL UNASSPATTERN ! SSOWN_LASTCPUTIME=INITVAL LASTCPUTIME ! SSOWN_ACTD=INITVAL ACTD ! SSOWN_OPTIONSFILE =INITVAL OPTIONSFILE SSOWN_SSUGLASIZE=INITVAL SSUGLASIZE SSOWN_LOADLEVEL=INITVAL LOADLEVEL SSOWN_D DELIM 1 =INITVAL D DELIM 1 SSOWN_D DELIM 2 =INITVAL D DELIM 2 SSOWN_STATE =INITVAL STATE ! ! End of initialisations. ! DIRINF == RECORD(ADIRINF); !DIRECTOR INFO RECORD BH = ROUNDUP(INTEGER(ABASEFILE),SEGSIZE) !HOLE FOR BASEFILE AOFM = ABASEOBJ+INTEGER(ABASEOBJ+28);!ADDRESS OF OBJECT FILE MAP SSOWN_ABGLA=ABASEFILE+BH !***** END OF TEMP ***** ! LONGINTEGER(ADDR(SSOWN_SSCOMREG(27))) = DEFAULTPARM; !USE DEFAULT PROTEM - LATER TO COME FROM OPTION FILE SSOWN_SSCOMREG(48) = X'0003D000'; !252K LESS MARGIN OF 8K SSOWN_SSCOMREG(35) = SSOWN_ABGLA; !ADDRESS OF BGLA SSOWN_SSOWNER = DIRINF_USER; !EXTRACT INFO FROM DIRINF SSOWN_SSOWNFSYS = DIRINF_FSYS SSOWN_SSREASON = DIRINF_REASON SSOWN_SSOPERNO = DIRINF_STARTCNSL SSOWN_AIOSTAT = DIRINF_AIOSTAT SSOWN_APAGETURNS = DIRINF_AACCTREC+8 ! AACTREC POINTS TO A RECORD OF THE ! FORM (%LONGINTEGER MUSECS,%INTEGER PAGETURNS,KINSTRS) ! SSOWN_ICREVS == INTEGER(DIRINF_AICREVS); !INS. COUNTER REVS SSOWN_PREVIC == INTEGER(ADDR(DIRINF_PREVIC)); !HORRID CONSTRUCT TO GET ROUND COMPILER LIMITATION SSOWN_KINSTRS == INTEGER(DIRINF_AACCTREC+12); !K INS. WHEN LAST UPDATED SSOWN_SSINVOCATION = DIRINF_ISUFF; ! Invocation number. SSOWN_SSSUFFIX = ITOS (SSOWN_SSINVOCATION); ! STRING TO BE ADDED TO END OF ! TEMP FILENAMES %IF NEWLOADER#0 %THEN %START SSSCTABLE = DIRINF_SCIDENSAD SSSCCOUNT = DIRINF_SCIDENS %FINISH %ELSE %START SSOWN_SSSCTABLE=DIRINF_SCIDENSAD SSOWN_SSSCCOUNT = DIRINF_SCIDENS %FINISH SSOWN_SSADIRINF = ADIRINF %IF NEWLOADER#0 %THEN %START ! Now find out whether we are running on a shareable or an unshareable ! basegla. Do this by extracting SSINIT's gla address from LNB+16. If ! this is in the same segment as SSOWN_ABGLA then it's unshared. ! After this inspect MARK and compare it to SSDATELINKED. If these are ! not the same then we have different system call tables in Director ! and Subsystem. Action is then as follows: ! MARK=SSDATELINKED Shared basegla ACTION ! Y Y OK ! Y N OK ! N Y DSTOP(130) ! N N Call FSC then OK *LSS_(%LNB+4); ! Gla for SSINIT *ST_GLAAD GLAAD=GLAAD&X'FFFC0000' !****TEMP !* %IF MARK#SSDATELINKED %THEN %START !* %IF GLAAD#SSOWN_ABGLA %THEN AABPRINTSTRING("NewSCT Shared basegla !* ") %ELSE AABPRINTSTRING("NewSCT Unshared basegla !* ") !* %FINISH %ELSE %START !* %IF GLAAD#SSOWN_ABGLA %THEN AABPRINTSTRING("SameSCT Shared basegla !* ") %ELSE AABPRINTSTRING("SameSCT Unshared basegla !* ") !* %FINISH !****TEMP %IF MARK#SSDATELINKED %THEN %START ! Mismatching system call table %IF GLAAD#SSOWN_ABGLA %THEN AAASTOP{DSTOP}(130) %ELSE %C FSC(SSSCTABLE,SSSCCOUNT) %FINISH %FINISH %ELSE %START %IF DIRINF_SCDATE#SSDATELINKED %THEN FSC(SSOWN_SSSCTABLE,SSOWN_SSSSSOUNT) %FINISH %IF GLAAD#SSOWN_ABGLA %THEN BGLALEN=0 {Shared basegla} %ELSE %C BGLALEN = INTEGER(AOFM+20)+INTEGER(AOFM+56) %AND SSOWN_UNSHAREDBGLA=1; !LENGTH OF AREA 2(GLA)+LENGTH OF AREA 5(UST) X1{CHANGECONTEXT}; !TO LOSE SS AND DIRECTOR GLAP PAGES FROM WORKING SET SSOWN_BASEFILE = DIRINF_BASEFILE %IF SSOWN_BASEFILE = "" %THEN SSOWN_BASEFILE = DEFBASE !DEFAULT NAME FLAG = X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,12,0,ADDR(SSOWN_SSMAXFSIZE)) SSOWN_SSMAXFSIZE = SSOWN_SSMAXFSIZE<<10; !MAXIMUM FILE SIZE IN BYTES FLAG = FINDFN(SSOWN_BASEFILE,POS) CUR == SSOWN_CONF(POS) CUR_FILE = SSOWN_BASEFILE; !PUT NAME IN TABLE CUR_SIZE = ROUNDUP(INTEGER(ABASEFILE),FILESIZEALLOC) CUR_CONAD = ABASEFILE; !ADDRESS OF BASEFILE CUR_HOLE = BH %IF NEWCONNECT#0 %THEN %START CUR_USE = X'80000001'; !NEVER DISCONNECT %FINISH %ELSE %START CUR_USE = 8 %FINISH !PUT T#BGLA INTO SSOWN_CONF TABLE FLAG = FINDFN(SSOWN_SSOWNER.".T#BGLA",POS) CUR == SSOWN_CONF(POS) CUR_FILE = SSOWN_SSOWNER.".T#BGLA" CUR_CONAD = SSOWN_ABGLA CUR_HOLE = SEGSIZE CUR_SIZE = SEGSIZE %IF NEWCONNECT=0 %THEN %START CUR_USE = 8 %FINISH %ELSE %START CUR_USE = X'80000001'; !NEVER DISCONNECT %FINISH CONNECT(SSOWN_BASEFILE."_BASEDIR",0,0,0,RR,FLAG) %IF FLAG # 0 %THEN X30{DSTOP}(126); !CANNOT CONNECT BASEDIR %IF NEWLOADER=0 %THEN %START SSOWN_SSASESSDIR = RR_CONAD %FINISH %ELSE %START SSOWN_SSDIRAD = RR_CONAD %FINISH CONNECT(SSOWN_BASEFILE."_OPTIONFILE",0,0,0,RR,FLAG) %IF FLAG # 0 %THEN X30{DSTOP}(127); !CANNOT CONNECT DEFAULT OPTION FILE SSOWN_SSADEFOPT = RR_CONAD %IF NEWLOADER=0 %THEN %START SSOWN_SSATEMPDIR = SSOWN_ABGLA+BGLALEN; !ADDR OF SESSION DIRECTORY SSOWN_SSCURBGLA = SSOWN_SSATEMPDIR+SSTEMPDIRSIZE %FINISH %ELSE %START SSOWN_SSCURBGLA = SSOWN_ABGLA + BGLALEN; ! Available from here. %FINISH SSOWN_SSMAXBGLA = SSOWN_ABGLA+SEGSIZE-1; !LAST BYTE IN BGLA SSOWN_SSCOMREG(11) = INTEGER(ATRANS)+256; !ADDRESS OF ETOI TABLE SSOWN_SSCOMREG(12) = INTEGER(ATRANS); !ADDRESS OF ITOE TABLE SSOWN_DIRDISCON = INITVAL DIRDISCON %IF NEWLOADER#0 %THEN %START SSOWN_SSAUXDR1=0; ! To ensure auxstack initialised when req INITLOADER(FLAG) %IF FLAG#0 %THEN X30{DSTOP}(129) %FINISH INITDYNAMICREFS I = X27{DSETIC}(40000); !LARGE DEFAULT TIME LIMIT CALL CONTROL; !THIS IS SUBSYSTEM X30{DSTOP}(104); !IN CASE WE GET BACK HERE %END; !OF SSINIT ! %SYSTEMROUTINE USEOPTIONS %INTEGER FLAG, I %INTEGER %NAME J, K %RECORD (RF) RR %RECORD (CONTF) %NAME C, D %IF STUDENTSS=0 %THEN %START CONNECT(SSOWN_OPTIONSFILE,0,0,0,RR,FLAG) %IF FLAG#0 %THEN RR_CONAD = SSOWN_SSADEFOPT; ! Cannot connect own control file. ! so use default one. %FINISH %ELSE %START ! If we ever went through here with SSOWN_USEOPTSTARTED#0, then RR would ! not get set up and we would would get horrid failures in trying ! to access the record C. There is supposed to be protection to ! prevent USEOPTIONS being called more than once, so that problem ! should not arise. But in that case, we don't need to test SSOWN_USEOPTSTARTED ! at all. %IF SSOWN_USEOPTSTARTED=0 %THEN %START; ! Only allow this the first time. FLAG = X28{DSFI} (SSOWN_SSOWNER, SSOWN_SSOWNFSYS, 2, 0, ADDR(SSOWN_OPTIONSFILE)) CONNECT (SSOWN_OPTIONSFILE, 0, 0, 8, RR, FLAG); ! Cannot be DISCONNECTed. %IF FLAG#0 %THEN RR_CONAD = SSOWN_SSADEFOPT %FINISH %FINISH C == RECORD(RR_CONAD) %IF FLAG=0 %AND (SSOWN_USEOPTSTARTED=0 %OR RR_FILETYPE#9) %THEN %START D == RECORD(SSOWN_SSADEFOPT); ! CHECK VERSION, FIRST MAP DEF OPTIONS FILE %IF C_MARK#D_MARK %OR RR_FILETYPE#9 %THEN %START; ! UPDATE REQUIRED %IF NEWCONNECT=0 %THEN %START CONNECT (SSOWN_OPTIONSFILE,3,0,0,RR,FLAG) %FINISH %ELSE %START CHANGEACCESS (LAST,3,FLAG); !RECONNECT IN WRITE MODE %FINISH %FOR I=36,4,4092 %CYCLE; ! UPDATE IF -1(=UNUSED) IN EITHER J == INTEGER (RR_CONAD + I) K == INTEGER (SSOWN_SSADEFOPT + I) %IF (J=X'81818181' %OR J=-1 %OR K=-1) %AND J#K %THEN J = K %REPEAT MOVE(36,SSOWN_SSADEFOPT,RR_CONAD); !UPDATE HEADER AND VERSION NO %FINISH %FINISH SSOWN_SSNOBLANKLINES = C_NOBL&1; !ONLY 0 OR 1 VALID SSOWN_SSASTACKSIZE = C_ASTK SSOWN_SSUSTACKSIZE = C_USTK %IF SSOWN_SSUSTACKSIZE>MAXUSERSTACKSIZE %THEN SSOWN_SSUSTACKSIZE = MAXUSERSTACKSIZE %IF C_ISTK>0 %THEN SSOWN_INITSTACKSIZE = C_ISTK; ! PART OF USERSTACK RESERVED ! FOR INIT STACK SSOWN_SSTERMINALTYPE=C_TERMINAL SSOWN_SSITWIDTH = C_ITWIDTH SSOWN_SSLDELIM = C_LDELIM SSOWN_SSRDELIM = C_RDELIM SSOWN_AVD = C_MODDIR; ! Active directory. SSOWN_HOLDAVD = SSOWN_AVD; ! Save active directory name for use in TIDYFILES. SSOWN_SSARRAYDIAG = C_ARRAYDIAG SSOWN_SSCFAULTS <- C_CFAULTS; !COMPILER FAULTS SSOWN_SSINITPARMS = C_INITPARMS SSOWN_SSDATAECHO = C_DATAECHO SSOWN_DATAECHO=SSOWN_SSDATAECHO %IF SSOWN_FDLEVEL >1; !IN CASE CALLED FROM OBEY %IF C_INITWORKSIZE # 0 %THEN SSOWN_SSINITWORKSIZE = C_INITWORKSIZE %IF SSOWN_SSJOURNAL#C_JOURNAL %AND SSOWN_SSREASON#BATCHREASON %THEN %START !NOT BATCH JOB %IF SSOWN_SSJOURNAL = 2 %START; !CURRENT SETTING IS PERMRECALL FSTATUS(SSPERMJNAME,5,0,FLAG);!MARK FILE TO BE DESTROYED AT LOGOFF %FINISH SSOWN_SSJOURNAL = C_JOURNAL INITJOURNAL %IF SSOWN_USEOPTSTARTED = 1; !ONLY IF ALREADY RUNNING %FINISH %IF SSOWN_USEOPTSTARTED = 0 %START; ! ONLY RELEVANT AT START UP SSOWN_RCODE==SSOWN_SSCOMREG(24); !COMREG(24) IS RETURNCODE LONGINTEGER(ADDR(SSOWN_SSCOMREG(27))) = C_INITPARMS !LOAD INITIAL SETTING %IF SSOWN_SSREASON#BATCHREASON %START; !FOREGROUND SESSION SSOWN_ITINLENGTH = C_ITINSIZE SSOWN_ITOUTLENGTH = C_ITOUTSIZE SSOWN_STARTFILE = C_FSTARTFILE %FINISH %ELSE SSOWN_STARTFILE = C_BSTARTFILE; !BATCH JOB SSOWN_USEOPTSTARTED = 1 %FINISH %IF NEWCONNECT#0 %THEN %START DISCONNECT (SSOWN_OPTIONSFILE, FLAG) %FINISH %END; !OF USEOPTIONS ! %SYSTEMROUTINE BATCHSTOP(%INTEGER REASON) !*********************************************************************** !* * !* This routine is called from STOP or when input ended is detected * !* during a batch job. It closes the main output file and sends a * !* message to the user - who might be logged on. * !* * !*********************************************************************** %INTEGER FLAG, START, LEN %STRING (40) MESSAGE %RECORD(DIRINFF)%NAME DIRINF DIRINF == RECORD(SSOWN_SSADIRINF) SSOWN_FDLEVEL = 1 TIDYFILES; !IN CASE CALLED FROM WITHIN OBEY NEWLINES(5) %IF REASON = 1 %THEN PRINTSTRING( %C "***JOB TIME LIMIT EXCEEDED***") %IF REASON = 2 %THEN PRINTSTRING( %C "***JOB TERMINATED BY OPERATOR***") %IF REASON = 3 %THEN PRINTSTRING( %C "***NO MORE SPACE FOR JOB OUTPUT***") NEWLINES(2) PRINTSTRING("*** BATCH JOB ENDED AT ".TIME." ON ".DATE. %C " ****") NEWLINES(2) METER("") NEWLINES(3) FLAG = CLOSE(SSOWN_SSFDMAP(91)); !CLOSE MAIN OUTPUT FILE MESSAGE = "BATCH JOB ".DIRINF_JOBNAME." COMPLETED" START = ADDR(MESSAGE)+1 LEN = LENGTH(MESSAGE) FLAG = X16{DMESSAGE2}(SSOWN_SSOWNER,LEN,1,SSOWN_SSINVOCATION!!1,SSOWN_SSOWNFSYS,START) ! The fourth parameter of DMESSAGE2 is the invocation number of the ! process to which the message is to be sent. It is quite common ! for an interactive process, being invocation 0, to detach a batch ! job which becomes invocation 1. When the batch job completes, the ! completion message should naturally go to the interactive process, ! so this code used to specify an invocation number of 0. However, ! other combinations of invocation numbers can occur, so we now ! attempt to make a better guess. ! SSOWN_SSINVOCATION !! 1 is not guaranteed to be the right invocation, ! but it is more likely than simply using 0. Even if it is wrong, the ! consequences will not be disastrous. HALT %END; !OF BATCHSTOP ! %SYSTEMROUTINE REROUTECONTINGENCY(%INTEGER EP,CLASS, %C %LONGINTEGER MASK, DR,%INTEGER S,XNB,%INTEGERNAME FLAG) !NOTE THAT THE 16 BYTES STARTING AT DR ARE REPLACED BY ONE PARAMETER !%ROUTINENAME RR WHEN THIS ROUTINE IS SPECIFIED %CONSTINTEGER MAXEP = 5 %RECORD(RRCF)%NAME RRC FLAG = 0; !DEFAULT REPLY %IF 0 ERR %IF FLAG # 0 INTEGER(RR_CONAD) = 32 INTEGER(RR_CONAD+4) = 32 INTEGER(RR_CONAD+12) = 8; !TYPE = JOURNAL FILE %FINISH %ELSE %START -> ERR %IF FLAG # 0 %OR RR_FILETYPE # 8 %FINISH SSOWN_IT_JNBASE = RR_CONAD SSOWN_IT_JNMAX = SSOWN_IT_JNBASE+JNSIZE %IF INTEGER(SSOWN_IT_JNBASE) = 0 %START; !LAST SESSION ENDED WITHOUT CLOSING JOURNAL %FOR I=SSOWN_IT_JNBASE+32,1,SSOWN_IT_JNMAX-1 %CYCLE %IF BYTEINTEGER(I) = 255 %THEN %START SSOWN_IT_JNCUR = I -> ENDFOUND %FINISH %REPEAT SSOWN_IT_JNCUR = SSOWN_IT_JNBASE+32; ! NO TERMINATOR FOUND BYTEINTEGER(SSOWN_IT_JNMAX-1) = 0; !SO GETJOURNAL WILL NOT PRODUCE INVALID WRAP AROUND %FINISH %ELSE SSOWN_IT_JNCUR = SSOWN_IT_JNBASE+INTEGER(SSOWN_IT_JNBASE) BYTE INTEGER (SSOWN_IT_JNCUR) = 255 ENDFOUND: INTEGER(SSOWN_IT_JNBASE) = 0; !TO INDICATE FAILURE DURING SESSION ERR: %END; !OF INITJOURNAL ! %SYSTEMROUTINE CLOSEJOURNAL %RETURN %IF SSOWN_IT_JNBASE <= 0 INTEGER(SSOWN_IT_JNBASE) = SSOWN_IT_JNCUR-SSOWN_IT_JNBASE; !OFFSET OF END %END; !OF CLOSEJOURNAL ! %SYSTEM %ROUTINE JOURNAL OFF %IF STUDENTSS=0 %THEN %START %IF SSOWN_IT_JNBASE>0 %THEN SSOWN_IT_JNBASE = - SSOWN_IT_JNBASE %FINISH %END ! %SYSTEMROUTINE GETJOURNAL(%STRINGNAME FILE, %INTEGERNAME FLAG) !THIS ROUTINE IS USED BY RECALL AND RECAP %INTEGER LEN, START, CONAD, WRAP, AFM, LFM %IF SSOWN_IT_JNBASE<=0 %THEN %START; ! JOURNAL NOT SELECTED FLAG = 304 -> ERR %FINISH WRAP = BYTEINTEGER(SSOWN_IT_JNMAX-1); !WRAPPED ROUND IF NON-ZERO ! IF LAST BYTE IN JOURNAL FILE NON ZERO THEN WRAP ROUND %IF WRAP=0 %C %THEN LEN = SSOWN_IT_JNCUR-SSOWN_IT_JNBASE %C %ELSE LEN = SSOWN_IT_JNMAX-SSOWN_IT_JNBASE-1; ! The byte at SSOWN_IT_JNCUR is a marker (X'FF') ! and we don't want it in the output file. FILE = "T#TMPJN" OUTFILE(FILE,LEN,0,0,CONAD,FLAG) -> ERR %IF FLAG#0 INTEGER(CONAD) = LEN INTEGER(CONAD+12) = 3; !TYPE=CHARACTER START = CONAD+32 %IF WRAP#0 %THEN %START; !MUST HAVE WRAPPED AROUND AFM = SSOWN_IT_JNCUR + 1 LFM = SSOWN_IT_JNMAX - AFM MOVE (LFM,AFM,START) START = START + LFM LEN = LEN - LFM %FINISH MOVE(LEN-32,SSOWN_IT_JNBASE+32,START) ERR: SSOWN_IT_JNBASE = -SSOWN_IT_JNBASE; !TO INHIBIT JOURNAL DURING RECALL AND RECAP SSOWN_SSOPENUSED = 1; !TO ENSURE SSOWN_IT_JNBASE GETS RESET AT COMMAND LEVEL %END; !OF GETJOURNAL ! ! %SYSTEMROUTINE OFFER(%STRING (31) FILE, %C %STRING (6) TO, %INTEGERNAME FLAG) FLAG = CHECKFILENAME(FILE,5) %IF FLAG=0 %THEN %START %IF NEWCONNECT=0 %THEN %START DISCONNECT(LAST,FLAG); !IGNORE FLAG %FINISH %ELSE %START RDISCON (LAST, FLAG); ! to make sure that Director disconnects it. %FINISH FLAG = DIRTOSS(X19{DOFFER}(SSOWN_CURFOWNER,TO,SSOWN_CURFNAME,SSOWN_CURFSYS)) %IF FLAG#0 %THEN %START %IF FLAG=201 %THEN SSOWN_SSFNAME = TO %ELSE SSOWN_SSFNAME = SSOWN_CURFNAME %FINISH %FINISH %END; !OF OFFER ! %SYSTEMROUTINE ACCEPT(%STRING (31) FILE, NEWNAME, %C %INTEGERNAME FLAG) %STRING (6) OWNER %STRING (11) NAME %INTEGER FSYS FLAG = CHECKFILENAME(FILE,6); !ANY NAME EXCEPT OWN -> ERR %IF FLAG # 0 OWNER = SSOWN_CURFOWNER NAME = SSOWN_CURFNAME; !HOLD FOR USE IN CALL OF X2{DTRANSFER} FSYS = SSOWN_CURFSYS %IF NEWNAME # "" %START; !NEW NAME TO BE GIVEN TO FILE FLAG = CHECKFILENAME(NEWNAME,5) !ANY OWN FILE -> ERR %IF FLAG # 0 %FINISH NEWNAME = SSOWN_CURFNAME; !PROTEM - DEFAULT VALUE OF ! NEWNAME IS SAME AS ORIGINAL ! SSOWN_CURFNAME FLAG = DIRTOSS(X2{DTRANSFER}(OWNER,SSOWN_SSOWNER,NAME,NEWNAME,FSYS,SSOWN_SSOWNFSYS,0)) %IF FLAG=218 %OR FLAG=278 %OR FLAG=505 %THEN SSOWN_SSFNAME=OWNER.".".NAME %ELSE SSOWN_SSFNAME=SSOWN_CURFILE ERR: %END; !OF ACCEPT ! !**************************************************************************** ! ! ROUTINE PERMIT INNER ! !**************************************************************************** ! ! This routine is the routine which calls DPERMISSION and is used ! by all the other permit routines. Note that it is passed an ! integer FILETYPE - this should be set to either ! 0 - to refer to a disc file or ! 1 - to refer to the archived file index. ! ! Note also that this routine will permit other users files if ! the caller has the neccessary privilege. If the caller has ! not got the privilege then the privilege error (93) is ! translated into the subsystem error - Illegal use of another ! users file . This makes the command appear no different ! tham it was formerly to the unprivileged caller. ! ! CHECKFILENAME is used to set up the neccesary FILEname, FSYS, ! fileOWNER this means no special code is needed for the ! permitting of other users files. ! ! Note also that 16 is added to the TYPE Field if the file ! to be permitted is archived. This is to let director know. %ROUTINE PERMIT INNER (%STRING(31) FILE, %STRING(8) DATE, %STRING(6) USER, %INTEGER FILE TYPE, MODE, %INTEGERNAME FLAG) %STRING(31)FOWNER,FNAME %CONSTINTEGER DISC FILE = 0; ! FILE TYPE = DISC FILE %INTEGER TYPE %IF FILE->FOWNER.(".").FNAME %AND FNAME="" %THEN FILE="" %ELSE FOWNER=SSOWN_SSOWNER %IF FILE # "" %THEN %START; !PERMIT 1 FILE FLAG = CHECKFILENAME(FILE,7) !ANY OWN FILE %RETURN %IF FLAG # 0 FILE = SSOWN_CURFNAME; !FILE USED IN CALL OF X22{DPERMISSION} %IF SSOWN_CURFOWNER=USER=SSOWN_SSOWNER %THEN {SET OWNP} TYPE = 0 %C %ELSE %IF USER="" %THEN {SET EEP} TYPE = 1 %C %ELSE %IF MODE>=0 %THEN {ADD USER TO LIST} TYPE = 2 %C %ELSE {REMOVE USER FROM LIST} TYPE = 3 TYPE=TYPE+16 %IF FILE TYPE#DISC FILE FLAG=DIRTOSS(X22{DPERMISSION}(SSOWN_CURFOWNER,USER,DATE,FILE,SSOWN_CURFSYS,TYPE,MODE)) %FINISH %ELSE %START ! {WHOLE INDEX PERMISSION} %IF MODE>=0 %THEN TYPE = 6 %ELSE TYPE = 7 TYPE = TYPE + 16 %IF FILE TYPE # DISC FILE; ! If referring to archive file FLAG = DIRTOSS(X22{DPERMISSION}(FOWNER,USER,DATE,FILE,-1,TYPE,MODE)); !-1 for unknown fsys %FINISH FLAG = 258 %IF FLAG = 593; ! Illegal use of other users file %IF FLAG # 0 %THEN SSOWN_SSFNAME = SSOWN_CURFNAME %END; !OF PERMIT INNER %SYSTEMROUTINE ARCHIVEPERMIT (%STRING(31) FILE, %STRING(8) DATE, %STRING(6) USER, %INTEGER MODE, %INTEGERNAME FLAG) ! = the old PERMIT - for archived files %CONSTINTEGER ARCHIVED FILE = 1 %IF USER="=" %THEN USER=UINFS(1); !short form for self PERMIT INNER (FILE, DATE, USER, ARCHIVED FILE, MODE, FLAG) %END; !OF ARCHIVEPERMIT %SYSTEMROUTINE PERMIT(%STRING (31) FILE, %C %STRING (6) USER, %INTEGER MODE, %INTEGERNAME FLAG) ! = the old PERMIT - for online files %CONSTINTEGER DISC FILE = 0 %IF USER="=" %THEN USER=UINFS(1); !short form for self PERMIT INNER (FILE, "", USER, DISC FILE, MODE, FLAG) %END; !PERMIT ! ! %SYSTEMINTEGERFN GIVEREGS(%INTEGERARRAYNAME ARR, %INTEGER P) ! P should be in the range 0 -> -3. ! The most recent contingency is 0, the next most recent is -1 and ! so on. (Just like #REGS). ! The result of the function is a bit significant flag. ! If the 2**0 bit is set then there was no info. ! If the 2**1 bit is set then P was out of range ! and was defaulted to 0, i.e. the most recent. ! If there was contingency information then a copy is made to the ! array ARR: a 23 member, one dimensional array declared (-2:20). %INTEGER I,FLAG FLAG=0 %UNLESS -3<=P<=0 %THEN P=0 %AND FLAG=2 P=(SSOWN_SAVEIDPOINTER+P-1)&3 %IF SSOWN_SAVEIDATA(18,P)=0 %THEN %RESULT=FLAG!1 ARR(I)=SSOWN_SAVEIDATA(I,P) %FOR I=20,-1,-2 %RESULT=FLAG %END; ! OF GIVEREGS ! ! ! - END OF INFREQUENT CODE ] ! ! [ START OF SMES CODE - ! %CONSTINTEGER MINMESS=1 %CONSTINTEGER MAXMESS = 425 ! !**START %STRING(71)%FN MESSAGE(%INTEGER N) !*********************************************************************** !* * !* Outputs an error message stored in a compressed format * !* * !* 1 Real overflow * !* 2 Real underflow * !* 3 Integer overflow * !* 4 Decimal overflow * !* 5 Zero divide * !* 6 Array bounds exceeded * !* 7 Capacity exceeded * !* 8 Illegal operation * !* 9 Address error * !* 10 Interrupt of class * !* 11 Unassigned variable * !* 12 Time exceeded * !* 13 No more space for output * !* 14 Operator termination * !* 15 Illegal exponentiation * !* 16 Switch label not set * !* 17 Corrupt dope vector * !* 18 Illegal cycle * !* 19 Int pt too large * !* 20 Array inside out * !* 21 No result * !* 22 Param not destination * !* 23 Arrays too large or too much recursion * !* 24 Stream not defined * !* 25 Input ended * !* 26 Symbol in data * !* 27 IOCP error * !* 28 SUB character in data * !* 29 Stream in use * !* 30 Graph fault * !* 31 Diagnostics fail * !* 32 Resolution fault * !* 33 Invalid margins * !* 34 Symbol instead of string * !* 35 String inside out * !* 36 Wrong params provided * !* 37 Unsatisfied reference * !* 38 Unassigned switch variable * !* 39 Illegal system call * !* 40 Unrecoverable disc fault * !* 41 Unrecoverable store or processor fault * !* 50 SQRT arg negative * !* 51 LOG arg negative * !* 52 LOG arg zero * !* 53 EXP arg out of range * !* 54 SIN arg out of range * !* 55 COS arg out of range * !* 56 TAN arg out of range * !* 57 TAN arg inappropriate * !* 58 ASIN arg out of range * !* 59 ACOS arg out of range * !* 60 ATAN2 args zero * !* 61 SINH arg out of range * !* 62 COSH arg out of range * !* 63 LGAMMA arg not positive * !* 64 LGAMMA arg too large * !* 65 GAMMA arg out of range * !* 66 COT arg out of range * !* 67 COT arg inappropriate * !* 68 Real exponentiation fault * !* 69 Complex exponentiation fault * !* 70 RADIUS args too large * !* 71 ARCTAN args zero * !* 72 ARCSIN arg out of range * !* 73 ARCCOS arg out of range * !* 74 HYPSIN arg out of range * !* 75 HYPCOS arg out of range * !* 76 Matrix bound zero or negative * !* 101 Missing left bracket * !* 102 Missing right bracket * !* 103 Negative sign incorrect * !* 104 Invalid format * !* 105 Decimal field too wide * !* 106 Format width zero invalid * !* 107 Repetition factor invalid * !* 108 Null literal invalid * !* 109 Integer field too large * !* 110 No width field allowed * !* 111 Literal in input format * !* 112 Minimum digits greater than width * !* 114 Non-repeatable edit desc * !* 115 Comma required * !* 116 Decimal point not allowed * !* 117 Unit not connected * !* 118 File already connected * !* 119 Access conflict * !* 120 RECL conflict * !* 121 Form conflict * !* 122 Status conflict * !* 123 Invalid status * !* 124 Form not suitable * !* 125 Specifier not recognised * !* 126 Specifiers inconsistent * !* 127 Illegal specifier value * !* 128 Invalid filename * !* 129 No filename specified * !* 130 Record length not specified * !* 132 Value separator missing * !* 133 No digits specified * !* 134 Invalid scaling * !* 135 Invalid logical value * !* 136 Invalid character value * !* 137 Value not recognised * !* 138 Invalid repetition value * !* 139 Illegal repetition factor * !* 140 Invalid integer * !* 141 Invalid real * !* 142 Invalid subscript(s) * !* 143 Invalid complex constant * !* 144 Variable is not an array * !* 145 Equals sign missing after name * !* 146 Variable not in NAMELIST list * !* 147 Invalid item * !* 148 Invalid character * !* 149 Invalid variable name * !* 150 Literal not terminated * !* 151 Channel not defined * !* 152 File does not exist * !* 153 Input file ended * !* 154 Wrong length record * !* 155 Incompatible format descriptor * !* 156 Read after write * !* 157 Write after ENDFILE * !* 158 Record number out of range * !* 159 No format descriptor for data item * !* 160 DECODE/ENCODE buffer fault * !* 161 Invalid record size * !* 162 No write permission for file * !* 163 Physical end of tape * !* 164 Invalid channel number * !* 165 Too many files defined * !* 166 Invalid record size * !* 167 Invalid filename & * !* 168 File already exists * !* 169 Output file capacity exceeded * !* 170 Unrecoverable system I/O error * !* 171 Invalid operation on file * !* 172 Wrong length record * !* 173 No access permission * !* 174 Invalid file description * !* 175 File not available * !* 176 File already open * !* 177 Addresses inside out * !* 178 File not open * !* 179 File description incorrect for D.A. * !* 180 File record size incorrect for D.A. * !* 181 Facility not available * !* 182 I/O error-unspecified * !* 183 Illegal I/O operation * !* 184 Format text too large * !* 185 File has conflicting use * !* 186 Blank field not permitted * !* 187 Invalid format specification * !* 188 RECL too large * !* 189 NREC too large * !* 191 F77JINIT not called * !* 192 Delete status invalid * !* 193 Not connected for unformatted I/O * !* 194 Not connected for formatted I/O * !* 195 BACKSPACE not allowed * !* 196 Illegal BACKSPACE * !* 197 DA workfiles not available * !* 198 No filetype for a new DA file * !* 199 Number of DA records not specified * !* 200 Direct-access not a file property * !* 201 Invalid username & * !* 202 Invalid parameter & * !* 203 CPU limit exceeds permitted maximum * !* 204 Output limit exceeds permitted maximum * !* 205 Resource allowance exceeded * !* 206 Invalid control statement * !* 207 No file access allowed * !* 208 Data file not on-line * !* 209 Tape access not allowed * !* 210 Tape not available * !* 211 CPU time exceeded * !* 212 Job output limit exceeded * !* 213 Termination requested * !* 214 Invalid keyword * !* 215 Too many parameters * !* 216 User not registered for file use * !* 217 Spool data area full * !* 218 File & does not exist * !* 219 File already exists * !* 220 Invalid filename & * !* 221 Source library not defined * !* 222 No object file * !* 223 Invalid channel number * !* 224 File name too long * !* 225 Failed to create area * !* 226 Corrupt object file * !* 227 Too many external names * !* 228 Program too large * !* 229 File names must be different * !* 230 File facilities not available * !* 231 Invalid filename for level two user * !* 232 Files in library still connected * !* 233 & * !* 256 File & not connected * !* 257 File & not inserted * !* 258 Illegal use of another user's file - & * !* 259 Illegal use of own file * !* 260 Invalid connect mode * !* 261 VM hole too small * !* 262 VM full * !* 263 Wrong number of parameters * !* 264 Invalid device code & * !* 265 Attempt to re-define open channel * !* 266 Inconsistent file use * !* 267 Invalid filetype & * !* 268 Multiple BACKSPACE not allowed * !* 269 Illegal use of PD file member * !* 270 Invalid membername & * !* 271 Attempt to write to PD member * !* 272 Subsystem error * !* 273 File & on offer * !* 274 File not on offer * !* 275 File system full * !* 276 No free descriptors in file index * !* 277 Too many input files * !* 278 File connected in another VM * !* 279 Conflicting use of file & in another process * !* 280 User individual file limit exceeded * !* 281 Too many permissions * !* 282 User not in permission list * !* 283 Own permission insufficient * !* 284 Spooler failure * !* 285 Looping on alias & * !* 286 Not a PD file * !* 287 Member already exists * !* 288 Member & does not exist * !* 289 Entry & not found * !* 290 Entry & already in directory * !* 291 Too many entries * !* 292 Point list full * !* 293 Inconsistent directory entry for & * !* 294 Illegal use of .NULL * !* 295 Attempt to DEFINE too large file * !* 296 Inconsistent length for data area & * !* 297 Inconsistent parameters * !* 298 No main entry in file * !* 299 Attempt to load FORTRAN dynamically * !* 300 Table too small * !* 301 Channel not open * !* 302 Channel is open * !* 303 Requested access permission not allowed * !* 304 RECALL option not selected * !* 305 No input files * !* 306 Duplicate request * !* 307 Illegal call from within program * !* 308 User total limit exceeded * !* 309 Too many files connected * !* 310 Attempt to overwrite PD file * !* 311 Corrupt file & * !* 312 Too little space for initialised stack * !* 313 Directory & not in SEARCHDIR list * !* 314 SEARCHDIR list full * !* 315 Cannot OBEY within OBEY * !* 316 Cannot call macro from program * !* 317 Document & belongs to another user * !* 318 Document & not queued or active * !* 319 Attempt to write - no Write Ring requested * !* 320 Illegal parameter format * !* 321 Ambiguous keyword * !* 322 Keyword not recognised * !* 323 Too many parameters * !* 324 Duplicated parameter * !* 325 Missing keyword * !* 326 Invalid value for & parameter * !* 327 No such stream * !* 328 No input selected * !* 329 No output selected * !* 330 No format information supplied in DEFINEMT * !* 331 Spooler queue full * !* 332 Invalid access permission * !* 333 Group members cannot donate funds * !* 334 Insufficient funds * !* 335 Insufficient privilege to use device & * !* 336 Invalid macro header * !* 337 Too many input levels * !* 338 Invalid parameter for READ * !* 339 OUT parameter invalid * !* 340 Cannot set own permission for all files * !* 341 Cannot remove all own permissions * !* 342 Cannot set .ALL archived files permission * !* 343 Cannot set self permission for archived files * !* 350 File & already loaded * !* 351 Maximum load level exceeded * !* 352 Chain of aliases too long * !* 353 Entry & not loaded * !* 354 Entry & already loaded * !* 355 Data area not wholly within file * !* 356 Overlaps previously defined data area & * !* 357 & not positive integer * !* 358 Not callable from within user program * !* 359 Too many separate USEFOR requests * !* 401 Unassigned variable * !* 402 Adjustable dimension bound is unassigned * !* 403 Assigned value is invalid * !* 404 Assigned label is not in specified list * !* 405 Integer is not assigned with a format label * !* 406 Array bound exceeded * !* 407 Array parameter upper bound is less than lower bound * !* 408 Array parameter declared size is greater than actual * !* 409 Assumed size array requires zero last dimension * !* 410 Character array param only valid for FORT77 call * !* 411 Invalid character substring position value * !* 412 Character param declared size is greater than actual * !* 415 Do loop increment is zero * !* 418 Recursive call to a procedure * !* 419 Wrong type or size of function * !* 421 Wrong number of parameters * !* 422 Wrong type or size of parameter * !* 424 Negative unit number specified * !* 425 Fault no. * !*********************************************************************** %CONSTBYTEINTEGERARRAY OUTTT(0:73)= '?','A','B','C','D','E','F','G', 'H','I','J','K','L','M','N', 'O','P','Q','R','S','T','U', 'V','W','X','Y','Z','&','-', '/','''','(',')', 'a','b','c','d','e','f','g', 'h','i','j','k','l','m','n', 'o','p','q','r','s','t','u', 'v','w','x','y','z','.','%', '#','?','?', '0','1','2','3','4','5','6', '7','8','9' %CONSTINTEGER WORDMAX= 1510,DEFAULT= 1507 %CONSTHALFINTEGERARRAY WORD(0:WORDMAX)=0,%C 1, 32769, 32770, 2, 32769, 32772, 3, 32774, 32770, 4, 32776, 32770, 5, 32778, 32779, 6, 32781, 32782, 32784, 7, 32786, 32784, 8, 32788, 32790, 9, 32792, 32794, 10, 32795, 32797, 32798, 11, 32799, 32801, 12, 32803, 32784, 13, 32804, 32805, 32806, 32807, 32808, 14, 32810, 32812, 15, 32788, 32815, 16, 32818, 32820, 32821, 32822, 17, 32823, 32825, 32826, 18, 32788, 32828, 19, 32829, 32824, 32830, 32831, 20, 32781, 32832, 32834, 21, 32804, 32835, 22, 32837, 32821, 32838, 23, 32841, 32830, 32831, 32843, 32830, 32844, 32845, 24, 32847, 32821, 32849, 25, 32851, 32852, 26, 32853, 32855, 32856, 27, 32857, 32794, 28, 32858, 32859, 32855, 32856, 29, 32847, 32855, 32861, 30, 32862, 32863, 31, 32864, 32867, 32, 32868, 32863, 33, 32870, 32872, 34, 32853, 32874, 32797, 32876, 35, 32878, 32832, 32834, 36, 32880, 32881, 32883, 37, 32885, 32888, 38, 32799, 32890, 32801, 39, 32788, 32892, 32894, 40, 32895, 32898, 32863, 41, 32895, 32899, 32843, 32900, 32863, 50, 32902, 32903, 32904, 51, 32906, 32903, 32904, 52, 32906, 32903, 32907, 53, 32908, 32903, 32834, 32797, 32909, 54, 32910, 32903, 32834, 32797, 32909, 55, 32911, 32903, 32834, 32797, 32909, 56, 32912, 32903, 32834, 32797, 32909, 57, 32912, 32903, 32913, 58, 32916, 32903, 32834, 32797, 32909, 59, 32917, 32903, 32834, 32797, 32909, 60, 32918, 32920, 32907, 61, 32921, 32903, 32834, 32797, 32909, 62, 32922, 32903, 32834, 32797, 32909, 63, 32923, 32903, 32821, 32925, 64, 32923, 32903, 32830, 32831, 65, 32927, 32903, 32834, 32797, 32909, 66, 32928, 32903, 32834, 32797, 32909, 67, 32928, 32903, 32913, 68, 32769, 32815, 32863, 69, 32929, 32815, 32863, 70, 32931, 32920, 32830, 32831, 71, 32933, 32920, 32907, 72, 32935, 32903, 32834, 32797, 32909, 73, 32937, 32903, 32834, 32797, 32909, 74, 32939, 32903, 32834, 32797, 32909, 75, 32941, 32903, 32834, 32797, 32909, 76, 32943, 32945, 32907, 32843, 32904, 101, 32946, 32948, 32949, 102, 32946, 32951, 32949, 103, 32952, 32954, 32955, 104, 32870, 32957, 105, 32776, 32959, 32830, 32960, 106, 32961, 32963, 32907, 32964, 107, 32966, 32968, 32964, 108, 32970, 32971, 32964, 109, 32774, 32959, 32830, 32831, 110, 32804, 32963, 32959, 32973, 111, 32975, 32855, 32977, 32957, 112, 32978, 32980, 32982, 32984, 32963, 114, 32985, 32988, 32989, 115, 32990, 32991, 116, 32776, 32993, 32821, 32973, 117, 32994, 32821, 32995, 118, 32997, 32998, 32995, 119, 33000, 33002, 120, 33004, 33002, 121, 33005, 33002, 122, 33006, 33002, 123, 32870, 33008, 124, 33005, 32821, 33010, 125, 33012, 32821, 33014, 126, 33016, 33018, 127, 32788, 33021, 33023, 128, 32870, 33024, 129, 32804, 33024, 33026, 130, 33028, 33030, 32821, 33026, 132, 33032, 33033, 33035, 133, 32804, 32980, 33026, 134, 32870, 33037, 135, 32870, 33039, 33023, 136, 32870, 32859, 33023, 137, 33032, 32821, 33014, 138, 32870, 33041, 33023, 139, 32788, 33041, 32968, 140, 32870, 33043, 141, 32870, 33045, 142, 32870, 33046, 143, 32870, 33049, 33051, 144, 33053, 33055, 32821, 33056, 33057, 145, 33058, 32954, 33035, 33060, 33061, 146, 33053, 32821, 32855, 33062, 33064, 147, 32870, 33065, 148, 32870, 32859, 149, 32870, 32801, 33061, 150, 32975, 32821, 33066, 151, 33068, 32821, 32849, 152, 32997, 33070, 32821, 33071, 153, 32851, 33072, 32852, 154, 32880, 33030, 33073, 155, 33075, 32957, 33078, 156, 33080, 33060, 33081, 157, 33082, 33060, 33083, 158, 33028, 33085, 32834, 32797, 32909, 159, 32804, 32957, 33078, 32807, 32856, 33065, 160, 33087, 33090, 32863, 161, 32870, 33073, 33092, 162, 32804, 33081, 33093, 32807, 33072, 163, 33095, 33097, 32797, 33098, 164, 32870, 33099, 33085, 165, 33101, 33102, 33103, 32849, 166, 32870, 33073, 33092, 167, 32870, 33024, 33104, 168, 32997, 32998, 33105, 169, 33107, 33072, 33109, 32784, 170, 32895, 32892, 33111, 32794, 171, 32870, 32790, 33112, 33072, 172, 32880, 33030, 33073, 173, 32804, 33113, 33093, 174, 32870, 33072, 33115, 175, 32997, 32821, 33118, 176, 32997, 32998, 33120, 177, 33121, 32832, 32834, 178, 32997, 32821, 33120, 179, 32997, 33115, 32955, 32807, 33123, 180, 32997, 33073, 33092, 32955, 32807, 33123, 181, 33124, 32821, 33118, 182, 33111, 33126, 183, 32788, 33111, 32790, 184, 32961, 33130, 32830, 32831, 185, 32997, 33131, 33132, 32861, 186, 33135, 32959, 32821, 33136, 187, 32870, 32957, 33138, 188, 33004, 32830, 32831, 189, 33141, 32830, 32831, 191, 33142, 32821, 33144, 192, 33146, 33008, 32964, 193, 33148, 32995, 32807, 33149, 33111, 194, 33148, 32995, 32807, 33152, 33111, 195, 33154, 32821, 32973, 196, 32788, 33154, 197, 33156, 33157, 32821, 33118, 198, 32804, 33159, 32807, 33161, 33162, 33156, 33072, 199, 33163, 32797, 33156, 33165, 32821, 33026, 200, 33167, 32821, 33161, 33072, 33170, 201, 32870, 33172, 33104, 202, 32870, 33174, 33104, 203, 33176, 33177, 33178, 33136, 33180, 204, 33107, 33177, 33178, 33136, 33180, 205, 33182, 33184, 32784, 206, 32870, 33186, 33188, 207, 32804, 33072, 33113, 32973, 208, 33190, 33072, 32821, 33191, 209, 33193, 33113, 32821, 32973, 210, 33193, 32821, 33118, 211, 33176, 33194, 32784, 212, 33195, 32808, 33177, 32784, 213, 33196, 33199, 214, 32870, 33201, 215, 33101, 33102, 33203, 216, 33205, 32821, 33206, 32807, 33072, 32861, 217, 33208, 32856, 33209, 33210, 218, 32997, 33104, 33070, 32821, 33071, 219, 32997, 32998, 33105, 220, 32870, 33024, 33104, 221, 33211, 33213, 32821, 32849, 222, 32804, 33215, 33072, 223, 32870, 33099, 33085, 224, 32997, 33061, 32830, 33217, 225, 33218, 33220, 33221, 33209, 226, 32823, 33215, 33072, 227, 33101, 33102, 33223, 33225, 228, 33226, 32830, 32831, 229, 32997, 33225, 33228, 33229, 33230, 230, 32997, 33232, 32821, 33118, 231, 32870, 33024, 32807, 33234, 33235, 33236, 232, 33237, 32855, 33213, 33238, 32995, 233, 33104, 256, 32997, 33104, 32821, 32995, 257, 32997, 33104, 32821, 33239, 258, 32788, 32861, 32797, 33241, 33243, 33072, 33245, 33104, 259, 32788, 32861, 32797, 33246, 33072, 260, 32870, 33247, 33249, 261, 33250, 33251, 32830, 33252, 262, 33250, 33210, 263, 32880, 33085, 32797, 33203, 264, 32870, 33253, 33255, 33104, 265, 33256, 33220, 33258, 33120, 33099, 266, 33260, 33072, 32861, 267, 32870, 33159, 33104, 268, 33263, 33154, 32821, 32973, 269, 32788, 32861, 32797, 33265, 33072, 33266, 270, 32870, 33268, 33104, 271, 33256, 33220, 33081, 33220, 33265, 33266, 272, 33270, 32794, 273, 32997, 33104, 33112, 33272, 274, 32997, 32821, 33112, 33272, 275, 32997, 32892, 33210, 276, 32804, 33273, 33274, 32855, 33072, 33277, 277, 33101, 33102, 32977, 33103, 278, 32997, 32995, 32855, 33241, 33250, 279, 33278, 32861, 32797, 33072, 33104, 32855, 33241, 33281, 280, 33205, 33283, 33072, 33177, 32784, 281, 33101, 33102, 33285, 282, 33205, 32821, 32855, 33093, 33064, 283, 33288, 33093, 33289, 284, 33292, 33294, 285, 33296, 33112, 33298, 33104, 286, 33148, 33161, 33265, 33072, 287, 33299, 32998, 33105, 288, 33299, 33104, 33070, 32821, 33071, 289, 33301, 33104, 32821, 33302, 290, 33301, 33104, 32998, 32855, 33303, 291, 33101, 33102, 33305, 292, 33307, 33064, 33210, 293, 33260, 33303, 33308, 32807, 33104, 294, 32788, 32861, 32797, 33309, 295, 33256, 33220, 33310, 32830, 32831, 33072, 296, 33260, 33030, 32807, 32856, 33209, 33104, 297, 33260, 33203, 298, 32804, 33312, 33308, 32855, 33072, 299, 33256, 33220, 33313, 33314, 33316, 300, 33319, 32830, 33252, 301, 33068, 32821, 33120, 302, 33068, 33055, 33120, 303, 33320, 33113, 33093, 32821, 32973, 304, 33322, 33324, 32821, 33326, 305, 32804, 32977, 33103, 306, 33328, 33330, 307, 32788, 32894, 33332, 33333, 33335, 308, 33205, 33337, 33177, 32784, 309, 33101, 33102, 33103, 32995, 310, 33256, 33220, 33338, 33265, 33072, 311, 32823, 33072, 33104, 312, 33101, 33340, 32806, 32807, 33342, 33345, 313, 33346, 33104, 32821, 32855, 33348, 33064, 314, 33348, 33064, 33210, 315, 33350, 33352, 33333, 33352, 316, 33350, 32894, 33353, 33332, 33335, 317, 33354, 33104, 33356, 33220, 33241, 33236, 318, 33354, 33104, 32821, 33358, 32843, 33360, 319, 33256, 33220, 33081, 33245, 33362, 33082, 33363, 33199, 320, 32788, 33174, 32957, 321, 33364, 33201, 322, 33366, 32821, 33014, 323, 33101, 33102, 33203, 324, 33368, 33174, 325, 32946, 33201, 326, 32870, 33023, 32807, 33104, 33174, 327, 32804, 33370, 33371, 328, 32804, 32977, 33326, 329, 32804, 32808, 33326, 330, 32804, 32957, 33373, 33376, 32855, 33378, 331, 33292, 33380, 33210, 332, 32870, 33113, 33093, 333, 33381, 33382, 33384, 33386, 33388, 334, 33389, 33388, 335, 33389, 33392, 33220, 32861, 33253, 33104, 336, 32870, 33353, 33394, 337, 33101, 33102, 32977, 33396, 338, 32870, 33174, 32807, 33398, 339, 33399, 33174, 32964, 340, 33350, 32822, 33246, 33093, 32807, 33400, 33103, 341, 33350, 33401, 33400, 33246, 33285, 342, 33350, 32822, 33403, 33404, 33103, 33093, 343, 33350, 32822, 33406, 33093, 32807, 33404, 33103, 350, 32997, 33104, 32998, 33407, 351, 33409, 33313, 33234, 32784, 352, 33411, 32797, 33412, 32830, 33217, 353, 33301, 33104, 32821, 33407, 354, 33301, 33104, 32998, 33407, 355, 33190, 33209, 32821, 33414, 33333, 33072, 356, 33416, 33418, 32849, 32856, 33209, 33104, 357, 33104, 32821, 32925, 33043, 358, 33148, 33420, 33332, 33333, 33236, 33335, 359, 33101, 33102, 33422, 33424, 33426, 401, 32799, 32801, 402, 33428, 33430, 32945, 33055, 33432, 403, 33434, 33023, 33055, 32964, 404, 33434, 32820, 33055, 32821, 32855, 33026, 33064, 405, 32774, 33055, 32821, 33436, 33438, 33161, 32957, 32820, 406, 32781, 32945, 32784, 407, 32781, 33174, 33439, 32945, 33055, 33440, 32984, 33441, 32945, 408, 32781, 33174, 33442, 33092, 33055, 32982, 32984, 33444, 409, 33446, 33092, 33057, 33448, 32907, 33450, 33430, 410, 33451, 33057, 33453, 33454, 33455, 32807, 33456, 32894, 411, 32870, 32859, 33458, 33460, 33023, 412, 33451, 33453, 33442, 33092, 33055, 32982, 32984, 33444, 415, 33462, 33463, 33464, 33055, 32907, 418, 33466, 32894, 33220, 33161, 33468, 419, 32880, 33470, 32843, 33092, 32797, 33471, 421, 32880, 33085, 32797, 33203, 422, 32880, 33470, 32843, 33092, 32797, 33174, 424, 32952, 33473, 33085, 33026, 425, 33474, 33475, 0 %CONSTINTEGERARRAY LETT(0: 707)=0,%C X'252C3600',X'5FB4B94D',X'597EE000',X'6B7492E5', X'4D65FB80',X'137692CF',X'4B900000',X'092C74DB', X'43600000',X'352E5780',X'494ED4C9',X'4A000000', X'039650F2',X'457EB749',X'66000000',X'4BC472CB', X'492C8000',X'070E10C7',X'53A72000',X'136592CF', X'43600000',X'5F84B943',X'694DF700',X'0324994B', X'67980000',X'4B9657E4',X'137692E5',X'65AE1A00', X'5F300000',X'476439E6',X'2B7439E7',X'533DD2C8', X'6D0E54C3',X'4564A000',X'294DB280',X'1D780000', X'5B7E5280',X'678431CA',X'4D7E4000',X'5FAE986B', X'68000000',X'1F84B943',X'697E4000',X'692E56D3', X'5D0E94DF',X'5C000000',X'4BC617DD',X'4B7694C3', X'694DF700',X'27BD3A47',X'50000000',X'590C52D8', X'5D7E8000',X'672E8000',X'077E596B',X'61A00000', X'497E1280',X'6D2C7A5F',X'64000000',X'47CC764A', X'13768000',X'697DE000',X'590E53CA',X'537674C9', X'4A000000',X'5FAE8000',X'652E7AD9',X'68000000', X'210E50DA',X'492E7A53',X'5D0E94DF',X'5C000000', X'039650F3',X'66000000',X'5F900000',X'5BAC7400', X'652C7AE5',X'674DF700',X'27A652C3',X'5A000000', X'492CD4DD',X'4B200000',X'13761AE8',X'4B7492C8', X'27CDB15F',X'58000000',X'53700000',X'490E9080', X'12786800',X'26A84000',X'47443943',X'47A4B900', X'6B9CA000',X'0F943850',X'4D0EB668',X'094C33DD', X'5F9E94C7',X'66000000',X'4D0D3600',X'252E77D9', X'6BA537DC',X'1376D0D9',X'53200000',X'5B0E53D3', X'5D980000',X'53767A4B',X'43200000',X'67A654DD', X'4E000000',X'27A654DD',X'4E000000',X'2F95F74E', X'610E50DB',X'66000000',X'6195FB53',X'492C8000', X'2B7670E9',X'539CD4CB',X'48000000',X'652CD2E5', X'4B747280',X'67BD3A47',X'50000000',X'67CE7A4B', X'5A000000',X'470D9600',X'2B7652C7',X'5FB4B943', X'4564A000',X'494E7180',X'67A5F94A',X'6195F1CB', X'679DF900',X'268A4A00',X'4394E000',X'5D2CF0E9', X'53B4A000',X'1878E000',X'752E5780',X'0AC20000', X'650DD3CA',X'2649C000',X'067A6000',X'2809C000', X'53743861',X'657E1953',X'43A4A000',X'02992700', X'0219E980',X'02A0277D',X'06000000',X'4394F980', X'2649C400',X'067A6400',X'1838269B',X'02000000', X'617E74E9',X'53B4A000',X'0E09A682',X'067A8000', X'077DB859',X'4BC00000',X'240884AB',X'26000000', X'02906A03',X'1C000000',X'02906993',X'1C000000', X'0290619F',X'26000000',X'10CA0993',X'1C000000', X'10CA019F',X'26000000',X'1B0E9953',X'70000000', X'457EB748',X'1B4E79D3',X'5D380000',X'592CDA00', X'459431D7',X'4BA00000',X'654CF468',X'1D2CF0E9', X'53B4A000',X'674CF700',X'537477E5',X'652C7A00', X'4D7E56C3',X'68000000',X'4D4CB648',X'6F4C9280', X'0D7E56C3',X'68000000',X'6F4C9A50',X'5376D0D9', X'53200000',X'252E12E9',X'53A537DC',X'4D0C7A5F', X'64000000',X'1DAD9600',X'594E92E5',X'43600000', X'436597EF',X'4B200000',X'194E92E5',X'43600000', X'53761AE8',X'1B4DD4DB',X'6B680000',X'494CF4E9', X'66000000',X'4F94B0E9',X'4B900000',X'69443700', X'1D7DCE65',X'4B84B0E9',X'43159280',X'4B253A00', X'492E7180',X'077DB6C2',X'652E3AD3',X'652C8000', X'617D3768',X'2B753A00',X'477DD74B',X'47A4B200', X'0D4D9280',X'436652C3',X'49C80000',X'031C72E7', X'66000000',X'477DD359',X'531E8000',X'24286600', X'0D7E5680',X'27A43A6B',X'66000000',X'67A43A6B', X'66000000',X'67AD3A43',X'4564A000',X'2784B1D3', X'4D4CB900',X'652C77CF',X'5D4E72C8',X'2784B1D3', X'4D4CB966',X'537477DD',X'674E7A4B',X'5DA00000', X'6784B1D3',X'4D4CB900',X'6D0D9ACA',X'4D4D92DD', X'436CA000',X'6784B1D3',X'4D4CB200',X'252C77E5', X'48000000',X'592DD3E9',X'50000000',X'2D0D9ACA', X'672E10E5',X'43A5F900',X'5B4E79D3',X'5D380000', X'671C3653',X'5D380000',X'597CF4C7',X'43600000', X'652E12E9',X'53A537DC',X'537692CF',X'4B900000', X'652C3600',X'67AC59C7',X'654E1A3F',X'67000000', X'477DB859',X'4BC00000',X'477DD9E9',X'43768000', X'2D0E54C3',X'4564A000',X'53980000',X'43700000', X'439650F2',X'0B8EB0D9',X'66000000',X'433692E4', X'5D0DB280',X'1C09A299',X'129A8000',X'594E7A00', X'53A4B680',X'692E56D3',X'5D0E92C8',X'0744375D', X'4B600000',X'497CB980',X'4BC539E8',X'4D4D9280', X'652C77E5',X'48000000',X'137477DB',X'610E94C5', X'59280000',X'492E71E5',X'538697E4',X'252C3200', X'6F953A4A',X'2F953A4A',X'0A708313',X'18280000', X'5DADB14B',X'64000000',X'08286789',X'0AE8A707', X'1E20A000',X'45ACD34B',X'64000000',X'674F5280', X'612E56D3',X'679D37DC',X'214739D3',X'470D8000', X'4B748000',X'690E1280',X'4744375D',X'4B600000', X'297DE000',X'5B0DDC80',X'4D4D92E6',X'36000000', X'4BC539E9',X'66000000',X'1FAE986B',X'68000000', X'470E10C7',X'53A72000',X'12E9E000',X'5F700000', X'431C72E7',X'66000000',X'492E71E5',X'538694DF', X'5C000000',X'43B434D9',X'43159280',X'5F84B700', X'0324994B',X'679CB980',X'09D83D80',X'0D0C74D9', X'53A72000',X'4B9657E5',X'39ADD9E1',X'4B1D3353', X'4B200000',X'692F1A00',X'510E6000',X'477DD359', X'531E94DD',X'4E000000',X'05643756',X'612E56D3', X'69A4B200',X'6784B1D3',X'4D4C70E9',X'537DC000', X'1C90A180',X'0DF11F11',X'1449C4A8',X'470D964B', X'48000000',X'092D92E9',X'4A000000',X'1D7E8000', X'6B74D7E5',X'5B0E9A4B',X'48000000',X'4D7E56C3', X'69A4B200',X'040865A7',X'20086280',X'08080000', X'6F7E55CD',X'5364B980',X'4D4D92E9',X'7384A000', X'42000000',X'5D2EE000',X'1DADB14B',X'64000000', X'652C77E5',X'49980000',X'094E52C7',X'68E431C7', X'4B9E6000',X'6195F84B',X'65A72000',X'6B9CB95D', X'436CA000',X'610E50DB',X'4BA4B900',X'0682A000', X'594DB4E8',X'4BC472CB',X'49980000',X'5B0F14DB', X'6B680000',X'252E77EB',X'651CA000',X'436597EF', X'43747280',X'477DDA65',X'5F600000',X'67A43A4B', X'5B2DDA00',X'090E9080',X'5F739653',X'5D280000', X'290E1280',X'694DB280',X'157C4000',X'292E56D3', X'5D0E94DF',X'5C000000',X'652E3ACB',X'67A4B200', X'572F3BDF',X'65200000',X'610E50DB',X'4BA4B966', X'2B9CB900',X'652CF4E7',X'692E52C8',X'2785F7D8', X'4394B080',X'4DAD9600',X'277EB947',X'4A000000', X'594C5943',X'65C80000',X'5F1552C7',X'68000000', X'597DD380',X'0D0D364B',X'48000000',X'69780000', X'4794B0E9',X'4A000000',X'4BC692E5',X'5D0D8000', X'5D0DB2E6',X'2195F3E5',X'43680000',X'5BAE7A00', X'45280000',X'494CD34B',X'652DDA00',X'4D0C74D9', X'53A532E6',X'592ED2D8',X'69BDE000',X'6B9CB900', X'0D4D92E6',X'67A53658',X'537672E5',X'692C8000', X'4375FA51',X'4B900000',X'6B9CB93D',X'66000000', X'38000000',X'5FBDC000',X'477DD74B',X'47A00000', X'5B7C9280',X'2C680000',X'517D9280',X'676C3658', X'492ED4C7',X'4A000000',X'477C9280',X'03A692DB', X'61A00000',X'652B924B',X'4D4DD280',X'137477DD', X'674E7A4B',X'5DA00000',X'1BAD9A53',X'6164A000', X'20200000',X'5B2DB14B',X'64000000',X'5B2DB14B', X'657436CA',X'27AC59F3',X'67A4B680',X'5F34D2E4', X'4D94B280',X'492E71E5',X'538697E5',X'66000000', X'537492F0',X'077DD359',X'531E94DD',X'4E000000', X'6195F1CB',X'67980000',X'537494ED',X'5326B0D8', X'612E56D3',X'679D37DD',X'66000000',X'1FBDC000', X'53767ACD',X'4D4C74CB',X'5DA00000',X'2785F7D9', X'4B900000',X'4D0D366B',X'65280000',X'197DF853', X'5D380000',X'436530E6',X'1B2DB14B',X'64000000', X'0B769972',X'4D7EB748',X'494E52C7',X'697E5C80', X'4B769953',X'4B980000',X'217D3768',X'4B769972', X'7672A618',X'0828C49D',X'0A000000',X'5B0D3700', X'597C3200',X'0C7A4A25',X'02700000',X'49CDD0DB', X'531C3659',X'72000000',X'290C564A',X'252E3ACB', X'67A4B200',X'24286099',X'18000000',X'5F8694DF', X'5C000000',X'672D92C7',X'692C8000',X'09AE1653', X'470E9280',X'652E3ACB',X'67A00000',X'4D95F680', X'6F4E9453',X'5C000000',X'6195F3E5',X'43680000', X'697E90D8',X'5FB4B96F',X'654E9280',X'594E9A59', X'4A000000',X'53753A53',X'436539CB',X'48000000', X'67A431D6',X'094E52C7',X'697E5C80',X'26282907', X'10212900',X'070DD75F',X'68000000',X'1E10AC80', X'5B0C795E',X'097C7ADB',X'4B768000',X'452D97DD', X'4F980000',X'63ACBACB',X'48000000',X'431E94ED', X'4A000000',X'5D780000',X'254DD380',X'036C54CF', X'6B7EB980',X'172F3BDF',X'65200000',X'09AE1653', X'470E92C8',X'67AC7400',X'67A652C3',X'5A000000', X'5374D7E5',X'5B0E94DF',X'5C000000',X'67AE1859', X'532C8000',X'0828C49D',X'0A6A8000',X'63ACBACA', X'0F95FAE0',X'5B2DB14B',X'65980000',X'470DD75F', X'68000000',X'497DD0E9',X'4A000000',X'4DADD266', X'13767ACD',X'4D4C74CB',X'5DA00000',X'61953B53', X'592CF280',X'512C324B',X'64000000',X'592ED2D9', X'66000000',X'24282200',X'1EAA8000',X'43658000', X'652DB7ED',X'4A000000',X'76098600',X'43947453', X'6D2C8000',X'672D9300',X'597C324B',X'48000000', X'1B0F14DB',X'6B680000',X'074434DC',X'436530E7', X'4B980000',X'6F45F659',X'72000000',X'1FB4B959', X'43866000',X'6194BB53',X'5FAE7672',X'470D9643', X'4564A000',X'672E10E5',X'43A4A000',X'2A98A31F', X'24000000',X'652E3ACB',X'67A66000',X'03255AE7', X'690C564A',X'494DB2DD',X'674DF700',X'6B7439E7', X'533DD2C8',X'039E74CF',X'5D2C8000',X'439E74CF', X'5D2C8000',X'6F4E9400',X'6B8612E4',X'592E7980', X'597EF2E4',X'492C7643',X'652C8000',X'431E9AC3', X'58000000',X'039E7ADB',X'4B200000',X'652E3AD3', X'652E6000',X'590E7A00',X'07443943',X'47A4B900', X'610E50DA',X'5F759C80',X'6D0D94C8',X'0C7A4A7D', X'11F10000',X'67AC59E9',X'654DD380',X'617E74E9', X'537DC000',X'09780000',X'597DF800',X'5374794B', X'5B2DDA00',X'252C7AE5',X'674ED280',X'6195F1CB', X'49AE5280',X'69CE1280',X'4DADD1E9',X'537DC000', X'6B753A00',X'0D0EB668',X'5D7F6000' %INTEGER I,J,K,M,Q,S,UP %STRING(70)OMESS OMESS=" " %FOR I=1,1,WORDMAX-1 %CYCLE -> FOUND %IF N=WORD(I) %REPEAT I=DEFAULT FOUND: J=1 UP=0 %CYCLE K=WORD(I+J) %IF K&X'8000'=0 %THEN %EXIT K=K!!X'8000' OMESS=OMESS." " %UNLESS J=1 %CYCLE M=LETT(K); S=25 %CYCLE Q=M>>S&63; %IF Q=62 %THEN UP=63 %ELSE %START %IF Q\=0 %THEN OMESS=OMESS.TOSTRING(OUTTT(Q+UP)) UP=0 %FINISH S=S-6 %REPEAT %UNTIL S<0 K=K+1 %REPEAT %UNTIL M&1=0 J=J+1 %REPEAT %RESULT=OMESS %END !**END ! %SYSTEMSTRINGFN FAILUREMESSAGE(%INTEGER MESS) %STRING (255) S1, S2, RES %IF SSOWN_SSFNAME -> S1.(".").S2 %AND S1=SSOWN_SSOWNER %THEN SSOWN_SSFNAME = S2 %IF (MESS=178 %AND (SSOWN_SSLASTDFN=25 %OR SSOWN_SSLASTDFN=40 %OR SSOWN_SSLASTDFN=42)) %C %OR (MESS=176 %AND (SSOWN_SSLASTDFN=15 %OR SSOWN_SSLASTDFN=17 %OR SSOWN_SSLASTDFN=36 %OR SSOWN_SSLASTDFN=43)) %C %OR (MESS=174 %AND SSOWN_SSLASTDFN=9) %C %OR (MESS=119 %AND SSOWN_SSLASTDFN=16) %C %OR (MESS=180 %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>31; !IF NEGATIVE ROOT THEN STOP REQUESTED %IF SSOWN_INHIBITPSYSMES # 0 %AND STOP = 0 %THEN %RETURN !SSFOFF HAS BEEN CALLED SUPPRESS FAILURE MESSAGES !UNLESS CATASTROPHIC FAILURE ROOT = IMOD(ROOT); ! This fails for ROOT=X'80000000', but ! ROOT = IMOD(ROOT<<1)>>1 would work better, if that situation were expected. %IF SSOWN_SSFNAME -> P1.(".").P2 %AND P1=SSOWN_SSOWNER %THEN SSOWN_SSFNAME = P2 %IF LENGTH(SSOWN_SSFNAME)>2 %C %AND CHARNO(SSOWN_SSFNAME,1)='T' %C %AND CHARNO(SSOWN_SSFNAME,2)='#' %C %THEN LENGTH(SSOWN_SSFNAME) = LENGTH(SSOWN_SSFNAME) - 1 !REMOVE PROCESS SUFFIX %IF 1 <= ROOT <= MAXROOT %C %THEN PRINTSTRING(" ".ROOTNAME(ROOT)." fails - ") %C %ELSE PRINTSTRING(" Failure: ") %AND WRITE(ROOT,1) %C %AND SPACES(3) PRINTSTRING(FAILUREMESSAGE(MESS)) %IF STOP # 0 %START; !MONITOR AND STOP ! **** **** Can we change this so that the action can be **** **** ! **** **** specified by the user, and leave %MONITOR **** **** ! **** **** and %STOP as the default action? Perhaps we **** **** ! **** **** could signal some event which the user can **** **** ! **** **** trap. **** **** ! **** **** We can't afford to %RETURN, as there will be **** **** ! **** **** many bits of code which call PSYSMES **** **** ! **** **** expecting a %STOP. **** **** %MONITOR SSOWN_SSCOMREG(10) = 1; !FOR JCL %STOP %FINISH %END; !OF PSYSMES %SYSTEMROUTINE SETFNAME(%STRING (40) NAME) !ALLOWS SSOWN_SSFNAME TO BE SET FROM EXTERNAL PROCEDURE - E.G. EDITOR SSOWN_SSFNAME = NAME %END; !OF SETFNAME %SYSTEMROUTINE SSMESS(%INTEGER N) SSOWN_SSFNAME = "" PRINTSTRING(FAILUREMESSAGE(N)) NEWLINES(2) %END; ! SSMESS !* %SYSTEMROUTINE SSMESSA(%INTEGER N, %STRING (63) A) SSOWN_SSFNAME = A PRINTSTRING(FAILUREMESSAGE(N)) %END; ! SSMESSA ! ! - END OF SMES CODE ] ! ! [ START OF NDIAG CODE - ! ! NDIAG EXTENDED 02-09-80 TO PROVIDE FOR PASCAL, FORTRAN 77 AND SIMULA DIAGNOSTICS ! EXTENDED FOR ALGOLE(60) WITH EBCDIC STRING !INCORPORATES CODE FOR NEW FORTRAN DIAGNOSTICS !INCLUDES ICL MATHS ROUTINE ERROR ROUTINE !INCLUDES CORRECTION FOR FAULT AT THE END OF ONCOND. R.M.1/12/77 !REFS TO WRITE JS VAR COMMENTED OUT !IMP AND ALGOL SECTION REPLACED 13.4.78 !* !* !* %ROUTINESPEC INDIAG(%INTEGER OLDLNB, LANG, PCOUNT, MODE, DIAG, %C ASIZE, %INTEGERNAME FIRST, NEWLNB) %ROUTINESPEC ERMESS(%INTEGER N, INF) %INTEGERFNSPEC WTFAULT(%INTEGER INF) ! FAULT EVENT MESSAGE ! 1 (1/2) REAL OVERFLOW ! 2 (0/0) REAL UNDERFLOW ! 3 (1/1) INTEGER OVERFLOW ! 4 (0/0) DECIMAL OVERFLOW ! 5 (1/3) ZERO DIVIDE ! 6 (6/2) ARRAY BOUNDS EXCEEDED ! 7 (6/1) CAPACITY EXCEEDED ! 8 (0/0) ILLEGAL OPERATION ! 9 (0/0) ADDRESS ERROR ! 10 (0/0) INTERRUPT OF CLASS ! 11 (8/1) UNASSIGNED VARIABLE ! 12 (F/1) TIME EXCEEDED ! 13 (F/2) OUTPUT EXCEEDED ! 14 (F/3) OPERATOR TERMINATION ! 15 (5/5) ILLEGAL EXPONENT ! 16 (5/4) SWITCH LABEL NOT SET ! 17 (0/0) CORRUPT DOPE VECTOR *** NO LONGER USED***** ! 18 (5/1) ILLEGAL CYCLE ! 19 (1/7) INT PT TOO LARGE ! 20 (5/6) ARRAY INSIDE OUT ! 21 (0/0) NO RESULT ! 22 (0/0) PARAM NOT DESTINATION ! 23 (2/1) PROGRAM TOO LARGE ! 24 (0/0) STREAM NOT DEFINED ! 25 (9/1) INPUT ENDED ! 26 (4/1) SYMBOL IN DATA ! 27 (0/0) IOCP ERROR *** NOT USED ON EMAS VMEB???***** ! 28 (3/1) SUB CHARACTER IN DATA ! 29 (0/0) STREAM IN USE ! 30 (B/1) GRAPH FAULT ! 31 (0/0) DIAGNOSTICS FAIL ! 32 (7/1) RESOLUTION FAULT ! 33 (0/0) INVALID MARGINS ! 34 (4/2) SYMBOL INSTEAD OF STRING ! 35 (0/0) STRING INSIDE OUT ! 36 (0/0) WRONG PARAMS PROVIDED ! 37 (0/0) UNSATISFIED REFERENCE ! 38 (8/2) Unassigned switch variable ! 39 (0/0) Failure No. 39 ! 40 (0/0) Failure No. 40 ! 41 (0/0) Failure No. 41 ! 42 (0/0) Failure No. 42 ! 43 (0/0) Failure No. 43 ! 44 (0/0) Failure No. 44 ! 45 (0/0) Failure No. 45 ! 46 (0/0) Failure No. 46 ! 47 (0/0) Failure No. 47 ! 48 (0/0) Failure No. 48 ! 49 (0/0) Failure No. 49 ! 50 (5/2) SQRT ARG NEGATIVE ! 51 (5/3) LOG ARG NEGATIVE ! 52 (5/3) LOG ARG ZERO ! 53 (1/6) EXP ARG OUT OF RANGE ! 54 (1/4) SIN ARG OUT OF RANGE ! 55 (1/4) COS ARG OUT OF RANGE ! 56 (1/4) TAN ARG OUT OF RANGE ! 57 (1/4) TAN ARG INAPPROPRIATE ! 58 (0/0) ASIN ARG OUT OF RANGE ! 59 (0/0) ACOS ARG OUT OF RANGE ! 60 (0/0) ATAN2 ARGS ZERO ! 61 (0/0) SINH ARG OUT OF RANGE ! 62 (0/0) COSH ARG OUT OF RANGE ! 63 (0/0) LGAMMA ARG NOT POSITIVE ! 64 (0/0) LGAMMA ARG TOO LARGE ! 65 (0/0) GAMMA ARG OUT OF RANGE ! 66 (1/4) COT ARG OUT OF RANGE ! 67 (1/4) COT ARG INAPPROPRIATE ! 68 (0/0) REAL EXPONENTIATION FAULT ! 69 (0/0) COMPLEX EXPONENTIATION FAULT ! 70 (A/6) RADIUS ARGS TOO LARGE ! 71 (A/3) ARCTAN ARGS ZERO ! 72 (A/1) ARCSIN ARG OUT OF RANGE ! 73 (A/2) ARCCOS ARG OUT OF RANGE ! 74 (A/4) HYPSIN ARG OUT OF RANGE ! 75 (A/5) HYPCOS ARG OUT OF RANGE ! 76 (A/7) Matrix bound zero or negative %ROUTINE TRANS(%INTEGERNAME FAULT, EVENT, SUBEVENT) !*********************************************************************** !* TRANSLATE FAULT TO EVENT & VICE VERSA * !*********************************************************************** %CONSTINTEGER MAXFAULTS=76 %CONSTBYTEINTEGERARRAY FTOE(0:MAXFAULTS)= %C 0,X'12',0,X'11',0,X'13',X'62',X'61',0(3), X'81',X'F1',X'F2',X'F3',X'55',X'54', 0,X'51',X'17',X'56',0(2),X'21',0, X'91',X'41',0,X'31',0,X'B1',0,X'71', 0,X'42',0(3),X'82',0(11),X'52',X'53',X'53',X'16', X'14'(4),0(8),X'14'(2),0(2), X'A6',X'A3',X'A1',X'A2',X'A4',X'A5',X'A7' %INTEGER K,J %IF FAULT=0 %THEN %START; ! EVENT-SUBEVENT GIVEN J=EVENT<<4+SUBEVENT ! %RETURN %IF J=0; ! %MONITOR ! %FOR K=MAXFAULTS,-1,1 %CYCLE ! %IF J=FTOE(K) %THEN FAULT=K %AND %RETURN ! %REPEAT ! ! **** **** Machine code equivalent follows: **** **** ! %RETURN %UNLESS 0 *STD_%TOS *LSS_%TOS *ISB_FTOE+4 *ST_(FAULT) MISSED: ! **** **** End of machine code **** **** ! %FINISH %ELSE %START %IF 1<=FAULT<=MAXFAULTS %START K=FTOE(FAULT) EVENT=K>>4; SUBEVENT=K&15 %FINISH %FINISH %END %ROUTINE PRHEX(%INTEGER VALUE) ! %INTEGER I ! %FOR I=28,-4,0 %CYCLE ! PRINT SYMBOL(HEX(VALUE>>I&15)) ! %REPEAT ! **** **** Machine code equivalent: **** **** ! %STRING (8) S %LONG %INTEGER DH *LD_S *LSS_8 *UCP_0 *ST_(%DR) *MODD_1 *STD_DH *LUH_VALUE *SUPK_%L=8 *LSS_HEX+4 *ISB_240 *LUH_X'18000100' *LD_DH *TTR_%L=8 PRINT STRING (S) ! ! **** **** End of machine code **** **** ! %END %ROUTINE ASSDUMP(%INTEGER PCOUNT, OLDLNB) %INTEGER I PRINTSTRING(" PC =") PRHEX(PCOUNT) PRINTSTRING(" LNB =") PRHEX(OLDLNB) PRINTSTRING(" CODE ") NCODE(PCOUNT-64,PCOUNT+64,PCOUNT-64) %IF STUDENTSS=0 %THEN %START PRINTSTRING(" GLA ") I=INTEGER(OLDLNB+16) CXDUMP(I,I+128,3) PRINTSTRING(" STACK FRAME ") CXDUMP(OLDLNB,OLDLNB+256,3) %FINISH %END %ROUTINE ONCOND(%INTEGER EVENT, SUBEVENT, LNB) !*********************************************************************** !* UNWIND THE IMP STACK LOOKING FOR ON CONDITIONS * !* There is only one call of ONCOND - it is in NDIAG. * !*********************************************************************** %LONGREAL INFO %INTEGER GLAAD, LANG, TSTART, BIT, ONWORD, PREVLNB, I, STSTART, %C STSEG %UNLESS 1<=EVENT<=14 %THEN %RETURN BIT=1<<(EVENT+17) *LSS_(%LNB+0); *ST_PREVLNB %CYCLE I = INTEGER (PREVLNB) & X'FFFFFFFC' %EXIT %UNLESS LNB>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, ! 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,; ! 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,; ! 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, %RETURN; ! if VALidate fails. TSTOK: I=INTEGER(TSTART+12)>>24; ! LENGTH OF NAME ! Why not BYTE INTEGER (TSTART+12)? This line and the next ! could be reduced to I = BYTE INTEGER(TSTART+12)&(-4) + 16. I=I>>2<<2+16 ONWORD=INTEGER(TSTART+I) %IF ONWORD&BIT#0 %THEN -> HIT %EXIT %IF INTEGER(TSTART+12)#0; !ROUTINE TSTART=INTEGER(TSTART+4)&X'FFFF';!ENCLOSING BLOCK ! Presumably that is supposed to be quicker than ! HALF INTEGER (TSTART+6). %REPEAT PREVLNB=LNB LNB=INTEGER(LNB) %REPEAT %RETURN HIT: ! ON CONDITION FOUND ! If here and SSOWN_RCODE is 103050709 then we have arrived via the ! ENTERONUSERSTACK trap. Since we have found an %ON %EVENT trap prepared ! to deal with the contingency then SSOWN_RCODE can be reset to 0 %IF SSOWN_RCODE=103050709 %THEN SSOWN_RCODE=0 I=INTEGER(TSTART)&X'FFFF'; ! LINE NOS WORD %IF I#0 %THEN I=INTEGER(LNB+I) INTEGER(ADDR(INFO))=EVENT<<8!SUBEVENT INTEGER(ADDR(INFO)+4)=I SIGNAL(1,0,0,I) ! AMEND EXIT DESCRIPTOR OF NEXT LEVEL ! TO ENSURE ACS=2 AND PRCL UNSTACKS ! CORRECTLY IF RELEVANT INTEGER(PREVLNB)=(LNB&X'FFFFFFFE')!(INTEGER(PREVLNB)&1) INTEGER(PREVLNB+4)=INTEGER(PREVLNB+4)&(-4)!X'12' ! ACS=2 INTEGER(PREVLNB+8)=INTEGER(GLAAD+ONWORD&X'3FFFF') SSOWN_ACTIVE=0 *LSD_INFO; ! INFO FOR THE ON SEQUENCE *LLN_PREVLNB; ! LNB TO RT AFTER EXIT RT *EXIT_-64; ! PRESERVING ACC SIZE %END !* !* %ROUTINE CALL DIAGS(%INTEGER OLDLNB, PC, ASIZE, %INTEGERNAME FIRST, NEWLNB, %C %INTEGER LF) ! This routine simply passes on the parameters (less LANGFLAG) to ! PDIAG or SDIAG. ! ! %CONSTSTRING (10) %ARRAY LD (7:10) = %C ! "S#PDIAG", "S#SDIAG", "", "S#F77DIAG" ! As far as I can see, CALL DIAGS can only be called with LF=7 ! (PASCAL) or 8 (SIMULA) - so we only need: %CONST %STRING (7) %ARRAY LD (7:8) = "S#PDIAG", "S#SDIAG" %INTEGER DR0, DR1, A, FLAG, TYPE %STRING (1) DUMMY %LONG %INTEGER %NAME DESC %IF NEWLOADER=0 %THEN %START FINDENTRY(LD(LF),0,0,DUMMY,DR0,DR1,FLAG) %IF FLAG # 0 %THEN %START PRINTSTRING(LD(LF)." NOT LOADED") NEWLINE %STOP %FINISH %FINISH %ELSE %START DESC==LONGINTEGER(ADDR(DR0)) TYPE=CODE DESC=LOOKLOADED(LD(LF),TYPE) %IF DESC=0 %THEN %START PRINTSTRING(LD(LF)." NOT LOADED") NEWLINE %STOP %FINISH %FINISH A = ADDR(OLDLNB) *PRCL_4 *LSQ_(%LNB+5) *SLSD_(%LNB+9) *SLSS_(%LNB+11) *ST_%TOS *LD_DR0 *RALN_12 *CALL_(%DR) %END ! ! %SYSTEMROUTINE NDIAG(%INTEGER PCOUNT, LNB, FAULT, INF) !*********************************************************************** !* 'MASTER DIAGNOSTIC ROUTINE'. DISCOVERS THE LANGUAGE OF THE * !* FAILED ROUTINE FROM WORD 4 OF THE GLA AND CALLS APPROPRIATE * !* DIAGNOSTIC ROUTINE. THIS IS REPEATED TILL ALL DIAGNOSTICS * !* GIVEN. * !* PCOUNT = PCOUNTER AT FAILURE * !* LNB = LOCAL NAME BASE AT FAILURE * !* FAULT = FAILURE (0=%MONITOR REQUESTED) * !* INF =ANY FURTHER INFORMATION * !*********************************************************************** ! Nothing in NDIAG changes the value of INF. %INTEGER LF, I, J, GLA, OLDLNB, NEWLNB, EVENT, SUBEVENT, %C CONTFLAG %INTEGER PREASON %LONGINTEGER JJ %SWITCH LGE(0:10) %CONSTINTEGER MAXLANGUAGE = 10 %STRING (20) FAILNO CONTFLAG = 0 ! LAY DOWN A CONTINGENCY !AGAINST ERRORS IN NDIAG I=0 ! **** **** Perhaps we should validate PCOUNT. **** **** *STLN_OLDLNB *JLK_3 *J_; !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, 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, ! 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,; ! 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,; ! but we'll risk it if it's read-write. NSG: LF = 0 -> LSD ! SG: LF = INTEGER(GLA + 16) >> 24 LF=0 %IF LF>MAXLANGUAGE LSD: %IF PREASON#0 %THEN %START PREASON = 0 SUBEVENT=0; EVENT=FAULT>>8 %IF 400<=FAULT<=500 %THEN %START ERMESS (FAULT,INF) NEWLINE %FINISH %ELSE %START %IF 50<=FAULT<=76 {Error reported by Maths. function} %C %THEN CONTFLAG = 2 %C %ELSE %IF FAULT=10 {Interrupt} %C %THEN %START { INF has the "weight" or "class", which is the same as { the PE number for Program Error interrupts. Only { Program Error interrupts are reported by this route - { others have nothing to do with the program and are { handled by other parts of the system - but a few other { faults which do not involve real interrupts are reported { as "simulated" interrupts with class numbers which are { impossible as Program Error numbers, and this code can { cope with those. FAULT = WTFAULT (INF) { Convert "class" or "weight" to a "Fault { number", which is also the number for { the appropriate error message. CONTFLAG = 1 %FINISH %IF 7#LF#8 %THEN %START { i.e., not for PASCAL or SIMULA} { If the FAULT parameter is >= 256, it consists of an { event number in the top 24 bits and a subevent number { in the bottom eight bits. We have already extracted { the event number, so we pick up the subevent number. { Then we clear FAULT, so that TRANS will convert the { event and subevent numbers into a 'proper' fault number { which will yield an appropriate error message. %IF FAULT>=256 %THEN %START SUBEVENT = FAULT & 255 FAULT = 0 %FINISH TRANS (FAULT,EVENT,SUBEVENT) { Ensures that FAULT, EVENT { and SUBEVENT are all set { to define the same occurrence. ONCOND(EVENT,SUBEVENT,LNB) %UNLESS FAULT=0=EVENT %THEN SSOWN_SSCOMREG(10)=1; !FOR USE BY JCL %FINISH SSOWN_FIRST = 1 %IF FAULT>=0 %THEN %START %IF FAULT=0 %AND EVENT#0 %START PRINTSTRING(" MONITOR ENTERED ") PRINTSTRING("EVENT"); WRITE(EVENT,1) PRINTSYMBOL('/'); WRITE(SUBEVENT,1) %FINISH %ELSE %START %IF FAULT#0 %THEN SELECT OUTPUT(99); !DONT SELECT IF JUST CALL OF %MONITOR %IF LF = 7 %OR LF = 8 %THEN %START SSOWN_FIRST = -1 CALL DIAGS(CONTFLAG,INF,FAULT,SSOWN_FIRST,NEWLNB,LF) SSOWN_FIRST = 1 %FINISH %ELSE %START ERMESS(FAULT,INF) %FINISH %FINISH NEWLINE %FINISH %ELSE EVENT=0 %FINISH %FINISH ->LGE(LF) LGE(0): LGE(4): ! UNKNOWN & ASSEMBLER LGE(6): ! OPTCODE LGE(9): ; !BCPL PRINTSTRING(" NO DIAGNOSTICS FOR CALLING PROCEDURE ") ASSDUMP(PCOUNT,OLDLNB) NEWLNB = INTEGER (OLDLNB) -> IMPJOIN LGE(7):; ! PASCAL. LGE(8):; ! SIMULA. CALL DIAGS(OLDLNB,PCOUNT,SSOWN_SSARRAYDIAG,SSOWN_FIRST,NEWLNB,LF) -> IMPJOIN LGE(2): ! FORTRAN LGE(10): ! FORTRAN 77. FDIAG (OLDLNB, PCOUNT, 0, 4, SSOWN_SSARRAYDIAG, SSOWN_FIRST, NEWLNB) %IF NEWLNB=0 %THEN ->EXIT PCOUNT=INTEGER(INTEGER(OLDLNB)+8)-4 ->NEXT RTF ! ! ! LGE(1): LGE(3): ! IMP & IMPS LGE(5): ! ALGOL 60 INDIAG(OLDLNB,LF,PCOUNT,0,2,SSOWN_SSARRAYDIAG,SSOWN_FIRST, %C NEWLNB) ! IMP DIAGS IMPJOIN: %IF NEWLNB=0 %THEN ->EXIT PCOUNT=INTEGER(OLDLNB+8); ! CONTINUE TO UNWIND STACK NEXTRTF: %IF LF=7 %AND OLDLNB&X'FFFFFFFC'=NEWLNB&X'FFFFFFFC' %THEN -> SKIPC36 -> EXIT %IF OLDLNB&X'FFFFFFFC'=SSOWN_SSCOMREG(36) %OR (OLDLNB!!NEWLNB)>>SEGSHIFT#0 ! FAR ENOUGH SKIPC36: OLDLNB=NEWLNB %REPEAT ! ! MDERROR: ! ENTER FROM CONTINGENCY *ST_JJ; ! DESCPTR TO IMAGE STORE J<-JJ; ! GET ADDRESS FROM DESCRIPTOR PRINTSTRING(" INTERRUPT DURING DIAGNOSTICS WT= ") WRITE(INTEGER(J),3) ASSDUMP(INTEGER(J+16),OLDLNB) ->QUIT EOUT: ! ERRROR EXIT PRINTSTRING(" NDIAG FAILS ".FAILNO." ") SSOWN_ACTIVE=0 -> QUIT EXIT: SIGNAL(1,0,0,I); ! POP UP CONTINGENCY SSOWN_ACTIVE=0 %IF FAULT=0=EVENT %THEN ->END ! %IF COMREG(27)&X'400000'#0 %THEN -> END ! FTRAN ERROR RECOV QUIT: %IF NEWLOADER#0 %THEN %START %IF SSOWN_LOADINPROGRESS#0 %THEN %START UNLOAD2 (1,1) SSOWN_LOADINPROGRESS = 0 %FINISH %FINISH %STOP END: %END; ! OF NDIAG !! ! LAYOUT OF DIAGNOSIC TABLES !****** ** ********* ****** ! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF ! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE ! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED. ! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY ! FIRST WORD IN THE SST). ! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL ! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT ! FORM OF THE TABLES:- ! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB) ! WORD 1 = (12 LANG DEPENDENT BITS)<<20 ! ENVIRONMENT ! (TOP 2 BITS FOR ROUTINE TYPE.B'01'==SYSTEM ROUTINE) ! (NEXT BIT SET FOR EBCDIC CHARS&STRINGS(ALGOLE ONLY)) ! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO ! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE ! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED ! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC ! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY ! A WORD OF X'FFFFFFFF' ! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY ! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF ! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT ! BIT 2**19 =0 UNDER LNB =1 IN GLA ! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES ! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST ! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS ! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN ! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS. !! %SYSTEMROUTINE INDIAG(%INTEGER OLDLNB, LANG, PCOUNT, MODE, %C DIAG, ASIZE, %INTEGERNAME FIRST, NEWLNB) !*********************************************************************** !* THE DIAGNOSTIC ROUTINE FOR IMP %AND ALGOL(LANG=5) * !* THE ALGOL SYMBOL TABLES ARE SET UP AS FOR IMP * !* MODE = 0 FOR JOBBER&EMAS2900, =1 FOR OPEH IN VMEB&VMEK * !* DIAG = DIAGNOSTIC LEVEL * !* 1 = ROUTE SUMMARY ONLY (ASIZE)=ADDR MODULE NAME FROM OPEH * !* 2 = DIAGNOSTICS AS TRADITIONALLY PERFORMED * !* ASIZE IS NO OF ELEMENTS OF EACH ARRAY TO BE PRINTED(DIAG>1) * !*********************************************************************** %RECORDFORMAT F(%INTEGER VAL, %STRING (11) VNAME) %ROUTINESPEC PLOCALS(%INTEGER ADATA, %STRING (15) LOC) %ROUTINESPEC PSCALAR(%RECORD(F)%NAME VAR) %ROUTINESPEC PARR(%RECORD(F)%NAME VAR, %INTEGER ASIZE) %ROUTINESPEC PVAR(%INTEGER TYPE, PREC, NAM, LANG, FORM, %C VADDR) %INTEGERFNSPEC CKREC(%STRING(50) NAME); ! CHECK RECURSION %INTEGER GLAAD, FLINE, NAM, TYPE, PREC, TSTART, PREV BLK, %C WORD0, WORD1, WORD2, WORD3, I %INTEGER INHIBIT %STRING (10) STMNT %STRING (20) PROC %STRING (50) NAME %INTEGER COUNT; ! Used in checking for recursion. %CONSTINTEGER ALGOL=5; ! LANGUAGE CODE *MPSR_X'000040C0'; ! Mask underflow %IF FIRST=1 %THEN %START SSOWN_GLOBPTR=0 COUNT = 0 %FINISH OLDLNB = OLDLNB & X'FFFFFFFC' ! **** **** Should we VALidate OLDLNB and GLAAD? **** **** %IF LANG#ALGOL %THEN %START STMNT=" LINE" PROC=" ROUTINE/FN/MAP " %FINISH %ELSE %START STMNT=" STATEMENT" PROC=" PROCEDURE " %FINISH GLAAD=INTEGER(OLDLNB+16); ! ADDR OF GLA/PLT TSTART=INTEGER(OLDLNB+12)&X'FFFFFF'; ! Extracts bound of PLT descriptor. ! The next statement seems to assume that the bound of the PLT ! descriptor is zero for a routine in the basefile. %IF TSTART=0 %THEN %START %IF PCOUNT PRINT STRING%C ("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>16=0 %THEN %START %IF MODE=0 %THEN PRINTSTRING(LT(LANG)) PRINTSTRING("ENVIRONMENTAL BLOCK ") %FINISH %ELSE %START %IF FLINE>=0 %AND FLINE#WORD0>>16 %THEN %START PRINTSTRING(STMNT) WRITE(FLINE,4) PRINTSTRING(" OF") %FINISH %IF WORD3=0 %THEN PRINTSTRING(" BLOCK") %C %ELSE PRINT STRING(PROC.NAME) PRINTSTRING(" STARTING AT".STMNT) WRITE(WORD0>>16,2) %IF MODE=1 %AND DIAG=1 %THEN %START PRINTSTRING("(MODULE ".STRING(ASIZE).")") %FINISH NEWLINE %IF LANG#ALGOL %THEN I=20 %ELSE I=16 %IF MODE=0 %OR DIAG>1 %THEN %START PLOCALS(TSTART+I+(WORD3>>26)<<2,"LOCAL") %IF WORD1&X'C0000000'#0 %THEN %START ! EXTERNAL(ETC) ROUTINE I=WORD1&X'3FFFF'+INTEGER(GLAAD+12)+I PLOCALS(I,"GLOBAL") %FINISH %FINISH %FINISH %FINISH %IF WORD3#0 %START NEWLNB=INTEGER(OLDLNB) %UNLESS DIAG = 1 %OR INHIBIT=1 %THEN NEWLINE %RETURN %FINISH PREV BLK=WORD1&X'FFFF' TSTART=PREV BLK %REPEAT %UNTIL PREVBLK=0 NEWLNB=0 NEWLINE %RETURN %ROUTINE QSORT(%RECORD(F)%ARRAYNAME A, %INTEGER I, J) %RECORD (F)D %INTEGER L, U %IF I>=J %THEN %RETURN L = I - 1; U = J; D = A(J) %CYCLE %CYCLE L = L+1 {%EXIT outer loop} %IF L=U %THEN -> FOUND %REPEAT %UNTIL A(L)_VNAME>D_VNAME A(U) = A(L) %CYCLE U = U-1 {%EXIT outer loop} %IF L=U %THEN -> FOUND %REPEAT %UNTIL D_VNAME>A(U)_VNAME A(L) = A(U) %REPEAT FOUND: A(U) = D QSORT(A,I,L-1) QSORT(A,U+1,J) %END !* %INTEGERFN CKREC(%STRING(50) NAME); ! CHECK RECURSION !******************************************************** !* AVOID PRINTING TRACE OF RECURSING RTS * !******************************************************** %IF SSOWN_LASTNAME=NAME %START COUNT=COUNT+1 %IF COUNT=6 %THEN PRINTSTRING(" **** ".NAME." CONTINUED TO RECURSE **** ") %RESULT=1 %IF COUNT>5 %FINISHELSESTART %IF COUNT>6 %THEN %START PRINTSTRING("**** (FOR A FURTHER ") WRITE(COUNT-6,1) PRINTSTRING(" LEVEL") %IF COUNT>7 %THEN PRINTSYMBOL('S') PRINTSTRING(") **** ") %FINISH COUNT=0 SSOWN_LASTNAME=NAME %FINISH %RESULT=0 %END %ROUTINE PLOCALS(%INTEGER ADATA, %STRING (15) LOC) !*********************************************************************** !* ADATA POINTS TO THE FIRST ENTRY FOR LOCALS IN THE SYMBOL TABLES* !*********************************************************************** %INTEGER I, NRECS, SADATA %IF LOC="GLOBAL" %THEN %START I=0 %WHILE I0 %CYCLE NRECS=NRECS+1 ADATA=ADATA+8+BYTE INTEGER(ADATA+4)&(-4) %REPEAT %RETURN %IF NRECS=0 %BEGIN %RECORD(F)%ARRAY VARS(1:NRECS) %INTEGER I ADATA=SADATA %FOR I=NRECS,-1,1 %CYCLE VARS(I)<-RECORD(ADATA) ADATA=ADATA+8+BYTEINTEGER(ADATA+4)&(-4) %REPEAT QSORT(VARS,1,NRECS) %FOR I=1,1,NRECS %CYCLE %IF VARS(I)_VAL>>28&3=0 %THEN PSCALAR(VARS(I)) %REPEAT %IF ASIZE>0 %THEN %START %FOR I=1,1,NRECS %CYCLE %IF VARS(I)_VAL>>28&3#0 %THEN PARR(VARS(I), %C ASIZE) %REPEAT %FINISH %END %END %ROUTINE PSCALAR(%RECORD(F)%NAME VAR) !*********************************************************************** !* OUTPUT THE NEXT VARIABLE IN THE CURRENT BLOCK. * !* A VARIABLE ENTRY IN THE TABLES IS:- * !* FLAG<<20!VBREG<<18!DISP * !* WHERE:- * !* VBREG IS VARIABLE'S BASE REGISTER, DISP IS IT'S OFFSET * !* AND FLAGS=NAM<<6!PREC<<3!TYPE * !*********************************************************************** %INTEGER I, K, VADDR, F %STRING (11) LNAME I=VAR_VAL K=I>>20 TYPE=K&7 PREC=K>>4&7 NAM=K>>10&1 LNAME<-VAR_VNAME." " PRINT STRING(LNAME."=") %IF I&X'40000'=0 %THEN VADDR=OLDLNB %ELSE VADDR=GLAAD VADDR=VADDR+I&X'3FFFF' %IF TYPE=3=PREC {record} %THEN F=16 %ELSE F=0 PVAR(TYPE,PREC,NAM,LANG,F,VADDR) NEWLINE %END %ROUTINE PVAR(%INTEGER TYPE, PREC, NAM, LANG, FORM, VADDR) !*********************************************************************** !* OUTPUT A VARIABLE. FIXED FORMAT(FORM#0) TAKE 14 PLACES FOR * !* VARIABLES UP TO 32 BITS AND 21 PLACES THEREAFTER * !* For records FORM is size in bytes * !*********************************************************************** %INTEGER K, I, J, DTOPHALF %STRING(255) EBCDIC %CONSTINTEGER UNASSI=X'81818181' %SWITCH INTV, REALV(3:7) ! USE VALIDATE HERE TO CHECK ACCESS *LDTB_X'18000010' *LDA_VADDR *VAL_(%LNB+1) *JCC_3, 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, %IF TYPE=3=PREC %THEN FORM=DTOPHALF&X'0000FFFF' %FINISH ->ILL ENT %IF PREC<3; ! BITS NOT IMPLEMENTED %IF TYPE=1 %THEN ->INTV(PREC) %IF TYPE=2 %THEN ->REALV(PREC) %IF TYPE=3 %AND PREC=3 %THEN ->RECORD %IF TYPE=3 %AND PREC=5 %THEN ->BOOL %IF TYPE=5 %THEN ->STR INTV(4): ! 16 BIT INTEGER K=BYTEINTEGER(VADDR)<<8!BYTEINTEGER(VADDR+1) ->NOT ASS %IF K=UNASSI>>16 WRITE(K,12*FORM+1) %RETURN INTV(7): ! 128 BIT INTEGER REALV(3): ! 8 BIT REAL REALV(4): ! 16 BIT REAL ILL ENT: ! SHOULD NOT OCCURR PRINTSTRING("UNKNOWN TYPE OF VARIABLE") %RETURN INTV(5): ! 32 BIT INTEGER ->NOT ASS %IF INTEGER(VADDR)=UN ASSI WRITE(INTEGER(VADDR),1+12*FORM) %UNLESS LANG=ALGOL %OR FORM=1 %OR -255<=INTEGER(VADDR)<=255 %START PRINTSTRING(" (X'") PRHEX(INTEGER(VADDR)); PRINTSTRING("')") %FINISH %RETURN INTV(3): ! 8 BIT INTEGER WRITE(BYTEINTEGER(VADDR),1+12*FORM); %RETURN REALV(5): ! 32 BIT REAL ->NOT ASS %IF INTEGER(VADDR)=UN ASSI PRINT FL(REAL(VADDR),7) %RETURN INTV(6): ! 64 BIT INTEGER ->NOT ASS %IF UN ASSI=INTEGER(VADDR)=INTEGER(VADDR+4) PRINTSTRING("X'") PRHEX(INTEGER(VADDR)); SPACES(2) PRHEX(INTEGER(VADDR+4)) PRINTSYMBOL('''') %RETURN REALV(6): ! 64 BIT REAL ->NOT ASS %IF UNASSI=INTEGER(VADDR)=INTEGER(VADDR+4) PRINT FL(LONG REAL(VADDR),14) %RETURN REALV(7): ! 128 BIT REAL ->NOT ASS %IF UNASSI=INTEGER(VADDR)=INTEGER(VADDR+4) PRINT FL(LONGREAL(VADDR),14) %IF FORM=0 %THEN %START PRINTSTRING(" (R'"); PRHEX(INTEGER(VADDR)) PRHEX(INTEGER(VADDR+4)) SPACE; PRHEX(INTEGER(VADDR+8)) PRHEX(INTEGER(VADDR+12)) PRINTSTRING("')") %FINISH %RETURN RECORD: ! Record, Print 1st FORM (max 16) bytes meantime ->NOT ASS %IF UNASSI=INTEGER(VADDR)=INTEGER(VADDR+4) PRINTSTRING(" X'"); PRHEX(INTEGER(VADDR)) %IF FORM=0 %OR FORM>4 %THEN PRHEX(INTEGER(VADDR+4)) %IF FORM=0 %OR FORM>8 %THEN SPACE %AND PRHEX(INTEGER(VADDR+8)) %IF FORM=0 %OR FORM>12 %THEN PRHEX(INTEGER(VADDR+12)) PRINTSTRING("'") %RETURN BOOL: ! BOOLEAN ->NOT ASS %IF INTEGER(VADDR)=UNASSI %IF INTEGER(VADDR)=0 %THEN PRINTSTRING(" 'FALSE' ") %C %ELSE PRINTSTRING(" 'TRUE' ") %RETURN STR: %IF WORD1&X'20000000'=0 %START; ! STRINGS IN ISO CODE I=BYTEINTEGER(VADDR) ->NOT ASS %IF BYTE INTEGER(VADDR+1)=UNASSI&255=I ->WRONGL %IF I>DTOPHALF&X'1FF';!CUR LENGTH>MAX LENGTH %FINISH %ELSE %START; ! STRINGS IN EBCDIC I=DTOPHALF&255 CHARNO(EBCDIC,0)=I; ! SET LENGTH K=0 %WHILE KNPRINT %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, %RESULT =0 ADUP: %RESULT =1 %END %ROUTINE DDV(%LONGINTEGER DV,%INTEGERARRAYNAME LB,UB); ! decode dope vector. !*********************************************************************** !* WORK DOWN A DOPE VECTOR DESCRIBED BY WORD DESCRIPTOR DV AND * !* RETURN SIZE,DIMENIONALITY AND SUBSCRIPT RANGES IN DATA * !*********************************************************************** %INTEGER I, ND, AD, U ND=(DV>>32)&255; ND=ND//3 LB(0)=ND; UB(0)=ND AD=INTEGER(ADDR(DV)+4) %FOR I=ND,-1,1 %CYCLE U=INTEGER(AD+8)//INTEGER(AD+4)-1 LB(I)=INTEGER(AD) UB(I)=LB(I)+U AD=AD+12 %REPEAT UB(ND+1)=0 LB(ND+1)=0 %END %ROUTINE PARR(%RECORD(F)%NAME VAR, %INTEGER ASIZE) !*********************************************************************** !* PRINT THE FIRST ASIZE ELEMENTS OF THE ARRAY DEFINED BY VAR * !* ARRAYNAMES PRINTED ALSO AT PRESENT. UP TO COMPILERS TO AVOID THIS* !*********************************************************************** %INTEGER I, J, K, TYPE, PREC, ELS, ND, VADDR, HDADDR, %C BASEADDR, ELSP, M1, REFADDR, ELSL, DUPSEEN %LONGINTEGER ARRD,DOPED %INTEGERARRAY LBS, UBS, SUBS(0:13) I=VAR_VAL K=I>>20 PREC=K>>4&7 TYPE=K&7 PRINTSTRING(" ARRAY ".VAR_VNAME) %IF I&X'40000'#0 %THEN VADDR=GLAAD %ELSE VADDR=OLDLNB HDADDR=VADDR+I&X'3FFFF' ! VALIDATE HEADER AND THE 2 DESCRIPTORS *LDTB_X'18000010' *LDA_HDADDR *VAL_(%LNB+1) *JCC_3, ARRD=LONG INTEGER(HDADDR) DOPED=LONG INTEGER(HDADDR+8) *LD_ARRD *VAL_(%LNB+1) *JCC_3, *LD_DOPED *VAL_(%LNB+1) *JCC_3, ! 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 0UBS(I) %REPEAT PRINT SYMBOL(')') NEWLINE %IF J#0 %THEN PRINTSTRING("BOUND PAIRS INVALID") %AND %RETURN ! WORK OUT HOW MANY ELEMENTS TO PRINT ON A LINE %IF TYPE=5 %THEN ELSP=1 %C %ELSE %IF ELS<=4 %THEN ELSP=6 %C %ELSE ELSP=4 %CYCLE; ! THROUGH ALL THE COLUMNS ! PRINT COLUMN HEADER EXCEPT FOR 1-D ARRAYS %IF ND>1 %THEN %START PRINT STRING(" COLUMN (*,") %FOR I=2,1,ND %CYCLE WRITE(SUBS(I),1) PRINT SYMBOL(',') %UNLESS I=ND %REPEAT PRINT SYMBOL(')') %FINISH ! COMPUTE THE ADDRESS OF FIRST ELEMENT OF THE COLUMN K=0; M1=1; I=1 %WHILE I<=ND %CYCLE K=K+M1*(SUBS(I)-LBS(I)) M1=M1*(UBS(I)-LBS(I)+1) I=I+1 %REPEAT VADDR=BASEADDR+K*ELS REFADDR=0; ! ADDR OF LAST ACTUALLY PRINTED DUPSEEN=0; ELSL=99; ! FORCE FIRST EL ONTO NEW LINE !! ! %CYCLE DOWN THE COLUMN AND PRINT THE ELEMENTS. SEQUENCES OF REPEATED ! ELEMENTS ARE REPLACED BY "(RPT)". AT THE START OF EACH LINE THE ! CURRENT VALUE OF THE FIRST SUBSCRIPTED IS PRINTED FOLLOWED BY A APAREN !! %FOR I=LBS(1),1,UBS(1) %CYCLE %IF REFADDR#0 %THEN %START; ! CHK LAST PRINTED IN THIS COL K = XDP(REFADDR,VADDR,ELS); ! CHECK DUPS %IF K#0 %THEN %START PRINT STRING("(RPT)") %IF DUPSEEN=0 DUPSEEN=DUPSEEN+1 ->SKIP %FINISH %FINISH ! START A NEW LINE AND ! PRINT SUBSCRIPT VALUE IF NEEDED %IF DUPSEEN#0 %OR ELSL>=ELSP %START NEWLINE; WRITE(I,3); PRINT STRING(")") DUPSEEN=0; ELSL=0 %FINISH PVAR(TYPE,PREC,0,LANG,ELS,VADDR) ELSL=ELSL+1 REFADDR=VADDR SKIP: VADDR=VADDR+ELS ASIZE=ASIZE-1 %EXIT %IF ASIZE<0 %REPEAT; ! UNTIL COLUMN FINISHED NEWLINE %EXIT %IF ASIZE<=0 %OR ND=1 ! UPDATE SECOND SUBSCRIPT TO NEXT COLUMN ! CHECK FOR AND DEAL WITH OVERFLOW ! INTO NEXT OR FURTHER CLOUMNS I=2; SUBS(1)=LBS(1) %CYCLE SUBS(I)=SUBS(I)+1 %EXIT %UNLESS SUBS(I)>UBS(I) SUBS(I)=LBS(I); ! RESET TO LOWER BOUND I=I+1 %REPEAT %EXIT %IF I>ND; ! ALL DONE %REPEAT; ! FOR FURTHER CLOMUNS %RETURN HINV: PRINTSTRING(" HAS INVALID HEADER ") %END; ! OF RT PARR %END; ! OF RT INDIAG !* %INTEGERFN WTFAULT(%INTEGER INF) !*********************************************************************** !* TURNS INTERRUPT WT INTO PROPER FAULT FOR COMMON CASES * !*********************************************************************** ! %CONSTBYTEINTEGERARRAY TR(0 : 13) = 1,2,3,4,5,6,7,3, ! 9,9,7,7,8,10 ! %INTEGER N ! N=10; ! DEFAULT FOR UNUSUAL CASE ! %IF INF=32 %THEN N=9; ! VSI MSG=ADDRESS ERROR ! %IF INF=64 %THEN N=211; ! CPU TIME EXCEEDED ! %IF INF=65 %THEN N=213; ! TERMINATION REQUESTED ! %IF INF<=13 %THEN N=TR(INF) ! %IF INF=136 %THEN N=13; ! OUTPUT EXCEEDED ! %IF INF=140 %THEN N=25; ! INPUT ENDED ! %RESULT=N ! **** Equivalent machine code: **** %CONST %INTEGER N = 23 %CONST %BYTE %INTEGER %ARRAY V(0:2*N+2) = %C 0,1,2,3,4,5,6,7,8,9,10,11,12,13,16,18,19,20,21,32, 64, 65,136,140, 1,2,3,4,5,6,7,3,9,9, 7, 7, 8,10,39,40,40,41,39, 9,211,213, 13, 25,10 %IF 0<=INF<256 %THEN %START *LD_V *LB_INF *SWNE_%L=24; ! Should be N+1. *LSS_(%DR+24); ! Should be N+1. *EXIT_-64 %FINISH %RESULT = 10 ! **** End of machine code. **** %END %ROUTINE ERMESS(%INTEGER N, INF) !*********************************************************************** !* OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT * !*********************************************************************** %RETURN %IF N<=0 PRINTMESS(N) %IF N=26 %OR N=34 %THEN PRINT SYMBOL(NEXT SYMBOL) %IF N=10 %THEN WRITE(INF,1); ! GIVE WT FOR FUNNY INTS NEWLINE %END; ! ERMESS !* %SYSTEMROUTINE MLIBERR(%INTEGER N) %INTEGER I *STLN_I NDIAG(0,INTEGER(I),N,0) %END; ! MLIBERR !* !%SYSTEMINTEGERFNSPEC WRITE JS VAR(%STRING (32) NAME, %C %INTEGER OPTION, ADDR) !* !* ! %OWNINTEGER FLX; ! used to be FLABINDEX. ! %OWNINTEGER FLABMAX ! %OWNINTEGER FTRACELEVEL=2 !* !* ! ! The following routine PTRACE never seems to be called ! so I have suppressed it, but the text is still included in ! case it is needed: %IF 0#0 %THEN %START %ROUTINE PTRACE(%INTEGER INDEX) %STRING (63) S %INTEGER I, P1, AD I=FLABKEY(INDEX) P1=FLABINF(INDEX) AD=FLABAD(INDEX) S=STRING(AD) %IF I>0 %THEN %START %IF I=1 %THEN %START %IF S="S#GO" %THEN %START PRINTSTRING("ENTER MAIN PROGRAM ") %RETURN %FINISH PRINTSTRING("ENTER FN./SUBR. ") %FINISH %ELSE %START PRINTSTRING("EXIT FN./SUBR. ") %FINISH %FINISH %ELSE %START PRINTSTRING("LABEL ") WRITE(P1,9) %FINISH %IF S="S#GO" %THEN S="MAIN PROGRAM" PRINTSTRING(" ".S) %IF I<0 %THEN %START PRINTSTRING(" (") WRITE(-I,1) PRINTSYMBOL(')') %FINISH NEWLINE %RETURN %END; ! PTRACE %FINISH ! !* %SYSTEMROUTINE ICL MATHS ERROR ROUTINE( %C %INTEGER AOP {ADDRESS OF PARMS}) ! MODIFIED 1/02/78 11.30 ! THIS ROUTINE ACCEPTS CONTROL FROM AN ICL MATHS ROUTINE ! AFTER IT HAS FOUND A FAULT WITH ONE OF ITS ! PARAMETERS. THE ICL ERROR CONDITION NUMBER ! IS CONVERTED INTO A FORTRANG FAULT NUMBER, ! AND A MONITOR FROM THE APPROPRIATE POINT ! IS GIVEN. EXECUTION IS THEN TERMINATED ! UNDER CONTROL. ! THE PARAMETER ('AOP') POINTS TO A FIVE BYTE AREA. ! EACH BYTE IS IDENTIFIED BY THE NAMES:- P1 ! PROCNO ! ERRNO ! P2 ! P3 RESPECTIVELY ! OF THE FIVE PARAMETERS PASSED, ONLY 'PROCNO' AND 'ERRNO' ARE ! RELEVANT: 'PROCNO' IDENTIFIES THE ICL MATHS ROUTINE WHICH ! ISSUED THE FAULT ! 'ERRNO' IDENTIFIES THE ACTUAL FAULT ! IN THIS ROUTINE, 'PROCNO' CAN TAKE THE FOLLOWING VALUES:- ! PROCNO ICL MATHS ROUTINE ! 1 - 3 SIN (SINGLE, DOUBLE, QUADRUPLE PRECISION) ! 4 - 6 COS ! 13 - 15 TAN ! 16 - 18 COT ! 22 - 24 ASIN ! 25 - 27 ACOS ! 37 - 39 ATAN2 ! 49 - 51 CSIN ! 52 - 54 CCOS ! 73 - 75 SINH ! 76 - 78 COSH ! 97 - 99 EXP ! 103 - 105 LOG ! 106 - 108 LOG10 ! 112 - 114 CEXP ! 115 - 117 CLOG ! 118 - 120 SQRT ! 124 - 126 'REAL' ** 'REAL' ! 133 - 135 'COMPLEX' ** 'REAL' ! 145 - 147 GAMMA ! 148 - 150 LGAMMA ! THE FOLLOWING TABLE REPRESENTS THE TRANSLATIONS EFFECTED ! FROM ICL ERROR CONDITION NUMBERS TO FORTRANG FAULTS %CONSTBYTEINTEGERARRAY ERROR CODE TABLE( 1:2 , 0:49)= %C 54 , 71 , 55 , 71 , 70 , 70 , 70 , 70 , 56 , 57 , 66 , 67 , 70 , 70 , 58 , 71 , 59 , 71 , 70 , 70 , 70 , 70 , 70 , 70 , 60 , 71 , 70 , 70 , 70 , 70 , 70 , 70 , 54 , 54 , 55 , 55 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 61 , 71 , 62 , 71 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 53 , 53 , 70 , 70 , 51 , 52 , 51 , 52 , 70 , 70 , 53 , 53 , 52 , 71 , 50 , 71 , 70 , 70 , 68 , 68 , 70 , 70 , 70 , 70 , 69 , 69 , 70 , 70 , 70 , 70 , 70 , 70 , 65 , 65 , 63 , 64 ! THE LIST OF FORTRANG MATHEMATICAL LIBRARY ERROR MESSAGES ! IS AS FOLLOWS:- ! FAULT MESSAGE ! 50 SQRT ARG NEGATIVE ! 51 LOG ARG NEGATIVE ! 52 LOG ARG ZERO ! 53 EXP ARG OUT OF RANGE ! 54 SIN ARG OUT OF RANGE ! 55 COS ARG OUT OF RANGE ! 56 TAN ARG OUT OF RANGE ! 57 TAN ARG INAPPROPRIATE ! 58 ASIN ARG OUT OF RANGE ! 59 ACOS ARG OUT OF RANGE ! 60 ATAN2 ARGS ZERO ! 61 SINH ARG OUT OF RANGE ! 62 COSH ARG OUT OF RANGE ! 63 LGAMMA ARG NOT POSITIVE ! 64 LGAMMA ARG TOO LARGE ! 65 GAMMA ARG OUT OF RANGE ! 66 COT ARG OUT OF RANGE ! 67 COT ARG INAPPROPRIATE ! 68 REAL EXPONENTIATION FAULT ! 69 COMPLEX EXPONENTIATION FAULT ! 70 FUNCTION NOT SUPPORTED ! 71 UNKNOWN FUNCTION FAULT %INTEGER PVB {PREVIOUS LNB}; !POINTER TO THE STACK OF ! THE PREVIOUS ROUTINE %INTEGER FAULT; !FORTRANG EQUIVALENT FAULT TO !ISSUED ICL MATHS FUNCTION !ERROR NUMBER %INTEGER SSN; !SEGMENT NUMBER OF THE STACK %INTEGER I; !WORK VARIABLE %INTEGER PROCNO %INTEGER ERRNO %INTEGER PC, GLA %BYTEINTEGER LF, VSN PROCNO=BYTEINTEGER(AOP {ADDRESS OF PARMS}+1) ERRNO=BYTEINTEGER(AOP+2) ! CONVERT ICL ERROR NUMBER TO FORTRANG FAULT %IF PROCNO<=0 %OR PROCNO>150 %THEN FAULT=70 %ELSE %START I=(PROCNO-1)//3 %IF 0>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, 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 %IF INTEGER(PVB {PREVIOUS LNB}+24)\=M'FDIA' %C %THEN ->GET NEXT FRAME 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, LF = BYTEINTEGER(GLA + 16) VSN = BYTEINTEGER(GLA + 17) %IF LF = X'07' %AND VSN = X'0A' %THEN %EXIT PC = INTEGER(PVB {PREVIOUS LNB} + 8) - 4 PVB = INTEGER(PVB) %REPEAT %FINISH P2: NDIAG(PC,PVB {PREVIOUS LNB},FAULT,0); !WRITE OUT THE ERROR MESSAGE ! AND GIVE A MONITOR TRACE %RETURN ERR: PRINTSTRING("DIAGS FAIL - STACK CORRUPT") NEWLINE %END; !OF ICL MATHS ERROR ROUTINE %SYSTEMROUTINE PPROFILE(%INTEGER A, B) !*********************************************************************** !* SUPPORTS THE PROFILE FEATURE IN IMP BY GIVING THE LINE MAP * !* AND RESTTING ALL COUNTS * !*********************************************************************** %INTEGER LINES, V, I, J, MAX, MAXMAX LINES=A&X'FFFF'-1 MAX=0 %FOR I=LINES,-1,1 %CYCLE %IF INTEGER(B+4*I)>MAX %THEN MAX=INTEGER(B+4*I) %REPEAT MAXMAX=MAX MAX=1+MAX//40; ! TWO&AHALF PER CENT %FOR I=1,1,LINES %CYCLE V=INTEGER(B+4*I) %IF V>=MAX %THEN %START WRITE(I,4) J=I %WHILE INTEGER(B+4*J+4)=V %CYCLE J=J+1 %REPEAT %IF J#I %THEN PRINTSTRING("->") %C %AND WRITE(J,4) %ELSE SPACES(7) I=J WRITE(V,6) %IF V=MAXMAX %THEN PRINTSTRING(" ***") NEWLINE %FINISH %REPEAT %FOR I=LINES,-1,1 %CYCLE INTEGER(B+4*I)=0 %REPEAT %END ! ! ! - END OF NDIAG CODE ] ! ! [ START OF BCOM TEXT - ! ! ! **** **** ! N.B. Various points in the text are flagged with the comment "!{SEQ}". ! These are places where the sequential connect mode should be exploited ! when it becomes accessible. ! **** **** ! ! ! ! ! %SYSTEMROUTINE SETPAR(%STRING (255) S) !STORE PARAM LIST FOR ! SUBSEQUENT EXTRACTION OF ! INDIVIDUAL PARAMS !USING SPAR %INTEGER I, J, POINT, LENS, APARSTRING; ! J is only needed for the machine ! code version. SSOWN_LOCATE PRMS = 0 STRING(ADDR(SSOWN_PARSTRING(0))) = S SSOWN_PCOUNT = 0 SSOWN_PMAP = 0; !MAP OF BITS INDICATING ! PARAMS SET SSOWN_CURPAR = 1; !FIRST PARAM OF LIST LENS = LENGTH(S) %IF LENS > 0 %START; !IF ANY PARAMS AT ALL POINT = 0 ! %FOR I=1,1,LENS+1 %CYCLE ! %IF I = LENS+1 %OR SSOWN_PARSTRING(I) = ',' %START ! PCOUNT = PCOUNT+1 ! SSOWN_PINDEX(PCOUNT) = POINT; !START OF THIS PARAM ! SSOWN_PARSTRING(POINT) = I-POINT-1 ! !LENGTH OF THIS PARAM ! %IF SSOWN_PARSTRING(POINT) > 0 %C ! %THEN SSOWN_PMAP = SSOWN_PMAP!1<<(PCOUNT-1) ! POINT = I ! %FINISH ! %REPEAT ! ! **** **** Machine code equivalent: **** **** ! I = 0 APARSTRING=ADDR(SSOWN_PARSTRING(0)) %CYCLE J = LENS - I I = I + 1 *LDTB_X'18000100' *LDA_APARSTRING *INCA_I *LDB_J *SWNE_%L=%DR,0,44; ! %MASK=0,%REF=',' *CYD_0 *STUH_%B *ISB_APARSTRING *ST_I SSOWN_PCOUNT = SSOWN_PCOUNT+1 SSOWN_PINDEX(SSOWN_PCOUNT) = POINT; !START OF THIS PARAM J = I - POINT - 1 SSOWN_PARSTRING(POINT) = J !LENGTH OF THIS PARAM %IF J>0 %THEN SSOWN_PMAP = SSOWN_PMAP!(1<<(SSOWN_PCOUNT-1)) POINT = I %REPEAT %UNTIL I>LENS ! ! **** **** End of machine code **** **** ! %FINISH %END; ! SETPAR ! %SYSTEMINTEGERFN PARMAP !RETURNS AN INTEGER SHOWING ! WHICH PARAMETERS ARE ! NON-NULL. BIT 2**0= !PARAM 1 ETC. %RESULT = SSOWN_PMAP %END; !OF PARMAP %SYSTEMSTRINGFN SPAR(%INTEGER N) !N SHOULD BE NUMBER OF ! REQUIRED PARAM, OR 0 ! MEANING NEXT PARAM !ON EXIT RESULT WILL CONTAIN ! PARAM OR NULL IF NONE ! AVAILABLE. %STRING (255) S %INTEGER SAVE SAVE = N NEXT: %IF N=0 %THEN %START N = SSOWN_CURPAR SSOWN_CURPAR = SSOWN_CURPAR+1 %FINISH %IF N>SSOWN_PCOUNT %THEN %RESULT = ""; !NO PARAM AVAILABLE %IF SSOWN_LOCATE PRMS=0 %THEN %START S = STRING(ADDR(SSOWN_PARSTRING(0))+SSOWN_PINDEX(N)) UCTRANSLATE (ADDR(S)+1,LENGTH(S)) %FINISH %ELSE S = STRING (SSOWN_PAPTR(N)) %IF S="" %AND SAVE=0 %THEN %START; ! IGNORE NULL STRING IN SIMPLE LIST N = 0 -> NEXT %FINISH %RESULT = S %END; ! SPAR %SYSTEM %ROUTINE ANALYSE PARAMETERS %C (%STRING %NAME DCL PARMS, CALL PARMS, %INTEGER MAX PARMS, %C %STRING %ARRAY %NAME KEYS, %INTEGER MAX KEY SIZE, %C %RECORD (DRF) %ARRAY %NAME ACTUAL, %C %INTEGER %NAME TOTAL KEYS, RESPONSE) ! ! THIS ROUTINE TAKES TWO 'PARAMETER STRINGS', 'DCL PARMS' FROM A ! MACRO DECLARATION AND 'CALL PARM' FROM A CALL OF THE SAME MACRO. ! IT PRODUCES IN THE %STRING %ARRAY 'KEYS' ALL THE KEYWORDS DECLARED IN ! THE MACRO DECLARATION, IN THE CORRECT ORDER, AND IN %RECORD %ARRAY ! 'ACTUAL', BYTE-VECTOR DESCRIPTORS TO THE CORRESPONDING ACTUAL ! PARAMETER TEXTS TO BE USED IN THE CALL. THESE DESCRIPTORS WILL BE ! TO AREAS WITHIN THE %STRING 'CALL PARMS' OR (WHERE A DEFAULT IS ! USED) WITHIN 'DCL PARMS'. A DESCRIPTOR WITH BOUND ZERO WILL ! INDICATE A NULL STRING. A DESCRIPTOR WITH A TYPE-AND-BOUND WORD ! OF X'FFFFFFFF' INDICATES THAT NO VALUE WAS SUPPLIED FOR THE PARAMETER, ! EITHER AS A DEFAULT IN 'DCL PARMS' OR IN 'CALL PARM'. ! THE VALUES OF 'MAX PARMS' AND 'MAX KEY SIZE' MUST BE SET ON ENTRY ! TO INDICATE THE MAXIMUM NUMBER OF PARAMETERS AND THE MAXIMUM LENGTH ! OF THE KEYWORD STRINGS WHICH CAN BE ACCEPTED. THE %ARRAYS 'KEYS' ! AND 'ACTUAL' MUST BE DECLARED WITH UPPER BOUNDS NOT LESS THAN ! 'MAX PARMS' AND LOWER BOUNDS OF 1. THE %STRINGS IN %ARRAY 'KEYS' ! MUST HAVE MAXIMUM LENGTH NOT LESS THAN 'MAX KEY SIZE'. ! ON EXIT, 'RESPONSE' WILL BE =0 FOR SUCCESS, >0 FOR WARNINGS AND ! <0 FOR FAILURE. AS WELL AS THE SIGN BIT, OTHER BITS MAY BE SET ! TO INDICATE SPECIFIC WARNING OR ERROR CONDITIONS. ! BIT 24 (VALUE 128)- KEYWORDS INDISTINCT: TWO KEYWORDS HAVE THE ! SAME FIRST CHARACTERS, SO THAT THEIR ! ABBREVIATIONS COULD NOT BE DISTINGUISHED ! IN A CALL. ! BIT 25 (VALUE 64) - 'WRAP-AROUND': FIRST CHARACTER HAS BEEN ! SPECIFIED BY POSITION, BUT NOT IN FIRST ! POSITION IN THE CALL. ! BIT 26 (VALUE 32) - SOME PARAMETER SPECIFIED MORE THAN ONCE: ! LATEST VALUE ACCEPTED. ! BIT 27 (VALUE 16) - UNRECOGNISED KEYWORD IN CALL: FIELD IGNORED. ! BIT 28 (VALUE 8) - KEYWORD TOO LONG IN CALL: ! EXTRA CHARACTERS IGNORED. ! BIT 29 (VALUE 4) - TOO MANY FIELDS IN DECLARATION. ! BIT 30 (VALUE 2) - KEYWORD TOO LONG IN DECLARATION: ! EXTRA CHARACTERS IGNORED. ! BIT 31 (VALUE 1) - FIELD WITH NO KEYWORD IN DECLARATION. ! ! IF 'RESPONSE'>=0, THEN 'TOTAL KEYS' WILL ALSO BE SET TO INDICATE HOW ! MANY PARAMETERS THERE ARE. ! ! %ROUTINE PICK UNIT (%INTEGER %NAME CHAD, CHEND, %C %INTEGER DECL, %STRING %NAME KEYWORD, %INTEGER KSIZE, %C %INTEGER %NAME VLIM, VADDR, %INTEGER %NAME R) ! THIS ROUTINE SCANS BYTES FROM ADDRESS CHAD+1 TO ! ADDRESS CHEND (INCREMENTING CHAD AS IT GOES), TO FIND ! A KEYWORD AND/OR A PARAMETER VALUE. IT COPIES THE KEYWORD ! INTO THE PARAMETER 'KEYWORD', AND PUTS THE LENGTH AND ! ADDRESS OF THE PARAMETER VALUE INTO VLIM AND VADDR ! RESPECTIVELY. ! VADDR WILL BE BETWEEN (INITIAL VALUE OF) CHAD + 1 AND ! THE FINAL VALUE OF CHAD - 1. VLIM+VADDR-1 WILL ALSO LIE ! IN THAT RANGE. VLIM WILL NOT BE LESS THAN ZERO. ! ON ENTRY, CHAD MUST HAVE (ADDRESS OF THE FIRST CHARACTER ! TO BE EXAMINED) - 1. CHEND MUST HAVE THE ADDRESS OF THE ! LAST CHARACTER TO BE EXAMINED. ON EXIT, CHAD WILL HAVE BEEN ! UPDATED TO POINT TO THE LAST CHARACTER EXAMINED. IF IT ! IS THEN GREATER THAN CHEND, THE ORIGINAL TEXT HAS BEEN ! EXHAUSTED. IF IT IS EQUAL TO CHEND, THEN THE LAST CHARACTER ! OF THE ORIGINAL TEXT WAS THE COMMA WHICH TERMINATED THE ! PARAMETER FIELD. IF CHAD IS GREATER THAN OR EQUAL TO CHEND ON ! ENTRY, THEN THE ROUTINE WILL RETURN IMMEDIATELY WITH CHAD ! UNALTERED, WITH A NULL STRING IN KEYWORD, AND WITH VLIM=0. ! THERE WILL BE NO ERROR INDICATION IN THIS CASE. ! IF NO KEYWORD IS DETECTED IN A CALL ON PICK UNIT, THEN ! KEYWORD WILL BE ASSIGNED A NULL STRING. IF NO PARAMETER ! VALUE IS DETECTED, THEN VLIM WILL BE -1. IF THE VALUE ! SUPPLIED IS A NULL STRING (AS IN ...,KWD=,...), THEN ! VLIM WILL BE ZERO. WHERE A FIELD CONTAINS NO "=" SYMBOL ! (AND WHEN THERE IS NO OTHER WAY OF RESOLVING THE AMBIGUITY), ! THE VALUE OF THE PARAMETER DECL DECIDES WHETHER ANY TEXT ! FOUND IS TO BE TAKEN TO BE A KEYWORD (APPROPRIATE IN ! ANALYSING MACRO DECLARATIONS: DECL NON-ZERO) OR A ! PARAMETER VALUE (APPROPRIATE IN ANALYSING A CALL: DECL ZERO). ! THE PARAMETER KSIZE SPECIFIES THE MAXIMUM PERMISSIBLE SIZE OF ! THE STRING KEYWORD. ! ERRORS ARE NOTIFIED BY THE VALUE OF R ON EXIT. A ZERO VALUE ! MEANS THAT NO ERRORS HAVE OCCURRED. THE ONLY ERROR CONDITION ! DEFINED SO FAR IS "KEYWORD TOO LONG", GIVING R=1. %INTEGER TS, KADDR, KLIM, CHIN, CHYPE, BL, PAST ! ! THE ARRAY 'PROCN' IS INDEXED BY 'CHYPE' AND 'PAST' TO SELECT A ! DESTINATION IN THE SWITCH 'PROCN'. THIS PASSES CONTROL TO A ! PROCESS APPROPRIATE TO THE PRESENT STATE OF THE ANALYSIS ('PAST') ! AND THE CHARACTER BEING INSPECTED IN THE PARAMETER STRING ('CHYPE'). ! VALUES OF 'CHYPE' ARE: ! 0 - NO TEXT LEFT TO EXAMINE: ! 1 - LETTER: ! 2 - DIGIT: ! 3 - SPACE: ! 4 - COMMA: ! 5 - 'EQUALS' SIGN: ! 6 - OPEN BRACKET: ! 7 - CLOSE BRACKET: ! 8 - DOUBLE-QUOTE: ! 9 - ANYTHING ELSE. ! VALUES OF 'PAST' ARE: ! 1 - STARTING: NO NON-SPACE CHARACTER SEEN YET. ! 2 - TEXT FOUND, BUT STILL UNDECIDED WHETHER IT IS KEYWORD OR VALUE. ! 3 - PROCESSING THE 'VALUE' PART OF THE PARAMETER FIELD. ! 4 - IN QUOTES (AND THIS CAN ONLY BE IN THE VALUE PART). %CONST %BYTE %INTEGER %ARRAY PROCN (0:9,1:4) = %C 16, 10, 8, 0, 16, 8, 9, 8, 7, 8, 15, 11, 11, 2, 15, 4, 9, 8, 7, 8, 17, 1, 1, 3, 14, 1, 12, 13, 6, 1, 17, 1, 1, 2, 1, 1, 1, 1, 5, 1 ! %STRING (1) CHST ! %STRING (5) DISCARD ! %CONST %STRING (6) SPC = " ,=()""" %SWITCH PERFORM (0:17) ! LENGTH (CHST) = 1 R = 0 KADDR = ADDR (KEYWORD) KLIM = 0 VADDR = CHAD + 1 VLIM = 0 BL = 0 PAST = 1 TS = 0 -> SEECH ! ! PERFORM(10): PAST = 2 PERFORM(11): %IF KLIM>=KSIZE %C %THEN R = R ! 1 %C %ELSE %START KLIM = KLIM + 1 BYTE INTEGER (KADDR+KLIM) = CHIN %FINISH PERFORM(1): ADD NS: TS = 0 ADD TO F: VLIM = VLIM + 1 ! SEECH: CHAD = CHAD + 1 %IF CHAD>CHEND %THEN -> PERFORM (PROCN(0,PAST)) CHIN = BYTE INTEGER (CHAD) ! ! **** **** THIS NEXT SECTION IS A CANDIDATE **** **** ! **** **** FOR MACHINE CODING, BUT FOR THE **** **** ! **** **** MOMENT I HAVE USED A BIT OF **** **** ! **** **** TRICKERY WITH %STRINGS SPC, CHST **** **** ! **** **** AND DISCARD. THEIR DECLARATIONS **** **** ! **** **** WILL NOT BE NEEDED IF THIS BIT **** **** ! **** **** OF CODE IS REPLACED. **** **** ! **** **** IN FACT MY NEW CODE ACTUALLY **** **** ! **** **** TAKES MORE SPACE THAN THE OLD, **** **** ! **** **** SO I HAVE COMMENTED IT OUT, BUT **** **** ! **** **** I HAVE LEFT THE TEXT HERE AS AN **** **** ! **** **** INDICATION OF THE SORT OF CODE **** **** ! **** **** I HAD IN MIND. **** **** %IF 'A'<=CHIN<='Z' %OR (ULCEQUIV#0 %AND 'a'<=CHIN<='z') %C %THEN CHYPE = 1 %C %ELSE %IF '0'<=CHIN<='9' %THEN CHYPE = 2 %ELSE %START %IF CHIN=' ' %THEN CHYPE = 3 %C %ELSE %IF CHIN=',' %THEN CHYPE = 4 %C %ELSE %IF CHIN='=' %THEN CHYPE = 5 %C %ELSE %IF CHIN='(' %THEN CHYPE = 6 %C %ELSE %IF CHIN=')' %THEN CHYPE = 7 %C %ELSE %IF CHIN='"' %THEN CHYPE = 8 %C %ELSE CHYPE = 9 ! EQUIVALENT TO THAT, AND (I HOPE) FASTER AND MORE COMPACT: ! BUT IN FACT IT TAKES MORE SPACE, AND I HAVE NOT CHECKED ITS ! SPEED! ! BYTE INTEGER (ADDR(CHST)+1) = CHIN ! %IF SPC->DISCARD.(CHST) %C ! %THEN CHYPE = LENGTH(DISCARD) + 3 %C ! %ELSE CHYPE = 9 %FINISH ! **** **** END OF MACHINE CODE SECTION **** **** ! -> PERFORM (PROCN(CHYPE,PAST)) ! PERFORM(9): BL = 1 PERFORM(8): KLIM = 0 PERFORM(5): PAST = 3 -> ADD NS ! PERFORM(7): KLIM = 0 PERFORM(6): PAST = 4 -> ADD NS ! PERFORM(4): VADDR = CHAD + 1 VLIM = 0 TS = 0 PAST = 3 -> SEECH ! PERFORM(3): %IF VLIM#0 %THEN -> ADD S PERFORM(0): VADDR = VADDR + 1 -> SEECH PERFORM(2): ADD S: TS = TS + 1 -> ADD TO F ! PERFORM(12): BL = BL + 1 -> ADD NS ! PERFORM(13): %IF BL>0 %THEN BL = BL - 1 -> ADD NS ! PERFORM(14): %IF BL>0 %THEN -> ADD NS -> UNIT COMPLETE ! PERFORM(16): VLIM = -1 -> TIDY PERFORM(15): %IF DECL=0 %THEN KLIM = 0 %ELSE TS = VLIM + 1 PERFORM(17): UNIT COMPLETE: VLIM = VLIM - TS TIDY: LENGTH (KEYWORD) = KLIM %IF ULCEQUIV=0 %THEN %START %IF KLIM=0 %THEN R = R & X'FFFFFFFE' %FINISH %ELSE %START %IF KLIM=0 %THEN R = R & X'FFFFFFFE' %ELSE UCTRANSLATE (KADDR+1,KLIM) %FINISH %RETURN %END ! ! %INTEGER CPTR, CLIM, RESULT, VS, VP, L, M, KM, KN, CSTART %INTEGER WRAPPING, KEY VALID %INTEGER %NAME VALSIZE, VALPTR %RECORD (DRF) %NAME VAL %STRING (255) CALL KEY %STRING %NAME THIS KEY, THAT KEY ! RESPONSE = 0 CPTR = ADDR (DCL PARMS) CLIM = CPTR + LENGTH (DCL PARMS) %IF CLIM=CPTR %THEN %START TOTAL KEYS = 0 %RETURN %FINISH KN = 0 %WHILE CPTR3 %THEN L=3 %WHILE KML %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 CPTR0 %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_ADTOTAL KEYS %THEN %START KN = 1 WRAPPING = -1 %FINISH %REPEAT %RETURN ! ! %END ! %SYSTEM %ROUTINE FILPS (%STRING %NAME DPF, S) %INTEGER N, R %STRING (PRMKWDL) %ARRAY KY (1:PRMLIM) %RECORD (DRF) %ARRAY VL (1:PRMLIM) %INTEGER I, J, K, L, OINST, OOUTST, RPL %STRING (MAXPROMPTSIZE) OPRPT, TPRPT ANALYSE PARAMETERS (DPF, S, PRMLIM, KY, PRMKWDL, VL, N, R) SSOWN_LOCATE PRMS = 1 SSOWN_PMAP = 0 SSOWN_PCOUNT = N SSOWN_CURPAR = 1 %IF UINFI(2)=1 %THEN %START; ! Only for interactive working - OINST = INSTREAM OOUTST = OUTSTREAM %IF OINST#0 %THEN SELECT INPUT (0) %IF OOUTST#0 %THEN SELECT OUTPUT (0) OPRPT = UINFS (4) I = 1 %WHILE I<=N %CYCLE K = VL(I)_LENGTH %IF SSOWN_QPARMF#0 %OR K=-1 %THEN %START TPRPT = KY(I) J = LENGTH (TPRPT) %IF SSOWN_QPARMF#0 %AND K#-1 %AND JMAXPROMPTSIZE-1 %THEN L = MAXPROMPTSIZE - 1 LENGTH (TPRPT) = L CHARNO (TPRPT,J+1) = '(' CHARNO (TPRPT,L) = ')' MOVE (L-J-2,VL(I)_AD,ADDR(TPRPT)+J+2) %FINISH PROMPT (TPRPT.":") RPL = 0 %WHILE NEXT CH#NL %CYCLE %IF SSOWN_RPTR+RPL>=RPLIM %THEN %START MOVE (RPL, ADDR(SSOWN_RPS(SSOWN_RPTR)), ADDR(SSOWN_RPS(0))) SSOWN_RPTR = 0 %FINISH RPL = RPL + 1 READ CH (SSOWN_RPS(SSOWN_RPTR+RPL)) %REPEAT SKIP SYMBOL SSOWN_RPS (SSOWN_RPTR) = RPL %IF SSOWN_QPARMF=0 %OR VL(I)_LENGTH=-1 %OR RPL#0 %THEN %START CAST OUT (STRING(ADDR(SSOWN_RPS(SSOWN_RPTR)))) VL(I)_AD = ADDR (SSOWN_RPS(SSOWN_RPTR)) + 1 VL(I)_LENGTH = X'18000000' ! SSOWN_RPS (SSOWN_RPTR) SSOWN_RPTR = SSOWN_RPTR + SSOWN_RPS(SSOWN_RPTR) + 1 %FINISH %FINISH I = I + 1 %REPEAT PROMPT (OPRPT) %IF OINST#0 %THEN SELECT INPUT (OINST) %IF OOUTST#0 %THEN SELECT OUTPUT (OOUTST) %FINISH %IF N>0 %THEN %START %FOR I=1,1,N %CYCLE %IF VL(I)_LENGTH#-1 %THEN %START K = VL(I)_LENGTH & X'00FFFFFF' %IF K>0 %THEN %START L = VL(I)_AD %UNLESS L-RPLIM<=ADDR(SSOWN_RPS(0))<=L %THEN %START %IF SSOWN_RPTR+K>RPLIM %THEN SSOWN_RPTR = 0 J = ADDR (SSOWN_RPS(SSOWN_RPTR)) SSOWN_RPS (SSOWN_RPTR) = K MOVE (K,L,J+1) SSOWN_PAPTR (I) = J SSOWN_RPTR = SSOWN_RPTR + K + 1 %FINISH %ELSE SSOWN_PAPTR (I) = L - 1 SSOWN_PMAP = SSOWN_PMAP ! (1<<(I-1)) %FINISH %ELSE SSOWN_PAPTR (I) = ADDR (SSOWN_NULP) %FINISH %ELSE SSOWN_PAPTR (I) = ADDR (SSOWN_NULP) %REPEAT %FINISH %END %IF DIAGOP#0 %THEN %START %EXTERNAL %ROUTINE LIST PARAMETERS %C (%INTEGER P, %C %STRING %ARRAY %NAME KNAME, %C %RECORD (DRF) %ARRAY %NAME VALUE) %INTEGER I, J, K, L %IF P>0 %THEN %START %FOR I=1,1,P %CYCLE L = ADDR (KNAME(I)) L = BYTE INTEGER (L) PRINT STRING (KNAME(I)) SPACES (12-LENGTH(KNAME(I))) %IF VALUE(I)_LENGTH#-1 %THEN %START PRINT SYMBOL ('"') K = VALUE(I)_LENGTH & X'00FFFFFF' %IF K>0 %THEN %START L = VALUE(I)_AD %FOR J=L,1,L+K-1 %CYCLE PRINT SYMBOL (BYTE INTEGER(J)) %REPEAT %FINISH PRINT SYMBOL ('"') %FINISH %ELSE PRINT STRING ("") NEWLINE %REPEAT %FINISH %END %FINISH ! %EXTERNALLONGREALFN ZCPUTIME %SYSTEMLONGREALFNSPEC CPUTIME %RESULT = CPUTIME %END; !OF CPUTIME %SYSTEM %STRING (255) %FN PRINTPARMS (%LONGINTEGER P) ! **** **** This used to be a ROUTINE. It ought to be documented. **** **** %STRING (255) T %INTEGER I T = "" P = P !! DEFAULTPARM %FOR I=0,1,MAXPARMS %CYCLE %IF P&1=1 %AND PARMS(I)#"" %THEN %START; ! IGNORE BLANK PARMS %IF T#"" %THEN T = T."," T = T.PARMS(I) %FINISH P = P>>1 %REPEAT %IF T="" %THEN T = "DEFAULTS" %RESULT = T %END; !OF PRINTPARMS ! %SYSTEMROUTINE CONSOURCE(%STRING(31)FILE,%INTEGERNAME AD) !FOR USE BY INCLUDE FACILITY IN IMP COMPILER %INTEGER FLAG %RECORD (RF)RR CONNECT(FILE,0,0,0,RR,FLAG); !{SEQ} %IF FLAG=0 %THEN %START %IF RR_FILETYPE#SSCHARFILETYPE %THEN %START; !INVALID FILETYPE %IF NEWCONNECT#0 %THEN %START DISCONNECT (LAST, FLAG) %FINISH FLAG= 267 SSOWN_SSFNAME=FILE %FINISH %ELSE %START AD=RR_CONAD %IF NEWCONNECT#0 %THEN %START SETUSE (LAST,-1,0) %FINISH %RETURN %FINISH %FINISH %IF SSOWN_SSCOMREG(23)#0 %THEN %START SELECT OUTPUT (0) PSYSMES(23,FLAG) %FINISH %STOP %END; !OF CONSOURCE ! ! BATCHSTOP and USE OPTIONS have been moved into the ! INFREQUENT CODE module. ! ! %EXTERNALROUTINE ZACCEPT(%STRING (255) S) %INTEGER FLAG %STRING (31) FILE, NEWNAME,TEMPLATE TEMPLATE = "FILE,NEWNAME=" UCTRANSLATE (ADDR(S)+1,LENGTH(S)) FILPS (TEMPLATE,S) %IF 1#PARMAP#3 %THEN %START; ! WRONG NO OF PARAMS FLAG = 263 -> ERR %FINISH FILE = SPAR(1) NEWNAME = SPAR(2) ACCEPT(FILE,NEWNAME,FLAG) ERR: SSOWN_RCODE = FLAG %IF FLAG # 0 %THEN PSYSMES(1,FLAG) %END; !OF ACCEPT %EXTERNALROUTINE ALIAS(%STRING (255) S) !WARNING - DOES NOT ALLOW FOR ! FULL LENGTH NAMES - UNLIKELY %INTEGER FLAG %STRING (32) CURRENT, NEW %STRING(11) TEMPLATE TEMPLATE = "NAME,ALIAS=" %IF S#"" %THEN LENGTH (TEMPLATE) = 11 %ELSE LENGTH (TEMPLATE) = 10 UCTRANSLATE (ADDR(S)+1,LENGTH(S)) FILPS (TEMPLATE,S) %IF 1#PARMAP#3 %THEN %START; ! WRONG NO. OF PARAMS FLAG = 263 -> ERR %FINISH CURRENT = "=".SPAR(1); ! INDICATES ALIAS NEW = SPAR(2) %IF NEW#"" %START %IF CHECKCOMMAND(NEW)#0 %OR CHARNO(NEW,1)='#' %THEN %START FLAG = 202 SSOWN_SSFNAME = NEW -> ERR %FINISH MODDIRFILE(9,SSOWN_AVD,NEW,CURRENT,0,0,0,FLAG) %FINISH %ELSE MODDIRFILE(2,SSOWN_AVD,"",CURRENT,0,0,0,FLAG) !REMOVE ALIAS ERR: SSOWN_RCODE = FLAG %IF FLAG # 0 %THEN PSYSMES(77,FLAG) %END; !OF ALIAS %EXTERNALROUTINE CLEAR(%STRING (255) S) %INTEGER FLAG, CHAN %STRING (31) SCHAN %RECORD(FDF)%NAME F FLAG = 0; !DEFAULT REPLY %IF S = "" %START; !CLEAR ALL NON-OPEN CHANNELS %FOR CHAN=80,-1,1 %CYCLE %IF SSOWN_SSFDMAP(CHAN)#0 %AND SSOWN_SSCOMREG(22)#CHAN#SSOWN_SSCOMREG(23) %THEN %START !CHANNEL DEFINED !AND NOT SELECTED F == RECORD(SSOWN_SSFDMAP(CHAN)) %IF F_STATUS = 0 %START; !CHANNEL CLOSED F_DSNUM = 0; !TO MARK IT AS UNUSED SSOWN_SSFDMAP(CHAN) = 0; !CLEAR POINTER %FINISH %FINISH %REPEAT %FINISH %ELSE %START; !CLEAR(N1,N2,N3) SETPAR(S) LOOP: SCHAN = SPAR(0); !NEXT PARAMETER %IF SCHAN = "" %THEN -> ERR; !END OF LIST CHAN = PSTOI(SCHAN) %UNLESS 1<=CHAN<=80 %THEN %START; ! INVALID CHAN FLAG = 223 -> FAIL %FINISH %IF SSOWN_SSFDMAP(CHAN)=0 %THEN %START; ! CHANNEL NOT DEFINED FLAG = 151 -> FAIL %FINISH F == RECORD(SSOWN_SSFDMAP(CHAN)) %IF F_STATUS#0 %OR SSOWN_SSCOMREG(22)=CHAN %OR SSOWN_SSCOMREG(23)=CHAN %THEN %START ! CHANNEL OPEN OR SELECTED FLAG = 265 -> FAIL %FINISH F_DSNUM = 0; !TO SHOW DESCRIPTOR FREE SSOWN_SSFDMAP(CHAN) = 0; !CLEAR POINTER -> LOOP FAIL: PSYSMES(42,FLAG) -> LOOP %FINISH ERR: SSOWN_RCODE = FLAG %END; !OF CLEAR %EXTERNALROUTINE CPULIMIT(%STRING (255) S) %STRING (17) TEMPLATE %INTEGER MIN, SEC, FLAG, KI %STRING (8) SSEC, SMIN %IF S = "?" %START; !PRINT CURRENT SETTING FLAG = 0 SEC = SSOWN_CURRKI//KIPS; !NO OF SECONDS MIN = SEC//60 SEC = SEC-(MIN*60) PRINTSTRING("Current cpulimit: ".ITOS(MIN)."m ".ITOS(SEC). %C "s") NEWLINE %FINISH %ELSE %START SEC = 0 MIN = 0 %IF S#"" %AND CHARNO(S,1)#',' %C %THEN TEMPLATE = "MINUTES,SECONDS=0" %C %ELSE TEMPLATE = "MINUTES=0,SECONDS" UCTRANSLATE (ADDR(S)+1,LENGTH(S)) FILPS (TEMPLATE,S) ! CHECK NO OF PARAMS. %UNLESS 0MAXCPL %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 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')< 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 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 %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 SSOWN_RCODE = 0 %END; !OF METER %EXTERNALROUTINE NEWDIRECTORY(%STRING (255) S) %CONSTINTEGER DFH = 160; ! DEFAULT HASHCONST %CONSTINTEGER DFPL = 856; ! DEFAULT PLENGTH %INTEGER HASHCONST, FLAG, PLENGTH %STRING (31) FILE %RECORD (FRF)FR %STRING (8) SH, SP %STRING (27) TEMPLATE TEMPLATE = "NAME,HASH=".ITOS(DFH).",PSIZE=".ITOS(DFPL) UCTRANSLATE (ADDR(S)+1,LENGTH(S)) FILPS (TEMPLATE,S) %IF 1#PARMAP#7 %THEN %START; ! WRONG NO OF PARAMS FLAG = 263 -> ERR %FINISH FILE = SPAR(1) FINFO(FILE,0,FR,FLAG) %IF FLAG=0 %THEN %START; ! FILE ALREADY EXISTS FLAG = 219 -> ERR %FINISH %IF PARMAP = 1 %START; !USE DEFAULT VALUES HASHCONST = DFH; ! DEFAULT HASHCONST PLENGTH = DFPL; ! DEFAULTPLENGTH %FINISH %ELSE %START SH = SPAR(2); !NO OF ENTRIES SP = SPAR(3); !SIZE OF PLIST HASHCONST = PSTOI(SH); !HASHCONST SUPPLIED PLENGTH = PSTOI(SP); !PLENGTH SUPPLIED %IF HASHCONST<=0 %OR PLENGTH<=0 %THEN %START FLAG = 202 -> ERR %FINISH %FINISH MODDIRFILE(10,FILE,"","",0,HASHCONST,PLENGTH,FLAG) -> ERR %IF FLAG # 0 PRINTSTRING("New directory '".FILE."' created") NEWLINE ERR: SSOWN_RCODE = FLAG %IF FLAG # 0 %THEN PSYSMES(41,FLAG) %END; !OF NEWDIRECTORY %EXTERNALROUTINE ZNEWGEN(%STRING (255) S) %SYSTEMROUTINESPEC NEWGEN(%STRING (31) S, T, %INTEGERNAME FLAG) %STRING (31) OLD, NEW %INTEGER FLAG %STRING(7) TEMPLATE TEMPLATE = "FROM,TO" UCTRANSLATE (ADDR(S)+1,LENGTH(S)) FILPS (TEMPLATE,S) %IF PARMAP#3 %THEN %START; ! WRONG NO OF PARAMETERS FLAG = 263 -> ERR %FINISH OLD = SPAR(1) NEW = SPAR(2) NEWGEN(OLD,NEW,FLAG) ERR: SSOWN_RCODE = FLAG %IF FLAG # 0 %THEN PSYSMES(61,FLAG) %END; !OF NEWGEN %EXTERNALROUTINE OBEY(%STRING (255) S) !CURRENTLY THIS ONLY ACCEPTS ! ONE LEVEL OF OBEYING %STRING (31) INFILE, OUTFILE %RECORD(FDF)%NAME F %RECORD (RF)RR %INTEGER FLAG, AFD, CURFDLEVEL %STRING(9) TEMPLATE TEMPLATE = "FILE,OUT=" %IF CURSTACK#0 %THEN %START FLAG = 307 -> ERR %FINISH %IF SSOWN_FDLEVEL>1 %THEN %START; ! CANNOT OBEY IN OBEY FLAG = 315 -> ERR %FINISH UCTRANSLATE (ADDR(S)+1,LENGTH(S)) FILPS (TEMPLATE,S) %IF 1#PARMAP#3 %THEN %START; !WRONG NO OF PARAMS FLAG=263 ->ERR %FINISH INFILE = SPAR(1) OUTFILE = SPAR(2) CONNECT(INFILE,0,0,0,RR,FLAG) -> ERR %IF FLAG # 0 %IF RR_FILETYPE#SSCHARFILETYPE %THEN %START; ! INVALID FILE TYPE SSOWN_SSFNAME = INFILE FLAG = 267 -> E1 %FINISH SSOWN_SSOPENUSED=1; !TO ENSURE TIDY CALLED AT END OF OBEY IF IT FAILS DEFINE(88,INFILE,AFD,FLAG) -> E1 %IF FLAG # 0 F == RECORD(AFD) SET IO DEFAULT (SSOWN_INDEFAULT,88); !DEFAULT INPUTCHANNEL %IF OUTFILE # "" %START DEFINE(89,OUTFILE,AFD,FLAG) -> E1 %IF FLAG#0 SELECTOUTPUT(89); !IF IT FAILS WILL GIVE ! MESSAGE ON CURRENT STREAM SET IO DEFAULT (SSOWN_OUTDEFAULT,89) %FINISH SELECTINPUT(0) SELECTOUTPUT(0) CURFDLEVEL = SSOWN_FDLEVEL SSOWN_FDLEVEL = SSOWN_FDLEVEL+1 SSOWN_DATAECHO = SSOWN_SSDATAECHO; !USE OPTIONS FILE SETTING BCI SSOWN_FDLEVEL = CURFDLEVEL; !RESET IT %IF SSOWN_SSREASON = DSTARTREASON %THEN SSOWN_DATAECHO = 0 !RETURN TO NO ECHO TIDYFILES; !MUST TIDY HERE E1: %IF NEWCONNECT#0 %THEN %START DISCONNECT (INFILE, FLAG) %FINISH ERR: %IF FLAG # 0 %THEN PSYSMES(46,FLAG) %END; !OF OBEY %EXTERNALROUTINE ZOFFER(%STRING (255) S) %STRING (255) FILE, USER %INTEGER FLAG %STRING(11) TEMPLATE TEMPLATE = "FILE,USER=" %IF S="" %THEN LENGTH(TEMPLATE) = 9 %ELSE LENGTH(TEMPLATE) = 10 UCTRANSLATE (ADDR(S)+1,LENGTH(S)) FILPS (TEMPLATE,S) ! Check number of parameters: %IF 1#PARMAP#3 %THEN FLAG = 263 %ELSE %START FILE = SPAR(1) USER = SPAR(2) %IF LENGTH(FILE)>31 %THEN %START SSOWN_SSFNAME = FILE FLAG = 220 %FINISH %ELSE %IF 0#LENGTH(USER)#6 %THEN %START SSOWN_SSFNAME = USER FLAG = 201 %FINISH %ELSE %START OFFER(FILE,USER,FLAG) %FINISH %FINISH SSOWN_RCODE = FLAG %IF FLAG#0 %THEN PSYSMES(30,FLAG) %END; !OF OFFER ! ! ! %EXTERNALROUTINE OPTION(%STRING (255) S) ! **** **** There should be a NOCFAULTS option. ! %SYSTEMROUTINESPEC NEWGEN(%STRING(31) FILE,NEW FILE,%INTEGERNAME FLAG) %CONSTINTEGER MAXVKEY = 17 %CONSTINTEGER MAXKEY = 14 %CONSTSTRING(8) TEMPOPTIONS = "T#OPTION" %RECORD (RF)RR %RECORD(CONTF)%NAME C %CONSTINTEGER MAXSEARCHDIRCOUNT = 16 %STRING (63) VALUE, KEYWORD, PARAM %INTEGER I, CONAD, FLAG, IVALUE, MODE, OLDFLAG %IF NEWLOADER#0 %THEN %START %INTEGER OLDPERMISTK, INUSE %FINISH %CONSTSTRING (13) %ARRAY VKEY(1 : MAXVKEY) = %C "INITSTACKSIZE","AUXSTACKSIZE","USERSTACKSIZE", "ITWIDTH","FSTARTFILE","BSTARTFILE", "PRELOADFILE","ACTIVEDIR","REMOVEDIR","SEARCHDIR","ARRAYDIAG",%C "INITWORKSIZE","NULL","ITINSIZE","ITOUTSIZE","CFAULTS","TERMINAL" %SWITCH SW(1 : MAXKEY) %SWITCH VSW(1 : MAXVKEY) %CONSTSTRING (12) %ARRAY KEY(1 : MAXKEY) = %C "BRACKETS","NOBRACKETS","NORECALL","TEMPRECALL","PERMRECALL", "NOFSTARTFILE","?","NOBLANKLINES","BLANKLINES","NOBSTARTFILE", "INITPARMS","NOECHO","PARTECHO","FULLECHO" %ROUTINE RMSD(%STRING (31) DIR, %INTEGERNAME FLAG); ! REMOVESEARCHDIR %INTEGER I FLAG = 313; !NOT FOUND - DEFAULT %RETURN %IF C_SEARCHDIRCOUNT = 0 %FOR I=C_SEARCHDIRCOUNT,-1,1 %CYCLE %IF C_SEARCHDIR(I) = DIR %START C_SEARCHDIRCOUNT = C_SEARCHDIRCOUNT-1;!DECREMENT COUNTER %WHILE I <= C_SEARCHDIRCOUNT %CYCLE; !COMPACT REST OF LIST IF NEC C_SEARCHDIR(I) = C_SEARCHDIR(I+1) I = I+1 %REPEAT FLAG = 0 %RETURN %FINISH %REPEAT %END; !OF REMOVESEARCHDIR %ROUTINE ADSD(%STRING (31) DIR); ! ADDSEARCHDIR %INTEGER I %IF C_SEARCHDIRCOUNT > 0 %START; !SOME ALREADY - MOVE UP %FOR I=C_SEARCHDIRCOUNT,-1,1 %CYCLE C_SEARCHDIR(I+1) = C_SEARCHDIR(I) %REPEAT %FINISH C_SEARCHDIRCOUNT = C_SEARCHDIRCOUNT+1; !INCREMENT COUNTER C_SEARCHDIR(1) = DIR; !NEW DIRECTORY TO TOP OF LIST %END; !OF ADDSEARCHDIR %ROUTINE OUTI(%STRING (255) S, %INTEGER N) PRINTSTRING(S." :") WRITE(N,1) NEWLINE %END; !OF OUTI %ROUTINE OUTS(%STRING (255) S, T) PRINTSTRING(S." : ".T) NEWLINE %END; !OF OUTS ! ! !FIRST CALCULATE APPROPRIATE MODE FOR OPERATING ON OPTION FILE !IF ONLY PARAMETER IS '?' THEN USE READ MODE. OTHERWISE WRITE. %IF STUDENTSS=0 %THEN %START %IF S = "?" %THEN MODE = 0 %ELSE MODE = 3 %FINISH %ELSE %START MODE = 0 %FINISH CONNECT(SSOWN_OPTIONSFILE,0,0,0,RR,FLAG); !CONNECT ONLY IN READ MODE TO AVOID CONCURRENCY PROBLEMS %IF NEWCONNECT#0 %THEN %START SETUSE (LAST, -1, 0) %FINISH %IF FLAG = 218 %START; !FILE DOES NOT EXIST %IF STUDENTSS#0 %THEN %START FLAG = 0 C == RECORD (SSOWN_SSADEFOPT) %FINISH %ELSE %START %IF MODE = 0 %START; !ONLY READ ACCESS REQUIRED FLAG = 0 C == RECORD(SSOWN_SSADEFOPT); !NO OPTION FILE - USE DEFAULT %FINISH %ELSE %START; !NEED TO CREATE ONE OUTFILE(SSOWN_OPTIONSFILE,4096,0,0,CONAD,FLAG) -> ERR %IF FLAG # 0 FSTATUS(SSOWN_OPTIONSFILE,1,0,FLAG); !CHERISH OPTIONS FILE MOVE(OPTFILESIZE,SSOWN_SSADEFOPT,CONAD); !COPY INTO MY CONTROL FILE %FINISH %FINISH %FINISH %ELSE %IF FLAG=0 %THEN %START %IF RR_FILETYPE#SSOPTFILETYPE %THEN %START FLAG = 267 SSOWN_SSFNAME = SSOWN_OPTIONSFILE -> ERR %FINISH C == RECORD(RR_CONAD); !MAP RECORD ONTO FILE %FINISH %ELSE -> ERR; !FAILED TO CONNECT FOR SOME OTHER REASON %IF MODE = 3 %THEN %START; !FILE IS TO BE CHANGED %IF NEWCONNECT#0 %THEN %START RDISCON(SSOWN_OPTIONSFILE,FLAG); !IGNORE FLAG - ENSURE WE GET LATEST COPY %FINISH %ELSE %START DISCONNECT (SSOWN_OPTIONSFILE, FLAG) %FINISH OUTFILE(TEMPOPTIONS,4096,0,0,CONAD,FLAG) -> ERR %IF FLAG # 0 %IF NEWCONNECT#0 %THEN %START SETUSE (LAST, -1, 0) %FINISH CONNECT(SSOWN_OPTIONSFILE,0,0,0,RR,FLAG) -> ERR %IF FLAG # 0 %IF NEWCONNECT#0 %THEN %START SETUSE (LAST, -1, 0) %FINISH MOVE(OPTFILESIZE,RR_CONAD,CONAD); !COPY INTO TEMP FILE %IF NEWCONNECT=0 %THEN %START DISCONNECT (SSOWN_OPTIONSFILE,FLAG) %FINISH C == RECORD(CONAD); !MAP RECORD ONTO TEMPORARY COPY C_DATETIME = CURRENTPACKEDDT; !UPDATE DATE AND TIME %FINISH ! ! SETPAR(S) ! AGAIN: ! PARAM = SPAR(0); !NEXT PARAM OLDFLAG = FLAG; !SAVE PREVIOUS FLAG FLAG = 0; !RESET FOR NEXT PARAM -> USEINFO %IF PARAM = ""; !END OF LIST %FOR I=MAXKEY,-1,1 %CYCLE; !FIRST CHECK FOR SIMPLE KEYWORDS %IF PARAM = KEY(I) %THEN -> SW(I) %REPEAT %IF PARAM -> KEYWORD.("=").VALUE %START %IF '0' <= CHARNO(VALUE,1) <= '9' %START IVALUE = PSTOI(VALUE); !SOME TAKE A POSITIVE INTEGER AS PARAM %FINISH %ELSE %START !MUST BE A FILENAME %IF (LENGTH(VALUE)<8 %OR CHARNO(VALUE,7)#'.') %C %AND CHARNO(VALUE,1)#'.' %C %THEN VALUE = SSOWN_SSOWNER.".".VALUE IVALUE = -1; !IMPOSSIBLE VALUE %FINISH %FOR I=MAXVKEY,-1,1 %CYCLE %IF KEYWORD = VKEY(I) %THEN -> VSW(I) %REPEAT %FINISH SSOWN_SSFNAME = PARAM FLAG = 202; !INVALID PARAM PSYSMES(67,FLAG) -> AGAIN SW(1): !BRACKETS %IF STUDENTSS=0 %THEN %START C_LDELIM = '(' C_RDELIM = ')' %FINISH -> AGAIN SW(2): !NOBRACKETS %IF STUDENTSS=0 %THEN %START C_LDELIM = ' ' C_RDELIM = NL %FINISH -> AGAIN SW(3): !NOJOURNAL %IF STUDENTSS=0 %THEN %START C_JOURNAL = 0 %FINISH -> AGAIN SW(4): !TEMPRECALL %IF STUDENTSS=0 %THEN %START C_JOURNAL = 1 %FINISH -> AGAIN SW(5): !PERMJOURNAL %IF STUDENTSS=0 %THEN %START C_JOURNAL = 2 %FINISH -> AGAIN SW(6): !NOFSTARTFILE %IF STUDENTSS=0 %THEN %START C_FSTARTFILE = "" %FINISH -> AGAIN SW(7): ! ? LIST OPTIONS PRINTSTRING("List of current options:") NEWLINES(2) PRINTSTRING(KEY(3+C_JOURNAL)); !NORECALL ETC NEWLINE %IF C_LDELIM = ' ' %THEN PRINTSTRING("NO") PRINTSTRING("BRACKETS") NEWLINE %IF C_NOBL = 1 %THEN PRINTSTRING("NO") PRINTSTRING("BLANKLINES") NEWLINE OUTI("ITWIDTH",C_ITWIDTH) OUTI("ARRAYDIAG",C_ARRAYDIAG) OUTI("ITINSIZE",C_ITINSIZE>>KSHIFT) OUTI("ITOUTSIZE",C_ITOUTSIZE>>KSHIFT) ! OUTI("USERSTACKSIZE",C_USTK>>KSHIFT) %IF C_ISTK >= 0 %THEN OUTI("INITSTACKSIZE",C_ISTK>>KSHIFT) OUTI("AUXSTACKSIZE",C_ASTK>>KSHIFT) %IF C_INITWORKSIZE#0 %THEN OUTI("INITWORKSIZE",C_INITWORKSIZE>>KSHIFT) OUTS("ACTIVEDIR",C_MODDIR) %IF C_FSTARTFILE#"" %C %THEN OUTS("FSTARTFILE",C_FSTARTFILE) %C %ELSE %START PRINTSTRING("NOFSTARTFILE") NEWLINE %FINISH %IF C_BSTARTFILE#"" %C %THEN OUTS("BSTARTFILE",C_BSTARTFILE) %C %ELSE %START PRINTSTRING("NOBSTARTFILE") NEWLINE %FINISH PRINTSTRING("INITPARMS : "); PRINTSTRING(PRINTPARMS(C_INITPARMS)) NEWLINE %IF C_CFAULTS # "" %THEN OUTS("CFAULTS",C_CFAULTS) PRINTSTRING(KEY(12+C_DATAECHO)) NEWLINE %IF C_SEARCHDIRCOUNT > 0 %START NEWLINE %FOR I=1,1,C_SEARCHDIRCOUNT %CYCLE OUTS("SEARCHDIR ".ITOS(I),C_SEARCHDIR(I)) %REPEAT %FINISH -> AGAIN SW(8): !NOBLANKLINES %IF STUDENTSS=0 %THEN %START C_NOBL = 1 %FINISH -> AGAIN SW(9): !BLANKLINES %IF STUDENTSS=0 %THEN %START C_NOBL = 0 %FINISH -> AGAIN SW(10): !NOBSTARTFILE %IF STUDENTSS=0 %THEN %START C_BSTARTFILE = "" %FINISH -> AGAIN SW(11): !SET INITIAL PARMS ON STARTUP %IF STUDENTSS=0 %THEN %START C_INITPARMS = LONGINTEGER(ADDR(SSOWN_SSCOMREG(27))) %FINISH -> AGAIN SW(12): !NOECHO SW(13): !PARTECHO SW(14): !FULLECHO %IF STUDENTSS=0 %THEN %START C_DATAECHO = I-12; != 0, 1 OR 2 %FINISH ->AGAIN VSW(1): !INITSTACKSIZE ! %IF STUDENTSS=0 %THEN %START ! ! **** Comment relevant only to new loader: ! Altering the initstacksize is slightly complicated by the ! introduction of 'permanent' initialised stack at ss3.00. The ! PERMISTK is held at the top of the initialised stack area and ! expands 'downwards' to meet the TEMPISTK expanding upwards. ! Since altering the INITSTACKSIZE effectively means moving ! the perm ISTK which would of course cause severe problems ! for the routines expecting to find it, the operation cannot be ! permitted if any perm ISTK is in use. ! ******************************************************************** IVALUE = IVALUE< 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>KSHIFT) %THEN %START C_ASTK = IVALUE< 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< AGAIN %FINISH -> INVLU %FINISH %ELSE %START -> AGAIN %FINISH ! VSW(14): !ITINSIZE ! %IF STUDENTSS=0 %THEN %START %IF 16>=IVALUE>0 %THEN %START C_ITINSIZE = IVALUE< 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< AGAIN %FINISH %IF CHARNO(VALUE,LENGTH(VALUE))='B' %START; !AS ABOVE - TEMP LENGTH(VALUE) = LENGTH(VALUE)-1 C_ITOUTSIZE = PSTOI(VALUE) -> AGAIN %FINISH -> INVLU %FINISH %ELSE %START -> AGAIN %FINISH ! VSW(16): !CFAULTS ! %IF STUDENTSS=0 %THEN %START %IF CHARNO(VALUE,1) = '.' %THEN %START; !DEVICE CODE %IF LENGTH(VALUE) > 15 %THEN FLAG = 202; !INVALID PARAMETER %FINISH %ELSE %START FLAG = CHECKFILENAME(VALUE,5); !OWN FILE %IF FLAG = 0 %THEN VALUE = SSOWN_CURFNAME; !REMOVE OWNERNAME %FINISH %IF FLAG # 0 %THEN -> INVLU C_CFAULTS = VALUE %FINISH -> AGAIN ! VSW(17): !TERMINAL=N ! %IF STUDENTSS=0 %THEN %START C_TERMINAL=IVALUE %FINISH %ELSE %START SSOWN_SSTERMINALTYPE = IVALUE %FINISH ->AGAIN INVLU: SSOWN_SSFNAME = VALUE %IF FLAG = 0 %THEN FLAG = 202; !INVALID PARAM UNLESS OTHERWISE STATED PSYSMES(67,FLAG) -> AGAIN USEINFO: !NOW USE NEW OPTIONS - WHERE RELEVANT %IF STUDENTSS=0 %THEN %START %IF MODE = 3 %THEN %START NEWGEN(TEMPOPTIONS,SSOWN_OPTIONSFILE,FLAG) -> ERR %IF FLAG # 0 USEOPTIONS %FINISH %FINISH ERR: %IF FLAG # 0 %THEN %START PSYSMES(67,FLAG) %IF STUDENTSS=0 %THEN %START DESTROY(TEMPOPTIONS,OLDFLAG); !MUST LEAVE FLAG INTACT FOR SSOWN_RCODE %FINISH %FINISH %ELSE FLAG = OLDFLAG SSOWN_RCODE = FLAG; !SET RETURN FLAG %END; !OF OPTION ! ! %EXTERNALROUTINE PARM(%STRING (255) S) ! **** There should perhaps be a complete set of "inverse PARMs". ! %CONST %LONG %INTEGER FREEBIT = X'0008000000000000' %INTEGER J, FLAG %LONGINTEGER PAT FLAG = 0 %IF S = "?" %START PRINTSTRING("Parms set: ") PRINTSTRING(PRINTPARMS(LONGINTEGER(ADDR(SSOWN_SSCOMREG(27))))) NEWLINE %FINISH %ELSE %START PAT = DEFAULTPARM !! FREEBIT %IF ""#S#"FREE" %THEN %START; ! Test for "FREE" only needed ! during transition from default "FIXED" to default "FREE". FLAG = 202 SETPAR(S) %CYCLE S = SPAR(0); !GET NEXT PARAM %EXIT %IF S=""; ! End of list. J = 0 %WHILE J<=MAXPARMS %AND S#PARMS(J) %CYCLE J = J + 1 %REPEAT %IF J<=MAXPARMS %THEN %START PAT = PAT!(LONGONE<>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 QUSER="?" %OR QDATE="?" %OR QMODE="?" %START PRINT=TRUE DPERM=0 %UNLESS FILE="" %START; !file="" means only whole index permissions QDATE=""; !set to null for call on dpermission 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 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< ERR %FINISH %FINISH %IF FILE=""=USER %THEN USER = "??????" FLAG = 0 PERMIT INNER (FILE, DATE, USER, TYPE, IMODE, FLAG); ! Permit the file ERR: %IF FLAG#0 %START %IF TYPE=DISC FILE %THEN PSYSMES(32, FLAG) %ELSE %C PRINTSTRING("APERMIT fails - ".FAILUREMESSAGE(FLAG)) %FINISH %END ; ! DO PERMIT %EXTERNALROUTINE ZPERMIT (%STRING(255) PARAM) ! = the old ZPERMIT - for online files %CONSTINTEGER DISC FILE = 0 DO PERMIT (DISC FILE, PARAM) %END; !OF ZPERMIT %EXTERNALROUTINE APERMIT (%STRING(255) PARAM) ! = the old ZPERMIT - for archived files %CONSTINTEGER ARCHIVED FILE = 1 DO PERMIT (ARCHIVED FILE, PARAM) %END; !OF APERMIT %EXTERNALROUTINE REMOVE(%STRING (255) S) %STRING (31) OBJFILE %INTEGER FLAG FLAG = 0 SETPAR(S) %CYCLE OBJFILE = SPAR(0) -> ERR %IF OBJFILE = ""; !END OF LIST MODDIRFILE(2,SSOWN_AVD,"",OBJFILE,0,0,0,FLAG) %IF FLAG # 0 %THEN PSYSMES(36,FLAG) %REPEAT ERR: SSOWN_RCODE = FLAG %END; !OF REMOVE %EXTERNALROUTINE REMOVEMACRO(%STRING(255)S) REMOVE(S) %END; !OF REMOVEMACRO %EXTERNALROUTINE ZRENAME(%STRING (255) S) %SYSTEMROUTINESPEC RENAME(%STRING (31) OLD, NEW, %C %INTEGERNAME FLAG) %INTEGER FLAG, PD %STRING (31) OLD, NEW, OLDMEMBER, NEWMEMBER %STRING(15) TEMPLATE TEMPLATE = "OLDNAME,NEWNAME" UCTRANSLATE (ADDR(S)+1,LENGTH(S)) FILPS (TEMPLATE,S) %IF PARMAP#3 %THEN %START; ! WRONG NO OF PARAMS FLAG = 263 -> ERR %FINISH OLD = SPAR(1); !OLD NAME NEW = SPAR(2) %IF OLD -> OLD.("_").OLDMEMBER %THEN PD = 1 %ELSE PD = 0 %IF PD = 1 %START %UNLESS NEW -> NEW.("_").NEWMEMBER %AND NEW=OLD %THEN %START ! INCONSISTENT PARAMETERS FLAG = 297 -> ERR %FINISH MODPDFILE(3,OLD,OLDMEMBER,NEWMEMBER,FLAG) %FINISH %ELSE RENAME(OLD,NEW,FLAG) ERR: SSOWN_RCODE = FLAG %IF FLAG # 0 %THEN PSYSMES(38,FLAG) %END; !OF RENAME ! %EXTERNALINTEGERFN RETURNCODE %RESULT = SSOWN_RCODE %END; !OF RETURNCODE %EXTERNALROUTINE SEND(%STRING (255) S) %STRING (31) FILE, DEVICE %INTEGER FLAG %STRING(23) TEMPLATE TEMPLATE = "FILE=T#LIST,DEVICE=.LP" UCTRANSLATE (ADDR(S)+1,LENGTH(S)) FILPS (TEMPLATE,S) %IF PARMAP>3 %THEN %START FLAG=263 ->ERR %FINISH FILE = SPAR(1); !FILENAME %IF FILE = "" %THEN FILE = "T#LIST"; !DEFAULT FILENAME DEVICE = SPAR(2) %IF DEVICE = "" %THEN DEVICE = ".LP" ! SIMPLE TEST FOR INVALID DEVICE CODE %IF CHARNO(DEVICE,1)#'.' %THEN %START FLAG = 264 -> ERR %FINISH SENDFILE(FILE,DEVICE,"",0,0,FLAG) ERR: SSOWN_RCODE = FLAG %IF FLAG # 0 %THEN PSYSMES(40,FLAG) %END; !OF SEND %EXTERNALROUTINE SETRETURNCODE(%INTEGER I) SSOWN_RCODE = I %END; !OF SETRETURNCODE %EXTERNALROUTINE ZSTOP(%STRING (255) S) %INTEGER I %IF STUDENTSS#0 %THEN %START %ROUTINE MONITORSESSION %CONSTINTEGER RECLENGTH = 32 %RECORDFORMAT MF(%STRING (6) USER, %BYTEINTEGER S1, %C %INTEGER PDT, CPUMILLSECS, PAGETURNS, ELSECS, S2, S3) %RECORD (MF) %NAME M %INTEGERNAME COUNT %INTEGER FLAG, CT, MAX, HOLDCOUNT, POS %RECORD (RF) RR SSOWN_ALLCONNECT = 1; !To ensure we can connect monitor file CONNECT(SSOWN_SESSMONFILE,11,0,0,RR,FLAG); !Connect WRITE and other users %IF FLAG # 0 %THEN %RETURN FLAG = FINDFN (SSOWN_CURFILE, POS) MAX = (SSOWN_CONF(POS)_SIZE-36)//RECLENGTH; !Maximum of records it can hold COUNT == INTEGER(RR_CONAD+32) *INCT_(COUNT) *ST_HOLDCOUNT %IF HOLDCOUNT *RRSB_0 *RCP_R'50800000000000000000000000000000' *JCC_2, *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, *ST_X *RRSB_0 *RCP_R'50800000000000000000000000000000' *JCC_2, *LSQ_X *RAD_R'51880000000000000000000000000000' *STUH_WORK *USH_-44 *AND_X'FFF' *ST_%B *L_WORK *USH_12 *NEQ_X'8000000000000000' *OR_%B *EXIT_-64 FAIL:%SIGNAL %EVENT 1,1 %END; ! OF LINT ! ! - END OF PRINT TEXT ] ! ! [ START OF IOCP TEXT - !* !* %SYSTEMINTEGERFN IOCP(%INTEGER EP, PARM) %CONSTINTEGER MAXEP = 27 %CONST %INTEGER %ARRAY XSP (0:7) = %C X'FFFFFFDF', X'00000000', X'00000000', X'00000001', X'FFFFFFFF', X'FFFFFFFF', X'FFFFFFFF', X'FFFFFFFF' ! The bits in XSP correspond to the bytes in CHTOSYM. For each I in ! the range 0 to 255, if CHTOSYM(I)#I or CHTOSYM(I)=0 or CHTOSYM(I)=NL, ! then XSP bit I will be one, and otherwise bit I will be zero. ! It is vital that, if CHTOSYM is changed, the corresponding changes ! should be made to XSP. Accordingly, the code used to generate ! XSP is appended as a comment: ! **** **** **** **** **** **** **** **** **** **** **** **** ! **** %INTEGER I, S ! **** %INTEGER %ARRAY XSP (0:7) ! **** %ROUTINE PRHEX(%INTEGER VALUE, PLACES) ! **** %CONST %BYTE %INTEGER %ARRAY HEX (0:15) = '0','1','2','3','4', %C ! **** '5','6','7','8','9','A','B','C','D','E','F' ! **** %INTEGER I ! **** %FOR I=PLACES<<2-4,-4,0 %CYCLE ! **** PRINT SYMBOL(HEX(VALUE>>I&15)) ! **** %REPEAT ! **** %END ! **** %ROUTINE SET BIT (%INTEGER N) ! **** %INTEGER BNDX ! **** BNDX = N >> 5 ! **** XSP (BNDX) = XSP(BNDX) ! (1<<(31-(N&31))) ! **** %RETURN ! **** %END ! **** %FOR I=0,1,7 %CYCLE ! **** XSP (I) = 0 ! **** %REPEAT ! **** SET BIT (0) ! **** %FOR I=255,-1,1 %CYCLE ! **** S = CHTOSYM (I) ! **** %UNLESS I=S#NL %THEN SET BIT (I) ! **** %REPEAT ! **** PRINT STRING ("%CONST %INTEGER %ARRAY XSP (0:7) = ") ! **** %FOR I=0,1,7 %CYCLE ! **** PRINT STRING ("X'") ! **** PRHEX (XSP(I),8) ! **** PRINT SYMBOL ('''') ! **** %IF I<7 %THEN PRINT STRING (", ") %ELSE NEWLINE ! **** %REPEAT ! **** **** **** **** **** **** **** **** **** **** **** **** %SWITCH SW (0 : 2*MAXEP) ! %SWITCH AUXSW (1:MAXEP) not needed now SW is declared up to 2*MAXEP. %INTEGER TOP, C, FLAG, HOLD, LEN, AFD, RES, I, FROM, TO %INTEGER TRTAD, AEP6S, EP6SEND, SENDNL, CHAD, CHS LEFT ! %INTEGER INFEND %INTEGER SAVEOUTDSNUM, MCICNTRL, NEXTRES, ACURREC, READING %INTEGER PART AD, PART LEN, RESIDUE LEN, NLF, ACKBITS, ADFORLIM %LONG %INTEGER DRH ! ! %ROUTINE PECHO %IF SSOWN_OUTF_DSNUM=SSOWN_OUTDEFAULT %C %THEN SAVEOUTDSNUM = -1 %C %ELSE %START SAVEOUTDSNUM = SSOWN_OUTF_DSNUM SELECTOUTPUT(0) %FINISH I = IOCP (7,ADDR(SSOWN_PROMPTTEXT)); ! PRINTSTRING(SSOWN_PROMPTTEXT) ! %FOR I=SSOWN_INF_CUR,1,INF_END-1 %CYCLE ! ! %UNTIL end of available data or end of line. ! PRINTSYMBOL(BYTEINTEGER(I)) ! %IF BYTEINTEGER(I) = NL %THEN %EXIT ! %REPEAT DRH = SSOWN_INF_CUR ! (LENGTHENI((SSOWN_INF_END-SSOWN_INF_CUR-1)!X'18000000')<<32) ! ! This code prepares a descriptor in DRH ready for a call ! on IOCP entry 23 ('PRINT SEVERAL SYMBOLS'), which will ! be equivalent to the IMP code commented out above. ! A byte vector descriptor must be ready in DRH. Its ! address must be a copy of SSOWN_INF_CUR, and its bound must be ! one LESS than the length of the available data. This is ! so that we don't test last byte - if SWNE gets that ! far then it will be printed anyway. ! ! ! *LD_DRH *SWNE_%L=%DR,0,10; ! %MASK=0, %REF=NL. *INCA_1; ! Take one more byte than what SWNE has skipped. *CYD_0 *STUH_%B ! Acc now has address of first byte NOT to be printed. *ISB_DRH+4; ! That is a copy of SSOWN_INF_CUR. ! Acc now has count of bytes to be printed. *ST_DRH; ! DRH has lost its type, but that is not ! needed for the ensuing call on IOCP. I = IOCP (23,ADDR(DRH)) %IF SAVEOUTDSNUM > 0 %THEN SELECTOUTPUT(SAVEOUTDSNUM) %END; ! of PECHO. ! ! %ROUTINE GETINPUT %INTEGER LEN, LNB, FLAG, START, ADICRSA SSOWN_RSYMLIM = 0 SSOWN_RCHLIM = 0 %IF SSOWN_INF_ACCESSROUTE = 9 %THEN %START; ! For console: ADICRSA=ADDR(SSOWN_ICRSA) %IF SSOWN_ICRSA=0 %THEN LEN = 0 %ELSE %START START = SSOWN_ICRSA + 1 LEN = SSOWN_ICRSE - SSOWN_ICRSA %FINISH %IF LEN=0 %THEN %START CONSOLE(1,START,LEN) SSOWN_ICRSE = START + LEN %FINISH SSOWN_INF_CUR = START SSOWN_INF_CURREC = START *LDTB_X'18000000' *LDB_LEN *LDA_START *SWNE_%L=%DR,0,25; ! %MASK=0, %REF=EM. *JCC_8, *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_CUR0 %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_CUR0 %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_ 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_ ! 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_ 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, *MODD_1 *CYD_0 *INCA_-1 *STD_%TOS *MV_%L=%DR *LD_%TOS *J_ ! SW6ZX: *CYD_0 *STUH_%B *J_%TOS ! ! MARKNL: ! %IF NLF#0 %THEN %START *LSS_NLF *JAT_4, ! 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, *MODD_1 *CYD_0 *STUH_%B *ST_(%XNB+0) *J_ 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 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_ ! 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, ! ! %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_ ! 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_ ! 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_ ! 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, ! 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, *JLK_ ! 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_ *ST_%B *SBB_TO *ST_TO *JLK_; ! 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 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_CUR0 %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, ! 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_ ! %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_ S2E0L1: ! The second: %MASK=0,%REF=EM: *LD_DRH *SWNE_%L=%DR,0,25 S2E0L2: *JCC_8,; ! -> %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_; ! -> %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, ! 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, *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_ 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_ SSOWN_OUTF_CUR = TO RESIDUE LEN = RESIDUE LEN - PART LEN %FINISH %ELSE I = -1 %IF I#0 %THEN PUT OUTPUT %REPEAT %IF SENDNL#0 %THEN %START ! Put out NL using simulated IOCP 5. %IF SSOWN_OUTF_CUR>=SSOWN_OUTF_END %THEN PUT OUTPUT BYTE INTEGER (SSOWN_OUTF_CUR) = NL SSOWN_OUTF_CUR = SSOWN_OUTF_CUR + 1 PUT OUTPUT %FINISH ! -> RESULTZERO ! ! RESULTZERO: !STANDARD EXIT %RESULT = 0 INEND: !SIGNAL INPUT ENDED SIGNAL(2,140,0,FLAG) %END; !OF IOCP %SYSTEMINTEGERFN JOBREADCH !THIS IS REQUIRED BY THE JOB CONTROL TO PROVIDE TRUE READCH WHICH !MUST NOT BE RE-ROUTED TO MASTERCHARIN. IT ACHIEVES THIS BY STATICISING !SSOWN_CONTROLMODE, SETTING IT TO ZERO, CALLING READCH AND RE-SETTING SSOWN_CONTROLMODE !THIS IS A HORRID MECHANISM AND MUST BE REPLACED %INTEGER HOLDCONTROLMODE, RES HOLDCONTROLMODE = SSOWN_CONTROLMODE SSOWN_CONTROLMODE = 0 READCH(RES) SSOWN_CONTROLMODE = HOLDCONTROLMODE %RESULT = RES %END; !OF JOBREADCH %SYSTEMINTEGERFN JOBNEXTCH !SEE COMMENTS IN JOBREADCH ABOVE %INTEGER HOLDCONTROLMODE, RES HOLDCONTROLMODE = SSOWN_CONTROLMODE SSOWN_CONTROLMODE = 0 RES = NEXTCH SSOWN_CONTROLMODE = HOLDCONTROLMODE %RESULT = RES %END; !OF JOBNEXTCH %EXTERNALINTEGERFN INSTREAM !RESULT IS STREAM NO ! CURRENTLY SELECTED FOR INPUT %INTEGER STREAM STREAM = SSOWN_SSCOMREG(22) %IF STREAM = SSOWN_INDEFAULT %THEN STREAM = 0 !STANDARD MAPPING %RESULT = STREAM %END; !OF INSTREAM %EXTERNALINTEGERFN OUTSTREAM %INTEGER STREAM STREAM = SSOWN_SSCOMREG(23) %IF STREAM = SSOWN_OUTDEFAULT %THEN STREAM = 0 !STANDARD MAPPING %RESULT = STREAM %END; !OF OUTSTREAM %EXTERNALINTEGERFN INPOS !RESULT IS POSITION OF LAST CHARACTER READ FROM INPUT LINE %RESULT = IOCP(20,0) %END; !OF INPOS %EXTERNALINTEGERFN OUTPOS !RESULT IS POSITION OF LAST ! CHARACTER OUTPUT TO LINE %RESULT = IOCP(20,1); !OUTPOS ENTRY IN IOCP %END; !OF OUTPOS %EXTERNALROUTINE TERMINATE %INTEGER DUMMY DUMMY = IOCP(25,0) %END; !OF TERMINATE %SYSTEMROUTINE SIM2(%INTEGER EP, R1, R2, %INTEGERNAME R3) !PROVISIONAL SIM ROUTINE ONLY ! ACCEPTS CALLS ON EP 0 AND 1 ! PROTEM %SWITCH SW(0 : 1) %INTEGER %ARRAY IOCP PARM (1:3) %INTEGER DUMMY ! %INTEGER P, C %IF EP = 15 %THEN -> SELECTIO; !ENTRY TO DO SELECTINPUT OR OUTPUT %UNLESS 0<=EP<=1 %THEN %START; ! INVALID EP R3 = -1 -> ERR %FINISH -> SW(EP) SW(0): !READ A RECORD FROM CURRENT ! STREAM INTO AREA AT R1 !RETURN LENGTH IN R3 ! %FOR R3=0,1,159 %CYCLE ! C = IOCP(4,0); !READCH CALL ON IOCP ! BYTEINTEGER(R1+R3) = C; !PUT IT IN BUFFER ! %IF C = EM %START; !INPUT ENDED ! BYTEINTEGER(R1+R3+1) = NL; !ADD NEWLINE TO END ! R3 = R3+2 ! -> ERR ! %FINISH ! %IF C = NL %THEN R3 = R3+1 %AND -> ERR ! !END OF RECORD ! %REPEAT ! !GOT HERE SO MUST BE LINE OF ! ! 160 CHAS ! R3 = 0; !TO INDICATE INCOMPLETE RECORD ! -> ERR IOCP PARM (1) = R1 IOCP PARM (2) = R2 IOCP PARM (3) = ADDR (R3) DUMMY = IOCP (26,ADDR(IOCP PARM(1))) -> ERR ! SW(1): !OUTPUT A RECORD AT R1 OF ! LENGTH R2 R3 = 0; !DEFAULT REPLY ! %IF SSOWN_OUTF_ACCESSROUTE = 9 %START ! !OUTPUT TO IT ! %IF R2 > 1 %THEN %START ! %FOR P=1,1,R2-1 %CYCLE ! DUMMY = IOCP(5,BYTEINTEGER(R1+P)) ! !PRINTCH ! %REPEAT ! %FINISH ! DUMMY = IOCP(5,NL); !NEWLINE CALL ! %FINISH %ELSE %START; !OUTPUT TO FILE (OR SPOOLED ! ! DEVICE) ! %IF 12 # BYTEINTEGER(R1) # 13 %THEN BYTEINTEGER(R1) = NL ! !DEFAULT CONTROL CHARACTER ! %IF SSOWN_OUTF_CUR+R2 <= SSOWN_OUTF_END %START ! !ROOM IN FILE ! MOVE(R2,R1,SSOWN_OUTF_CUR) ! SSOWN_OUTF_CUR = SSOWN_OUTF_CUR+R2; !UPDATE POINTER ! -> ERR ! %FINISH ! %FOR P=0,1,R2-1 %CYCLE ! DUMMY = IOCP(5,BYTEINTEGER(R1+P)) ! !PRINTCH ! %REPEAT ! %FINISH IOCP PARM (1) = R1 IOCP PARM (2) = R2 IOCP PARM (3) = ADDR (R3) DUMMY = IOCP (27,ADDR(IOCP PARM(1))) -> ERR SELECTIO: !SELECTINPUT OR OUTPUT %IF R1 = 0 %THEN SELECTINPUT(R2) %ELSE SELECTOUTPUT(R2) R3 = 0; !WORKED OK IF GOT BACK HERE !DOES NOT ALLOW FOR ERROR RECOVERY PROTEM ERR: %END; !OF SIM2 %EXTERNALSTRINGFN INTERRUPT !IF THERE IS AN OUTSTANDING ! MULTI-CHARACTER TERMINAL ! INTERRUPT IT !RETURNS IT AND CLEARS IT- ! OTHERWISE RETURNS NULL STRING %INTEGER FLAG %STRING (15) RES %IF SSOWN_TTYPE # 2 %THEN %RESULT = ""; !NO MULTI-CHAR INTS FROM OPER RES = SSOWN_IOSTAT_INTMESS %IF RES # "" %THEN FLAG = X6{DCLEARINTMESSAGE} %RESULT = RES %END; !OF INTERRUPT %EXTERNALROUTINE CLOSESTREAM(%INTEGER CHAN) %INTEGER FLAG %IF 0MAXPROMPTSIZE %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,; ! -> %IF residue length=0. ETOI (ADDR(SSOWN_PROMPTTEXT)+1,LEN) NOBCDIC: %FINISH %END; !OF FPRMPT ! %INTEGER %FN RQOUT (%INTEGER T, AD) %INTEGER FLAG, R SSOWN_SSTTACT = 1 R = X34{REQUESTOUTPUT} (T, AD) SSOWN_SSTTACT = 0 %IF SSOWN_SSTTKN#0 %THEN %START CONSOLE (7,FLAG,FLAG) SSOWN_SSTTKN = 0 %FINISH %RESULT = R %END ! %SYSTEMROUTINE CONSOLE(%INTEGER EP, %INTEGERNAME START, LEN) %CONSTINTEGER MAXEP = 19 %CONST %INTEGER OPBIN = X'21' %SWITCH SW(1 : MAXEP) %INTEGER I, HOLD, FLAG, OPMESSAGELEN %STRING (255) S %IF NOTES ON#0 %THEN %START !**NOTESTART %IF SSOWN_SSNOTE # 0 %START %BEGIN %STRING (15) IS, JS %IF BYTEINTEGER(ADDR(START)) # X'81' %C %THEN IS = ITOS(START) %ELSE IS = "UNASSIGNED" %IF BYTEINTEGER(ADDR(LEN)) # X'81' %C %THEN JS = ITOS(LEN) %ELSE JS = "UNASSIGNED" NOTE("CONSOLE( ".ITOS(EP).", ".IS.", ".JS." )") %END; !OF BEGIN - END BLOCK %FINISH !**NOTEEND %FINISH %ROUTINE OPMESS(%STRING (255) S) TOJOURNAL(ADDR(S)+1,LENGTH(S)); !OUTPUT TO JOURNAL FILE X20{DOPER}(SSOWN_OPERNO,S) %END; !OF OPMESS %ROUTINE GETOPER !GET INPUT FROM OPER CONSOLE %RECORDFORMAT PF(%INTEGER DEST, SRCE, %STRING (23) MESS) %RECORD (PF)P %STRINGNAME IN %BYTEINTEGERNAME LAST IN == STRING(ADDR(SSOWN_INBUFF(0))) IN = ""; !CLEAR IT OUT %IF SSOWN_PROMPTTEXT = COMMANDPROMPT %C %THEN SSOWN_PROMPTTEXT = "Command:" !NO NEWLINES ALLOWED IN OPER PROMPTS X21{DOPERPROMPT}(SSOWN_OPERNO,SSOWN_PROMPTTEXT) %CYCLE X23{DPOFF}(P) IN = IN.P_MESS LAST == BYTEINTEGER(ADDR(IN)+LENGTH(IN)) %IF LAST = 133 %THEN LAST = 10;!MAP TO IMP NEWLINE %EXIT %IF LAST = NL %REPEAT START = ADDR(SSOWN_INBUFF(1)); !START OF INPUT TEXT LEN = SSOWN_INBUFF(0); !LENGTH OF INPUT TEXT %END; !OF GETOPER %ROUTINE INITFEP %INTEGER FLAG, ISIZE %RECORD (RF)CONREC %RECORD (FRF) INFOREC !CREATE INPUT AND OUTPUT %IF SSOWN_ITINLENGTH<320 %THEN SSOWN_ITINLENGTH = 1024 %IF SSOWN_ITOUTLENGTH<1024 %THEN SSOWN_ITOUTLENGTH = 3072 SSOWN_IOSTAT == RECORD(SSOWN_AIOSTAT); !MAP OWN RECORD FOR INPUT STATUS ! BUFFER FILES OUTFILE(ITFILENAME,SSOWN_ITINLENGTH+SSOWN_ITOUTLENGTH,0,8,SSOWN_AITBUFFER, %C FLAG) %IF FLAG#0 %THEN %START FINFO (ITFILENAME,0,INFOREC,FLAG) %IF FLAG=0 %THEN CONNECT (ITFILENAME,19,0,8,CONREC,FLAG) %IF FLAG # 0 %THEN X30{DSTOP}(107) !DISASTER CANNOT CREATE INPUT ! OUTPUT BUFFER SSOWN_AITBUFFER = CONREC_CONAD ISIZE = (INFOREC_SIZE*SSOWN_ITINLENGTH)//(SSOWN_ITINLENGTH+SSOWN_ITOUTLENGTH) %UNLESS 320<=ISIZE<=INFOREC_SIZE-1024 %THEN ISIZE = INFOREC_SIZE>>2 SSOWN_ITINLENGTH = ISIZE SSOWN_ITOUTLENGTH = INFOREC_SIZE - ISIZE %FINISH SSOWN_IT == RECORD(SSOWN_AITBUFFER); !MAP CONTROL RECORD ONTO START OF BUFFER SSOWN_IT = 0; !CLEAR RECORD SSOWN_IT_INLENGTH = SSOWN_ITINLENGTH-64; !LEAVE ROOM FOR THE CONTROL RECORD SSOWN_IT_OUTLENGTH = SSOWN_ITOUTLENGTH SSOWN_IT_INBASE = SSOWN_AITBUFFER+64; !LENGTH OF CONTROL RECORD SSOWN_IT_OUTBASE = SSOWN_IT_INBASE+SSOWN_IT_INLENGTH !NOW ENABLE THE STREAMS FLAG = X12{DENABLETERMINALSTREAM}(0,1,0,SSOWN_IT_INBASE,SSOWN_IT_INLENGTH, %C 0) %IF FLAG # 0 %THEN X30{DSTOP}(109) FLAG = X12{DENABLETERMINALSTREAM}(1,1,0,SSOWN_IT_OUTBASE,SSOWN_IT_ %C OUTLENGTH,0) %IF FLAG # 0 %THEN X30{DSTOP}(110) INITJOURNAL SSOWN_TTYPE = 2 %END; !OF INITFEP %ROUTINE TOBUFFER(%INTEGER START, LEN, %INTEGERNAME POS) !PUTS DATA INTO OUTPUT BUFFER WRAPPING AROUND IF REQUIRED !POS RETURNS THE POSITION OF THE NEXT FREE BYTE IN THE BUFFER %CONST %INTEGER CR = 13 %INTEGER HOLE, SIZE, TOAD, TOADLIM %INTEGER HOLDDRTB, HOLDDRA; ! These must stay together. SIZE = LEN HOLDDRTB = 0 TOAD = SSOWN_IT_OUTBASE+SSOWN_IT_OUTPOINTER TOADLIM = SSOWN_IT_OUTBASE + SSOWN_IT_OUTLENGTH - 1 %WHILE SIZE>0 %CYCLE %IF SSOWN_OPMODE=OPTEXT %AND SSOWN_FEPMODE=OPBIN %THEN %START ! CRs need inserting, but the FEP will not do it. %IF HOLDDRTB#0 %THEN %START ! Plant CR ! We can safely assume that TOAD<=TOADLIM BYTE INTEGER (TOAD) = CR %IF TOAD=TOADLIM %THEN TOAD = SSOWN_IT_OUTBASE %ELSE TOAD = TOAD + 1 START = HOLDDRA *LD_HOLDDRTB *SWEQ_%L=%DR,0,10; ! %MASK=0, %REF=NL *J_ %FINISH *LDTB_X'18000000' *LDA_START *LDB_SIZE SCANL: *SWNE_%L=%DR,0,10; ! %MASK=0, %REF=NL *STD_HOLDDRTB LEN = HOLDDRA - START %FINISH HOLE = TOADLIM - TOAD + 1 SIZE = SIZE - LEN %IF LEN <= HOLE %START; !ENOUGH ROOM MOVE(LEN,START,TOAD) %IF LEN=HOLE %THEN TOAD = SSOWN_IT_OUTBASE %ELSE TOAD = TOAD + LEN %FINISH %ELSE %START MOVE(HOLE,START,TOAD) LEN = LEN-HOLE MOVE(LEN,START+HOLE,SSOWN_IT_OUTBASE); !PUT REST AT START OF BUFFER TOAD = SSOWN_IT_OUTBASE + LEN %FINISH %REPEAT POS = TOAD - SSOWN_IT_OUTBASE %END; !OF TOBUFFER %ROUTINE GETFEP %INTEGER I, INPOS, POS, FLAG %IF SSOWN_IOSTAT_INPOS = SSOWN_IT_INPOINTER %START !NO INPUT IN BUFFER ! SSOWN_IT_OUTBUSY = 1; !DONT PRINT OPER MESSAGE WHILE WAITING FOR INPUT ! **** **** We think that last line could come out **** **** ! **** **** when the TCP s/w is modified. **** **** POS = SSOWN_IT_OUTPOINTER TOBUFFER(ADDR(SSOWN_PROMPTTEXT)+1,LENGTH(SSOWN_PROMPTTEXT),POS) SSOWN_SSTTACT = -1 FLAG = X33{REQUESTINPUT}(POS,SSOWN_IT_INPOINTER) SSOWN_SSTTACT = 0 !GET INPUT CALL %IF FLAG # 0 %THEN X30{DSTOP}(111) %FINISH START = SSOWN_IT_INBASE+SSOWN_IT_INPOINTER INPOS = SSOWN_IOSTAT_INPOS; !MUST FREEZE IT IN LOCAL ! VARIABLE TO AVOID CONFUSION ! IF IT CHANGES %IF INPOS > SSOWN_IT_INPOINTER %START !USE ALL INPUT - NO WRAPROUND LEN = INPOS-SSOWN_IT_INPOINTER SSOWN_IT_INPOINTER = INPOS %FINISH %ELSE %START; !WRAP AROUND SO ONLY USE PART ! TO END OF BUFFER LEN = SSOWN_IT_INLENGTH-SSOWN_IT_INPOINTER SSOWN_IT_INPOINTER = 0 %FINISH %IF LEN > 1 %START ! **** What follows is a "scan for NL" and it would be ! **** quicker in machine code. %FOR I=0,1,LEN-2 %CYCLE; !ONLY RETURN ONE LINE AT ATIME %IF BYTEINTEGER(START+I) = NL %START LEN = I+1 SSOWN_IT_INPOINTER = START+LEN-SSOWN_IT_INBASE;!TO SHOW HOW MUCH WE'VE USED %EXIT; !NEWLINE FOUND %FINISH %REPEAT %FINISH SSOWN_IT_OUTBUSY = 0 ! **** **** The final two statements of this routine **** **** ! **** **** can lead to the whole of OUTFEP being **** **** ! **** **** executed without any protection from **** **** ! **** **** asynchronous interrupts arriving. If a **** **** ! **** **** further INT:T or operator message should **** **** ! **** **** arrive, that could cause trouble. **** **** FLAG = 0 %IF SSOWN_IT_INTTWAITING # 0 %THEN CONSOLE(12,FLAG,FLAG) !INT:T WAITING %IF SSOWN_IT_OMWAITING # 0 %THEN CONSOLE(6,FLAG,FLAG) !PRINT MESSAGE THAT WAS WAITING %END; !OF GETFEP %INTEGERFN FREESPACE %INTEGER RES RES = SSOWN_IT_LASTFREE-SSOWN_IT_OUTPOINTER %IF RES <= 0 %THEN RES = RES+SSOWN_IT_OUTLENGTH RES = RES-MAXPROMPTSIZE %IF RES < 0 %THEN RES = 0 %RESULT = RES %END; !OF FREESPACE %ROUTINE OUTFEP(%INTEGER FROM, LEN) %INTEGER FREE, POS, FLAG, TRIGGER %RETURN %IF LEN <= 0 %IF SSOWN_SSTTHIDE=0 %THEN %START SSOWN_IT_OUTBUSY = 1 %IF EP # 10 %THEN TOJOURNAL(FROM,LEN); !OUTPUT TO RECALL FILE !UNLESS GRAPHICS OUTPUT !UNLESS OP MESSAGE OR INT:T %CYCLE FREE = FREESPACE; !HOW MUCH LEFT %EXIT %IF LEN <= FREESPACE; !ENOUGH ROOM FOR IT ALL %IF 6 # EP # 12 %THEN SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS TOBUFFER(FROM,FREE,POS); !POS POINTS TO BYTE AFTER END OF INSERTED TEXT TRIGGER = POS-SSOWN_IT_OUTLENGTH>>2; !SEND 3/4 OF BUFFER %IF TRIGGER < 0 %THEN TRIGGER = TRIGGER+SSOWN_IT_OUTLENGTH SSOWN_IT_OUTPOINTER = POS LEN = LEN-FREE FROM = FROM+FREE %IF 6 # EP # 12 %THEN ALLOW INTERRUPTS; !EXCEPT WHEN PRINTING OPER MESSAGES FLAG = RQOUT(POS,TRIGGER) %IF FLAG < 0 %THEN X30{DSTOP}(115) SSOWN_IT_LASTFREE = FLAG %REPEAT %IF LEN > 0 %START; !SOME LEFT %IF 6 # EP # 12 %THEN SSOWN_SSINHIBIT = 1 TOBUFFER(FROM,LEN,POS) SSOWN_IT_OUTPOINTER = POS FLAG = RQOUT(POS,-1) %IF FLAG < 0 %THEN X30{DSTOP}(115) SSOWN_IT_LASTFREE = FLAG %IF 6 # EP # 12 %THEN ALLOWINTERRUPTS %FINISH SSOWN_IT_OUTBUSY = 0 %FINISH ! **** **** The final two statements of this routine **** **** ! **** **** can lead to the whole of OUTFEP being **** **** ! **** **** executed without any protection from **** **** ! **** **** asynchronous interrupts arriving. If a **** **** ! **** **** further INT:T or operator message should **** **** ! **** **** arrive, that could cause trouble. **** **** FLAG = 0 %IF SSOWN_IT_OMWAITING # 0 %AND EP # 6 %C %THEN CONSOLE(6,FLAG,FLAG) %IF SSOWN_IT_INTTWAITING # 0 %AND EP # 12 %C %THEN CONSOLE(12,FLAG,FLAG) %END; !OF OUTFEP %ROUTINE KILL INPUT %INTEGER FLAG, CURSOR %RETURN %UNLESS SSOWN_TTYPE = 2 FLAG = X10{DDISABLETERMINALSTREAM1}(CURSOR,0,5) !ABORT INPUT %IF FLAG # 0 %THEN X30{DSTOP}(118) FLAG = X12{DENABLETERMINALSTREAM}(0,SSOWN_FEPMODE,0,SSOWN_IT_INBASE,SSOWN_IT_ %C INLENGTH,0) %IF FLAG # 0 %THEN X30{DSTOP}(119) SSOWN_IT_INPOINTER = SSOWN_IOSTAT_INPOS %END; !OF KILL INPUT %ROUTINE KILLOUTPUT %INTEGER FLAG, CURSOR %RETURN %UNLESS SSOWN_TTYPE = 2 SSOWN_IT_OUTBUSY = 1; !TO IGNORE OPER MESSAGES ! DURING KILL OUTPUT FLAG = X10{DDISABLETERMINALSTREAM1}(CURSOR,1,5) !ABORT OUTPUT %IF FLAG # 0 %THEN X30{DSTOP}(114) FLAG = X12{DENABLETERMINALSTREAM}(1,SSOWN_FEPMODE,0,SSOWN_IT_OUTBASE,SSOWN_IT_ %C OUTLENGTH,0) %IF FLAG # 0 %THEN X30{DSTOP}(116) SSOWN_IT_OUTPOINTER = 0 SSOWN_IT_LASTFREE = 0 SSOWN_IT_OUTBUSY = 0; !OFF WE GO AGAIN %END; !OF KILL OUTPUT %ROUTINE SETMODE(%INTEGER START, LEN) %INTEGER FLAG, CURSOR %RETURN %IF LEN <= 0 SSOWN_IT_OUTBUSY = 1; !TO HOLD OFF OPER MESSAGES %IF SSOWN_IT_OUTPOINTER # 0 %START; ! THIS IS RUBBISH, IF IT'S A TEST FOR AN EMPTY BUFFER. FLAG = 0; !PROTEM - AWAITING A CORRECTION FROM BRIAN GILMORE FLAG = RQOUT(SSOWN_IT_OUTPOINTER,SSOWN_IT_OUTPOINTER-1); ! BUT IF WE TAKE OUT ! THE TEST ABOVE, WE WILL NEED TO IMPROVE THIS. !CLEAR OUTPUT BUFFER %IF FLAG < 0 %THEN X30{DSTOP}(115) %FINISH FLAG = X10{DDISABLETERMINALSTREAM1}(CURSOR,1,4); !DISABLE OUTPUT %IF FLAG # 0 %THEN X30{DSTOP}(114) FLAG = X12{DENABLETERMINALSTREAM}(1,X'31',0,SSOWN_IT_OUTBASE,SSOWN_IT_ %C OUTLENGTH,0) !ENABLE FOR CONTROL OUTPUT %IF FLAG # 0 %THEN X30{DSTOP}(116) MOVE(LEN,START,SSOWN_IT_OUTBASE); !MOVE IN THE CONTROL MESSAGE FLAG = RQOUT(LEN,LEN-1); !SEND OUTPUT AND AWAIT TERMINATION %IF FLAG < 0 %THEN X30{DSTOP}(115) FLAG = X10{DDISABLETERMINALSTREAM1}(CURSOR,1,4) %IF FLAG # 0 %THEN X30{DSTOP}(114) FLAG = X12{DENABLETERMINALSTREAM}(1,SSOWN_FEPMODE,0,SSOWN_IT_OUTBASE,SSOWN_IT_ %C OUTLENGTH,0) !RE-ENABLE FOR NORMAL OUTPUT %IF FLAG # 0 %THEN X30{DSTOP}(116) SSOWN_IT_OUTPOINTER = 0 SSOWN_IT_LASTFREE = 0 SSOWN_IT_OUTBUSY = 0 %END; !OF SETMODE %UNLESS 1 <= EP <= MAXEP %THEN -> ERR !IGNORE INVALID EPS -> SW(EP) SW(1): !GET INPUT SSOWN_SSTTHIDE = 0 %IF SSOWN_TTYPE = 0 %THEN GETOPER %IF SSOWN_TTYPE = 2 %THEN GETFEP TOJOURNAL(ADDR(SSOWN_PROMPTTEXT)+1,LENGTH(SSOWN_PROMPTTEXT)) !PROMPT TO JOURNAL FILE TOJOURNAL(START,LEN); !INPUT TO JOURNAL FILE -> ERR SW(2): !PUT OUTPUT %IF LEN > 0 %THEN %START %IF LEN > 1 %AND SSOWN_OUTBUFF(LEN) = NL %THEN %START ! REMOVE TRAILING SPACES UNLESS ONLY A NEWLINE OR NOT ENDING WITH NL ! **** We could use TRAILSPACES here instead of the %CYCLE, ! **** but it probably isn't worth it. %FOR I=LEN-1,-1,1 %CYCLE; !LOCATE LAST PRINTABLE CHAR ON LINE %IF SSOWN_OUTBUFF(I) # ' ' %THEN %EXIT %REPEAT !I NOW POINTS TO HIGHEST PRINTABLE CHARACTER %IF I = 1 %AND SSOWN_OUTBUFF(1) = ' ' %THEN I = 0 !AMBIGUOUS VALUE LEN = I+1 SSOWN_OUTBUFF(LEN) = NL %FINISH I = 0 %IF SSOWN_TTYPE=2 %THEN %START; ! OUTFEP CAN TAKE ALL 73 CHAS ! IGNORE 1 CHAR LINES IF OPTION SELECTED %IF (LEN=1 %AND SSOWN_OUTBUFF(1)#NL) %OR LEN>SSOWN_SSNOBLANKLINES %THEN %START OUTFEP(ADDR(SSOWN_OUTBUFF(1)),LEN) %FINISH %FINISH %ELSE %IF LEN>1 %THEN %START; ! ALWAYS IGNORE BLANK LINES TO OPER SSOWN_OUTBUFF(0) = LEN OPMESS(STRING(ADDR(SSOWN_OUTBUFF(0)))) %FINISH %FINISH START = ADDR(SSOWN_OUTBUFF(1)); !START OF OUTPUT BUFFER LEN = 133; !MAX LENGTH OF BUFFER -> ERR SW(3): !SELECT IT -> ERR SW(4): !SELECT OPER SSOWN_OPERNO = START !START CONTAINS SSOWN_OPERNO SSOWN_AITBUFFER = GETSPACE(64) SSOWN_IT == RECORD(SSOWN_AITBUFFER) SSOWN_IT = 0 INITJOURNAL -> ERR SW(5): !SELECT FEP INITFEP -> ERR SW(6): !PRINT OPERATOR MESSAGE -> ERR %UNLESS SSOWN_TTYPE = 2 !EITHER USING OPER CONSOLE OR ! NOT YET CONNECTED TO FEP OR ! BATCH JOB %IF START # 0 %START; !BROADCAST MESSAGE %IF SSOWN_BOPMESSSTART = 0 %THEN SSOWN_BOPMESSSTART = START !NONE OUTSTANDING SSOWN_BOPMESSLEN = SSOWN_BOPMESSLEN+LEN %FINISH -> ERR %IF SSOWN_INHIBITMESSAGES # 0; !TEMPORARY INHIBIT %IF SSOWN_IT_OUTBUSY#0 %THEN %START SSOWN_IT_OMWAITING = 1 -> ERR %FINISH SSOWN_IT_OMWAITING=0; !STRAIGHT AWAY TO AVOID RACE WITH INT:T %BEGIN %RECORD %FORMAT FHDRF (%INTEGER NEXT FREE BYTE, %C TXT REL ST, MAX BYTES, ZERO, %C SEMA, DATE, NEXT CYCLIC, READ TO) %RECORD (FHDRF)%NAME H1 %INTEGER CONSEG, GAP, AVAILABLE, MOUT %BYTEINTEGERARRAY OPERBUFF(0 : 2001) %ROUTINE XNL (%INTEGER %NAME L) %INTEGER I, C, P %IF OPERBUFF(L)=NL %THEN L = L - 1 %IF 0=0 %THEN AVAILABLE = SSOWN_BOPMESSLEN %ELSE %START AVAILABLE = H1_MAX BYTES - SSOWN_BOPMESSSTART SSOWN_BOPMESSLEN = SSOWN_BOPMESSLEN + H1_MAX BYTES - H1_TXT REL ST %FINISH MOVE (AVAILABLE, %C SSOWN_BROADCASTFILEBASE+SSOWN_BOPMESSSTART, %C ADDR(OPERBUFF(1))) MOVE (SSOWN_BOPMESSLEN - AVAILABLE, %C SSOWN_BROADCASTFILEBASE+H1_TXT REL ST, %C ADDR(OPERBUFF(1))+AVAILABLE) XNL (SSOWN_BOPMESSLEN) OUTFEP(ADDR(OPERBUFF(0)),SSOWN_BOPMESSLEN+1) MOUT = 1 %FINISH %FINISH %CYCLE OPMESSAGELEN = 2000; !MAXIMUM SPACE FOR MESSAGE FLAG = X16{DMESSAGE2}(SSOWN_SSOWNER,OPMESSAGELEN,0,0,SSOWN_SSOWNFSYS, %C ADDR(OPERBUFF(1))) %IF OPMESSAGELEN = 0 %OR FLAG # 0 %THEN %EXIT !NO MESSAGE LEFT OR FAILURE XNL (OPMESSAGELEN) OUTFEP(ADDR(OPERBUFF(0)),OPMESSAGELEN+1) MOUT = 1 %REPEAT %IF MOUT#0 %THEN OUTFEP (ADDR(OPERBUFF(0)),1) SSOWN_BOPMESSSTART = 0 SSOWN_BOPMESSLEN = 0 %END; !OF BEGIN-END BLOCK -> ERR SW(7): !KILL OUTPUT KILL OUTPUT -> ERR SW(8): !KILL INPUT -> ERR %UNLESS SSOWN_TTYPE = 2; !ONLY IF USING FEP SSOWN_IT_INPOINTER = SSOWN_IOSTAT_INPOS -> ERR SW(9): !FORCE OUT OUTSTANDING OUTPUT -> ERR %UNLESS SSOWN_TTYPE = 2 %AND SSOWN_IT_OUTPOINTER # 0 !NO CONSOLE %IF START=0 %THEN I = -1 %ELSE I = SSOWN_IT_OUTPOINTER - 1 ! That decides whether to await reply from REQUESTOUTPUT or not. FLAG = RQOUT(SSOWN_IT_OUTPOINTER,I) !PUT OUT ALL CURRENT OUTPUT -> ERR SW(10): !DIRECT OUTPUT CALL FOR GRAPHICS ! SW10: used to be here. -> ERR %UNLESS SSOWN_TTYPE = 2; !MUST BE OUTPUTING TO TELETYPE OUTFEP(START,LEN) -> ERR SW(11): !DIRECT OUTPUT CALL FROM IOCP23 ! NO LONGER USED. ! -> ERR %IF LEN <= 0 ! %IF SSOWN_TTYPE = 2 %THEN -> SW10 ! S = "" ! %FOR I=START,1,START+LEN-1 %CYCLE ! HOLD = BYTEINTEGER(I) ! S = S.TOSTRING(HOLD) ! %IF HOLD = 10 %OR LENGTH(S) = 255 %START ! OPMESS(S) ! S = "" ! %FINISH ! %REPEAT -> ERR SW(12): !INT:T -> ERR %UNLESS SSOWN_TTYPE = 2; !NOT FROM I.T. %IF SSOWN_IT_OUTBUSY#0 %THEN %START SSOWN_IT_INTTWAITING = 1 -> ERR %FINISH SSOWN_IT_INTTWAITING=0; !STRAIGHT AWAY - TO AVOID A RACE WITH OPER MESSAGE S = " T=".ITOS(INT(CPUTIME-SSOWN_OLDCPUTIME))." PT=".ITOS( %C PAGETURNS-SSOWN_OLDPAGETURNS)." U=".ITOS(INTEGER(AUSERS)-SYSPROCS) !**FUNDSSTART %IF FUNDS ON#0 %THEN %START %IF SCARCEWORD&X'FF'>=SCARCEWORD>>24 %START ! INTERACTIVE USERS >= SCARCE LIMIT S=S." **Resources are Scarce." %FINISH %FINISH !**FUNDSEND S=S." " OUTFEP(ADDR(S)+1,LENGTH(S)) -> ERR SW(13): !GET BUFFER AND IOSTAT ADDRESSES %IF SSOWN_TTYPE=2 %C %AND SSOWN_INF_ACCESSROUTE=9=SSOWN_OUTF_ACCESSROUTE %C %AND SSOWN_CONTROLMODE=0 %C %THEN %START ! ONLY IF RUNNING FROM INTERACTIVE TERMINAL ! AND BOTH CURRENT STREAMS POINT TO TERMINAL START = SSOWN_AITBUFFER LEN = SSOWN_AIOSTAT %FINISH %ELSE %START START = 0 %FINISH -> ERR SW(14): !RESET SSOWN_IT_JNBASE %IF SSOWN_AITBUFFER # 0 %THEN SSOWN_IT_JNBASE = IMOD(SSOWN_IT_JNBASE) -> ERR SW(15): !SETMODE REQUEST -> ERR %UNLESS SSOWN_TTYPE = 2; !ONLY WORKS FOR INTERACTIVE TERMINAL SETMODE(START,LEN) -> ERR SW(17): !NEW SETMODE REQUEST -> ERR %UNLESS SSOWN_TTYPE = 2; !ONLY WORKS FOR INTETACTIVE TERMINAL SSOWN_FEPMODE = LEN SETMODE(START+1,BYTEINTEGER(START)) -> ERR SW(18): !SELECT OUTPUT MODE, 1=ISO, #1=BINARY -> ERR %UNLESS SSOWN_TTYPE = 2 %IF START = 1 %THEN I = OPTEXT %ELSE I = OPBIN %IF I = SSOWN_OPMODE %THEN -> ERR SSOWN_OPMODE = I %IF SSOWN_FEPMODE=OPBIN %THEN -> ERR SSOWN_IT_OUTBUSY = 1 %IF SSOWN_IT_OUTPOINTER # 0 %THEN %START FLAG = 0; !TEMP FLAG = RQOUT(SSOWN_IT_OUTPOINTER,SSOWN_IT_OUTPOINTER-1) %IF FLAG < 0 %THEN X30{DSTOP}(115) %FINISH FLAG = X10{DDISABLETERMINALSTREAM1}(HOLD,1,4) %IF FLAG # 0 %THEN X30{DSTOP}(114) FLAG = X12{DENABLETERMINALSTREAM}(1,OPBIN,0,SSOWN_IT_OUTBASE,SSOWN_IT_OUTLENGTH,0) %IF FLAG # 0 %THEN X30{DSTOP}(116) SSOWN_FEPMODE = OPBIN SSOWN_IT_OUTPOINTER = 0 SSOWN_IT_LASTFREE = 0 SSOWN_IT_OUTBUSY = 0 -> ERR SW(19): KILL INPUT -> ERR ERR: %END; !OF CONSOLE %SYSTEMROUTINE TOJOURNAL(%INTEGER FROM, LEN) %INTEGER HOLE %RETURN %IF SSOWN_IT_JNBASE <= 0 %OR LEN <= 0; !NOJOURNAL OR NO TEXT %IF LEN > 4096 %THEN LEN = 4096; !TRUNCATE LONG REQUESTS %CYCLE HOLE = SSOWN_IT_JNMAX - SSOWN_IT_JNCUR %IF LEN=SSOWN_IT_JNMAX %THEN SSOWN_IT_JNCUR = SSOWN_IT_JNBASE + 32 BYTEINTEGER(SSOWN_IT_JNCUR) = 255; !CURRENT END %END; !OF TOJOURNAL %IF NOTES ON#0 %THEN %START !**NOTESTART %SYSTEMROUTINE NOTE(%STRING (255) S) S = " ** ".S." " TOJOURNAL(ADDR(S)+1,LENGTH(S)) %END; !OF NOTE !**NOTEEND %FINISH ! ! ! - END OF IOCP TEXT ] ! ! [ START OF EFILE TEXT - %SYSTEMINTEGERFN FDMAP(%INTEGER CHAN) !RETURNS THE ADDRESS OF THE ! REQUESTED FILE DESCRIPTOR - ! IF ANY !OTHERWISE 0 IF NOT DEFINED SSOWN_SSOPENUSED = 1; !TEMPORARY %RESULT = SSOWN_SSFDMAP(CHAN) %END; !OF FDMAP %SYSTEMINTEGERFN DEVCODE(%STRING (16) DEVICE) !RETURNS -1 FOR INVALID DEVICE OTHERWISE DEVICE CODE %RECORD (RF)RR %INTEGER I, FLAG, SPECIAL %STRING (16) REST %STRING (147) %ARRAYFORMAT DEVARRAYAF(1 : 254) %STRING (147) %ARRAYNAME DEVARRAY SPECIAL = 0; !NOT A SPECIAL DEVICE - DEFAULT %IF DEVICE="" %OR CHARNO(DEVICE,1)#'.' %THEN %RESULT = 0 CHOPLDR (DEVICE,1) !INVALID DEVICE CODE UCTRANSLATE (ADDR(DEVICE)+1, LENGTH(DEVICE)) %IF DEVICE = "LP" %THEN %RESULT = 127; !SPECIAL CASE - VERY COMMON %IF DEVICE = "TEMP" %OR DEVICE = "NULL" %THEN %RESULT = 0 %IF (DEVICE -> REST.("BPP") %C %OR DEVICE -> REST.("SGP")) %C %AND REST="" %C %THEN %START CHOPLDR (DEVICE,1) SPECIAL = X'100' {SMH} %FINISH %IF SSOWN_DEVARRAYBASE = 0 %START; !TRY AND CONNECT SPOOLR CONTROL FILE CONNECT(SPOOLERCFILE,9,0,8,RR,FLAG); !CONNECT READ WITH WRITE ALLOWED ELSEWHER, PREVENT DISCONNECT %IF FLAG # 0 %THEN %RESULT = -FLAG SSOWN_MAXDEVARRAY = INTEGER(RR_CONAD+24); !NO OF QUEUES SSOWN_DEVARRAYBASE = RR_CONAD+RR_DATASTART %FINISH DEVARRAY == ARRAY(SSOWN_DEVARRAYBASE,DEVARRAYAF) %FOR I=SSOWN_MAXDEVARRAY,-1,1 %CYCLE %IF DEVARRAY(I) = DEVICE %THEN %RESULT = I!SPECIAL %REPEAT %RESULT = -1; !INVALID DEVICE %END; !OF DEVCODE %SYSTEMSTRINGFN DEVNAME(%INTEGER CODE) %STRING (147) %ARRAYFORMAT DEVARRAYAF(1 : 254) %STRING (147) %ARRAYNAME DEVARRAY %STRING (16) RES %INTEGER SPECIAL SPECIAL = CODE&X'100'; {SMH} !IF SET MUST BE A SPECIAL DEVICE CODE = CODE&X'FF' {SMH} %IF CODE = 127 %THEN %RESULT = ".LP" %IF 0 < CODE <= SSOWN_MAXDEVARRAY %THEN %START DEVARRAY == ARRAY(SSOWN_DEVARRAYBASE,DEVARRAYAF) RES = DEVARRAY(CODE) %IF SPECIAL # 0 %START %IF LENGTH(RES)>=2 %AND CHARNO(RES,2)='P' %THEN %START %IF CHARNO(RES,1)='G' %THEN RES = "S".RES %IF CHARNO(RES,1)='P' %THEN RES = "B".RES %FINISH %FINISH %RESULT = ".".RES %FINISH %RESULT = "" %END; !OF DEVNAME ! The following %FUNCTION, %ROUTINEs and %MAP were added to allow the FORTRAN ! 77 OPEN and CLOSE statements access to the Subsystem FD table. ! Mike Brown October 1981. ! %SYSTEM %ROUTINE SET OPEN USED ! Used when a file is opened, but not by OPEN. SSOWN_SSOPENUSED must be set, ! or else TIDYFILES is not called from AFTERCOMMAND to close open ! streams after the run of the compiled program. SSOWN_SSOPENUSED = 1 %END ! %SYSTEM %INTEGER %FN FDADDR ! Returns the address of the FD Subsystem FD table. %RESULT = ADDR(SSOWN_FD(1)) %END ! %SYSTEM %ROUTINE SETTOPFD (%INTEGER FDNO) ! Allows a new entry in the FD table set from FORTRAN 77 OPEN to be the ! current top FD entry number. Required when TIDYFILES does a CLOSE. %IF FDNO>SSOWN_TOPFD %THEN SSOWN_TOPFD = FDNO %END ! %SYSTEM %INTEGER %MAP MAPSSFD (%INTEGER DSNUM) ! Allows two-way access to the SSOWN_SSFDMAP pointer table. %RESULT == SSOWN_SSFDMAP (DSNUM) %END %SYSTEMROUTINE DEFINE(%INTEGER CHAN, %C %STRING (31) IDEN, %INTEGERNAME AFD, FLAG) %RECORD (DRF)DATADR %RECORD(FDF)%NAME F %INTEGER I, DEVC %STRING (16) REST FLAG = 0; !DEFAULT %UNLESS 0 < CHAN <= 99 %THEN FLAG = 223 %AND -> ERR !INVALID CHANNEL AFD = SSOWN_SSFDMAP(CHAN) %IF AFD # 0 %START; !CHANNEL ALREADY DEFINED F == RECORD(AFD) %IF F_STATUS # 0 %THEN FLAG = 265 %AND -> ERR !CHANNEL OPEN %FINISH %ELSE %START %FOR I=1,1,MAXFD %CYCLE; !LOOK FOR EMPTY RECORD %IF SSOWN_FD(I)_DSNUM = 0 %START !EMPTY CELL FOUND AFD = ADDR(SSOWN_FD(I)_LINK) SSOWN_SSFDMAP(CHAN) = AFD F == SSOWN_FD(I) %IF I > SSOWN_TOPFD %THEN SSOWN_TOPFD = I !HIGHEST FD USED SO FAR %EXIT %FINISH %IF I = MAXFD %THEN FLAG = 165 %AND -> ERR !TOO MANY DEFINITIONS %REPEAT %FINISH F = 0; !CLEAR WHOLE RECORD F_DSNUM = CHAN F_IDEN = IDEN F_RECTYPE = 2; !DEFAULT RECTYPE=V F_MINREC = 1 F_MAXREC = 1024 F_MAXSIZE = SEGSIZE; !DEFAULT MAXSIZE %IF IDEN#"" %AND CHARNO(IDEN,1)='.' %THEN %START %IF IDEN=".IN" %THEN F_ACCESSROUTE = 1 %C %ELSE %IF IDEN=".OUT" %THEN F_ACCESSROUTE = 2 %C %ELSE %IF IDEN=".TT" %THEN %START %UNLESS 90<=CHAN<=91 %THEN %START FLAG = 264 -> CLEAR %FINISH ! ONLY ALLOW .TT FOR CHANS 90 AND 91 PROTEM F_ACCESSROUTE = 9 F_MAXREC = 160; !MAX FOR STREAM OUTPUT BUFFER ! PROTEM %FINISH %ELSE %START DEVC = DEVCODE(IDEN) %IF DEVC<0 %THEN %START; ! INVALID DEVICE CODE FLAG = 264 -> CLEAR %FINISH %IF IDEN->REST.(".LP") %AND REST="" %THEN F_FLAGS = F_FLAGS!16 !INTERPRET FE CHAS %IF DEVC#0 %THEN %START; ! NOT .NULL OR .TEMP F_MODEOFUSE = 1 F_MAXREC = 160 %FINISH F_DEVCODE = DEVC & 255 F_F4 = DEVC>>8 F_TEMPIDEN = "T#".NEXTTEMP F_ACCESSROUTE = 8 %IF IDEN=".NULL" %THEN F_ACCESSROUTE = 10; ! SPECIAL CASE FOR ".NULL" %FINISH %FINISH %ELSE %START %IF IDEN = "*" %START; !ALIEN DATA SUPPLYDATADESCRIPTOR(DATADR) F_ACCESSROUTE = 11; !ALIEN DATA F_DATASTART = DATADR_AD F_MAXSIZE = DATADR_LENGTH&X'FFFFFF' %FINISH %ELSE %START; !MUST BE A FILENAME %IF 'a'<=CHARNO(IDEN,1)<='z' %C %OR 'A'<=CHARNO(IDEN,1)<='Z' %C %THEN FLAG=CHECKFILENAME(IDEN,15) %C %ELSE FLAG=220 {invalid filename} -> CLEAR %IF FLAG # 0 F_ACCESSROUTE = 8 %FINISH %FINISH F_MODE = 11; !PROTEM F_VALIDACTION = 127; !ALLOW ALL ACTIONS -> ERR CLEAR: F_DSNUM = 0 SSOWN_SSFDMAP(CHAN) = 0 ERR: SSOWN_SSFNAME = IDEN %END; !OF DEFINE %SYSTEM %ROUTINE SET IO DEFAULT (%INTEGER %NAME D, %INTEGER I) %INTEGER AFD, R %RECORD (FDF)%NAME F %CYCLE AFD = SSOWN_SSFDMAP (I) %RETURN %IF AFD = 0 F == RECORD (AFD) R = F_ACCESSROUTE %EXIT %IF R#6 I = F_ASVAR %REPEAT %IF R=5 %OR 8<=R<=10 %THEN D = I %END %SYSTEMROUTINE TIDYFILES %STRING (11) BOUTPUT %RECORD(FDF)%NAME F %RECORD (RF)RR %RECORD(DIRINFF)%NAME DIRINF %INTEGER AFD, FLAG, I %IF SSOWN_TIDYFSTARTED = 0 %START; !INITIAL ENTRY DIRINF == RECORD(SSOWN_SSADIRINF) SSOWN_TIDYFSTARTED = 1; !TO SHOW WE'VE BEEN HERE %IF BATCHREASON#SSOWN_SSREASON#TESTREASON %START; !OPER OR FEP TERMINAL DEFINE(90,".TT",AFD,FLAG) DEFINE(91,".TT",AFD,FLAG) %FINISH %IF SSOWN_SSREASON=BATCHREASON %THEN %START; !BATCH JOB CONNECT(DIRINF_JOBDOCFILE,0,0,(SSOWN_SSOWNFSYS<<8)!X'80',RR, %C FLAG) %IF FLAG # 0 %THEN X30{DSTOP}(128); !CANNOT CONNECT BATCH JOB FILE !TO ENSURE WE CONNECT THE CONTROL FILE ON THE RIGHT FSYS %IF INTEGER(RR_CONAD+24) # 0 %C %THEN SSOWN_CONTROLMODE = 0 %ELSE SSOWN_CONTROLMODE = 1 !DETACH SETS BIT IN THIS WORD !DETACHJOB AND CARD INPUT DO NOT DEFINE(90,DIRINF_JOBDOCFILE,AFD,FLAG) BOUTPUT = "JO#".SUBSTRING(DIRINF_JOBDOCFILE,8,LENGTH( %C DIRINF_JOBDOCFILE)) %IF NEWCONNECT=0 %THEN %START OUTFILE(BOUTPUT,K4,0,0,I,FLAG);!CHECK THAT WE CAN CREATE IT. %FINISH %ELSE %START OUTFILE(BOUTPUT,K4,-1,0,I,FLAG);!CHECK THAT WE CAN CREATE IT !BUT DON'T CONNECT IT. %FINISH %IF FLAG # 0 %START DEFINE(91,".LP",AFD,I) SELECTOUTPUT(91) PRINTSTRING("Batch Job ".DIRINF_JOBNAME. %C " Failure to create output file - ". %C FAILUREMESSAGE(FLAG)) BATCHSTOP(0) %FINISH %IF NEWCONNECT=0 %THEN %START DISCONNECT (BOUTPUT, FLAG); ! Ensures that file is permanent ! and should survive a crash for ! SPOOLR to list any contents. %FINISH DEFINE(91,BOUTPUT,AFD,FLAG) F == RECORD(AFD) F_MAXSIZE = X'100000'; !LARGE SIZE FOR BATCH OUTPUT FILE SSOWN_BOUTPUTDEVICE = "LP"; !DOES NOT YET ALLOW FOR RE-ROUTE %FINISH %IF SSOWN_SSREASON=TESTREASON %THEN %START; ! Test start for benchmark. DEFINE (90,".NULL",AFD,I); !Only input comes from FSTARTFILE DEFINE (91,".LP",AFD,I) %FINISH %FINISH %ELSE %START SSOWN_INHIBITPSYSMES = 0; !IN CASE SET BY SSFOFF %FOR I=1,1,SSOWN_TOPFD %CYCLE %IF SSOWN_FD(I)_LINK>=SSOWN_FDLEVEL %THEN %START %IF SSOWN_FD(I)_STATUS#0 %THEN FLAG = CLOSE(ADDR(SSOWN_FD(I)_LINK)) %IF SSOWN_FD(I)_F77FLAG=1 %THEN %START SSOWN_SSFDMAP(SSOWN_FD(I)_DSNUM) = 0 SSOWN_FD (I) = 0 %FINISH %FINISH %REPEAT %FINISH %IF SSOWN_FDLEVEL <= 1 %START SET IO DEFAULT (SSOWN_INDEFAULT,90) SET IO DEFAULT (SSOWN_OUTDEFAULT,91) %FINISH %IF SSOWN_TEMPAVDSET # 0 %START SSOWN_AVD = SSOWN_HOLDAVD SSOWN_TEMPAVDSET = 0 BDIRLIST; ! Rebuild loader search list NOW to release use count on T#DIR %FINISH SELECTINPUT(0) SELECTOUTPUT(0) SSOWN_SSOPENUSED = 0 CONSOLE(14,FLAG,FLAG); !TO RESET JNBASE IN CASE RECALL OR RECAP CALLED **PROTEM %END; !OF TIDYFILES %SYSTEMINTEGERFN OPEN(%INTEGER AFD, MODE) !* !* MODE = 1 INPUT !* 2 OUTPUT !* %RECORD(DAHF)%NAME HEAD %RECORD (RF)RR %RECORD(FDF)%NAME F %INTEGER START, LEN, OUTCONAD, FLAG, OPENMODE SSOWN_SSOPENUSED = 1; !TO INDICATE OPEN USED F == RECORD(AFD) F_LINK = SSOWN_FDLEVEL %IF MODE=1 %THEN %START; !OPEN FOR READING F_VALIDACTION = 109; !Exclude WRITE and ENDFILE %IF F_ACCESSROUTE=9 %THEN %START; ! INTERACTIVE TERMINAL F_CONAD = 0 F_CURREC = 0 F_CUR = 0 F_END = 0 F_VALIDACTION = 97; !Exclude WRITE, REWIND, BACKSPACE and ENDFILE %FINISH %C %ELSE %IF F_ACCESSROUTE=8 %THEN %START CONNECT(F_IDEN,0,F_MAXSIZE,0,RR,FLAG); !{SEQ} ???? %IF FLAG#0 %THEN %RESULT = FLAG HEAD == RECORD(RR_CONAD); !MAP HEAD ONTO FILE HEAFDER %UNLESS SSCHARFILETYPE<=RR_FILETYPE<=SSDATAFILETYPE %THEN %START %IF NEWCONNECT#0 %THEN %START DISCONNECT (LAST, FLAG) %FINISH %RESULT = 267; ! INVALID FILETYPE %FINISH F_CURSIZE = HEAD_SIZE %IF RR_FILETYPE=SSCHARFILETYPE %THEN %START F_RECTYPE = 4 F_MODEOFUSE = 1; !CHARACTER FILE ACCESS %FINISH %ELSE %START F_MODEOFUSE = 2; !SQ FILE ACCESS F_RECTYPE = HEAD_FORMAT&3; ! RECORD FORMAT 1=F 2=V F_FLAGS = F_FLAGS!(HEAD_FORMAT&EBCDICBIT) !INCLUDE EBCDIC BIT F_MAXREC = HEAD_FORMAT>>16 %IF F_RECTYPE=1 %THEN %START; ! FIXED FORMAT F_MINREC = F_MAXREC F_RECSIZE = F_MAXREC %FINISH %FINISH F_TRANSFERS = 0 F_CONAD = RR_CONAD F_CURREC = RR_CONAD+RR_DATASTART F_DATASTART = F_CURREC F_CUR = F_CURREC F_END = RR_CONAD+RR_DATAEND %FINISH %C %ELSE %IF F_ACCESSROUTE=5 %THEN %START; !MAGNETIC TAPE ! The next line is allegedly not needed as the assignment ! is not always needed and is in any case done by DEFINEMT. ! It is removed by request of BRPM. ! F_RECTYPE = 255; !OBTAIN DCB INFO FROM TAPE PROTEM MAGIO(AFD,9,FLAG); !OPEN FOR READING %IF FLAG#0 %THEN %RESULT = FLAG; !FAILURE TO OPEN MAG TAPE F_VALIDACTION = X'3D'; !EXCLUDE WRITE F_FLAGS = F_FLAGS!EBCDICBIT; !IBM TAPES ALWAYS EBCDIC %FINISH %C %ELSE %IF F_ACCESSROUTE=10 %THEN %START; !.NULL F_CUR = 0 F_END = 0 %FINISH %C %ELSE %IF F_ACCESSROUTE=11 %THEN %START; !ALIEN DATA F_CUR = F_DATASTART F_CURREC = F_CUR F_END = F_CUR+F_MAXSIZE F_MODEOFUSE = 1; !CHARACTER FILE TYPE INPUT %FINISH %C %ELSE %IF F_ACCESSROUTE#1 %THEN %RESULT = 266; !INCONSISTENT DEFINITION ! **** **** I think ACCESSROUTE=1 should be treated as **** **** ! **** **** a fault: if it can arise at all, then I do **** **** ! **** **** not think it should simply be ignored. **** **** %FINISH %C %ELSE %IF MODE=2 %THEN %START; !OPEN FOR WRITING F_VALIDACTION = 127 %IF F_ACCESSROUTE=9 %THEN %START; ! INTERACTIVE TERMINAL LEN = 0 START = 0 CONSOLE(2,START,LEN); !TO GET ADDRESSES F_CUR = START F_CURREC = START F_END = START+LEN F_VALIDACTION = 119; !EXCLUDE BACKSPACE %FINISH %C %ELSE %UNLESS 8#F_ACCESSROUTE#10 %THEN %START !FILE OR .NULL %IF F_FLAGS&8=0 %START; !NORMAL OPEN - NOT -MOD NEWFILE: OUTFILE(F_IDEN,K4,F_MAXSIZE,0,OUTCONAD,FLAG); !{SEQ} %IF FLAG#0 %THEN %RESULT = FLAG HEAD == RECORD(OUTCONAD) %IF F_MODEOFUSE=1 %C %THEN HEAD_FILETYPE = SSCHARFILETYPE %C %ELSE %START HEAD_FILETYPE = SSDATAFILETYPE HEAD_FORMAT = (F_MAXREC<<16)!F_RECTYPE!(F_FLAGS&EBCDICBIT) HEAD_RECORDS = 0 %FINISH F_CONAD = OUTCONAD F_CUR = F_CONAD+32 F_TRANSFERS = 0 F_END = OUTCONAD+K4 F_CURSIZE = K4 %FINISH %ELSE %START; !OPEN -MOD CONNECT(F_IDEN,3,F_MAXSIZE,0,RR,FLAG);!{SEQ} TRY AND CONNECT IT %IF FLAG=218 %THEN -> NEWFILE; !FILE DOES NOT EXIST %IF FLAG#0 %THEN %RESULT = FLAG HEAD == RECORD(RR_CONAD) %IF HEAD_FILETYPE=SSCHARFILETYPE %C %THEN F_MODEOFUSE = 1 {CHAR FILE ACCESS} %C %ELSE %START %IF HEAD_FILETYPE#SSDATAFILETYPE %THEN %START %IF NEWCONNECT#0 %THEN %START DISCONNECT (LAST, FLAG) %FINISH %RESULT = 266 %FINISH !INCONSISTENT FILE USE. F_MODEOFUSE = 2; !DATA FILE ACCESS F_FLAGS = F_FLAGS!(HEAD_FORMAT&EBCDICBIT) F_MAXREC = HEAD_FORMAT>>16 F_RECTYPE = HEAD_FORMAT&3 %IF F_RECTYPE=1 %THEN F_MINREC = F_MAXREC F_TRANSFERS = HEAD_RECORDS %FINISH F_CONAD = RR_CONAD F_CUR = RR_CONAD+RR_DATAEND ! **** **** In the next couple of lines, the **** **** ! **** **** current size of the file is found **** **** ! **** **** in HEAD_SIZE. This may not always **** **** ! **** **** be reliable: it would be better to **** **** ! **** **** use a call on FINFO. **** **** F_END = F_CONAD+HEAD_SIZE F_CURSIZE = HEAD_SIZE %FINISH F_CURREC = F_CUR F_DATASTART = F_CUR F_RECSIZE = F_MAXREC; ! This is set in INREC for every ! record for variable length records, but remains ! constant for fixed length records. %FINISH %C %ELSE %IF F_ACCESSROUTE=5 %THEN %START; !MAGNETIC TAPE %IF F_FLAGS&RINGNEEDED=0 %THEN %RESULT = 319 ! NO WRITE RING REQUESTED %IF F_RECTYPE=255 %THEN %RESULT = 330 ! NO FORMAT INFORMATION SUPPLIED FOR WRITING TAPE %IF F_FLAGS&8=0 %THEN OPENMODE = 10 %ELSE OPENMODE = 11 !NORMAL OR -MOD MAGIO(AFD,OPENMODE,FLAG) %IF FLAG#0 %THEN %RESULT = FLAG F_VALIDACTION = X'3F'; !INCLUDE WRITE %FINISH %C %ELSE %IF F_ACCESSROUTE#2 %THEN %RESULT = 266; !INCONSISTENT DEFINITION %FINISH !* %IF NEWCONNECT=0 %THEN %START %IF F_ACCESSROUTE=8 %THEN SETUSE (F_IDEN,1,0) %FINISH F_STATUS = 3 F_CUR STATE = 1 %RESULT = 0 %END; !OF OPEN !* %SYSTEMROUTINE EXTEND(%RECORD(FDF)%NAME F, %INTEGERNAME FLAG) !THIS ROUTINE ATTEMPTS TO ! EXTEND AN OPEN OUTPUT FILE. ! IT TAKES THE !FOLLOWING SIZES IN KBYTES: !4,16,64,128,256,384....... !THIS ALGORITHM CAN BE ! CHANGED IF THERE ARE ! PROBLEMS OF DISK FRAGMENTATION %INTEGER CURSIZE %INTEGER %ARRAY SFINF (0:6) CURSIZE = F_CURSIZE; !CURRENT FILE SIZE %IF CURSIZE>=F_MAXSIZE %THEN {already big enough} FLAG = 1 %ELSE %START %IF CURSIZEF_MAXSIZE %THEN CURSIZE = F_MAXSIZE CHANGEFILESIZE(F_IDEN,CURSIZE,FLAG); !TRY AND CHANGE IT %IF FLAG=280 {total file limit exceeded} %THEN %START FLAG = X28{DSFI} (SSOWN_CURFOWNER,SSOWN_CURFSYS,11,0,ADDR(SFINF(0))) %IF FLAG=0 %C %THEN FLAG = X28{DSFI} (SSOWN_CURFOWNER,SSOWN_CURFSYS,30,0,ADDR(SFINF(1))) %IF FLAG#0 %THEN FLAG = DIRTOSS (FLAG) %ELSE %START CURSIZE = F_CURSIZE + SFINF (0) {max total space} %C - SFINF (2) {total disc kb} %C + SFINF (6) {temp disc kb} CHANGEFILESIZE (F_IDEN,CURSIZE,FLAG) %FINISH %FINISH %IF FLAG=0 %THEN %START F_CURSIZE = CURSIZE F_END = F_CONAD+CURSIZE; !ABS END OF EXTENDED FILE INTEGER(F_CONAD+8) = CURSIZE %FINISH %FINISH %END; !OF EXTEND %SYSTEMROUTINE ADDTOJOBOUTPUT(%INTEGER START, LEN, %C %INTEGERNAME FLAG) !ROUTINE USED TO PUT FILE DESTINED FOR MAIN OUTPUT DEVICE INTO !THE JOB OUTPUT FILE. ONLY USED BY BATCH JOBS - TO KEEP ALL OUTPUT !FILES FROM THE SAME JOB TOGETHER %INTEGER CUR %RECORD(FDF)%NAME F FLAG = 0 %RETURN %IF LEN <= 0 LEN = LEN+3; !TO ALLOW FOR NEWPAGE+2 NLS F == RECORD(SSOWN_SSFDMAP(91)); !FD FOR OUTPUT %WHILE F_CUR+LEN > F_END %CYCLE; !EXTEND AS NEC. EXTEND(F,FLAG) %IF FLAG # 0 %THEN %RETURN %REPEAT CUR = F_CUR-F_DATASTART; !CURRENT LENGTH OF JOB OUTPUT MOVE(CUR,F_DATASTART,F_DATASTART+LEN); !MOVE IT UP THE FILE MOVE(LEN-3,START,F_DATASTART); !MOVE IN THE FILE F_DATASTART = F_DATASTART+LEN BYTEINTEGER(F_DATASTART-3) = 12; !NEWPAGE BYTEINTEGER(F_DATASTART-2) = NL BYTEINTEGER(F_DATASTART-1) = NL F_CUR = F_CUR+LEN F_CURREC = F_CURREC+LEN FLAG = 0 %END; !OF ADDTOJOBOUTPUT %EXTERNALROUTINE RETAINTAPE(%STRING (255) S) !THIS COMMAND SETS SSOWN_MTCLOSEMODE=7. THIS AFFECTS THE TAPE CLOSE !MECHANISM SO THAT THE TAPE IS NOT UNLOADED AT CLOSE. IT WILL !BE UNLOADED BY VOLUMS AT THE END OF THE JOB. SSOWN_MTCLOSEMODE = 7; !CLOSE FILE BUT DO NOT RELEASE TAPE %END; !OF RETAINTAPE %SYSTEMINTEGERFN CLOSE(%INTEGER AFD) %RECORD(FDF)%NAME F %RECORD(DAHF)%NAME H %INTEGER FLAG F == RECORD(AFD) %IF F_STATUS # 0 %START; !FILE IS OPEN F_STATUS = 0; !TO PREVENT FAILURE LOOP %IF F_ACCESSROUTE = 5 %START; !MAGNETIC TAPE MAGIO(AFD,SSOWN_MTCLOSEMODE,FLAG); !FULL CLOSE PROTEM -> CLOSEEND %FINISH %IF CHARNO(F_IDEN,1) # '.' %THEN SETUSE(F_IDEN,-1,0) !CLEAR USE %IF F_ACCESSROUTE = 8 %AND F_VALIDACTION&2 # 0 %START !OUTPUT FILE %IF F_CONAD # 0 %START; !FILE CONNECTED H == RECORD(F_CONAD) %IF 13#F_MODEOFUSE#3 %C %THEN H_DATAEND = F_CUR-F_CONAD %C %ELSE F_DARECNUM = 0 !CORRECT LENGTH EXCEPT FOR DA FILES %IF F_MODEOFUSE = 2 %THEN H_RECORDS = F_TRANSFERS !CURRENT LENGTH %IF F_DEVCODE # 0 %START SENDFILE(F_IDEN,DEVNAME(F_DEVCODE!(F_F4<<8)),"OUTPUT". %C ITOS(F_DSNUM),0,0,FLAG) {SMH} %FINISH %ELSE %START TRIM(F_IDEN,FLAG) DISCONNECT(LAST,FLAG) !SEND OR TRIM %FINISH %FINISH %FINISH ! DISCONNECT SMFILE IF CONNECTED IN WRITE MODE %IF F_ACCESSROUTE=3 %AND F_VALIDACTION&2#0 %THEN DISCONNECT(F_IDEN,FLAG) %IF F_ACCESSROUTE = 10 %START; !.NULL DESTROY(F_IDEN,FLAG) %FINISH %FINISH CLOSEEND: F_CONAD = 0 F_CURSTATE = 0 %RESULT = 0 !* %END; ! CLOSE %EXTERNALROUTINE CLOSEF(%INTEGERNAME CHAN) !THIS ROUTINE IS PROVIDED TO ENABLE FORTRAN USERS TO CLOSE FILES !NOTE THAT THE PARAMETER IS %INTEGERNAME %INTEGER AFD, FLAG %RECORD(FDF)%NAME F %UNLESS 1 <= CHAN <= 80 %THEN FLAG = 223 %AND -> ERR !INVALID CHANNEL NO AFD = SSOWN_SSFDMAP(CHAN) %IF AFD = 0 %THEN FLAG = 151 %AND -> ERR; !CHANNEL NOT DEFINED F == RECORD(AFD) %IF F_STATUS = 0 %THEN FLAG = 0 %AND -> ERR; ! File not open - ignore. FLAG = CLOSE(AFD) ! FIOINIT (0) **** **** COMMENTED OUT **** **** ERR: %IF FLAG # 0 %THEN PSYSMES(-87,FLAG);!MESSAGE AND %MONITORSTOP %END; !OF CLOSEF !* !* ! %SYSTEM %INTEGER %MAP FIO1FLAG %RESULT == SSOWN_INITFIO1 %END ! %SYSTEM %INTEGER %MAP FIO2FLAG %RESULT == SSOWN_INITFIO2 %END ! !* !* ! %SYSTEM %ROUTINE DFDFIN %C (%STRING (31) INFILE, %INTEGER CHAN, %INTEGER %NAME FLAG) %INTEGER AFD %RECORD (FDF) %NAME FD %IF SSOWN_DFDFINSDC=0 %THEN SSOWN_DFDFINSDC = SSOWN_INDEFAULT %IF INFILE#"" %THEN %START DEFINE (CHAN,INFILE,AFD,FLAG) SET IO DEFAULT (SSOWN_INDEFAULT,CHAN) %FINISH %ELSE %START %IF SSOWN_DFDFINSDC#0 %THEN SET IO DEFAULT (SSOWN_INDEFAULT,SSOWN_DFDFINSDC) SSOWN_DFDFINSDC = 0 %FINISH SELECT INPUT (0) %END %SYSTEM %ROUTINE DFDFOUT %C (%STRING (31) OUTFILE, %INTEGER CHAN, %INTEGER %NAME FLAG) %INTEGER AFD %RECORD (FDF) %NAME FD %IF SSOWN_DFDFOUTSDC=0 %THEN SSOWN_DFDFOUTSDC = SSOWN_OUTDEFAULT %IF OUTFILE#"" %THEN %START %IF LENGTH(OUTFILE)<5 %C %OR SUBSTRING(OUTFILE,LENGTH(OUTFILE)-3,LENGTH(OUTFILE))#"-MOD" %C %THEN DEFINE (CHAN,OUTFILE,AFD,FLAG) %C %ELSE %START DEFINE (CHAN,SUBSTRING(OUTFILE,1,LENGTH(OUTFILE)-4),AFD,FLAG) %IF FLAG=0 %THEN %START FD == RECORD (AFD) FD_FLAGS = FD_FLAGS ! 8 %FINISH %FINISH SET IO DEFAULT (SSOWN_OUTDEFAULT,CHAN) %FINISH %ELSE %START %IF SSOWN_DFDFOUTSDC#0 %THEN SET IO DEFAULT (SSOWN_OUTDEFAULT,SSOWN_DFDFOUTSDC) SSOWN_DFDFOUTSDC = 0 %FINISH SELECT OUTPUT (0) %END ! ! - END OF EFILE TEXT ] ! ! [ START OF CONT CODE - %ROUTINE ICS; ! INIT CONTROL STREAM SSOWN_ADCSL = ADDR (SSOWN_CSL {CONTROL STREAM LINE}) + 1 SSOWN_GL IOCP PARM (1) = SSOWN_ADCSL SSOWN_GL IOCP PARM (3) = ADDR (SSOWN_GLSL) %END %STRING (255) %MAP GCL (%INTEGER %NAME BLC, FLAG) ! Reads a line of text into a string and returns a pointer to it. ! The length of the string will indicate the number of bytes of text read. ! BLC will be a count of the number of blank lines skipped before ! GLC found the line which it is returning to the caller. ! FLAG= 0: success. Length>0. ! FLAG=+1: success, but end-of-file detected. Length>0. Don't call ! GETLINE again. ! FLAG=-1: end-of-file detected, no data available. Length=0. ! Don't call GETLINE again. ! The characters in the string - ! do not include the final newline which terminated the line: ! do not include the end-of-file character (decimal 25) when ! end-of-file is reported: ! include no 'trailing spaces'. ! In fact, all characters up to and including the final newline (or ! end-of-file) will have been read, even though they aren't all ! put in the string, so the next READ will start at the beginning ! of the next line. In particular, if there were more than 255 ! characters on the line, then all the characters beyond the 255th. ! will disappear without warning. The length will be 255 (or less, if ! any trailing spaces were removed from the truncated line). The ! lost characters cannot be read or recovered by any means. ! Blank lines are skipped entirely (and without warning), so the string ! will not be empty (unless FLAG=-1). ! Reading always starts at the beginning of a line. If GETLINE is ! called when the last character read was not a newline, then all ! characters up to and including the next newline will be skipped ! without warning. Exception: this rule does NOT cause the first ! line of input to be skipped, so long as GETLINE starts reading ! at the beginning of the line. ! ! I have an old note which suggests that we might need ! to do FLAG = IOCP (12,0) here, but I don't know why. ! ! IOCP 20 gives (N-1) when the next character to be read is in position ! N on the input line. %IF IOCP (20,0)#0 %THEN %START; ! if we are not at the start of a line: READ CH (FLAG) %UNTIL FLAG=NL %OR FLAG=EM %IF FLAG=EM %THEN %START FLAG = -1 BLC = 0 SSOWN_CSL {CONTROL STREAM LINE} = "" %RESULT == SSOWN_CSL {CONTROL STREAM LINE} %FINISH %FINISH SSOWN_GL IOCP PARM (2) = ADDR (FLAG) BLC = -1 %CYCLE %CYCLE BLC = BLC + 1 %IF SSOWN_INF_CURSTATE=7 %THEN %START SSOWN_CSL = "" FLAG = -1 %RESULT == SSOWN_CSL %FINISH FLAG = IOCP (26,ADDR(SSOWN_GL IOCP PARM(1))) %IF SSOWN_GLSL#0 %THEN %START %IF SSOWN_GLSL>1 %AND BYTE INTEGER (SSOWN_ADCSL-2+SSOWN_GLSL)=EM %THEN %START FLAG = EM SSOWN_GLSL = SSOWN_GLSL - 1 %FINISH %ELSE FLAG = NL %FINISH %ELSE %START SSOWN_GLSL = 160 %CYCLE READ CH (FLAG) %IF SSOWN_GLSL<255 %THEN BYTE INTEGER (SSOWN_ADCSL+SSOWN_GLSL) = FLAG SSOWN_GLSL = SSOWN_GLSL + 1 %REPEAT %UNTIL FLAG=NL %OR FLAG=EM %FINISH SSOWN_GLSL = SSOWN_GLSL - 1 %REPEAT %UNTIL SSOWN_GLSL>0 %OR FLAG=EM %IF SSOWN_GLSL>255 %THEN SSOWN_GLSL = 255 %IF SSOWN_GLSL>0 %THEN SSOWN_GLSL = SSOWN_GLSL - TRAIL SPACES (SSOWN_ADCSL-1+SSOWN_GLSL,SSOWN_ADCSL,0) %IF FLAG#EM %THEN FLAG = 0 %C %ELSE %IF SSOWN_GLSL=0 %THEN FLAG = -1 %C %ELSE FLAG = 1 %REPEAT %UNTIL SSOWN_GLSL>0 %OR FLAG#0 LENGTH (SSOWN_CSL {CONTROL STREAM LINE}) = SSOWN_GLSL %RESULT == SSOWN_CSL {CONTROL STREAM LINE} %END; ! of GCL ! %SYSTEM %ROUTINE RCL (%STRING %NAME S, %INTEGER BLANKS, %INTEGER %NAME R) ! ! This routine reads a line of text from the currently selected input ! stream and puts it in S. If you want to ignore blank lines, call it ! with BLANKS=0. Otherwise use BLANKS=1. ! ! The permitted values of BLANKS are ! -1 initialise the routine. ! 0 read text, ignore blank lines. ! 1 read text, return blank lines if found. ! ! The value of R after the call indicates the result: ! -1 end-of-file detected, no data available: ! S will be a null string, even if BLANKS=0. ! 0 line successfully read. ! 1 line successfully read but end-of-file detected: ! no more data available after this. ! 2 routine successfully initialised. ! 3 invalid parameters supplied by caller (i.e., BLANKS<-1 or BLANKS>1). ! ! The characters in the string - ! do not include the final newline which terminated the line: ! do not include the end-of-file character (decimal 25) when ! end-of-file is reported: ! include no 'trailing spaces'. ! ! Before you make calls on RCL to read input, you must call it at least ! once with BLANKS=-1. Once you have started reading text with RCL, you ! should not use BLANKS=-1 again except after SELECT INPUT for a different ! input stream. ! ! If you set BLANKS=1, then every line will be returned, including blank ! lines. If BLANKS=0 then RCL will return only non-blank lines (except ! when end-of-file is detected) and you will get no indication of any ! blank lines which have been skipped. Since RCL always removes trailing ! spaces from each line, a line which contains nothing but spaces will ! count as a blank line and will be "suppressed" if BLANKS=0. ! ! Just as the text supplied does not include a terminating NEWLINE symbol, ! so it does not include an end-of-file symbol (decimal 25) when ! end-of-file is detected. End-of-file normally produces S="" and R=-1, ! but it may give a non-null value for S with R=+1. If you use BLANKS=1, ! then you could get S="" with R=+1. If you use BLANKS=0, then S="" with ! R=-1 is the only way that you can get a null string returned by RCL. ! ! The length of the string will be the only indication of the number of ! characters in the line, and it is not possible to detect whether any ! trailing spaces were deleted. If there were more then 255 characters on ! the line, then all the characters beyond the 255th. will disappear ! without warning. The length will be 255 (or less, if any trailing ! spaces were removed from the truncated line). The lost characters ! cannot be read or recovered by any means. ! ! Reading always starts at the beginning of a line. If RCL is called when ! the last character read was not a newline, then all characters up to and ! including the next newline will be skipped without warning. ! Exception: this rule does NOT cause the first line of input to be ! skipped, so long as RCL starts reading at the beginning of the line. ! ! If you call other input routines as well as RCL, you need to know that ! on return from RCL the NEWLINE has in fact been read in, so that the ! next READ or READ SYMBOL (or any other input routine) will start at the ! first character of the next line. If you use BLANKS=0, this should ! cause no problems; you must simply remember that you cannot expect to ! find the NEWLINE with READ SYMBOL or READ CH. READ and READ STRING skip ! over newlines anyway, so it should make no difference to them. But if ! you use BLANKS=0, it is a bit more complicated than that: RCL reads as ! far as the NEWLINE which terminates a non-blank line, so after you have ! called RCL, even if you had BLANKS=1 and you got a blank line returned ! in S, then a READ would start at the beginning of the next line after a ! non-blank line. What this means is that you should not switch from RCL ! to other input routines unless the last call of RCL produced a non-blank ! line; or, if you want to make things even simpler, don't mix calls of ! RCL with other input routines. ! ! SSOWN_RCLB is the number of blank lines reported by RCL but not yet returned ! to the caller. If it is zero, then SSOWN_RCLH is the next thing to be returned. ! If SSOWN_RCLH has been returned to the caller, and RCL has not been called ! since, then SSOWN_RCLB is -1; that is SSOWN_RCLB=-1 means that RCL must be called before ! anything is returned to the caller (unless end-of-file has been detected). ! ! SSOWN_RCLF is zero unless end-of-file has been detected. RCL is the only thing ! that changes SSOWN_RCLF (apart from initialisation), and that sets SSOWN_RCLF non-zero if ! only if it detects end-of-file. ! %IF BLANKS<-1 %OR BLANKS>1 %THEN %START R = 3 %RETURN %FINISH %IF BLANKS=-1 %THEN %START SSOWN_RCLB = -1 SSOWN_RCLF = 0 R = 2 %RETURN %FINISH %IF SSOWN_RCLB=-1 %THEN %START %IF SSOWN_RCLF=0 %THEN SSOWN_RCLH = GCL (SSOWN_RCLB, SSOWN_RCLF) %ELSE %START S = "" R = SSOWN_RCLF %RETURN %FINISH %FINISH %IF BLANKS=01 %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, %RESULT = 1 ! ! **** **** End of machine code. **** **** ! %FINISH %ELSE %START %FOR I=2,1,LEN %CYCLE %UNLESS 'A'<=CHARNO(COM,I)<='Z' %C %OR '0'<=CHARNO(COM,I)<='9' %C %OR CHARNO(COM,I)='.' %OR CHARNO(COM,I)='_' %C %THEN %RESULT = 1 %REPEAT %FINISH %FINISH OK: %IF STUDENTSS=0 %THEN %START %RESULT = 0 %FINISH %ELSE %START %IF SSOWN_ALLCOMMAND#0 %THEN %RESULT = 0 %RESULT = ALLOWCOMMAND (COM) %FINISH %END; !OF CHECKCOMMAND ! %SYSTEMROUTINE BCI %IF NEWLOADER=0 %THEN %START %CONST %INTEGER ENTRYFLAG = 2 %FINISH %ELSE %START %INTEGER ENTRYFLAG %FINISH %INTEGER SAVECOM44, SAVECOM36, SOFAR, MAXLEFT, NPT {NEWPAGETURNS} %INTEGER NDCPU,NKINS %LONGREAL NCP {NEWCPUTIME} %STRING (1) DUMMY %INTEGER EOF SEEN, AFD, FLAG, DR0, DR1, PC, LNB, TYPE, MACAD !DR0 AND DR1 MUST STAY TOGETHER %RECORD (FDF) %NAME FD %LONG %INTEGER %NAME DESC %STRING (255) COMMAND, PARAM, HOLDLINE, PART, INPFNAME, OPFNAME, RESTOFLINE %STRING (255) %NAME LINE %INTEGER GLAPARM1 %ROUTINE GC {GETCOMMAND} (%STRINGNAME COMMAND, PARAM, %INTEGERNAME FLAG) %INTEGER SHELL, NEWTEXT !FLAG=0 OK !FLAG=1 INPUT ENDED !FLAG=2 INVALID COMMAND !FLAG=3 PARAM TOO LONG %STRING (255) P1, P2, RCSTL %INTEGER I, MAXPARML, L, V, S, T %ROUTINE GETLINE; !SKIPS BLANK LINES AND LEADING SPACES %INTEGER CLL %CYCLE %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: *LDTB_X'18000000' *LDA_GLAPARM1 *LDB_CLL; ! Descriptor to characters in string. *STD_%TOS; ! Save two copies on the stack. *STD_%TOS *SWEQ_%L=%DR,0,32; ! %MASK=0,%REF=SP - i.e., skip over ! leading spaces. ! Now we have found the first non-space. *CYD_0; ! Descriptor to string excluding spaces. *USH_8; ! Discard TYPE byte. *USH_-8; ! Leaves length (excluding leading ! spaces) in upper half of Acc. *STUH_%B; ! B now has that length, Acc has address ! of first non-space. *LDA_%TOS; ! DR now points to first byte of the ! original string, but its length ! is still reduced to exclude leading ! spaces. *LUH_%TOS; ! Restores a sensible TYPE field to the ! descriptor in Acc. Its length ! actually includes leading spaces, but ! that is no problem - it is bound to be ! >= the length in DR, and that is all ! matters. *MV_%L=%DR; ! Move the bytes (excluding leading ! spaces) down. *LD_%TOS; ! Restore descriptor to original string ! again. Note: its length cannot be 0. *INCA_-1; ! Point to 'length byte'. *STB_(%DR+0); ! Store reduced length. ! Leading spaces removed. ! %REPEAT %UNTIL LINE#"" %END; !OF GETLINE %ROUTINE ACT %STRING (255) Z, NC %STRING %NAME PX %INTEGER W, CTRL, A, J, Q, SAVEMARK, SPARE BYTES, PFLAG %INTEGER %FN FINDLAST (%STRING %NAME U, %INTEGER I) %IF CTRL=0 %C %OR (CTRL=1 %AND STARTSWITH(U,COMMAND,0)#0) %C %OR (CTRL=2 %AND U->(COMMAND)) %C %THEN PX == U %RESULT = 0 %END %ROUTINE FORALL (%INTEGER %FN %NAME J (%STRING %NAME U, %INTEGER I)) %INTEGER Q, V, N %IF SSOWN_BCIOLDEST#SSOWN_BCIBLANKS %THEN %START Q = SSOWN_BCIOLDEST N = 1 %CYCLE %IF Q=SSOWN_BCIBLANKS %THEN Q = 0 V = J (STRING(ADDR(SSOWN_PCHAR(Q))), N) N = N + 1 Q = Q + SSOWN_PCHAR(Q) + 1 %REPEAT %UNTIL Q=SSOWN_BCIFREE %OR V#0 %FINISH %END %INTEGER %FN PE (%STRING %NAME U, %INTEGER I) WRITE (I,4); SPACES (2); PRINT STRING (U); NEWLINE %RESULT = 0 %END %ROUTINE SIMPLE (%STRING %NAME T) RCSTL = T %END %ROUTINE REDO (%INTEGER F, %ROUTINE %NAME K (%STRING %NAME T)) CTRL = F PX == SSOWN_ACTD FORALL (FINDLAST) %IF PX==SSOWN_ACTD %THEN RCSTL = "" %ELSE K (PX) %END %INTEGER %FN CKN (%STRING %NAME U, %INTEGER I) %IF I=W %THEN %START RCSTL = U %RESULT = -1 %FINISH %ELSE %RESULT = 0 %END %ROUTINE REFIT (%STRING %NAME L) %STRING (255) A, B RCSTL = "" A = L RCSTL = RCSTL.B.Z %WHILE A -> B.(COMMAND).A RCSTL = RCSTL.A %END ! ! ! %IF PIPER#0 %THEN %START ! %CYCLE PARAM = "" %IF RESTOFLINE="" %THEN %START I = IOCP (12,0); ! Clear 'input ended' if we've had CTRL Y from console. GETLINE P1 = LINE HOLDLINE = "" I = 1 %CYCLE %IF P1->P1.("""").P2 %THEN V = -1 %ELSE V = 0 %IF I#0 %THEN UCTRANSLATE (ADDR(P1)+1, LENGTH(P1)) I = 1 - I HOLDLINE = HOLDLINE.P1."""" %EXIT %IF V=0 P1 = P2 %REPEAT LENGTH (HOLDLINE) = LENGTH (HOLDLINE) - 1 INPFNAME = "" NEWTEXT = -1 %FINISH %ELSE %START HOLDLINE = RESTOFLINE LINE == HOLDLINE RESTOFLINE = "" NEWTEXT = 0 %UNLESS OPFNAME->INPFNAME.("-MOD") %C %AND LENGTH(INPFNAME)+4=LENGTH(OPFNAME) %C %THEN INPFNAME = OPFNAME %FINISH %IF CHARNO(LINE,1)#'*' %THEN SHELL = -1 %ELSE %START SHELL = 0 CHARNO (LINE,1) = LENGTH (LINE) - 1 LINE == STRING (ADDR(LINE)+1) %FINISH %IF SSOWN_SSLDELIM = ' ' %THEN %START; !OPTION (NOBRACKETS) %IF SHELL#0 %THEN %START %IF LINE->LINE.("|").RESTOFLINE %C %THEN OPFNAME = "T#PIPE".NEXTTEMP %C %ELSE %IF %NOT LINE->LINE.(">").OPFNAME %C %THEN OPFNAME = "" %IF INPFNAME="" %AND LINE->LINE.("<").INPFNAME %THEN %START; %FINISH %FINISH %UNLESS LINE->COMMAND.(" ").PARAM %THEN COMMAND = LINE %FINISH %ELSE %START; !OPTION (BRACKETS) %IF LINE->COMMAND.("(").PARAM %THEN %START %IF SHELL#0 %AND COMMAND->COMMAND.("|").RESTOFLINE %THEN %START RESTOFLINE = RESTOFLINE."(".PARAM PARAM = "" OPFNAME = "T#PIPE".NEXTTEMP %IF INPFNAME="" %AND COMMAND->COMMAND.("<").INPFNAME %THEN %START; %FINISH %FINISH %ELSE %START RESTOFLINE = "" L = 0; ! Count of unmatched open brackets ! within the PARAM string. I = 0; ! Pointer into the PARAM string - ! 1 indicates first character, etc. V = -1; ! Zero within double-quotes, ! non-zero outside. MAXPARML = 255 - LENGTH (COMMAND) - 1 %CYCLE ! Scan for brackets (ignoring anything in quotes): %WHILE I=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 IPART.("|").RESTOFLINE %C %THEN OPFNAME = "T#PIPE".NEXTTEMP %C %ELSE %IF %NOT PART->PART.(">").OPFNAME %C %THEN OPFNAME = "" %IF INPFNAME="" %AND PART->PART.("<").INPFNAME %THEN %START; %FINISH %FINISH LENGTH (PARAM) = I - 1 %FINISH %ELSE %START T = MAXPARML - I ! Here we can test - ! T>0 for "more space left in PARAM string", ! S=',' for "line ended with comma", ! V=0 for "line ended within double quotes". %IF S#',' %OR T=0 %THEN S=')' %ELSE %START PROMPT ("):") GETLINE %IF T>LENGTH(LINE) %THEN T = LENGTH (LINE) LENGTH (PARAM) = LENGTH (PARAM) + T MOVE (T, GLAPARM1, ADDR(PARAM)+I+1) %FINISH %FINISH %REPEAT %UNTIL S=')' %FINISH %FINISH %ELSE %START %IF SHELL#0 %THEN %START %IF LINE->LINE.("|").RESTOFLINE %C %THEN OPFNAME = "T#PIPE".NEXTTEMP %C %ELSE %IF %NOT LINE->LINE.(">").OPFNAME %C %THEN OPFNAME = "" %IF INPFNAME="" %AND LINE->LINE.("<").INPFNAME %THEN %START; %FINISH %FINISH COMMAND = LINE %FINISH %WHILE COMMAND -> P1.(" ").P2 %CYCLE; ! REMOVE EMBEDDED SPACES COMMAND = P1.P2 %REPEAT %FINISH %IF RESTOFLINE="" %AND INPFNAME="" %AND OPFNAME="" %THEN SHELL=0 %ELSE %START %IF SHELL#0 %AND LENGTH(OPFNAME)>1 %AND CHARNO(OPFNAME,1)='>' %C %THEN OPFNAME = SUBSTRING(OPFNAME,2,LENGTH(OPFNAME))."-MOD" %FINISH ! Translate command to upper case. UCTRANSLATE (ADDR(COMMAND)+1,LENGTH(COMMAND)) CASTOUT (PARAM); ! Clear out spaces, translate to upper case - ! but allow for double quotes. PFLAG = 0 %IF NEWTEXT#0 %THEN %START SAVEMARK = 0 %IF SHELL#0 %THEN %START %IF STARTSWITH(COMMAND,"!-",-1)=0 %THEN SAVEMARK = -1 %FINISH %ELSE %START %IF COMMAND="!?" %AND PARAM="" %THEN %START FORALL (PE) FLAG = 3 %FINISH %C %ELSE %IF STARTSWITH (COMMAND,"!-",-1)=0 %THEN %START %IF COMMAND -> NC.("!").COMMAND %THEN %START RCSTL = "" %IF COMMAND="" %THEN REDO (0,SIMPLE) %C %ELSE %IF CHARNO(COMMAND,1)='!' %THEN NC = NC."!".COMMAND %C %ELSE %IF COMMAND->COMMAND.("!").Z %THEN %START %IF Z="" %THEN REDO(2,SIMPLE) %ELSE %START %IF CHARNO(Z,LENGTH(Z))='!' %THEN LENGTH(Z) = LENGTH(Z) - 1 REDO (2,REFIT) SAVEMARK = -1 %FINISH %FINISH %ELSE %START W = PSTOI (COMMAND) %IF W<=0 %THEN REDO (1,SIMPLE) %ELSE FORALL (CKN) %FINISH %IF RCSTL="" %THEN FLAG = 3 %ELSE %START %IF RCSTL->COMMAND.(TOSTRING(160)).RCSTL %THEN %START %IF NC#"" %THEN %START COMMAND = NC SAVEMARK = -1 %FINISH %IF PARAM="" %THEN PARAM = RCSTL %ELSE SAVEMARK = -1 %FINISH %ELSE %START COMMAND = RCSTL SHELL = -1 PARAM = "" %FINISH PFLAG = PFLAG ! 1 %FINISH %FINISH %ELSE SAVEMARK = -1 %IF PFLAG&1#0 %THEN %START PRINT STRING (COMMAND PROMPT) PRINT STRING (COMMAND) %IF PARAM#"" %THEN %START PRINT SYMBOL (SSOWN_SSLDELIM) PRINT STRING (PARAM) %IF SSOWN_SSLDELIM#' ' %THEN PRINT SYMBOL (')') %FINISH NEWLINE %FINISH %IF SHELL=0 %C %THEN HOLDLINE = COMMAND.TOSTRING(160).PARAM %C %ELSE %START HOLDLINE = COMMAND RESTOFLINE = COMMAND COMMAND = "" %FINISH %FINISH %FINISH %IF SAVEMARK#0 %THEN %START A = ADDR (SSOWN_PCHAR(0)) J = LENGTH (HOLDLINE) + 1 %IF SSOWN_BCIOLDEST>SSOWN_BCIFREE %C %THEN SPARE BYTES = SSOWN_BCIOLDEST - SSOWN_BCIFREE - 1 %C %ELSE SPARE BYTES = PCHARLIM - SSOWN_BCIFREE %WHILE SPARE BYTESSSOWN_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=0 %CYCLE I = I + 1 S = CHARNO (PARAM, I) %IF S='"' %THEN V = -1-V %C %ELSE %IF V#0 %THEN %START %IF S=')' %THEN L = L - 1 %C %ELSE %IF S='(' %THEN L = L + 1 %FINISH %REPEAT ! Now we have I=LENGTH(PARAM) or ! (L=-1 with S=')' and CHARNO(PARAM,I)=')'). %IF L<0 %THEN LENGTH (PARAM) = I - 1 %ELSE %START T = MAXPARML - I ! Here we can test - ! T>0 for "more space left in PARAM string", ! S=',' for "line ended with comma", ! V=0 for "line ended within double quotes". %IF S#',' %OR T=0 %THEN S=')' %ELSE %START PROMPT ("):") GETLINE %IF T>LENGTH(LINE) %THEN T = LENGTH (LINE) LENGTH (PARAM) = LENGTH (PARAM) + T MOVE (T, GLAPARM1, ADDR(PARAM)+I+1) %FINISH %FINISH %REPEAT %UNTIL S=')' %FINISH %FINISH ! Translate command to upper case. UCTRANSLATE (ADDR(COMMAND)+1,LENGTH(COMMAND)) CASTOUT (PARAM); ! Clear out spaces, translate to upper case - ! but allow for double quotes. PFLAG = 0 SAVEMARK = 0 %IF COMMAND="!?" %AND PARAM="" %THEN %START FORALL (PE) FLAG = 3 %FINISH %C %ELSE %IF STARTSWITH (COMMAND,"!-",-1)=0 %THEN %START %IF COMMAND -> NC.("!").COMMAND %THEN %START RCSTL = "" %IF COMMAND="" %THEN REDO (0,SIMPLE) %C %ELSE %IF CHARNO(COMMAND,1)='!' %THEN NC = NC."!".COMMAND %C %ELSE %IF COMMAND->COMMAND.("!").Z %THEN %START %IF Z="" %THEN REDO(2,SIMPLE) %ELSE %START %IF CHARNO(Z,LENGTH(Z))='!' %THEN LENGTH(Z) = LENGTH(Z) - 1 REDO (2,REFIT) SAVEMARK = -1 %FINISH %FINISH %ELSE %START W = PSTOI (COMMAND) %IF W<=0 %THEN REDO (1,SIMPLE) %ELSE FORALL (CKN) %FINISH %IF RCSTL="" %THEN FLAG = 3 %ELSE RCSTL -> COMMAND.(" ").RCSTL %IF NC#"" %THEN %START COMMAND = NC SAVEMARK = -1 %FINISH %IF PARAM="" %THEN PARAM = RCSTL %ELSE SAVEMARK = -1 PFLAG = PFLAG ! 1 %FINISH %ELSE SAVEMARK = -1 %FINISH %IF PFLAG&1#0 %THEN %START PRINT STRING (COMMAND PROMPT) PRINT STRING (COMMAND) %IF PARAM#"" %THEN %START PRINT SYMBOL (SSOWN_SSLDELIM) PRINT STRING (PARAM) %IF SSOWN_SSLDELIM#' ' %THEN PRINT SYMBOL (')') %FINISH NEWLINE %FINISH %IF SAVEMARK#0 %THEN %START A = ADDR (SSOWN_PCHAR(0)) J = LENGTH (COMMAND) + LENGTH (PARAM) + 2 %IF SSOWN_BCIOLDEST>SSOWN_BCIFREE %C %THEN SPARE BYTES = SSOWN_BCIOLDEST - SSOWN_BCIFREE - 1 %C %ELSE SPARE BYTES = PCHARLIM - SSOWN_BCIFREE %WHILE SPARE BYTESSSOWN_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_ *LSS_%TOS; !TOS TO ACC *ST_PC; !THEN TO INTEGER PC *STLN_LNB; !LNB TO INTEGER LNB SIGNAL(0,PC,LNB,FLAG) ENTER(ENTRYFLAG,DR0,DR1,PARAM); !ENTER PASSING PARAMETER -> NEXTCOM FAIL: *ST_DR0; !ACC CONTAINS DESCRIPTOR SSOWN_SSCOMREG(36) = SAVECOM36; !TO ENSURE STOP TAKES US BACK TO COMMAND LEVEL NDIAG(INTEGER(DR1+16),INTEGER(DR1+8),10,INTEGER(DR1)) !INT OF WT -> NEXTCOM NOTFOUND: PSYSMES(47,FLAG) %IF COMMAND#SSOWN_SSFNAME %THEN PRINTSTRING(COMMAND." not entered") NEWLINE %IF NEWLOADER#0 %THEN UNLOAD2(1,1); ! Load failed -> NEXTCOM %END; !OF BCI ! %SYSTEMSTRINGFN CLICOMMAND %RESULT=SSOWN_CLICOMM %END; ! OF SSOWN_CLICOMMAND ! ! %SYSTEMSTRINGFN CLIPARAM %RESULT=SSOWN_CLIPARM %END; ! OF CLIPARAM ! ! %SYSTEM %ROUTINE QUERYPROMPTS (%INTEGER I) SSOWN_QPARMF = I %END ! %SYSTEMROUTINE BEFORECOMMAND; !CALLED FROM JOB CONTROL MODULE %INTEGER FLAG,SOFAR,NEWPAGETURNS,MAXLEFT,NDCPU,NKINS %LONGREAL NEWCPUTIME SSOWN_SSCOMREG(10)=0; !CLEAR OUT MONITOR CALLED FLAG SSOWN_SSFNAME=""; !TEMPORARY %IF SSOWN_SSAUXDR1#0 %THEN SSOWN_SSCURAUX=INTEGER(SSOWN_SSAUXDR1) SSOWN_SSCOMREG(34)=1; !SET SIGNAL LEVEL BACK TO 1 SSOWN_RRCTOP=0; !RESET CONTINGENCY RE-ROUTEING %IF SSOWN_SSREASON=BATCHREASON %THEN %START FLAG = X28{DSFI}(SSOWN_SSOWNER,SSOWN_SSOWNFSYS,21,0,ADDR(SOFAR)) MAXLEFT = SSOWN_SESSKIC-SOFAR %IF MAXLEFTMAXLEFT %THEN SSOWN_CURRKI = MAXLEFT %FINISH FLAG = X27{DSETIC}(SSOWN_CURRKI) %IF SSOWN_SSOPENUSED # 0 %THEN TIDYFILES; !CLOSE ANY AT CURRENT LEVEL NEWPAGETURNS = PAGETURNS NEWCPUTIME = CPUTIME NDCPU=DCPUTIME NKINS=KINS %IF SSOWN_SSMONITOR&1#0 %START; !MONITOR CPU AND PAGE TURNS PER COMMAND WRITE(INT((NEWCPUTIME-SSOWN_OLDCPUTIME)*1000),1) PRINTSTRING(" MS") WRITE(NEWPAGETURNS-SSOWN_OLDPAGETURNS,1) PRINTSTRING(" PT") WRITE(NDCPU-SSOWN_OLDDCPU,1) PRINTSTRING(" DCPU") WRITE(NKINS-SSOWN_OLDKINS,1) PRINTSTRING(" KINS ") %FINISH SSOWN_OLDCPUTIME = NEWCPUTIME SSOWN_OLDPAGETURNS = NEWPAGETURNS SSOWN_OLDDCPU=NDCPU SSOWN_OLDKINS=KINS SSOWN_CONTROLMODE=1; !TO ENSURE INPUT READ FROM MASTERCHARIN %END; !OF BEFORECOMMAND %SYSTEMROUTINE AFTERCOMMAND SSOWN_CONTROLMODE=0 %IF NEWLOADER=0 %THEN %START UNLOAD(SSOWN_SSCOMREG(38)); ! TEMP %IF SSOWN_SSUSTACKUSED#0 %THEN INUST %FINISH %ELSE %START UNLOAD2 (SSOWN_LOADLEVEL,0); ! TEMP Is this required at all? %FINISH %IF OUTPOS#0 %THEN NEWLINE; !PUSH OUT REMAINING CHAS IN LINE %IF SSOWN_SSOPENUSED#0 %THEN TIDYFILES; !MUST BE CALLED HERE FOR SELECT SSOWN_DATAECHO=0; !FOR BOB EAGER? %END; !OF AFTERCOMMAND %SYSTEMROUTINE CONTROL %INTEGER FLAG %LONG %INTEGER DRH %RECORD (RF)RR %RECORD(DIRINFF)%NAME DIRINF %STRING (31) MESSAGEFILE %STRING (63) JMESSAGE %ROUTINE CALLBCI %CONST %INTEGER MAXNREC = 5 %RECORD (FINDF) %ARRAY FORINIT (1:MAXNREC) %INTEGER GOTINIT, III, NREC, BASEDIRENTRY, MASTERENTRY %STRING (6) MASTERNAME %STRING (72) MESS %INTEGER LNB, PC, CLASS, SUBCLASS, FAULT, FLAG, TYPE %INTEGER DR0,DR1 %LONGINTEGERNAME DESC %STRING (31) DUMMY *JLK_3 *J_ < CONTIN > *LSS_ %TOS *ST_PC !PC NOW CONTAINS RETURN PC *STLN_LNB DESC==LONGINTEGER(ADDR(DR0)) SIGNAL(1,1,0,FLAG); !CLEAR ALL LEVELS SIGNAL(0,PC,LNB,FLAG) X30{DSTOP}(200+FLAG) %IF FLAG # 0 SSOWN_FDLEVEL = 1 %IF SSOWN_SSAUXDR1 # 0 %START; !RESET AUX STACK INTEGER(SSOWN_SSAUXDR1) = SSOWN_SSAUXDR1+32 INTEGER(SSOWN_SSAUXDR1+8) = SSOWN_SSMAXAUX %FINISH TIDYFILES %IF NEWLOADER=0 %THEN %START UNLOAD(SSOWN_SSCOMREG(38)); !UNLOAD ALL ON USER GLA !COMREG 38 POINTS TO BASE OF USER GLA %FINISH %ELSE %START UNLOAD2 (SSOWN_LOADLEVEL, 0) %FINISH %IF SSOWN_CALLBCISTARTED = 0 %START; !FIRST TIME ONLY SSOWN_CALLBCISTARTED = 1 ALLOW INTERRUPTS; ! Able to accept interrupts from here on %IF STUDENTSS#0 %THEN %START %IF NEWLOADER=0 %THEN %START SSOWN_AVD = ""; ! Make sure none of INITIALISE, ALLOWCOMMAND, ! ALLOWCONNECT get loaded via the student's own ! ACTIVE DIRECTORY. SSOWN_DIRDISCON = 1 INITIALISE; ! Call routine supplied by course supervisor. SSOWN_DIRDISCON = 1; ! Ensure reload of directories after first search. SSOWN_AVD = SSOWN_HOLDAVD ! ! Now check that both entries are loaded. If not, SSOWN_ALLCOMMAND ! or SSOWN_ALLCONNECT should be set non-zero. FINDENTRY ("S#ALLOWCOMMAND",0,0,DUMMY,DR0,DR1,SSOWN_ALLCOMMAND) FINDENTRY ("S#ALLOWCONNECT",0,0,DUMMY,DR0,DR1,FLAG) %IF FLAG=0 %THEN %START FLAG = ALLOWCONNECT (SSOWN_SSOWNER,"T"); ! Dummy call to make sure that ! all directories are ! connected. SSOWN_ALLCONNECT = 0; ! From now on it is safe to call it within ! CONNECT. %FINISH %FINISH %ELSE %START GOTINIT = 0 NREC = MAXNREC III = FIND ("S#INITIALISE", NREC, ADDR(FORINIT(1)), CODE) %IF III=0#NREC %THEN %START ! Get the username of the supervisor, if any. III = X28{DSFI}(SSOWN_SSOWNER, SSOWN_SSOWNFSYS, 44, 0, ADDR(MASTERNAME)) %IF III=0 %THEN %START BASEDIRENTRY = 0 MASTERENTRY = 0 III = 1 %WHILE III<=NREC %CYCLE %UNLESS 0#FORINIT(III)_DIRNO#-2 %THEN BASEDIRENTRY=III %C %ELSE %IF FORINIT(III)_DIRNO>0 %C %AND (MASTERNAME="" %OR FORINIT(III)_FILE->(MASTERNAME.".")) %C %THEN %START MASTERENTRY = III %EXIT %FINISH III = III + 1 %REPEAT %IF MASTERENTRY=0 %AND NREC=1 %THEN MASTERENTRY = BASEDIRENTRY %IF MASTERENTRY#0 %THEN %START PRELOAD (FORINIT(MASTERENTRY)_FILE) %IF SSOWN_RCODE=0 %THEN %START SSOWN_LLINFO (-1) = SSOWN_LLINFO (0) INITIALISE; ! Call routine supplied by course supervisor. ! ! Now check that both entries are loaded. If not, SSOWN_ALLCOMMAND ! or SSOWN_ALLCONNECT should be set non-zero. TYPE=CODE %IF LOOKLOADED("S#ALLOWCOMMAND",TYPE)#0 %C %THEN SSOWN_ALLCOMMAND = 0 %C %ELSE SSOWN_ALLCOMMAND = -1 %IF LOOKLOADED("S#ALLOWCONNECT",TYPE)#0 %C %THEN SSOWN_ALLCONNECT = 0 %C %ELSE SSOWN_ALLCONNECT = -1 GOTINIT = -1 %FINISH %FINISH %FINISH %FINISH %IF GOTINIT=0 %THEN %START ! We have failed to find an acceptable INITIALISE routine. PRINTSTRING ("*** Access barred ***") NEWLINE ZSTOP ("") %FINISH %FINISH SSOWN_INTINPROGRESS = 0; ! Allow INT:A during messages. FLAG = 0; ! Because CONSOLE (6) will check its second parameter. CONSOLE (6, FLAG, FLAG); ! Get any outstanding messages. %FINISH %FINISH SSOWN_INTINPROGRESS = 0; !SAFE TO RECEIVE INT:A ICS; ! INIT CONTROL STREAM %IF SSOWN_CONTROLMODE=0 %OR SSOWN_SSREASON#BATCHREASON %THEN BCI %ELSE %START NEWLINES(2) OBEYJOB(DIRINF_JOBDOCFILE) BATCHSTOP(0) %FINISH %RETURN CONTIN: !COME HERE AFTER CONTINGENCY *ST_DR0; !ACC CONTAINS DESC. TO 18 WORD ! AREA %IF SSOWN_SSCOMREG(34)=0 %THEN SSOWN_SSCOMREG(34)=1 ! This peculiar line above is to ensure that there is always a trap ! present to get you to here. ! If you have done repeated SIGNAL(2, ) then this could be the ! last trap. If so and you get an interrupt during diagnostics then ! no traps left!!! SELECTOUTPUT(0) SELECTINPUT(0) CLASS = INTEGER(DR1) SUBCLASS = INTEGER(DR1+4) !INTERRUPT OF WT FAULT = 10; !INTERRUPT %IF CLASS=65 %START; ! INT: %IF 'V'<=SUBCLASS<='Y' %START; !FORCED TERMINATION %IF SSOWN_SSREASON = BATCHREASON %THEN BATCHSTOP(2) !TERMINATE BATCH JOB SSOWN_FDLEVEL = 1; !IN CASE IN OBEYFILE TIDYFILES %IF SUBCLASS<='X' %START CONSOLE(19,FLAG,FLAG); !KILL INPUT - IF NEC CONSOLE(7,FLAG,FLAG); !KILL OUTPUT - IF NEC NEWLINE %IF SUBCLASS='V' %C %THEN PRINTSTRING ("***Session has now ended***") %C %ELSE %C %IF SUBCLASS = 'W' %C %THEN PRINTSTRING ("***Session terminated due to inactivity") %C %ELSE PRINTSTRING ("***Session terminated by operator***") NEWLINE ZSTOP("") %FINISH %ELSE %START; !INTERACTIVE TERMINAL NOT AVAILABLE MESS = " ***Interactive terminal disconnected - session terminated*** " TOJOURNAL(ADDR(MESS)+1,LENGTH(MESS)) CLOSEJOURNAL HALT; !CANNOT PRINT ANY OUTPUT SO MUST NOT CALL COMMAND QUIT %FINISH %FINISH SSOWN_INTMESS(7) <- SUBCLASS; !FOR INT MESSAGE IN RECALL FILE TOJOURNAL(ADDR(SSOWN_INTMESS(1)),9) CLASS = 0 CONSOLE(7,FLAG,FLAG); !KILL OUTPUT %IF SUBCLASS = 'C' %THEN CONSOLE(8,FLAG,FLAG) !KILL INPUT FOR INT:C %IF SSOWN_SSREASON = DSTARTREASON %THEN SSOWN_DATAECHO = 0 !IN CASE SET NON ZERO IN OBEY %IF NEWLOADER#0 %THEN %START %IF SSOWN_LOADINPROGRESS#0 %THEN %START UNLOAD2 (1,1) SSOWN_LOADINPROGRESS = 0 %FINISH %FINISH %FINISH %ELSE %START SELECTOUTPUT(0) PRINTSTRING("Error detected in Subsystem: ") PRINTMESS (WTFAULT(CLASS)) NEWLINE PRINT STRING ( %C "The following diagnostics may be useful if you need to refer this problem to Advisory:") NEWLINE PRINT STRING ("Class: ") WRITE(CLASS,8) PRINT STRING (" Subclass: ") WRITE(SUBCLASS,8) NEWLINE ! Reset SSOWN_SSINHIBIT to 0 so that user can INT:A diagnostics - ! it might be non zero since we can never be sure where we got here ! from. ALLOWINTERRUPTS ! %IF SSOWN_LOADINPROGRESS#0 %THEN LOADDUMP(""); ! Fail during load SSOWN_FULLDUMP=1; ! Make sure of all possible diagnostics NDIAG(INTEGER(DR1+16),INTEGER(DR1+8),0,0) %FINISH %END; !OF CALL BCI USEOPTIONS; !EXTRACT INFO FROM OPTIONS FILE TIDYFILES; !SETS UP INITIAL STREAMS SSOWN_CURRKI = DEFCPL*KIPS; !DEFAULT COMMAND CPULIMIT DIRINF == RECORD(SSOWN_SSADIRINF) SSOWN_SSINHIBIT=1; ! Ensure interrupts held off after PRIME CONTINGENCY ! Tell Director where SSOWN_INHIBIT and _SSINTCOUNT are located. FLAG = X3{DASYNCINH}(0,ADDR(SSOWN_SSINHIBIT)) ! Give name of trap routine to Director. FLAG = X31{PRIMECONTINGENCY}(DIRTRAP) %IF TESTREASON # SSOWN_SSREASON # BATCHREASON %START; !INTERACTIVE USE %IF SSOWN_SSREASON = DSTARTREASON %START; !STARTED FROM OPER CONSOLE(4,SSOWN_SSOPERNO,FLAG); !SSOWN_SSOPERNO CONTAIN OPER NUMBER %FINISH %ELSE %START; !STARTED FROM INTERACTIVE TERMINAL %IF SSOWN_SSREASON=DNEWSTARTREASON %THEN %START SSOWN_ITINLENGTH = 1024 SSOWN_ITOUTLENGTH = 3072 %FINISH CONSOLE(5,FLAG,FLAG) SSOWN_SSREASON = DSTARTREASON; !DISTINCTION BETWEEN OPER AND IT NO LONGER RELEVENT %FINISH JMESSAGE = " **** LOG-ON AT ".TIME." ON ".DATE." **** " TOJOURNAL(ADDR(JMESSAGE)+1,LENGTH(JMESSAGE)) !PUT START-UP MESSAGE IN RECALL FILE MESSAGEFILE = FMESSAGE SSOWN_DATAECHO = 0; !DO NOT ECHO IN FOREGROUND %FINISH %ELSE %START SSOWN_DATAECHO = SSOWN_SSDATAECHO; !USE OPTION FILE SETTING FOR BATCH SSOWN_SESSKIC = DIRINF_SESSICLIM+KIPS; !ALLOW !ONE SECOND OVER USER REQUESTED PRINTSTRING("***** BATCH JOB ".DIRINF_JOBNAME. %C " STARTED AT ".TIME." ON ".DATE." ********") NEWLINES(2) MESSAGEFILE = BMESSAGE %FINISH JMESSAGE = CONFILE (ABASEFILE) %IF STUDENTSS#0 %THEN %START %IF JMESSAGE="#STUDENT" %THEN PRINTSTRING ("Student ") %C %ELSE %IF JMESSAGE#DEFBASE %THEN PRINTSTRING ("Test ") %FINISH %ELSE %START %IF JMESSAGE=DEFBASE %THEN PRINTSTRING ("Standard ") %C %ELSE %IF JMESSAGE#"#STUDENT" %THEN PRINTSTRING ("Test ") %FINISH PRINTSTRING(VERSION) NEWLINE PRINTSTRING(DATE." ".TIME." Users=".ITOS(NUSERS-SYSPROCS). %C " Fsys=".ITOS(SSOWN_SSOWNFSYS)." ") %IF SSOWN_UNSHAREDBGLA#0 %THEN PRINTSTRING("** Unshared basegla ") BDIRLIST 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 L1 %END; !OF CONTROL ! ! - END OF CONT CODE ] ! ! ! [ START OF BASE TEXT - ! ! ! Mode bits recognised by Director: ! **** **** must be updated if Director facilities are enhanced **** **** %CONST %INTEGER VALID MODE BITS = X'800003FF' ! For the significance of the bits, see comment in CONNECT. !!* !***END OF DECLARATIONS !* !* !* ! %SYSTEMROUTINE MOVE(%INTEGER LENGTH, FROM, TO) %INTEGER SUBL %IF LENGTH<=0 %THEN %RETURN LENGTH = LENGTH & X'00FFFFFF' %CYCLE *LDTB_X'18000000' *LDB_LENGTH *LDA_FROM *CYD_0 *LDA_TO *CHOV_%L=%DR *JCC_13, ! %EXIT %IF no dangerous overlap. *LSS_TO *USB_FROM; ! Unsigned arithmetic to avoid overflow. *ST_SUBL %WHILE LENGTH>SUBL %CYCLE LENGTH = LENGTH - SUBL *LDTB_X'18000000' *LDB_SUBL *LDA_FROM *INCA_LENGTH *CYD_0 *INCA_SUBL *MV_%L=%DR %REPEAT %REPEAT MOVEALL: *MV_%L=%DR %END; !OF MOVE ! %SYSTEMROUTINE FILL(%INTEGER LENGTH, FROM, FILLER) *LB_LENGTH *JAT_14,; !RETURN IF LENGTH<=0 *LDTB_X'18000000' *LDB_%B *LDA_FROM *LB_FILLER *MVL_%L=%DR L99: %END; !OF FILL ! %SYSTEM %INTEGER %FN SAMEBYTES (%INTEGER L, A1, A2) ! Compares L bytes at A1 with L bytes at A2. Returns count of ! bytes which match at start of the two areas: zero if the first ! bytes are not the same, and L if the two areas are exactly the ! same. *LDTB_X'18000000' *LDB_L *LDA_A1 *CYD_0 *LDA_A2 *CPS_%L=%DR *CYD_0 *STUH_%B *ISB_A2 *EXIT_-64 %END ! %SYSTEM %INTEGER %FN STOREMATCH (%INTEGER L, A1, A2) ! Compares L bytes at A1 with L bytes at A2. Returns non-zero if ! the two areas are the same, or zero if they differ. *LDTB_X'18000000' *LDB_L *LDA_A1 *CYD_0 *LDA_A2 *CPS_%L=%DR *JCC_8, %RESULT = 0 MF: %RESULT = -1 %END ! %EXTERNALSTRINGFN FROMSTRING(%STRINGNAME S, %INTEGER I, J) %INTEGER AH %STRING (255) HOLDS %IF I<1 %OR I>J %OR J>LENGTH(S) %THEN PSYSMES(-105,35) HOLDS = S; !MUST COPY IT TO AVOID ! ALTERING ORIGINAL AH = ADDR(HOLDS) BYTEINTEGER(AH+I-1) = J-I+1; !SET LENGTH %RESULT = STRING(AH+I-1) %END; !OF FROMSTRING ! %SYSTEM %STRING (255) %FN SUBSTRING (%STRING %NAME S, %INTEGER I, J) %STRING (255) HOLDS %IF I<1 %OR I>J+1 %OR J>LENGTH(S) %THEN %SIGNAL %EVENT 5,7 ! For strict compatibility with IMP 77, we should also %SIGNAL if ! I = LENGTH(S) + 1. J = J - I + 1 LENGTH (HOLDS) = J MOVE (J, ADDR(S)+I, ADDR(HOLDS)+1) %RESULT = HOLDS %END ! %SYSTEM %ROUTINE UCTRANSLATE (%INTEGER ADDRESS, LENGTH) %INTEGER P P=INTEGER(ATRANS)+512 *LDTB_X'18000100' *LDA_P *CYD_0 *LDA_ADDRESS *LDB_LENGTH *TTR_%L=%DR %END ! %EXTERNAL %STRING %FN UCSTRING (%STRING (255) S) %INTEGER P P=INTEGER(ATRANS)+512 *LDTB_X'18000100' *LDA_P *CYD_0 *LDA_S+4 *LDB_(%DR+0) *INCA_1 *TTR_%L=%DR %RESULT = S %END ! %SYSTEMROUTINE ITOE(%INTEGER AD, L) %INTEGER J J = SSOWN_SSCOMREG(12); !ADDR OF ITOE TABLE IN PUBLIC SEGMENT *LB_L *JAT_14, *LDTB_X'18000000' *LDB_%B *LDA_AD *LSS_J *LUH_X'18000100' *TTR_%L=%DR L99: %END; !OF ITOE ! %SYSTEMROUTINE ETOI(%INTEGER AD, L) %INTEGER J J = SSOWN_SSCOMREG(11); !ADDR OF ETOI TABLE IN PUBLIC SEGMENT *LB_L *JAT_14, *LDTB_X'18000000' *LDB_%B *LDA_AD *LSS_J *LUH_X'18000100' *TTR_%L=%DR L99: %END; !OF ETOI ! ! %INTEGERFN TRAIL SPACES(%INTEGER END, FIRST, TRANS) ! !*DETERMINE NO OF TRAILING SPACES FROM END BACK TO FIRST ! %INTEGER SAVE END, SPACECHAR ! SAVE END = END ! %IF TRANS # 0 %THEN SPACECHAR = 64 %ELSE SPACECHAR = ' ' ! !MAY BE EBCDIC FILE ! %WHILE BYTEINTEGER(END) = SPACECHAR %AND END >= FIRST %C ! %THEN END = END-1 ! %RESULT = SAVE END-END ! %END; !OF TRAIL SPACES ! Here is a much faster machine code version, equivalent to ! the IMP code above: %SYSTEM %INTEGER %FN TRAIL SPACES (%INTEGER LINE END, LINE START, TRANS) %INTEGER A *LDTB_X'18000000' *LB_LINE START *LDA_%B *SLB_LINE END *SBB_%TOS *ADB_1 *JAF_13,; ! if <=0 bytes to test. *LDB_%B *LSS_TRANS *JAT_4, *LB_64; ! EBCDIC space. *J_ ISO: *LB_32; ! ISO space. LOOP: *CYD_0 *SWEQ_%L=%DR *JCC_8, *SWNE_%L=%DR *JCC_7, ZERO: %RESULT = 0 ALLSPACES: *STUH_A %RESULT = A & X'00FFFFFF' %END ! ! %SYSTEM %ROUTINE CHOPLDR (%STRING %NAME A, %INTEGER I) ! This routine discards I bytes from the start of the string A, so that ! the length of A is reduced by A. I must be <= LENGTH(A) on entry. ! This is not checked. *LB_(A) *SBB_I *STB_(%DR+0) *INCA_1 *LDB_%B *STD_%TOS *INCA_I *CYD_0 *LD_%TOS *MV_%L=%DR %END ! %SYSTEM %C %INTEGER %FN STARTSWITH (%STRING %NAME A, %STRING (255) B, %INTEGER CHOP) ! This function returns zero if string A does not start with a copy ! of string B, and returns a non-zero value if string B is the same as ! the first characters of string A. If CHOP is zero, then that is ! the only effect of STARTSWITH. If CHOP is non-zero, then STARTSWITH ! also has the side effect of discarding the copy of B from the ! beginning of A, so that A is 'shortened' by LENGTH (B) bytes. ! The code below would work perfectly well if the second ! parameter were %STRING %NAME B, and a call would be significantly ! quicker, but it is a great nuisance not to be able to call ! STARTSWITH with a constant or literal string or an expression ! for the second parameter. I have therefore sacrificed speed ! to utility. Dedicated bit-twiddlers may however choose to ! exploit the following deplorable trick: you can put a %SPEC in ! your code for STARTSWITH with parameters ! (%STRING %NAME A, B, %INTEGER CHOP) ! and when you call it, it will actually work and even give you the ! extra speed. In fact, by giving two %SPECs and using the ! REDIRECT option in MODIFY, you could even use both forms of call ! to enter STARTSWITH. *LB_(A) ; ! Get byte vector descriptor to the whole ! string (including length byte) into DR, ! and get a copy of the length byte into B. *INCA_1 ; ! Point to the text of the string. ! The bound is wrong for the text - it is ! actually 'max. length + 1' - but that ! does not matter. *CYD_0 ; ! Acc now has the descriptor for the ! text of A. *SBB_(B) ; ! B now has LENGTH(A) - LENGTH(B). ! DR has descriptor to the whole of B. *JAT_14, ; ! Branch if LENGTH(B)>LENGTH(A). *LDB_(%DR+0) ; ! Change bound in DR to LENGTH(B). *JAT_11, ; ! 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, ; ! 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, ; ! Branch if CHOP=0. *LB_%TOS ; ! Restore LENGTH(A)-LENGTH(B). *STB_(A) ; ! Make that the new length of A. ! DR now has a descriptor to the whole ! of A. *INCA_1 ; ! Point at text of A. *LDB_%B ; ! Set bound = new length of text of A. *MV_%L=%DR ; ! Copy residue of A into text of A. REQ: %RESULT = -1 NEQ: %RESULT = 0 %END ! %SYSTEM %ROUTINE CAST OUT (%STRING %NAME PSTR) %INTEGER STREND, P %LONG %INTEGER DR, PARTDR, RESIDR, TTDR ! Ensure TTDR is set up as a descriptor to the lower-to-upper-case ! translate table. TTDR=X'1800010000000000'+INTEGER(ATRANS)+512 ! ! Prepare a descriptor to the text of the string: DR = (LENGTHENI(X'58000000'!LENGTH(PSTR))<<32)!(ADDR(PSTR)+1) ! *LD_DR; ! Initialise - not done for subsequent iterations. ! QUOTESCAN: *STD_DR *SWNE_%L=%DR,0,34; ! %MASK=0,%REF='"' *STD_RESIDR; ! Save descriptor to remainder of string, ! including and after the quote. *LB_RESIDR+4; ! Pick up address of the 'quote' byte. *SBB_DR+4; ! Subtract start address of text in original string - ! gives number of bytes before the quote symbol. *LD_DR; ! Restore descriptor to original text. *LDB_%B; ! Build descriptor to the bytes before the quote. *STD_PARTDR ! PARTDR is a descriptor to the bytes before the quote: ! RESIDR is a descriptor to the bytes including and after the quote. ! ! Translate the bytes before the quote to upper case. *LD_PARTDR *LSD_TTDR *TTR_%L=%DR ! ! Remove the spaces from the bytes before the quote. CLEARSP: *LD_PARTDR *SWNE_%L=%DR,0,32; ! %MASK=0,%REF=SP. *JCC_8,; ! -> 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_; ! 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,; ! -> 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,; ! -> 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,; ! -> 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,; ! 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_; ! 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_ DONE3: *INCA_-1 DONE2: *CYD_0 *STUH_%B DONE4: *ST_STREND LENGTH (PSTR) = STREND - ADDR(PSTR) - 1 %END ! %SYSTEM %INTEGER %FN SIZE OF (%NAME X) ! Needed for 'straight' code: ! %CONST %BYTE %INTEGER %ARRAY BYTES (0:7) = 1(4),2,4,8,16 %INTEGER I *LSS_(%LNB+5) *ST_I %IF I&X'C2000000'#0 %THEN %RESULT = I&X'00FFFFFF' ! 'Straight' code: ! I = (I>>27) & 7 ! %RESULT = BYTES (I) ! 'Bit-twiddling' equivalent: %RESULT = ((X'000000F0'<<((I>>27) & 7))>>11) + 1 %END ! %SYSTEMSTRINGFN ITOS(%INTEGER N) !********************************************************************** !* * !* TURNS AN INTEGER INTO A STRING USES MACHINE CODE * !* * !********************************************************************** %STRING (16) S %INTEGER D0, D1, D2, D3 *LSS_N; *CDEC_0 *LD_S; *INCA_1; ! PAST LENGTH BYTE *CPB_%B; ! SET CC=0 *SUPK_%L=15,0,32; ! UNPACK 15 DIGITS SPACE FILL *STD_D2; ! FINAL DR FOR LENGTH CALCS *JCC_8,; ! N=0 CASE *LSD_%TOS; *ST_D0; ! SIGN DESCRIPTOR STKED BY SUPK *LD_S; *INCA_1 *MVL_%L=15,15,48; ! FORCE IN ISO ZONE CODES %IF N<0 %THEN %START BYTEINTEGER(D1) = '-' D1 = D1-1 %FINISH BYTEINTEGER(D1) = D3-D1-1 %RESULT = STRING(D1) WASZERO: %RESULT = "0" %END; !OF ITOS ! %SYSTEMINTEGERFN PSTOI(%STRING (63) S) !CONVERT STRING CONTAINING ! POSITIVE INTEGER TO INTEGER ! RESULT !RESULT = -1 IF INVALID ! STRING IN ANY RESPECT %INTEGER VALUE, J, K, L VALUE = 0 L = LENGTH(S) %IF L = 0 %THEN %RESULT = -1 %FOR K=1,1,L %CYCLE J = CHARNO(S,K) %UNLESS '0' <= J <= '9' %THEN %RESULT = -1 VALUE = 10*VALUE+J&15 %REPEAT %RESULT = VALUE ! ! **** **** ! We could use PACK, etc., but the catch is in checking that the ! characters lie in the range '0' to '9'. We will need a few tables ! for TCH, generally accessible throughout the Subsystem, and then ! similar code could be simplified in quite a few places. ! **** **** ! %END; ! PSTOI ! ! %STRINGFN S2(%INTEGER N) ! THIS FUNCTION RETURNS A TWO DIGIT DECIMAL VALUE FOR N ! %INTEGER TENS, UNITS ! TENS = N//10 ! UNITS = N-10*TENS ! %RESULT = TOSTRING(TENS+'0').TOSTRING(UNITS+'0') ! %END; !OF S2 ! %INTEGERFN I2(%INTEGER AD) !AD POINTS TO THE FIRST OF A PAIR OF DECIMAL CHARACTERS. THE RESULT !IS THE NUMERIC VALUE OF THE CHAS %RESULT = 10*(BYTEINTEGER(AD)&X'F')+(BYTEINTEGER(AD+1)&X'F') ! I have tried ! %RESULT = 10*BYTEINTEGER(AD) + BYTEINTEGER(AD+1) - 11*'0' ! but, for reasons I don't understand, it takes the SAME space ! and MORE OCP time! (at IMP 9) %END; !OF I2 ! %ROUTINE DECWRITE2(%INTEGER VALUE,AD) !*********************************************************************** !* WRITES VALUE AS TWO DECIMAL ISO DIGITS INTO AD AND AD+1 * !*********************************************************************** *LSS_VALUE; *IMDV_10 *USH_8; *IAD_%TOS; *IAD_X'3030' *LDA_AD; *LDTB_X'58000002' *ST_(%DR) %END; ! OF DECWRITE2 ! %SYSTEMSTRING (8) %FN HTOS(%INTEGER VALUE, PLACES) !********************************************************************** !* * !* TURNS AN INTEGER INTO A HEXADECIMAL STRING OF GIVEN LENGTH * !* USES MACHINE CODE * !* * !********************************************************************** %STRING (8) S %INTEGER I I = 64-4*PLACES *LD_S; *LSS_PLACES; *ST_(%DR) *INCA_1; *STD_%TOS; *STD_%TOS *LSS_VALUE; *LUH_0; *USH_I *MPSR_X'24'; ! SET CC=1 *SUPK_%L=8 *LD_%TOS; *ANDS_%L=8,0,15; ! THROW AWAY ZONE CODES *LSS_HEX+4; *LUH_X'18000010' *LD_%TOS; *TTR_%L=8 %RESULT = S %END; !OF HTOS ! %SYSTEMROUTINE PHEX(%INTEGER I) PRINTSTRING(HTOS(I,8)) %END; !OF PHEX ! !*********************************************************************** !* * !* THESE FUNCTIONS ALL USE A PACKED FORMAT OF DATE AND TIME OF ONE OF * !* THE FOLLOWING FORMS.BITS ARE NUMBERED FROM 31 (MOST SIGNIFICANT) TO * !* 0 (LEAST SIGNIFICANT) * !* OLD FORMAT * !* BITS USE * !* 31 ZERO FOR OLD FORMAT * !* 30-26 YEAR-70 (VALID FOR 1970-2033) * !* 25-22 MONTH * !* 21-17 DAY * !* 16-12 HOUR * !* 11- 6 MINUTE * !* 5- 0 SECOND * !* * !* NEW FORMAT * !* BIT31 1 FOR NEW FORMAT * !* ALL OTHER BITS HOLD DT AS SECS SINCE 0000HRS ON 1/1/70 * !* CALCULATED AS PER CACM COLLECTER ALGORITHMS NO 199Z * !* NB TO KEEP LEAP YEARS CORRECT ONE MUST USE THIS ALGORITH FROM * !* 1ST JAN 1900 AND THEN CORRECT. THIS INVOLVES 64BIT ARITHMETIC * !*********************************************************************** ! %SYSTEM %INTEGER %FN CURRENT PACKED DT !*********************************************************************** !* GIVES CURRENT DT IN NEW PACKED FORM * !*********************************************************************** %CONSTLONGINTEGER MILL=1000000 *RRTC_0; *USH_-1 *SHS_1; *USH_1 *IMDV_MILL *ISB_SECS70; *STUH_%B *OR_X'80000000' *EXIT_-64 %END ! %SYSTEM %INTEGER %FN DTWORD (%INTEGER S) %INTEGER Y,M ! Given a binary date and time in either the old or the new format, ! returns the equivalent new-format date-and-time word. %IF S<0 %THEN %RESULT = S Y = (S>>26) + 70 M = (S>>22) & 15 ! D = (S>>17) & 31 ! HRS = (S>>12) & 31 ! MINS = (S>>6) & 63 ! SECS = S&63 %IF M>2 %THEN M = M-3 %ELSE %START M = M + 9 Y = Y - 1 %FINISH ! %RESULT = (((((1461*Y)//4 + (153*M+2)//5 + D + 58 - DAYS70) * 24 %C ! + HRS) * 60 + MINS) * 60 + SECS) ! X'80000000' %RESULT = (((((Y*1461)//4 %C + (M*153+2)//5 %C + ((S>>17)&31) - 25509) * 24 %C + ((S>>12)&31)) * 60 + ((S>>6)&63)) * 60 + (S&63)) ! X'80000000' %END ! ! **** **** The following three routines replaced the **** **** ! **** **** old versions of PACKDATE and PACKDATEANDTIME **** **** ! **** **** when the new format was put into service. **** **** ! %INTEGERFN KDAY(%INTEGER D,M,Y) !*********************************************************************** !* RETURNS DAYS SINCE 1900 GIVEN DAY MONTH &YEAR(<=99) * !*********************************************************************** %IF M>2 %THEN M = M-3 %ELSE %START M = M+9 Y = Y-1 %FINISH %RESULT=1461*Y//4+(153*M+2)//5+D+58 %END ! %INTEGERFN PACKDATE(%STRING (8) DATE) %INTEGER AD,I AD = ADDR(DATE) I=KDAY(I2(AD+1),I2(AD+4),I2(AD+7))-DAYS70 %RESULT=I*SECSIN 24 HRS!X'80000000' %END; !OF PACKDATE ! %SYSTEM %INTEGERFN PACKDATEANDTIME(%STRING (8) DATE, TIME) %INTEGER AT AT = ADDR(TIME) %RESULT=PACKDATE(DATE)+3600*I2(AT+1)+60*I2(AT+4)+I2(AT+7) %END; !OF PACKDATEANDTIME ! ! **** **** End of code for new format of date and time. **** **** ! ! **** **** Here are the old versions: **** **** ! ! %INTEGERFN PACKDATE(%STRING (8) DATE) ! %INTEGER AD ! AD = ADDR(DATE) ! %RESULT = ((I2(AD+7)-70)<<26)!(I2(AD+4)<<22)!(I2(AD+1)<<17) ! %END; !OF PACKDATE ! ! %SYSTEMINTEGERFN PACKDATEANDTIME(%STRING (8) DATE, TIME) ! %INTEGER AT ! AT = ADDR(TIME) ! %RESULT = PACKDATE(DATE)!(I2(AT+1)<<12)!(I2(AT+4)<<6)!(I2(AT+7)) ! %END; !OF PACKDATEANDTIME ! ! **** **** end of old versions **** **** ! %SYSTEM %STRING(8)%FN UNPACK DATE(%INTEGER P) %INTEGER D,M,Y,AD %STRING(8)S AD=ADDR(S) S="00/00/00" %IF P>0 %THEN %START; ! OLD FORMAT Y=P>>26+70 %IF Y>99 %THEN Y = Y - 100 M=P>>22&15 D=P>>17&31 %FINISH %ELSE %START P=(P&X'7FFFFFFF')//SECS IN 24 HRS KDATE(D,M,Y,P+DAYS70) %FINISH DECWRITE2(D,AD+1) DECWRITE2(M,AD+4) DECWRITE2(Y,AD+7) %RESULT=S %END ! %SYSTEM %STRING(8)%FN UNPACK TIME(%INTEGER P) %INTEGER H,M,SECS,AT %STRING(8)S AT=ADDR(S) S="00.00.00" %IF P>0 %START H=P>>12&31 M=P>>6&63 SECS=P&63 %FINISH %ELSE %START *LSS_P; *USH_1; *USH_-1 *IMDV_60; *IMDV_60; *IMDV_24 *LSS_%TOS; *ST_H *LSS_%TOS; *ST_M *LSS_%TOS; *ST_SECS %FINISH DECWRITE2(H,AT+1) DECWRITE2(M,AT+4) DECWRITE2(SECS,AT+7) %RESULT=S %END ! %ROUTINE KDATE(%INTEGERNAME D,M,Y,%INTEGER K) !*********************************************************************** !* K IS DAYS SINCE 1ST JAN 1900 * !* RETURNS D, M, Y 2 DIGIT Y ONLY * !*********************************************************************** ! %INTEGER W ! K=K+693902; ! DAYS SINCE CAESARS BDAY ! W=4*K-1 ! Y=W//146097 ! K=W-146097*Y ! D=K//4 ! K=(4*D+3)//1461: ! D=4*D+3-1461*K ! D=(D+4)//4 ! M=(5*D-3)//153 ! D=5*D-3-153*M ! D=(D+5)//5 ! Y=K *LSS_K; *IAD_693902 *IMY_4; *ISB_1; *IMDV_146097 *LSS_%TOS; *IDV_4; *IMY_4; *IAD_3 *IMDV_1461; *ST_(Y) *LSS_%TOS; *IAD_4; *IDV_4 *IMY_5; *ISB_3; *IMDV_153 *ST_(M); *LSS_%TOS *IAD_5; *IDV_5; *ST_(D) %IF M<10 %THEN M=M+3 %ELSE %START M=M-9 %IF Y=99 %THEN Y = 0 %ELSE Y=Y+1 %FINISH %END; ! OF KDATE ! %EXTERNALINTEGERFN UINFI(%INTEGER ENTRY) %CONSTINTEGER MAXENTRY = 26 %INTEGER LNB, CT,RES %SWITCH SW(1 : MAXENTRY) %RECORD(DIRINFF)%NAME DIRINF %UNLESS 1 <= ENTRY <= MAXENTRY %THEN %RESULT = 0 DIRINF == RECORD(SSOWN_SSADIRINF); !NEEDED FOR ENTRIES 7 - 9 -> SW(ENTRY) SW(1): !OWN FSYS %RESULT = SSOWN_SSOWNFSYS SW(2): !MODE 1=FOREGROUND !2=BATCH !3=FOREGROUND OBEYFILE RES = SSOWN_SSREASON %IF RES=DSTARTREASON %AND (SSOWN_FDLEVEL>1 %OR SSOWN_CONTROLMODE#0) %THEN RES = 3 ! IN OBEY FILE OR OBEYJOB %RESULT = RES SW(3): !NUMBER OF USERS %RESULT = NUSERS-SYSPROCS SW(4): !CURRENT ACR LEVEL *STLN_LNB; !CURRENT LNB %RESULT = (INTEGER(LNB+4)>>20)&X'F'; !ACR FROM STACK FRAME SW(5): !CURRENT CPULIMIT - SECONDS %RESULT = SSOWN_CURRKI//KIPS SW(6): !MAX FILE SIZE IN KBYTES - FOR DEFINE %RESULT = (SSOWN_SSMAXFSIZE>>KSHIFT)-1 SW(7): !SYNC1DEST %RESULT = DIRINF_SYNC1DEST SW(8): !SYNC2DEST %RESULT = DIRINF_SYNC2DEST SW(9): !ASYNCDEST %RESULT = DIRINF_ASYNCDEST SW(10): !ADIRINF %RESULT = SSOWN_SSADIRINF SW(11): !PROCNO %RESULT = DIRINF_PROCNO SW(12): !SSOWN_FDLEVEL %RESULT = SSOWN_FDLEVEL SW(13): !INCARNATION - AS AN INTEGER %RESULT = SSOWN_SSINVOCATION SW(14): !AUXSTACKSIZE %RESULT = SSOWN_SSASTACKSIZE>>KSHIFT; !IN KBYTES SW(15): !ITWIDTH %RESULT=SSOWN_SSITWIDTH SW(16): !BRACKETS - 1 IF SET 0 IF NOBRACKETS %IF SSOWN_SSLDELIM='(' %THENRESULT=1 %RESULT=0 SW(17): !MAXPROMPTSIZE %RESULT=MAXPROMPTSIZE SW(18): !#0 FOR JOB CONTROL MODE %RESULT=SSOWN_CONTROLMODE SW(19): !#0 RESOURCES=SCARCE %IF FUNDS ON#0 %THEN %START !**FUNDSSTART %IF SCARCEWORD&X'FF'>=SCARCEWORD>>24 %THENRESULT=1; !RESOURCES ARE SCARCE !**FUNDSEND %FINISH %RESULT=0 SW(20): !FUNDS LEFT - IN PENCE %RESULT = DIRINF_FUNDS//100; !RES IN PENCE/100 SW(21): !CHARGE FOR THIS SESSION IN PENCE %IF SSOWN_SSREASON=BATCHREASON %THEN CT=0 %ELSE %START CT=(SECSFRMN-SSOWN_STARTSECS)//60; !CONNECT TIME IN MINS %IF CT<0 %THEN CT=CT+1440; !GONE PAST MIDNIGHT %FINISH %RESULT=CHARGE(CPUTIME,PAGETURNS,CT) SW(22): ! Returns non-zero iff messages are inhibited. %RESULT = SSOWN_INHIBIT MESSAGES SW(23): !TERMINAL TYPE %RESULT=SSOWN_SSTERMINALTYPE SW(24): ! FEP software identification - %RESULT = DIRINF_DIDENT SW(25): ! Stream identification - %RESULT = DIRINF_STREAM ID SW(26): ! Loader version. %IF NEWLOADER=0 %THEN %START %RESULT = 0 %FINISH %ELSE %START %RESULT = 1 %FINISH %END; !OF UINFI ! %EXTERNALSTRINGFN UINFS(%INTEGER ENTRY) %CONST %RECORD (COMF) %NAME COM = X'80C00000' %RECORD (SCTF) %NAME SCT %RECORD (DIRINFF) %NAME DIRINF %CONSTINTEGER MAXENTRY = 14 %SWITCH SW(1 : MAXENTRY) %STRING (255) RES %CONST %STRING (4) %ARRAY %C OCPTYPES (1:6) = %C "2950","2960","2970", "2988","2972","2976" %INTEGER FLAG %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? %END; !OF UINFS ! %SYSTEM %ROUTINE SET SS INHIBIT SSOWN_SSINHIBIT = 1 %END ! %SYSTEMROUTINE ALLOW INTERRUPTS %INTEGER I ! Make sure that ALLOW INTERRUPTS does not do anything if there ! are no traps available. This is important between the call of PRIME ! CONTINGENCY in CONTROL and setting the traps in CALLBCI. We are completely ! unprotected in that bit. ! Achieve the desired effect by only allowing interrupts if ! SSOWN_SSCOMREG(34) i.e. SIGLEVEL, #0 %IF SSOWN_SSCOMREG(34)#0 %THEN %START SSOWN_SSINHIBIT = 0; !TO ALLOW INTERRUPTS AGAIN %WHILE SSOWN_SSINTCOUNT>0 %CYCLE; ! TAKE ANY OUTSTANDING ONES I = X3{DASYNCINH}(1,0) %REPEAT %FINISH %END; !OF ALLOW INTERRUPTS ! %SYSTEMINTEGERFN DIRTOSS(%INTEGER FLAG) ! **** **** ! ! Director will soon be changed so that its error messages will be ! more usable by subsystem, so we will have to translate fewer of ! them. Note particularly director error numbers 6, 10, 11, 18, ! 20, 32, 33, 37, 39. Also director error messages 28 and 29 might ! be used to amplify subsystem message 262 (VM full). ! ! **** **** ! Old version is retained below. New version would simply add 500 ! to Director's error number to distinguish director-detected errors from ! subsystem errors. FAILUREMESSAGE can cope with this. The only problem ! with using Director's error messages is that they do not include anything ! equivalent to SSOWN_SSFNAME. ! %IF FLAG=0 %THEN %RESULT = 0 %ELSE %RESULT = FLAG + 500 ! ! Result is subsystem fault number equivalent to the given director ! error number. Comments below assume FLAG is never <0. %CONSTINTEGER MAXDSS = 83 ! DSS is a translation table of director error numbers to subsystem error ! numbers. To fit the values into single bytes, they are reduced by a constant ! value - entries <100 in this table are actually 500 too small, and entries ! between 100 and 255 are 100 too small. The necessary corrections have to ! be performed after the table look-up. %CONSTBYTEINTEGERARRAY DSS(1 : MAXDSS) = %C 1, 2, 3, 4, 5, 173, 7, 8, 174, 175, 101, 12, 13, 14, 176, 119, 176, 120, 19, 173, 21, 22, 23, 24, 178, 26, 27, 162, 162, 30, 31, 118, 179, 34, 209, 176, 101, 38, 156, 178, 180, 178, 176, 44, 45, 46, 47, 48, 181, 182, 183, 52,53,54,55,56,57,58,59,60, 61,62,63,64,65,66,67,68,69,70, 71,72,73,74,75,76,77,78,79,80, 81,82,208 %IF FLAG = 0 %THEN %RESULT = 0; !MOST LIKELY RESULT %IF NOTES ON#0 %THEN %START !**NOTESTART %IF SSOWN_SSNOTE#0 %THEN NOTE("DIRECTOR FLAG = ".ITOS(FLAG)) !**NOTEEND %FINISH SSOWN_SSLASTDFN = FLAG %IF 1 <= FLAG <= MAXDSS %THEN %START FLAG = DSS(FLAG) ! This gives some number in the range 1 to 255 (since 0 never ! occurs as an entry in DSS). %IF FLAG < 100 %THEN FLAG = FLAG+500 %ELSE FLAG = FLAG+100 ! This can produce numbers in the ranges 200-355 and 501-599. %FINISH %ELSE FLAG = FLAG+500; ! This can give 501+MAXDSS and upwards. %RESULT = FLAG %END; !OF DIRTOSS ! %SYSTEMINTEGERFN ROUNDUP(%INTEGER N, ROUND) ! RESULT IS N ROUNDED UP TO ! MULTIPLE OF ROUND >=N ! N.B.: This will not work unless ROUND is a power of 2. ROUND = ROUND-1 %RESULT = (N+ROUND)&(\ROUND); ! AND WITH NOT ROUND %END; !OF ROUNDUP ! %SYSTEMROUTINE SIGNAL(%INTEGER EP, P1, P2, %INTEGERNAME FLAG) %RECORD(SIGDATAF)%NAME D %INTEGERNAME SIGLEVEL %INTEGER LNB, AD18, PC, I %CONSTINTEGER MAXEP = 9 %SWITCH SW(-1 : MAXEP) FLAG = 0; !DEFAULT SIGLEVEL == SSOWN_SSCOMREG(34) %UNLESS -1<=EP<=MAXEP %THEN %START FLAG = 1 -> ERR %FINISH -> SW(EP) SW(-1): SW(0): SW(9): !MEANS THE SAME AS ENTRY 0 %UNLESS 0<=SIGLEVEL 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 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 COMMON SW(5): %MONITOR %STOP SW(6): INTEGER(P1) = SIGLEVEL ERR: %END; !OF SIGNAL ! %SYSTEMROUTINE DIRTRAP(%INTEGER CLASS, SUBCLASS) %INTEGER RRCTYPE %CONST %INTEGER SUBCLASSES = 9 %CONST %STRING (SUBCLASSES) SUBCLASS ID = "QWXYKTACV"; ! Should be (SUBCLASSES). %INTEGER I, FLAG, LNB, SC, XNB, SIGNALAT, OMSTART, OMLENGTH %INTEGER DO SIGNAL, SUBCLASS INDEX %LONGINTEGER DR %RECORD(RRCF)%NAME RRC %INTEGERARRAY IDATA(0 : 17) %INTEGERNAME SIGLEVEL %RECORD(SIGDATAF)%NAME D %INTEGER INCAR,LEN,TYPE,LC,LP %STRING(255) MESS %SWITCH SW(1:16) {CLASS 68 message handling, 16 meantime} %RECORD(DIRINFF)%NAME DIRINF %IF CLASS=65 %THEN %START %IF SUBCLASS>255 %THEN SUBCLASS = SUBCLASS - 255 %IF 1<=SUBCLASS<=SUBCLASSES %THEN SUBCLASS = CHARNO(STRING(ADDR(SUBCLASS ID)),SUBCLASS) %FINISH %IF SSOWN_RRCTOP#0=SSOWN_STOPPING %START; ! MAY HAVE TO RE-ROUTE %FOR I = SSOWN_RRCTOP,-1,1 %CYCLE RRC == RECORD(SSOWN_RRCBASE+(32*(I-1))) RRCTYPE = RRC_TYPE %IF RRCTYPE>=4 %OR CLASS=RRC_CLASS %THEN %START %IF RRCTYPE>1 %THEN %START %IF RRCTYPE<4 %THEN SC = SUBCLASS %ELSE SC = CLASS %IF (RRC_MASK>>(SC-((RRCTYPE&1)<<6)))&1=0 %THEN %CONTINUE %FINISH ! Makes a call on the nominated routine instead of on DIRTRAP. ! Passes on the same parameters CLASS and SUBCLASS. XNB = RRC_XNB DR = RRC_DR *LXN_XNB *LD_DR *PRCL_4 *LSD_CLASS; ! Pass on both CLASS and SUBCLASS (they must be in *ST_%TOS; ! consecutive words). *RALN_7 *CALL_(%DR) ! %RETURN not needed, since the called routine must ! use X26{DRESUME} to relinquish control. Perhaps it would ! be sensible to put in -> INTEXIT ! to ensure that control gets to a X26{DRESUME} even if ! the routine does %RETURN. %FINISH %REPEAT %FINISH !NO RE-ROUTEING REQUIRED CONTINUE HERE SIGLEVEL == SSOWN_SSCOMREG(34) %UNLESS 0 < SIGLEVEL <= MAXSIGLEVEL %THEN X30{DSTOP}(103) FLAG = X32{READID}(ADDR(IDATA(0))); !READ INTERRUPT DATA ! NOW FRIG DISPLAY FOR THIS ! ROUTINE BECAUSE IT MIGHT BE ! USED !BY ONCOND IN NDIAGS *STLN_LNB; !CURRENT LNB INTEGER(LNB+4) = X'E1000000'!(IDATA(1)&X'FFFFFF') !CODE DESCRIPTOR WITH PART OF PSR %IF CLASS=68 %THEN %START ! Message between incarnations of the same process INCAR=SUBCLASS>>24; ! Incarnation of calling process TYPE=SUBCLASS&X'00FFFFFF'; ! Service required DIRINF==RECORD(SSOWN_SSADIRINF) ->SW(TYPE) SW(1): {INT:T to background process} ! Message will be 2 lines. The second will be the current command. ! Since 1 terminal line is no more than 80 chars, may have to trim parms. MESS="Jobname=".DIRINF_JOBNAME." Doc=".SUBSTRING(DIRINF_JOBDOCFILE,10,13). %C ": T=".ITOS(INT(CPUTIME-SSOWN_OLDCPUTIME))." PT=".ITOS(PAGETURNS-SSOWN_OLDPAGETURNS) %C ." Invoc=".ITOS(SSOWN_SSINVOCATION)." Comm=" LC=LENGTH(SSOWN_CLICOMM) LP=LENGTH(SSOWN_CLIPARM) %IF LC>31 %THEN MESS=MESS.SUBSTRING(SSOWN_CLICOMM,1,31)." " %AND LC=31 %C %ELSE MESS=MESS.SSOWN_CLICOMM." " ! Line <=80 and 6 already spoken for ("Comm=" and " ") %IF LC+LP>74 %THEN MESS=MESS.SUBSTRING(SSOWN_CLIPARM,1,71-LC)."... " %ELSE MESS=MESS.SSOWN_CLIPARM." " ! Send message to calling incarnation LEN=LENGTH(MESS) FLAG=X16{DMESSAGE2}(SSOWN_SSOWNER,LEN,1,INCAR,SSOWN_SSOWNFSYS,ADDR(MESS)+1) %IF 0#FLAG#61 %THEN %START ! Some failure or other ! But do what? %FINISH ->OUT SW(*): OUT: DO SIGNAL=0 %FINISH %ELSE %IF CLASS=66 %START; ! MESSAGE FROM OPERATOR !IN THE CASE OF BROADCAST MESSAGES SUBCLASS CONTAINS (OFF1<<16)!OFF2 !WHERE OFF1 AND OFF2 ARE OFFSETS WITHIN A FILE VOLUMS.BROADCAST OF THE !START AND END+1 OF THE MESSAGE. OMSTART = SUBCLASS>>16 OMLENGTH = SUBCLASS&X'FFFF'-OMSTART; !LENGTH OF MESSAGE %IF SSOWN_STOPPING=0 %THEN CONSOLE(6,OMSTART,OMLENGTH); ! CONSOLE OUTPUT REQUEST DO SIGNAL = 0 %FINISH %ELSE %START %IF SSOWN_STOPPING=0 %THEN DO SIGNAL = -1 %ELSE DO SIGNAL = 0 SIGNALAT = 2; !NORMALLY SIGNALAT CURRENT LEVEL ! IC OVERFLOW - GET 1 MIN NOW %IF CLASS=64 %THEN FLAG = X27{DSETIC}(30000) %C %ELSE %IF CLASS=65 %THEN %START; !INTERRUPT FROM USER ! For batch jobs, all user interrupts are treated as INT:X. %IF SSOWN_SSREASON=BATCHREASON %C %THEN SUBCLASS = 'X' %C %ELSE %IF 'a'<=SUBCLASS<='z' %C %THEN SUBCLASS = SUBCLASS-32 ! LOWER CASE=UPPER CASE %IF 0<=SUBCLASS<=127 %THEN %START I = ADDR (SUBCLASS ID) *LDTB_X'18000000' *LDB_SUBCLASSES *LDA_I; ! Byte vector descriptor to string. *INCA_1; ! Descriptor to characters. *LB_SUBCLASS *SWNE_%L=%DR *JAF_11, *LSS_0 *J_ FOUND: *CYD_0 *STUH_%B *ISB_I STORE: *ST_SUBCLASS INDEX %FINISH %ELSE SUBCLASS INDEX = 0 ! SUBCLASS INDEX now has 1 for subclass 'Q', ! 2 for 'W', ! 3 for 'X', ! 4 for 'Y', ! 5 for 'K', ! 6 for 'T', ! 7 for 'A', ! 8 for 'C', ! 9 for 'V', ! 0 for any other value. %IF SUBCLASS INDEX>0 %THEN %START %IF 2<=SUBCLASS INDEX<=4 %OR SUBCLASS INDEX=9 %THEN %START; ! for W, X, Y and V. %IF SSOWN_STOPPING#0 %THEN X30{DSTOP} (113) SSOWN_INT IN PROGRESS = 0 %FINISH %IF SSOWN_INT IN PROGRESS=0=SSOWN_STOPPING %THEN %START ! We flag INT:Q because it needs special treatment in OBEY. %IF SUBCLASS='Q' %THEN SSOWN_INTQ = 1 %ELSE %START SSOWN_INT IN PROGRESS = 1 ! Next we pick out W, X, Y, V, A and C. ! INT:Y is generated by an FEP to force log-off. ! All we do with these is SIGNAL them at the outermost level. %IF 'K'#SUBCLASS#'T' %THEN %START SIGNALAT = 3 %FINISH %ELSE %START ! Now we are left with K and T. DO SIGNAL = 0 %IF SUBCLASS#'K' %C %THEN CONSOLE (12, FLAG, FLAG) %C %ELSE %START %IF SSOWN_SSTTHIDE=0 %THEN %START %IF SSOWN_SSTTACT#1 %C %THEN CONSOLE (7, FLAG, FLAG) %C %ELSE SSOWN_SSTTKN = -1 %IF SSOWN_SSTTACT#-1 %THEN SSOWN_SSTTHIDE = -1 %ELSE %START FLAG = IOCP (7,ADDR(SSOWN_PROMPTTEXT)) FLAG = IOCP (25, 0) %FINISH %FINISH %FINISH SSOWN_INT IN PROGRESS = 0 %FINISH %FINISH %FINISH %ELSE DO SIGNAL = 0 %FINISH %ELSE DO SIGNAL = 0 %FINISH %ELSE %IF SSOWN_STOPPING#0 %THEN X30{DSTOP} (113) %FINISH %IF DO SIGNAL#0 %THEN %START %IF SIGNALAT=2 %START D == SSOWN_SIGDATA(SIGLEVEL); !MOVE IDATA TO ARRAY MOVE(72,ADDR(IDATA(0)),ADDR(D_A(0))) MOVE(72,ADDR(IDATA(0)),ADDR(SSOWN_SAVEIDATA(0,SSOWN_SAVEIDPOINTER))) !MOVE INTO SSOWN_SAVEIDATA SSOWN_SAVEIDATA(-2,SSOWN_SAVEIDPOINTER) = CLASS SSOWN_SAVEIDATA(-1,SSOWN_SAVEIDPOINTER) = SUBCLASS MOVE(9,APTIME,ADDR(SSOWN_SAVEIDATA(18,SSOWN_SAVEIDPOINTER))) !PUT TIME INTO RECORD SSOWN_SAVEIDPOINTER = (SSOWN_SAVEIDPOINTER+1)&3 %FINISH SIGNAL(SIGNALAT,CLASS,SUBCLASS,FLAG) %FINISH INTEXIT: X26{DRESUME}(0,0,ADDR(IDATA(0))); !GO ON WHERE INTERRUPTED ! ! %END; !OF DIRTRAP %SYSTEMROUTINE HALT !CALL DIRECTOR STOP TO STOP ! PROCESS X30{DSTOP}(100) %END; !OF HALT %SYSTEMINTEGERFN CHECKFILENAME(%STRING (31) FILE, %INTEGER TYPE) !CHECKS FILENAME ACCORDING TO ! TYPE !2**0 OWN FILE - STD NAME !2**1 ANY FILE - STD NAME !2**2 ANY NAME (INCLUDING #) !2**3 PD MEMBERNAME !IF OK PUTS OWNER AND NAME ! BACK IN CUFOWNER,SSOWN_CURFNAME ! AND SSOWN_CURFILE ! WITH NO CHANCE OF CAPACITY ! EXCEEDED ! %INTEGER I, CHAR not needed for machine code version. %INTEGER LENN %STRING (40) HOLDSSFNAME %STRING (18) OWNER, NAME, MEMBER %IF FILE = LAST %THEN %RESULT = 0; !CURRENT FILE HOLDSSFNAME = SSOWN_SSFNAME; !TO RESET SSFNAME IF FILENAME IS OK UCTRANSLATE (ADDR(FILE)+1, LENGTH(FILE)) SSOWN_SSFNAME = FILE; !FOR ALL TYPES OF FAILURE %IF LENGTH(FILE) > 30 %THEN %RESULT = 220 !INVALID FILENAME %IF FILE -> FILE.("_").MEMBER %START ! %IF PDFNFC#0 %THEN %START ! %IF FILE="" %THEN FILE=SSOWN_PDPREFIX ! %FINISH !FILE INCLUDES MEMBERNAME %IF TYPE&8 = 0 %THEN %RESULT = 269 !ILLEGAL USE OF PDFILE MEMBER ! LENN = LENGTH(MEMBER) ! %UNLESS 1 <= LENN <= 11 %THEN %RESULT = 270 !INVALID MEMBER ! I = 0 ! %WHILE I %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 *LSS_TYPE *AND_4 *JAT_4, *CYD_0 *STUH_%B *ISB_NAME+4 *UCP_1 *JCC_8, *SWEQ_%L=%DR,0,35; ! %MASK=0,%REF='#' *CYD_0 *STUH_%TOS *CPB_%TOS *JCC_7, 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<=AD8 %C %AND SUBSTRING(RES,8,9)="T#" %C %THEN LENGTH(RES) = LENGTH(RES)-1 %IF CUR_CONAD+32>AD %OR INTEGER(CUR_CONAD+12)#SSPDFILETYPE %THEN %RESULT = RES ! If here then found a pdfile - which member is it OFFSET=INTEGER(CUR_CONAD+24) MEMNUMS=INTEGER(CUR_CONAD+28) %RESULT=RES.PDFILE(AD,CUR_CONAD,OFFSET,MEMNUMS) %FINISH %REPEAT %RESULT = ""; !NO FILE THERE %END; !OF CONFILE ! ! %SYSTEMROUTINE DISCONNECT(%STRING (31) FILE, %INTEGERNAME FLAG) ! ! This will disconnect members of PD files as well! It simply ignores ! SSOWN_CURMEMBER, and so it disconnects the PD file. Since connect-a-member ! is effectively a connection of the PD file itself, this all works ! tidily. ! %RECORD(CONFF)%NAME CUR %INTEGER POS %IF NOTES ON#0 %THEN %START !**NOTESTART %IF SSOWN_SSNOTE # 0 %THEN NOTE("DISCONNECT(".FILE.")") !**NOTEEND %FINISH FLAG = CHECKFILENAME(FILE,7); !ANY FILE %IF FLAG=0 %THEN %START FLAG = FINDFN(SSOWN_CURFILE,POS) %IF FLAG#0 %THEN FLAG = 256 %ELSE %START CUR == SSOWN_CONF(POS) %IF NEWCONNECT=0 %THEN %START %IF INTEGER(CUR_CONAD+12) = SSOLDDIRFILETYPE %THEN SSOWN_DIRDISCON = 1 ! TO WARN LOADER THAT A DIRECTORY HAS BEEN DISCONNECTED %IF CUR_USE&X'3F'#0 %THEN FLAG = 266 %ELSE %START SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,0)) %IF FLAG = 0 %THEN CLEARFN(POS); !CLEAR IT OUT OF ARRAY SSOWN_CONF ALLOW INTERRUPTS %FINISH %FINISH %ELSE %START %IF CUR_USE&X'3FFFFFFF'#0 %THEN CUR_USE = CUR_USE - 1 %IF CUR_USE&X'BFFFFFFF'=0 %THEN %START %IF INTEGER(CUR_CONAD+12) = SSOLDDIRFILETYPE %THEN SSOWN_DIRDISCON = 1 ! TO WARN LOADER THAT A DIRECTORY HAS BEEN DISCONNECTED SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS %IF CUR_USE&X'40000000'#0 %THEN %START ! If the file was TEMP or VTEMP: FLAG = -1 %FINISH %ELSE %IF CUR_MODE&2#0 %THEN %START FLAG = DIRTOSS (X4{DCHACCESS}( %C SSOWN_CURFOWNER,SSOWN_CURFNAME,CUR_FSYS,1)) %IF FLAG=0 %THEN CUR_MODE = 1 %FINISH %IF FLAG#0 %THEN %START FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,0)) %IF FLAG = 0 %THEN CLEARFN(POS); !CLEAR IT OUT OF ARRAY CONF %FINISH ALLOW INTERRUPTS %FINISH %FINISH %FINISH %IF FLAG#0 %THEN SSOWN_SSFNAME = SSOWN_CURFILE %FINISH %IF NOTES ON#0 %THEN %START !**NOTESTART %IF SSOWN_SSNOTE # 0 %THEN NOTE("DISCONNECT FLAG = ".ITOS(FLAG)) !**NOTEEND %FINISH %END; !OF DISCONNECT ! %SYSTEM %ROUTINE SDISCONNECT %C (%STRING (31) FILE, %INTEGER FSYS, %INTEGER %NAME FLAG) !*********************************************************************** !* * !* SDISCONNECT provided for JOBBER and JOURNAL allows for * !* disconnection of a particular file on a particular FSYS. It is * !* used in conjunction with a facility in CONNECT which allows the * !* user to specify the FSYS of the file he wishes to connect. * !* * !*********************************************************************** %RECORD(CONFF)%NAME CUR %INTEGER POS %IF NEWCONNECT=0 %THEN %START FLAG = CHECKFILENAME(FILE,7); !ANY FILE %IF FLAG=0 %THEN %START SSOWN_CURFSYS = FSYS; !USER SUPPLIES FSYS DISCONNECT(LAST,FLAG); !TO ENSURE USE OF CORRECT SSOWN_CURFSYS %FINISH %FINISH %ELSE %START %IF NOTES ON#0 %THEN %START !**NOTESTART %IF SSOWN_SSNOTE # 0 %THEN NOTE("DISCONNECT(".FILE.")") !**NOTEEND %FINISH FLAG = CHECKFILENAME(FILE,7); !ANY FILE %IF FLAG=0 %THEN %START FLAG = FINDFN(SSOWN_CURFILE,POS) SSOWN_CURFSYS = FSYS %IF FLAG#0 %THEN FLAG = 256 %ELSE %START CUR == SSOWN_CONF(POS) %IF CUR_USE&X'3FFFFFFF'#0 %THEN %START CUR_USE = CUR_USE - 1 %IF CUR_USE&X'BFFFFFFF'=0 %THEN %START %IF INTEGER(CUR_CONAD+12) = SSOLDDIRFILETYPE %THEN SSOWN_DIRDISCON = 1 ! TO WARN LOADER THAT A DIRECTORY HAS BEEN DISCONNECTED SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,0)) %IF FLAG = 0 %THEN CLEARFN(POS); !CLEAR IT OUT OF ARRAY CONF ALLOW INTERRUPTS %FINISH %FINISH %FINISH %IF FLAG#0 %THEN SSOWN_SSFNAME = SSOWN_CURFILE %FINISH %IF NOTES ON#0 %THEN %START !**NOTESTART %IF SSOWN_SSNOTE # 0 %THEN NOTE("DISCONNECT FLAG = ".ITOS(FLAG)) !**NOTEEND %FINISH %FINISH %END; !OF SDISCONNECT ! %ROUTINE KDISCON (%INTEGER POS, %INTEGER %NAME FLAG) %RECORD(CONFF)%NAME CUR %STRING (18) OWNER, NAME %IF NEWCONNECT#0 %THEN %START CUR == SSOWN_CONF(POS) %IF CUR_USE&X'BFFFFFFF'#0 %THEN FLAG = 266 %C %ELSE %IF CUR_FILE->OWNER.(".").NAME %THEN %START SSOWN_SSINHIBIT = 1; !HOLD OFF INTERRUPTS FLAG = DIRTOSS(X11{DDISCONNECT}(OWNER,NAME,CUR_FSYS,0)) %IF FLAG = 0 %THEN CLEARFN(POS); !CLEAR IT OUT OF ARRAY CONF ALLOW INTERRUPTS %FINISH %FINISH %END; ! OF KDISCON ! %ROUTINE RDISCON (%STRING (31) FILE, %INTEGER %NAME F) %INTEGER POS, CLEAR, FLAG %IF NEWCONNECT#0 %THEN %START %IF NOTES ON#0 %THEN %START !**NOTESTART %IF SSOWN_SSNOTE # 0 %THEN NOTE("DISCONNECT(".FILE.")") !**NOTEEND %FINISH CLEAR = LENGTH(FILE) %IF CLEAR>1 %AND CHARNO(FILE,CLEAR)='*' %C %THEN LENGTH(FILE) = CLEAR - 1 %C %ELSE CLEAR = 0 FLAG = CHECKFILENAME(FILE,7); !ANY FILE %IF FLAG=0 %THEN %START FLAG = FINDFN(SSOWN_CURFILE,POS) %IF FLAG#0 %THEN FLAG = 256 %ELSE %START %IF CLEAR#0 %THEN SSOWN_CONF(POS)_USE = SSOWN_CONF(POS)_USE & X'C0000000' KDISCON (POS, FLAG) %FINISH %IF FLAG#0 %THEN SSOWN_SSFNAME = SSOWN_CURFILE %FINISH %IF NOTES ON#0 %THEN %START !**NOTESTART %IF SSOWN_SSNOTE # 0 %THEN NOTE("DISCONNECT FLAG = ".ITOS(FLAG)) !**NOTEEND %FINISH %FINISH %END ! %EXTERNALROUTINE ZDISCONNECT(%STRING (255) S) %INTEGER FLAG, DUMMY, I %STRING (31) FILE SETPAR(S) FLAG = 0 %CYCLE FILE = SPAR(0) %EXIT %IF FILE = ""; !END OF LIST %IF FILE = ".ALL" %START; !DISCONNECT ALL FILES POSSIBLE FLAG = 0; !ALWAYS OK %FOR I=0,1,MAXCONF %CYCLE %IF ""#SSOWN_CONF(I)_FILE#"EMPTY" %THEN %START %IF NEWCONNECT=0 %THEN %START DISCONNECT(SSOWN_CONF(I)_FILE,DUMMY) %FINISH %ELSE %START KDISCON (I, FLAG) %FINISH !IGNORE FLAG %FINISH %REPEAT %EXIT %FINISH %IF NEWCONNECT=0 %THEN %START DISCONNECT (FILE, FLAG) %FINISH %ELSE %START RDISCON (FILE, FLAG) %FINISH %IF FLAG # 0 %THEN PSYSMES(14,FLAG) %REPEAT SSOWN_RCODE = FLAG %END; ! of DISCONNECT command. ! %INTEGER %FN DODCONN (%STRING (6) USER, %STRING (11) FILE, %C %INTEGER FSYS, MODE, APF, %INTEGER %NAME SEG, GAP) %INTEGER Z %IF NEWCONNECT#0 %THEN %START Z = X7{DCONNECT}(USER,FILE,FSYS,MODE,APF,SEG,GAP) %IF Z=28 %OR Z=29 %OR Z=35 %THEN %START ! CBT freelist empty, or ! No free CONLIST entries, or ! Segment in use or GAP too small. ZDISCONNECT (".ALL") Z = X7{DCONNECT}(USER,FILE,FSYS,MODE,APF,SEG,GAP) %FINISH %RESULT = DIRTOSS (Z) %FINISH %END ! %SYSTEMROUTINE CONNECT(%STRING (31) FILE, %C %INTEGER MODE, HOLE, PROT, %RECORD(RF)%NAME R, %INTEGERNAME FLAG) ! ! Needed for student subsystem: ! %CONST %INTEGER MAXALWAYS = 3 %CONST %STRING (6) %ARRAY ALWAYS (1:MAXALWAYS) = "SUBSYS", "SPOOLR","MAILER" ! ! End of student subsystem specials. ! %RECORD(PDHF)%NAME PDH %RECORD(PDF)%NAME PD %RECORD (DPERMF) DPERM %INTEGER I, P, SIZE, CYMODE, CONAD, N %STRING (11) MEMBER %RECORD(HF)%NAME H; !FILE HEADER %RECORD(CONFF)%NAME CUR %RECORD (FRF)FR %INTEGER CONSEG, POS, REQMODE ! ! Mode bits are: ! X'00000001' read ! X'00000002' write ! X'00000004' execute ! X'00000008' accept shared write ! X'00000010' newcopy ! X'00000020' comms mode ! X'00000040' disc only ! X'00000080' new stack segment ! X'00000100' disallow DISCONNECT, CHANGE ACCESS, CHANGE SIZE ! X'00000200' sequential ! X'80000000' non-slaved segment ! ! Common valid combinations are (in decimal): ! 1 read ! 2 write {*} ! 3 read/write ! 4 execute {*} ! 5 read/execute ! 9 read (accept shared write) ! 10 write (accept shared write) {*} ! 11 read/write (accept shared write) ! 18 write newcopy {*} ! 19 read/write newcopy ! 513 read sequential ! 514 write sequential {*} ! 515 read/write sequential ! 521 read sequential (accept shared write) ! 522 write sequential (accept shared write) {*} ! 523 read/write sequential (accept shared write) ! 530 write newcopy sequential {*} ! 531 read/write newcopy sequential ! where {*} means that Director grants read access in addition ! to the requested modes. ! ! %ROUTINE FINFO AND CHOOSEMODE FINFO(LAST,0,FR,FLAG); !GET FILEINFO TO GET SIZE %RETURN %IF FLAG # 0; !FINFO FAILS %IF MODE&7=0 %START; !NO MODE REQUESTED - CHOOSE ONE ! If the user has READ permission, we will give him READ ! access only. Failing that, if he has WRITE permission ! we will give him WRITE access. If he has EXECUTE permission ! without either READ or WRITE, then we will give him ! EXECUTE access. We assume he has at least one of these ! permissions, since otherwise he would have failed to ! get beyond FINFO. %IF FR_RUP&1#0 %THEN I = 1 %C %ELSE %IF FR_RUP&2#0 %THEN I = 2 %C %ELSE I = 4 MODE = MODE ! I %FINISH %ELSE %IF (\FR_RUP)&MODE&7#0 %THEN %START !REQUESTED ACCESS NOT ALLOWED SSOWN_SSFNAME = SSOWN_CURFILE FLAG = 303 %FINISH %END ! %ROUTINE DOCONNECT %IF NEWCONNECT#0 %THEN %START HOLE = HOLE>>SEGSHIFT !HOLE IN SEGMENTS %IF NEWLOADER=0 %THEN %START %IF SSOWN_CURFNAME = "T#US".SSOWN_SSSUFFIX %THEN MODE = MODE!X'80' %FINISH %ELSE %START %IF SSOWN_CURFNAME = "T#USTK".SSOWN_SSSUFFIX %THEN MODE = MODE!X'80' %FINISH !TEMP %IF PROT&8#0 %THEN MODE = MODE ! X'0100' ! Tell Director "never disconnect". FLAG = DODCONN(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,MODE,0,CONSEG,HOLE) %IF FLAG#0 %THEN %START CLEARFN (POS) SSOWN_SSFNAME = SSOWN_CURFILE %FINISH %ELSE %START CUR_CONAD = CONSEG< 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 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>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< 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 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< ERR %IF FLAG#0 %FINISH %FINISH %ELSE %START I = 0 %IF HOLE#0 %AND HOLE ERR %IF FLAG#0 I = -1 %FINISH %FINISH %ELSE %START %IF (MODE!!CUR_MODE)&X'FE'=0 %OR MODE=0 %THEN %START ! If the current MODE and the HOLE size are already correct, ! then there is nothing to do. MODE=0 means that the ! caller does not care what mode he gets. I = -1 %IF (\CUR_USE)<<2#0 %THEN CUR_USE = CUR_USE + 1 %IF PROT&8#0 %THEN CUR_USE = CUR_USE ! X'80000000' %FINISH %ELSE %IF 1<=MODE<=5 %THEN %START ! Either the MODE or the HOLE size needs changing. ! If the HOLE size is adequate, then we check the MODE. ! Some new MODEs can be reached by CHANGE ACCESS, so ! we use that routine if the MODE is acceptable. In ! all other cases, we DISCONNECT the file and reCONNECT ! it in the new MODE. ! **** **** The checks on MODE will have to be **** **** ! **** **** revised if CHANGE ACCESS becomes more **** **** ! **** **** versatile. **** **** %IF CUR_USE&X'BFFFFFFF'#0 %THEN %START FLAG = 266 -> ERR %FINISH FINFO(LAST,0,FR,FLAG) %IF (\FR_RUP)&MODE&7#0 %THEN %START; ! REQUESTED PERMISSION NOT ALLOWED. FLAG = 303 -> ERR %FINISH CUR_MODE = MODE ! 1 FLAG = DIRTOSS(X4{DCHACCESS}(SSOWN_CURFOWNER,SSOWN_CURFNAME,CUR_FSYS,MODE)) -> ERR %IF FLAG # 0 I = -1 %FINISH %FINISH %FINISH %IF I=0 %THEN %START %IF NEWCONNECT=0 %THEN %START DISCONNECT (LAST, FLAG) -> ERR %IF FLAG#0 CONNECT (LAST, MODE, HOLE, PROT, R, FLAG) -> ERR %IF FLAG#0 FLAG = FINDFN (SSOWN_CURFILE,POS) CUR == SSOWN_CONF(POS) %FINISH %ELSE %START %IF CUR_USE&X'BFFFFFFF'#0 %THEN %START FLAG = 266 -> ERR %FINISH FINFO AND CHOOSEMODE -> ERR %IF FLAG#0 %IF INTEGER(CUR_CONAD+12) = SSOLDDIRFILETYPE %THEN SSOWN_DIRDISCON = 1 ! TO WARN LOADER THAT A DIRECTORY HAS BEEN DISCONNECTED FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,0)) ! If the file were VTEMP it would have disappeared now. %IF FLAG=0 %AND FR_ARCH&8#0 %THEN %START FLAG = DIRTOSS(X8{DCREATE} %C (SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,CUR_SIZE>>KSHIFT,8)) %IF FLAG#0 %THEN CLEARFN (POS) %FINISH %IF FLAG=0 %THEN DOCONNECT -> ERR %IF FLAG#0 %FINISH %FINISH %FINISH %FINISH ! MODE AND HOLE OK - NOW MOVE ! INFO FROM CUR INTO RECORD R R_CONAD = CUR_CONAD; !CONNECT ADDRESS H == RECORD(CUR_CONAD); !MAP H ONTO FILE HEADER R_FILETYPE = H_FILETYPE R_FILETYPE = 3 %IF H_FILETYPE = 0 R_DATASTART = H_DATASTART R_DATAEND = H_DATAEND %IF NEWCONNECT=0 %THEN %START CUR_USE = CUR_USE ! (PROT&X'3F') %FINISH %IF MODE&2#0 %AND H_DATASTART>=32 %THEN %START !EXPLICIT CONNECT IN WRITE MODE !AND HEADER AT LEAST 32 BYTES ! LONG H_DATETIME = CURRENTPACKEDDT %FINISH ERR: %IF NOTES ON#0 %THEN %START !**NOTESTART %IF SSOWN_SSNOTE # 0 %THEN NOTE("CONNECT(".HOLDFILE.") FLAG = ". %C ITOS(FLAG)) !**NOTEEND %FINISH ALLOW INTERRUPTS; ! **** **** CONNECT is recursive. **** **** ! **** **** This cannot be right. **** **** ! **** **** In fact, on closer inspection, I don't think **** **** ! **** **** recursion in CONNECT can cause trouble with **** **** ! **** **** ALLOW INTERRUPTS: but what can easily occur **** **** ! **** **** is ALLOW INTERRUPTS being done when CONNECT **** **** ! **** **** has not set SSOWN_SSINHIBIT=1. Is this a problem? **** **** ! **** **** What if the caller has inhibited interrupts? **** **** %END; !OF CONNECT ! %SYSTEMROUTINE OUTFILE(%STRING (31) FILE, %INTEGER FILESIZE, HOLE, %C PROT, %INTEGERNAME CONAD, FLAG) ! ! HOLE<0 means "don't connect". CONAD will be set to zero. ! ! Note on PROT: ! bit 24 (X'00000080') non-zero means that (PROT>>8)&X'FF' gives FSYS: ! bit 25 (X'00000040') non-zero means that user nominates CONAD: ! bit 1 (X'40000000') non-zero means that a TEMP file is required - ! this can also be specified by nominating a file name whose ! first two characters are "T#": ! bit 2 (X'20000000') non-zero means that a VTEMP file is required - ! if both TEMP and VTEMP are specified, then the file will be ! be VTEMP: ! bits 26-31 (X'0000003F') are copied into the USE field of the the ! entry in the connected file table SSOWN_CONF. This represents a count ! of the number of current 'uses' which require the file to be ! connected. It is, for instance, incremented whenever the file ! is OPENed for use by the i/o routines, and decremented whenever ! it is CLOSEd. The file cannot be disconnected while USE is ! non-zero. Thus, by setting a 'large' initial value in USE ! (i.e., - conventionally - by putting 8 in the bottom end of ! PROT), you can prevent the file ever being disconnected until ! the end-of-session. Actually this mechanism is unreliable - ! although USE is simply incremented and decremented, it is ! not tested for being >0. The test is actually USE&X'3F'#0. ! This means that, if USE were incremented from 63 to 64, the ! file would appear to become 'unused'! I haven't figured ! out the reasons for that yet. %RECORD (FRF)FR %RECORD (DPERMF) DPERM %RECORD(HF)%NAME H %INTEGER MODE, CONSEG, CRF, POS, CURSIZE, PSIZE, TYPE, ATLEAST, I, N, CYMODE %INTEGER XCON %RECORD(CONFF)%NAME CUR %IF NOTES ON#0 %THEN %START !**NOTESTART %IF SSOWN_SSNOTE # 0 %THEN NOTE("OUTFILE(".FILE.",".ITOS(FILESIZE). %C ",".ITOS(HOLE).",".ITOS(PROT).")") !**NOTEEND %FINISH %IF FILESIZE<0 %THEN %START FILESIZE = -FILESIZE ATLEAST = 1 %FINISH %ELSE ATLEAST = 0 !NEGATIVE SIZE MEANS CREATE AT LEAST THIS SIZE FLAG = CHECKFILENAME(FILE,5); !OWN FILE ANY NAME -> ERR %IF FLAG # 0 %UNLESS 'A'<=CHARNO(SSOWN_CURFNAME,1)<='Z'%THEN %START; ! INVALID NEW FILENAME. FLAG=220 -> ERR %FINISH PSIZE = ROUNDUP(FILESIZE,FILESIZEALLOC) %IF HOLE>0 %THEN %START %IF HOLE=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 CURSIZEPSIZE %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<>18 LASTSEG=(CUR_CONAD+CUR_HOLE-1)>>18 %IF LENGTH(RES)>8 %AND CHARNO(RES,8)='T' %AND CHARNO(RES,9)='#' %C %THEN LENGTH(RES)=LENGTH(RES)-1 %RESULT=RES %FINISH %REPEAT %RESULT="" %END; ! OF SEGSINUSE ! %SYSTEMROUTINE SETUSE(%STRING (31) FILE, %INTEGER MODE, VALUE) %RECORD(CONFF)%NAME CUR %INTEGER POS, FLAG FLAG = CHECKFILENAME(FILE,15); !ANY INCLUDING PD MEMBER -> ERR %IF FLAG#0; !INVALID FILENAME FLAG = FINDFN(SSOWN_CURFILE,POS) -> ERR %IF FLAG#0; !NOT CONNECTED CUR == SSOWN_CONF(POS) %IF NEWCONNECT=0 %THEN %START !*********************************************************************** !* * !* This routine is used to modify the USE field in the CONNECT record: * !* Mode=0 Set use to value * !* Mode=1 Add 1 to use * !* Mode=-1 Subtract 1 from use * !* * !*********************************************************************** %IF MODE=0 %C %THEN CUR_USE = VALUE {USE VALUE PROVIDED} %C %ELSE %IF MODE=1 %C %THEN CUR_USE = CUR_USE+1 {ADD ONE} %C %ELSE %IF MODE=-1 %AND CUR_USE>0 %C %THEN CUR_USE = CUR_USE-1 {SUBTRACT ONE} %FINISH %ELSE %START !*********************************************************************** !* * !* This routine is used to modify the USE field in the CONNECT record: * !* Mode=0 Set top bit of USE if VALUE#0, else clear top bit * !* Mode=1 Add 1 to USE count * !* Mode=-1 Subtract 1 from USE count * !* * !*********************************************************************** %IF MODE>0 %THEN %START %IF (\CUR_USE)<<2#0 %THEN CUR_USE = CUR_USE + 1 %FINISH %ELSE %IF MODE<0 %THEN %START %IF CUR_USE<<2#0 %THEN %START CUR_USE = CUR_USE - 1 %IF CUR_USE&X'BFFFFFFF'=0 %C %AND INTEGER(CUR_CONAD+12) = SSOLDDIRFILETYPE %C %THEN SSOWN_DIRDISCON = 1 ! TO WARN LOADER THAT A DIRECTORY HAS BEEN DISCONNECTED %FINISH %FINISH %ELSE CUR_USE = CUR_USE ! X'80000000' ! That actually stops anyone from ever clearing the "fixed connection" bit. ! To make the routine perform according to the specification comment above, ! replace that last line by the two following lines. ! %FINISH %ELSE %IF VALUE#0 %THEN CUR_USE = CUR_USE ! X'80000000' ! %ELSE CUR_USE = CUR_USE & X'7FFFFFFF' %FINISH ERR: %END; !OF SETUSE ! %SYSTEMROUTINE DESTROY(%STRING (31) FILE, %INTEGERNAME FLAG) %INTEGER POS %RECORD(CONFF)%NAME CUR FLAG = CHECKFILENAME(FILE,5); !ANY OWN FILE -> ERR1 %IF FLAG # 0 FLAG = FINDFN(SSOWN_CURFILE,POS) %IF FLAG=0 %THEN %START; ! CURRENTLY CONNECTED - USE DESTROY ! OPTION IN DISCONNECT. CUR == SSOWN_CONF(POS) %IF NEWCONNECT=0 %THEN %START %IF CUR_USE&X'3F'#0 %THEN FLAG = 266 %ELSE %START SSOWN_SSINHIBIT = 1 ! DISCONNECT+DESTROY FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,1)) %IF FLAG=0 %OR FLAG=278 %OR FLAG=283 %THEN CLEARFN(POS); !CLEAR RECORD IN TABLE ! 283 is 'no DESTROY permission', but the file will still ! be disconnected. Similarly 278 is 'file connected in ! another VM. ALLOW INTERRUPTS %FINISH %FINISH %ELSE %START %IF CUR_USE&X'BFFFFFFF'#0 %THEN FLAG = 266 %ELSE %START SSOWN_SSINHIBIT = 1 ! DISCONNECT+DESTROY FLAG = DIRTOSS(X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,1)) %IF FLAG=0 %OR FLAG=278 %OR FLAG=283 %THEN CLEARFN(POS); !CLEAR RECORD IN TABLE ! 283 is 'no DESTROY permission', but the file will still ! be disconnected. Similarly 278 is 'file connected in ! another VM. ALLOW INTERRUPTS %FINISH %FINISH %FINISH %ELSE %START; !NOT CONNECTED FLAG = DIRTOSS(X9{DDESTROY}(SSOWN_CURFOWNER,SSOWN_CURFNAME,"",SSOWN_CURFSYS,0)) %FINISH %IF FLAG # 0 %THEN SSOWN_SSFNAME = SSOWN_CURFILE ERR1: !SSOWN_SSFNAME ALREADY SET %END; !OF DESTROY ! %SYSTEMROUTINE RENAME(%STRING (31) FILE, NEWFILE, %INTEGERNAME FLAG) %STRING (11) NEWNAME %INTEGER POS FLAG = CHECKFILENAME(NEWFILE,5) !CHECK NEWNAME FIRST -> ERR %IF FLAG # 0 NEWNAME = SSOWN_CURFNAME; !HOLD NEWNAME FLAG = CHECKFILENAME(FILE,5); !NOW CHECK OLD NAME -> ERR %IF FLAG # 0 %IF NEWCONNECT#0 %THEN %START FLAG = FINDFN (SSOWN_CURFILE, POS) %IF FLAG=0 %THEN KDISCON (POS, FLAG) %IF FLAG=0 %THEN FLAG = DIRTOSS(X24{DRENAME} %C (SSOWN_CURFOWNER,SSOWN_CURFNAME,NEWNAME,SSOWN_CURFSYS)) %FINISH %ELSE %START DISCONNECT (LAST, FLAG) FLAG = DIRTOSS (X24{DRENAME}(SSOWN_CURFOWNER,SSOWN_CURFNAME,NEWNAME,SSOWN_CURFSYS)) %FINISH ERR: %END; !OF RENAME ! %SYSTEM %ROUTINE NEWGEN (%STRING (31) FILE, NEWFILE, %INTEGER %NAME FLAG) %RECORD (FRF)FR %STRING (11) NEWNAME FLAG = CHECKFILENAME(NEWFILE,5) !CHECK NEWNAME FIRST -> ERR %IF FLAG # 0 %IF STUDENTSS#0 %THEN %START %IF SSOWN_CURFNAME="SS#JOURNAL" %THEN X30{DSTOP}(200) ! To stop breakers editing the RECALL file. %FINISH %IF NEWCONNECT=0 %THEN %START DISCONNECT (LAST, FLAG) %FINISH %ELSE %START RDISCON(LAST,FLAG); !TRY AND DISCONNECT - IGNORE FLAG %FINISH NEWNAME = SSOWN_CURFNAME; !HOLD NEWNAME FLAG = CHECKFILENAME(FILE,5) -> ERR %IF FLAG # 0 %IF NEWCONNECT=0 %THEN %START DISCONNECT (LAST, FLAG) %FINISH %ELSE %START RDISCON(LAST,FLAG); !MUST DISCONNECT IF CONNECTED %FINISH -> ERR %UNLESS FLAG = 0 %OR FLAG = 256 !OK OR NOT CONNECTED FLAG = X17{DNEWGEN}(SSOWN_CURFOWNER,NEWNAME,SSOWN_CURFNAME,SSOWN_CURFSYS) ! Director's flag for "File does not exist" is 32. ! Subsystem's flag for it is 218. %IF FLAG=32 %THEN %START; ! One of the files did not exist. FINFO (LAST, 0, FR, FLAG) ! If SSOWN_CURFNAME doesn't exist, then this will set copy SSOWN_CURFILE into ! SSOWN_SSFNAME and set FLAG=218. %IF FLAG#218 %THEN %START ! It must have been NEWNAME that did not exist. FLAG = 218 SSOWN_SSFNAME = NEWNAME %FINISH %FINISH %ELSE FLAG = DIRTOSS (FLAG) ERR: %END; !OF NEWGEN ! %SYSTEM %ROUTINE CHANGEACCESS (%STRING (31) FILE, %C %INTEGER MODE, %INTEGER %NAME FLAG) %INTEGER POS %RECORD(HF)%NAME H %RECORD(CONFF)%NAME CUR %RECORD (FRF)FR MODE = MODE & VALID MODE BITS & X'FFFFFFEF'; ! Ignore NEWCOPY bit. FLAG = CHECKFILENAME(FILE,7); !ANY FILE %RETURN %IF FLAG # 0 FLAG = FINDFN(SSOWN_CURFILE,POS); !FIND IT IN CONNECTED FILE TABLE %IF FLAG#0 %THEN %START; ! NOT CONNECTED. FLAG = 256 -> ERR %FINISH CUR == SSOWN_CONF(POS) %IF CUR_MODE=MODE %THEN -> ERR; !CURRENT MODE OK FINFO(LAST,0,FR,FLAG) %IF (\FR_RUP)&MODE&7#0 %THEN %START; ! REQUESTED PERMISSION NOT ALLOWED. FLAG = 303 -> ERR %FINISH %IF NEWCONNECT#0 %THEN %START %IF CUR_USE&X'BFFFFFFF'#1 %THEN %START FLAG=266; ! CONFLICTING USE ->ERR %FINISH %FINISH ! ! Check that MODE is acceptable to Director for X4{DCHACCESS}: ! **** **** This check must be updated as Director **** **** ! **** **** becomes more versatile. **** **** MODE = MODE ! 1 %UNLESS 1<=MODE<=5 %THEN %START FLAG = 260 -> ERR %FINISH FLAG = DIRTOSS(X4{DCHACCESS}(SSOWN_CURFOWNER,SSOWN_CURFNAME,CUR_FSYS,MODE)) -> ERR %IF FLAG # 0 %IF MODE&2#0 %AND CUR_MODE&2=0 %START; !CHANGE TO WRITE MODE - UPDATE "LAST ALTERED" H == RECORD(CUR_CONAD) %IF H_DATASTART >= 32 %THEN H_DATETIME = CURRENTPACKEDDT %FINISH CUR_MODE = MODE ERR: %IF FLAG#0 %THEN SSOWN_SSFNAME = SSOWN_CURFILE %END; ! of CHANGEACCESS ! %SYSTEM %ROUTINE CHANGEFILESIZE (%STRING (31)FILE, %INTEGER NEWSIZE, %C %INTEGER %NAME FLAG) ! N.B. This does NOT update the FILE SIZE field in the file header. %INTEGER NEWKSIZE, POS %RECORD(CONFF)%NAME CUR %RECORD (FRF)FR NEWSIZE = ROUNDUP(NEWSIZE,FILESIZEALLOC) NEWKSIZE = NEWSIZE>>KSHIFT; !NUMBER OF KBYTES TO ALTER !NEW SIZE IN KB FLAG = CHECKFILENAME(FILE,5); !ANY OWN FILE -> ERR %IF FLAG # 0 %IF NEWCONNECT#0 %THEN %START FLAG = FINDFN(SSOWN_CURFILE,POS); !FIND POS IN TABLE %IF FLAG=0 %THEN %START; ! File is connected. CUR == SSOWN_CONF(POS) %IF NEWSIZE=CUR_SIZE %THEN -> ERR; ! Size does not need changing. %FINISH %ELSE %START POS = -1 FINFO(LAST,0,FR,FLAG) -> ERR %IF FLAG # 0 %IF NEWSIZE = FR_SIZE %THEN -> ERR !SIZE OK - RETURN %FINISH %IF POS#-1 %THEN %START; ! CONNECTED ! FLAG = 0 - this is already true. %IF NEWSIZE>CUR_HOLE %THEN %START; ! HOLE TOO SMALL. %IF CUR_USE&X'BFFFFFFF'=0 %THEN %START SSOWN_SSINHIBIT = 1 FLAG = X11{DDISCONNECT}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,0) ! If the file were VTEMP, that would DESTROY it! %IF FLAG=0 %THEN CLEARFN (POS) %ELSE FLAG = 261 ALLOW INTERRUPTS %FINISH %ELSE FLAG = 261; ! VM hole too small. %FINISH %ELSE %IF NEWSIZE ERR %IF FLAG#0 %FINISH SSOWN_SSINHIBIT = 1 FLAG = DIRTOSS(X5{DCHSIZE}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,NEWKSIZE)) %IF FLAG#0 %AND POS#-1 %THEN CUR_SIZE = NEWSIZE %FINISH %ELSE %START FINFO(LAST,0,FR,FLAG) -> ERR %IF FLAG # 0 %IF NEWSIZE = FR_SIZE %THEN -> ERR !SIZE OK - RETURN %IF FR_CONAD # 0 %START; ! CONNECTED FLAG = FINDFN(SSOWN_CURFILE,POS); !FIND POS IN TABLE CUR == SSOWN_CONF(POS) %IF NEWSIZE>CUR_HOLE %THEN %START; ! HOLE TOO SMALL. FLAG = 261 -> ERR %FINISH %FINISH SSOWN_SSINHIBIT = 1 FLAG = DIRTOSS(X5{DCHSIZE}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,NEWKSIZE)) %IF FLAG=0 %AND FR_CONAD # 0 %THEN CUR_SIZE = NEWSIZE %FINISH ALLOW INTERRUPTS ERR: %END; !OF CHANGEFILESIZE ! %IF NEWCONNECT#0 %THEN %START %SYSTEM %ROUTINE TRIM (%STRING (31) FILE, %INTEGER %NAME FLAG) %RECORD (CONFF) %NAME CUR %RECORD (RF) RR %INTEGER SIZE, POS, DOCH CONNECT (FILE, 0, 0, 0, RR, FLAG) %IF FLAG#0 %THEN -> ERR FLAG = FINDFN (SSOWN_CURFILE, POS) CUR == SSOWN_CONF (POS) SIZE = ROUNDUP (RR_DATAEND, FILESIZEALLOC) DOCH = 0 %IF SIZE#CUR_SIZE %THEN %START %IF INTEGER (RR_CONAD+12)<16 %THEN %START CHANGEACCESS (LAST, 3, FLAG) %IF FLAG=0 %THEN %START INTEGER (RR_CONAD+8) = SIZE DOCH = -1 %FINISH %FINISH %ELSE DOCH = -1; ! OLD OBJECT FILES EXCEPTED ! DONT ALTER 3RD WORD OF OBJECT FILES PROTEM %FINISH DISCONNECT (LAST, FLAG) %IF FLAG=0 %AND DOCH#0 %THEN CHANGEFILESIZE (LAST, SIZE, FLAG) ERR: %END; ! of TRIM %FINISH %ELSE %START %SYSTEMROUTINE TRIM(%STRING (31) FILE, %INTEGERNAME FLAG) %RECORD (RF)RR %INTEGER SIZE CONNECT(FILE,3,0,0,RR,FLAG) -> ERR %IF FLAG # 0 SIZE = RR_DATAEND CHANGEFILESIZE(FILE,SIZE,FLAG) -> ERR %IF FLAG # 0 %IF INTEGER(RR_CONAD+12) < 16 %C %THEN INTEGER(RR_CONAD+8) = ROUNDUP(SIZE,FILESIZEALLOC) !OLD OBJECT FILES EXCEPTED !DONT ALTER 3RD WORD OF ! OBJECT FILES PROTEM ERR: %END; !OF TRIM %FINISH ! %SYSTEM %ROUTINE MODPDFILE (%INTEGER EP, %C %STRING (31) PDFILE, %STRING (11) MEMBER, %C %STRING (31) INFILE, %INTEGER %NAME FLAG) !THIS ROUTINE PROVIDES ! SERVICES FOR MODIFYING PD FILES ! EP=1 INSERT ! EP=2 REMOVE ! EP=3 RENAME ! EP=4 CREATE PDFILE %INTEGER I, FLC {file length}, BASE, NEWSIZE, ADIR, OLDSIZE, OLDLENGTH %INTEGER LEN, NEWSTART, NEWLENGTH, POS %STRING (6) OWNER %SWITCH SW(1 : 4) %RECORD (RF)PDR, FR %RECORD(PDF)%NAME PD %RECORD(PDHF)%NAME PDH %INTEGERFN CHECKMEMBERNAME(%STRING (11) S) !CHECKS THAT MEMBER HAS ! STANDARD NAME ! %INTEGER I not needed for machine code version. SSOWN_SSFNAME = S; !FOR FAILURE MESSAGE %RESULT = 270 %UNLESS 1<=LENGTH(S)<=11 %AND 'A'<=CHARNO(S,1)<='Z' ! I = 1 ! %WHILE I1 %THEN %START *LDB_(S) *INCA_1 *MODD_1 *LSS_ACCEPT ALPHANUMERICS+4 *LUH_256 *TCH_%L=%DR *JCC_8, %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 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 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>KSHIFT)) %IF FLAG=0 %THEN %START SSOWN_CONF(POS)_SIZE = I PDH_SIZE = I %FINISH %FINISH %FINISH %ELSE %START PDH_DATAEND = PDH_DATAEND - (FLC+32) TRIM (PDFILE,FLAG) %FINISH -> ERR SW(3): !RENAME (MEMBER,FILE) FLAG = CHECKMEMBERNAME(INFILE) -> ERR %IF FLAG # 0 I = 0 %WHILE I ERR %FINISH I = I+1 %REPEAT I = 0 %WHILE I ERR %FINISH I = I+1 %REPEAT SSOWN_SSFNAME = MEMBER FLAG = 288; !MEMBER NOT FOUND -> ERR SW(4): !CREATE EMPTY PDFILE OUTFILE(PDFILE,4096,4096,0,BASE,FLAG) -> ERR %IF FLAG # 0 PDH == RECORD(BASE) PDH_FILETYPE = 6; !TYPE=PARTITIONED PDH_ADIR = 32; !START OF DIRECTORY PDH_COUNT = 0; !NO MEMBERS -> ERR ERR: ALLOW INTERRUPTS %IF BASE # 0 %THEN DISCONNECT(PDFILE,BASE); !IGNORE FLAG %END; ! of MODPDFILE ! ! ! ! %SYSTEMROUTINE FINFO(%STRING (31) FILE, %INTEGER MODE, %C %RECORD(FRF)%NAME FR, %INTEGERNAME FLAG) %RECORD (DFF) DF FLAG = CHECKFILENAME(FILE,7); !ANY FILENAME %IF FLAG=0 %THEN %START FR = 0; !CLEAR WHOLE RECORD %IF MODE = 1 %THEN CONNECT(LAST,0,0,0,FR,FLAG); ! MUST CONNECT - ANY MODE %IF FLAG=0 %THEN %START FLAG = DIRTOSS(X14{DFINFO}(SSOWN_CURFOWNER,SSOWN_CURFNAME,SSOWN_CURFSYS,ADDR(DF))) %IF FLAG#0 %THEN SSOWN_SSFNAME = SSOWN_CURFILE %ELSE %START !FILL IN INFO FROM X14{DFINFO} CALL SSOWN_CURFSYS = DF_FSYS FR_SIZE = DF_NKB<>4)!(DF_CODES&X'0C') ! X'80': archive ! X'08': very temporary ! X'04': temporary ! X'01': cherished FR_TRAN = DF_TRAN; !ON OFFER TO %FINISH %FINISH %FINISH ERR: %END; !OF FINFO ! ! %SYSTEMROUTINE FSTATUS(%STRING (31)FILE, %INTEGER ACT, VALUE %C %INTEGERNAME FLAG) FLAG = CHECKFILENAME(FILE,5); !ANY OWN FILE -> ERR %IF FLAG # 0 FLAG = DIRTOSS(X15{DFSTATUS}(SSOWN_SSOWNER,SSOWN_CURFNAME,SSOWN_SSOWNFSYS,ACT,VALUE)) %IF FLAG # 0 %THEN SSOWN_SSFNAME = SSOWN_CURFNAME ERR: %END; !OF FSTATUS ! ! ! FILL SYSTEM CALLS (now called FSC) and SSINIT have been moved into the ! INFREQUENT CODE module. ! %SYSTEMINTEGERFN GETSPACE(%INTEGER BYTES) ! Gets space from BGLA - returns 0 if not enough room. %INTEGER RES RES = (SSOWN_SSMAXBGLA-BYTES) & (-8); ! Rounded down to double-word boundary. %IF SSOWN_SSCURBGLA>RES %THEN %RESULT = 0 SSOWN_SSMAXBGLA = RES %RESULT = RES %END; !OF GETSPACE ! ! %SYSTEMROUTINE SETWORK(%INTEGERNAME AD, FLAG) !ON ENTRY AD CONTAINS LENGTH REQUIRED %INTEGER CONAD, H ! ADDRESS IN AD %IF AD < SSOWN_SSINITWORKSIZE %THEN AD = SSOWN_SSINITWORKSIZE !MINIMUM SIZE %IF AD > SSOWN_SSMAXFSIZE %THEN AD = SSOWN_SSMAXFSIZE !MAX SIZE %IF AD <= SSOWN_CURLENGTH %START AD = SSOWN_SSCOMREG(14) INTEGER(AD) = 32 ! FILL IN HEADER AGAIN LEST IT HAS BEEN CORRUPTED ! but this is a rather odd header ... I don't know why it shouldn't ! be a regular data file header. INTEGER(AD+4) = 32 INTEGER(AD+8) = SSOWN_CURLENGTH INTEGER(AD+12) = 0 FLAG = 0 %FINISH %ELSE %IF SSOWN_CURLENGTH#0 %AND AD<=SSMAXWORKSIZE %THEN %START CHANGE FILE SIZE ("T#WRK", AD, FLAG) %IF FLAG=0 %THEN %START SSOWN_CURLENGTH = AD AD = SSOWN_SSCOMREG(14) INTEGER(AD) = 32 ! FILL IN HEADER AGAIN LEST IT HAS BEEN CORRUPTED ! but this is a rather odd header ... I don't know why it shouldn't ! be a regular data file header. INTEGER(AD+4) = 32 INTEGER(AD+8) = SSOWN_CURLENGTH INTEGER(AD+12) = 0 %FINISH %ELSE SSOWN_SSCOMREG(14) = 0 %FINISH %ELSE %START %IF AD<=SSMAXWORKSIZE %THEN H = SSMAXWORKSIZE %ELSE H = AD ! *** The code of SETWORK assumes implicitly that once created ! *** T#WRK will always be around so set PROT field to 1 ! *** CMcC. 22/03/83. %IF NEWCONNECT=0 %THEN %START %IF SSOWN_CURLENGTH#0 %THEN SETUSE ("T#WRK",0,0) OUTFILE("T#WRK",AD,H,TEMPMARKER!1,CONAD,FLAG) %FINISH %ELSE %START %IF SSOWN_CURLENGTH#0 %THEN SETUSE ("T#WRK",-1,0) OUTFILE("T#WRK",AD,H,TEMPMARKER,CONAD,FLAG) %FINISH !UNIQUE NAME FOR THIS PROCESS %IF FLAG=0 %START SSOWN_SSCOMREG(14) = CONAD SSOWN_CURLENGTH = AD AD = CONAD %FINISH %ELSE SSOWN_SSCOMREG(14) = 0 %FINISH %END; !OF SETWORK ! ! %INTEGERFN KINS %INTEGER RES, INSTRUCTIONS, NET, ADD *LSS_(6); !GET IMAGE STORE 6 - INS. COUNTER *ST_INSTRUCTIONS NET = SSOWN_ICREVS-(INSTRUCTIONS>>24)&1; !SUBTRACT 1 REV IF GUARD BIT SET %IF NET >= 0 %THEN ADD = NET<<14 %ELSE ADD = -((-NET)<<14) %RESULT = SSOWN_KINSTRS+SSOWN_PREVIC-(ADD+INSTRUCTIONS<<8>>18);!K INS. %END; ! OF KINS ! ! %SYSTEMLONGREALFN CPUTIME %RESULT = KINS/KIPS; !TIME IN SECONDS %END; !OF CPUTIME %EXTERNALINTEGERFN PAGETURNS %RESULT = INTEGER(SSOWN_APAGETURNS) %END; !OF PAGETURNS %SYSTEMINTEGERMAP COMREG(%INTEGER I) %RESULT == SSOWN_SSCOMREG(I) %END; !OF COMREG %EXTERNALSTRINGFN DATE %RESULT = STRING(APDATE) %END; !OF DATE %EXTERNALSTRINGFN TIME %RESULT = STRING(APTIME) %END; !OF TIME %SYSTEMSTRINGFN NEXTTEMP ! SSOWN_SEQ = SSOWN_SEQ+1 ! %RESULT = TOSTRING(HEX((SSOWN_SEQ>>8)&X'F')).TOSTRING(HEX((SSOWN_SEQ>>4)& %C ! X'F')).TOSTRING(HEX(SSOWN_SEQ&X'F')) %INTEGER W,A,SEQC %LONG %INTEGER DRH W = ADDR (W) + 1 A = ADDR (HEX(0)) - 240 SEQC=SSOWN_SEQ+1 SSOWN_SEQ=SEQC *LSS_SEQC *UCP_0; ! to set CC#0. *USH_20 *LDTB_X'58000003' *LDA_W *STD_DRH *SUPK_%L=%DR *LSS_A *LUH_X'18000100' *LD_DRH *TTR_%L=%DR BYTE INTEGER (ADDR(W)) = 3 %RESULT = STRING (ADDR(W)) %END; !OF NEXTTEMP ! %SYSTEMROUTINE SENDFILE(%STRING (31) FILE, %C %STRING (16) DEVICE, %STRING (24) NAME, %C %INTEGER COPIES, FORMS, %INTEGERNAME FLAG) %RECORD (PF)P %STRING (16) HOLD DEVICE %RECORD (RF)RR %INTEGER LEN, DATALENGTH %STRING (255) MESSAGE %STRING (8) REST ! %ROUTINE CVP; ! CONVERT PAPER TAPE !CONVERTS CHARACTER FILE TO PAPER TAPE FILE WITH EVEN PARITY !AND WITH CR INSERTED WHERE NEC. %CONSTBYTEINTEGERARRAY PARITY(0 : 127) = %C 0,129,130,3,132,5,6,135,136,9,10,139,12,141,142,15, 144,17,18,147,20,149,150,23,24,153,154,27,156,29,30,159, 160,33,34,163,36,165,166,39,40,169,170,43,172,45,46,175, 48,177,178,51,180,53,54,183,184,57,58,187,60,189,190,63, 192,65,66,195,68,197,198,71,72,201,202,75,204,77,78,207, 80,209,210,83,212,85,86,215,216,89,90,219,92,221,222,95, 96,225,226,99,228,101,102,231,232,105,106,235,108,237,238,111, 240,113,114,243,116,245,246,119,120,249,250,123,252,125,126,255 %RECORD (RF)RR %STRING (11) TEMPFILE %INTEGER INP, IN, OUTP, X, OUTCONAD, LASTCH CONNECT(FILE,0,0,0,RR,FLAG) -> ERR %IF FLAG # 0 %IF NEWCONNECT#0 %THEN %START SETUSE (LAST, -1, 0) %FINISH LEN = RR_DATAEND-RR_DATASTART %IF LEN = 0 %THEN -> ERR; !EMPTY FILE WILL BE DESTROYED LATER TEMPFILE = "T#PP".NEXTTEMP OUTFILE(TEMPFILE,LEN*2,0,0,OUTCONAD,FLAG) -> ERR %IF FLAG # 0 OUTP = OUTCONAD+32 INTEGER(OUTCONAD+4) = 32 LASTCH = 0 %FOR INP=RR_CONAD+RR_DATASTART,1,RR_CONAD+RR_DATAEND-1 %CYCLE IN = BYTEINTEGER(INP)&127; !ONLY THE BOTTOM 7 BITS USED ! Before a NL character (10), we will put out a CR (13). %IF IN=NL %THEN X = 13 %ELSE X = IN ! In the cycle below, we plant characters in the output ! area until we have planted a copy of the input character. %CYCLE ! Avoid planting redundant CR characters: %IF X#13 %OR NL#LASTCH#13 %THEN %START BYTE INTEGER (OUTP) = PARITY (X) OUTP = OUTP + 1 %FINISH LASTCH = X X = NL %REPEAT %UNTIL LASTCH = IN %REPEAT INTEGER(OUTCONAD) = OUTP-OUTCONAD %IF NEWCONNECT#0 %THEN %START SETUSE (LAST, -1, 0) %FINISH DESTROY(FILE,FLAG) FILE = TEMPFILE ERR: %END; !OF CONVERT PAPER TAPE ! HOLDDEVICE = DEVICE %IF LENGTH(DEVICE)>=1 %AND CHARNO(DEVICE,1)='.' %THEN %START CHOPLDR (DEVICE,1) %FINISH %IF DEVICE -> REST.("PP") %THEN %START %IF REST="" %THEN %START CVP; ! CONVERT PAPER TAPE -> ERR %IF FLAG # 0 %FINISH %ELSE %IF REST="B" %THEN CHOPLDR (DEVICE,1) %FINISH FLAG = CHECKFILENAME(FILE,5); !ANY OWN FILE -> ERR %IF FLAG # 0 CONNECT(LAST,0,0,0,RR,FLAG); !TO GET LENGTH -> ERR %IF FLAG # 0 %IF NEWCONNECT#0 %THEN %START SETUSE (LAST, -1, 0) %FINISH DATALENGTH = RR_DATAEND-RR_DATASTART %IF DATALENGTH<=0 %THEN %START; ! EMPTY FILE. DESTROY(LAST,FLAG) -> ERR %FINISH %IF DEVICE=SSOWN_BOUTPUTDEVICE %C %AND COPIES=0=FORMS %C %AND SSOWN_DELIVERYCHANGED=0 %C %THEN %START !IF MULTIPLE COPIES OR SPECIAL FORMS DO NOT INCLUDE ADDTOJOBOUTPUT(RR_DATASTART+RR_CONAD,DATALENGTH,FLAG) !TRY TO APPEND TO FRONT OF JOB JOURNAL %IF FLAG=0 %THEN %START DESTROY(FILE,FLAG) -> ERR %FINISH %FINISH %IF NEWCONNECT#0 %THEN %START RDISCON (FILE, FLAG) %FINISH %ELSE %START DISCONNECT (FILE, FLAG) %FINISH -> ERR %IF FLAG#0 %IF DEVICE->REST.("SGP") %AND REST="" %THEN %START CHOPLDR (DEVICE,1) FORMS = 1 %FINISH MESSAGE = "DOCUMENT SRCE=".SSOWN_CURFNAME.",DEST=".DEVICE. %C ",START=".ITOS(RR_DATASTART).",LENGTH=".ITOS(DATALENGTH) %IF NAME # "" %THEN MESSAGE = MESSAGE.",NAME=".NAME %IF FORMS # 0 %THEN MESSAGE = MESSAGE.",FORMS=".ITOS(FORMS) %IF COPIES # 0 %THEN MESSAGE = MESSAGE.",COPIES=".ITOS( %C COPIES) LEN = LENGTH(MESSAGE) %IF SSOWN_INHIBITSPOOLER = 0 %START FLAG = X29{DSPOOL}(P,LEN,ADDR(MESSAGE)+1) %IF 100>FLAG#0 %THEN %START; ! if Director couldn't pass the ! request on to Spooler: FLAG = DIRTOSS (FLAG) %FINISH %ELSE %IF P_P1#0 %START %IF 203<=P_P1<=204 %THEN FLAG = 331 {QUEUE FULL} %C %ELSE %IF P_P1=210 %THEN %START FLAG = 335 SSOWN_SSFNAME = HOLDDEVICE %FINISH %ELSE %IF P_P1=202 %THEN %START FLAG = 264 SSOWN_SSFNAME = HOLDDEVICE %FINISH %ELSE FLAG = 1000+P_P1; ! VERY UNLIKELY FAILURE! %FINISH %FINISH %ELSE %START PRINTSTRING(MESSAGE) FLAG = 1001 %FINISH ERR: %END; !OF SENDFILE ! ! - END OF BASE TEXT ] ! %IF NEWLOADER#0 %THEN %START ! ! Tempcode required to handle old style directories ! ! !*********************************************************************** !* * !* Temporary Routines required while old directories still extant. * !* * !*********************************************************************** ! ! %INTEGERFN OLDHASH(%STRING (31) NAME, %INTEGER HASHCONST) %INTEGER RES, A, B, C, D, E, F, G, H, I, J, K !A-K ALL NEEDED STRING(ADDR(A)) = NAME."<>12ABXY89*" RES = A!!B>>4!!C %RESULT = (RES-RES//HASHCONST*HASHCONST) %END; !OF HASH ! ! %ROUTINE MAKEDIR(%STRING (31) FILE, %C %INTEGER HASHCONST, PLENGTH, %INTEGERNAME FLAG) %RECORD(DHF)%NAME DH %INTEGER LEN, CONAD PLENGTH = PLENGTH+4; !TO ALLOW FOR LENGTH WORD LEN = 32+4+HASHCONST*20+PLENGTH OUTFILE(FILE,LEN,LEN,0,CONAD,FLAG) -> ERR %IF FLAG # 0 %IF NEWCONNECT#0 %THEN %START SETUSE (LAST, -1, 0) %FINISH FILL(LEN-32,CONAD+32,0); !FILL WITH ZEROS FSTATUS(FILE,1,0,FLAG); !CHERISH FILE DH == RECORD(CONAD); !MAP DH ONTO START OF FILE DH_DATAEND = LEN DH_DATASTART = 32 DH_FILETYPE = SSOLDDIRFILETYPE; !TYPE=DIRECTORY DH_PSTART = 32+4+HASHCONST*20 INTEGER(CONAD+DH_DATASTART) = HASHCONST INTEGER(CONAD+DH_PSTART) = PLENGTH ERR: SSOWN_DIRDISCON = 1; !TO ENSURE NEW DIRECTORY RE-CONNECTED %END; !OF MAKEDIR ! ! %SYSTEMROUTINE MODDIRFILE(%INTEGER EP, %C %STRING (31) DIRFILE, ENTRY, FILENAME, %C %INTEGER TYPE, DR0, DR1, %INTEGERNAME FLAG) %STRING (31) DUMMY1, DUMMY2 %INTEGER CONMODE,DESCTYPE %CONSTINTEGER MAXEP = 10 %SWITCH SW(1 : MAXEP) %INTEGER HASHBASE, HSTART, PSTART, HASHCONST, I, POINT %INTEGER LBASE, P, OBJCONAD %RECORD (RF)RR %INTEGERARRAYFORMAT BASEAF(1 : 7) %INTEGERARRAYNAME BASE %INTEGERARRAYFORMAT LDATAAF(0 : 16) %INTEGERARRAYNAME LDATA %RECORD(SNF)%ARRAYFORMAT HAF(0 : 100000) !V HIGH LIMIT %RECORD(SNF)%ARRAYNAME H %RECORD(SNF)%NAME HH %RECORD(DHF)%NAME DH; !MAP ONTO HEADER %RECORD (LEF) %NAME LE; !NEW FORMAT %RECORD(LDF)%NAME LD %INTEGERFN STUFF(%INTEGER START, %STRING (255) NAME) %INTEGER TOP, LENN, P, BP !FIRST SEARCHES FOR NAME ! ALREADY IN LIST, IF NOT IN ! PUTS IT IN !RETURNS ADDRESS OR -1 IF ! LIST FULL TOP = START+INTEGER(START); !FIRST INTEGER IN LIST ! CONTAINS LENGTH OF LIST LENN = LENGTH(NAME) !FIRST LOOK FOR NAEE P = START+4 %WHILE STRING(P) # "" %CYCLE %IF STRING(P) = NAME %THEN %RESULT = P-START !NAME FOUND P = P+BYTEINTEGER(P)+1 %REPEAT !NOT FOUND SO LOOK FOR ! SUITABLE HOLE AND PUT IT IN P = START+4 %WHILE STRING(P) # "" %CYCLE %IF BYTEINTEGER(P+1) = 255 %START ! If the first text byte of a non-null string is X'FF', ! then it is 'unused' and the space may be used to store ! another bit of text. BP = BYTEINTEGER(P) %IF LENN = BP %THEN STRING(P) = NAME %C %AND %RESULT = P-START !EXACT FIT %IF LENN+2 <= BP %START !MUST BE AT LEAST 2 BYTES SPARE STRING(P) = NAME BYTEINTEGER(P+LENN+1) = BP-LENN-1 !LENGTH OF DUMMY STRING BYTEINTEGER(P+LENN+2) = 255 !TO INDICATE THAT IT IS A DUMMY %RESULT = P-START %FINISH %FINISH P = P+BYTEINTEGER(P)+1 %REPEAT !NO HOLE FOUND SO ADD IT TO ! END OF LIST %IF TOP-P >= LENN+2 %START; !IF THERE IS ENOUGH ROOM STRING(P) = NAME BYTEINTEGER(P+LENN+1) = 0; !TO TERMINATE LIST %RESULT = P-START %FINISH %RESULT = -1; !LIST FULL %END; ! OF STUFF %INTEGERFN TEMPLOCATE(%INTEGER START, %STRING (255) NAME) ! LOCATE NAME IN LIST AND ! RETURN OFFSET OR -1 IF NOT ! FOUND ! This routine works its way through a packed sequence of strings, ! assuming that the first string starts four bytes after the ! address supplied, and that the sequence is terminated by a null ! string (i.e., a zero byte). %INTEGER P P = START+4 %WHILE STRING(P) # "" %CYCLE %IF STRING(P) = NAME %THEN %RESULT = P-START !NAME LOCATED P = P+BYTEINTEGER(P)+1 %REPEAT %RESULT = -1 %END; !OF TEMPLOCATE %ROUTINE TEMPADDENTRY(%STRING (31) ENTRY, %C %INTEGER TYPE, DR0, DR1, %INTEGERNAME FLAG) !ADD ONE ENTRY TO HASH TABLE ! AND PUT VALUE INTO H_POINT - !THIS MIGHT BE A PACKED ! DESCRIPTOR OR A TRUE ! POINTER TO A FILENAME !IN THE PLIST %INTEGER LENE, INITP, P, EMPTY, POINT LENE = LENGTH(ENTRY) FLAG = 0; !DEFAULT REPLY INITP = OLDHASH(ENTRY,HASHCONST) P = INITP EMPTY = -1; !IMPOSSIBLE INITIAL VALUE %IF LENE <= 10 %START; !SHORT NAME %BEGIN; !TO ALLOW FOR MORE DECLARATIONS %RECORD(SNF)%ARRAYFORMAT HAF(0 : HASHCONST-1) %RECORD(SNF)%ARRAYNAME H H == ARRAY(HASHBASE,HAF) !MAP H ONTO HASH TABLE %CYCLE %IF H(P)_NAME = "" %START !GOT TO END OF LIST %IF EMPTY # -1 %THEN P = EMPTY !USE FIRST EMPTY HOLE FOUND H(P)_POINT = DR0; !POINTER OR FIRST WORD OF ! DESCRIPTOR H(P)_DR1 = DR1; !ZERO OR SECOND WORD OF ! DESCRIPTOR H(P)_NAME = ENTRY H(P)_TYPE = TYPE %EXIT %FINISH %IF (H(P)_TYPE=TYPE %OR H(P)_TYPE=2) %C %AND H(P)_NAME=ENTRY %C %THEN %START %IF EP=9 %OR EP=3 %THEN %START FLAG = 290 SSOWN_SSFNAME = ENTRY %EXIT %FINISH %FINISH !ENTRY ALREADY IN DIRECTORY %IF H(P)_NAME = ".EMPTY" %AND EMPTY = -1 %C %THEN EMPTY = P !NOTE FIRST EMPTY HOLE P = P+1 %IF P = HASHCONST %THEN P = 0 %IF P = INITP %THEN %START !GONE RIGHT ROUND %IF EMPTY = -1 %THEN FLAG = 291 %AND %EXIT !NO EMPTY HOLES LEFT P = EMPTY H(P)_NAME = ""; !TO FORCE USE OF THIS HOLE %FINISH %REPEAT %END %FINISH %ELSE %START; !LONG NAMES %BEGIN %RECORD(LNF)%ARRAYFORMAT HAF(0 : HASHCONST-1) %RECORD(LNF)%ARRAYNAME H %STRING (6) SENTRY; !FIRST 6 CHAS OF ENTRY %STRING (26) REST H == ARRAY(HASHBASE,HAF) !MAP H ONTO HASH TABLE SENTRY = SUBSTRING(ENTRY,1,6); !FIRST 6 CHAS OF ENTRY REST = SUBSTRING(ENTRY,7,LENE) !REST OF ENTRY TYPE = TYPE!X'80'; !TO SHOW IT IS A LONG NAME %CYCLE %IF H(P)_NAME = "" %START %IF EMPTY # -1 %THEN P = EMPTY !USE FIRST AVAILABLE EMPTY HOLE H(P)_POINT = DR0; !POINTER OR FIRST WORD OF ! DESCRIPTOR H(P)_DR1 = DR1; !ZERO OR SECOND WORD OF ! DESCRIPTOR POINT = STUFF(PSTART,REST) %IF POINT < 0 %THEN FLAG = 292 %AND %EXIT !POINTER LIST FULL H(P)_REST = POINT !POINTER TO REST OF ENTRY NAME H(P)_TYPE = TYPE H(P)_NAME = SENTRY !FIRST 6 CHAS OF ENTRY %EXIT; !SUCCESS %FINISH %IF (H(P)_TYPE=TYPE %OR H(P)_TYPE=X'82') %C %AND H(P)_NAME=SENTRY %C %AND STRING(PSTART+H(P)_REST)=REST %C %THEN %START %IF EP=9 %OR EP=3 %THEN %START FLAG = 290 SSOWN_SSFNAME = ENTRY %EXIT %FINISH %FINISH %IF H(P)_NAME = ".EMPTY" %AND EMPTY = -1 %C %THEN EMPTY = P P = P+1 %IF P = HASHCONST %THEN P = 0 !WRAP ROUND %IF P = INITP %START !BEEN RIGHT ROUND %IF EMPTY = -1 %THEN FLAG = 291 %AND %EXIT !TOO MANY ENTRIES P = EMPTY; !USE FIRST EMPTY HOLE H(P)_NAME = ""; !CLEAR OUT NAME %FINISH %REPEAT %END %FINISH %END; !OF TEMPADDENTRY %INTEGERFN LOADSTART(%STRING (31) FILE, %INTEGERNAME FLAG) CONNECT(FILE,0,0,0,RR,FLAG) !CONNECT OBJECT FILE READ+EXECUTE %IF FLAG=0 %THEN %START %IF NEWCONNECT#0 %THEN %START SETUSE (LAST, -1, 0) %FINISH OBJCONAD = RR_CONAD; !CONNECT ADDRESS OF OBJECT FILE %IF RR_FILETYPE=SSOBJFILETYPE %C %THEN %RESULT = RR_CONAD+INTEGER(RR_CONAD+24) %C %ELSE %START !INVALID FILETYPE FLAG = 267 SSOWN_SSFNAME = FILE %FINISH %FINISH %RESULT = 0; !FUNCTION MUST HAVE A RESULT %END; !OF LOADSTART CONMODE=0; !Current connect mode %UNLESS 1 <= EP <= MAXEP %THEN FLAG = -1 %AND -> ERR %IF EP = 10 %THEN -> SW(10) %IF DIRFILE = "" %THEN -> SW(1) %IF 2#EP %THEN CONMODE=3; !WRITE mode except for REMOVE CONNECT(DIRFILE,CONMODE,0,0,RR,FLAG) %IF FLAG=218 %THEN %START; ! CREATE NEWDIRECTORY MAKEDIR(DIRFILE,160,856,FLAG) CONNECT(DIRFILE,CONMODE,0,0,RR,FLAG);!TRY AGAIN %FINISH -> ERR %IF FLAG # 0 %IF NEWCONNECT#0 %THEN %START SETUSE (LAST, -1, 0) %FINISH DH == RECORD(RR_CONAD) %IF DH_FILETYPE#SSOLDDIRFILETYPE %THEN %START; ! INVALID FILETYPE SSOWN_SSFNAME = DIRFILE FLAG = 267 -> ERR %FINISH HSTART = RR_CONAD+DH_DATASTART; !START OF HASH TABLE HASHBASE = HSTART+4 HASHCONST = INTEGER(HSTART) PSTART = DH_PSTART+RR_CONAD !START OF POINTED LIST %UNLESS FILENAME = "" %OR FILENAME -> DUMMY1.(".").DUMMY2 %C %OR CHARNO(FILENAME,1) = '=' %C %THEN FILENAME = SSOWN_SSOWNER.".".FILENAME -> SW(EP) SW(9): !ADD ALIAS %IF FILENAME # "" %START; !FILENAME TYPE ENTRY DR1 = 0; !DR1 NOT USED POINT = STUFF(PSTART,FILENAME) !PUT FILENAME IN PLIST %IF POINT < 0 %THEN FLAG = 292 %AND %RETURN !PLIST FULL %FINISH %ELSE POINT = DR0; !PACKED DESRIPTOR TEMPADDENTRY(ENTRY,TYPE,POINT,DR1,FLAG) -> ERR SW(2): !REMOVE ENTRY SW(6): !REMOVE ENTRIES - LEAVE ! FILENAME IN POINT = TEMPLOCATE(PSTART,FILENAME) %IF POINT < 0 %THEN FLAG = 257 %AND SSOWN_SSFNAME = FILENAME %C %AND -> ERR CONMODE=3 CHANGEACCESS(DIRFILE,CONMODE,FLAG); !Change to WRITE mode if INSERTED %IF FLAG#0 %THEN -> ERR H == ARRAY(HASHBASE,HAF) %FOR I=0,1,HASHCONST-1 %CYCLE; ! %CYCLE THROUGH HASH TABLE ! CLEARING ENTRIES %IF H(I)_POINT = POINT %THEN H(I)_NAME = ".EMPTY" %REPEAT %IF EP = 2 %THEN BYTEINTEGER(PSTART+POINT+1) = 255 !MARK FILENAME AS UNUSED -> ERR SW(3): !ADD ALL ENTYRIES IN FILE ! (NOT LOADED) LBASE = LOADSTART(FILENAME,FLAG) !GET ADDRESS OF LOADDATA -> ERR %IF FLAG # 0 POINT = TEMPLOCATE(PSTART,FILENAME) %IF POINT < 0 %START; !FIRST INSERTION OF THIS FILE POINT = STUFF(PSTART,FILENAME) !PUT FILENAME IN POINTED LIST %IF POINT < 0 %THEN FLAG = 292 %AND -> ERR %FINISH %ELSE %START H == ARRAY(HASHBASE,HAF) %FOR I=0,1,HASHCONST-1 %CYCLE; !CLEAR OUT ANY CURRENT ENTRIES %IF H(I)_POINT = POINT %THEN H(I)_NAME = ".EMPTY" %REPEAT %FINISH LDATA == ARRAY(LBASE,LDATAAF); !MAP LDATA ONTO LOAD DATYA !FIRST PUT IN CODE ENTRIES P = LDATA(1) %WHILE P # 0 %CYCLE LE == RECORD(OBJCONAD+P) %IF LE_IDEN # "S#GO" %START; !TO AVOID DUPLICATE NAMES TEMPADDENTRY(LE_IDEN,0,POINT,0,FLAG) -> ERR %IF FLAG # 0 %FINISH P = LE_LINK %REPEAT !NOW PUT IN DATA ENTRIES P = LDATA(4); !LIST HEAD OF DATA ENTRIES %WHILE P # 0 %CYCLE LD == RECORD(OBJCONAD+P) TEMPADDENTRY(LD_IDEN,1,POINT,0,FLAG) -> ERR %IF FLAG # 0 P = LD_LINK %REPEAT -> ERR SW(10): !NEW DIRECTORY CALL MAKEDIR(DIRFILE,DR0,DR1,FLAG) -> ERR SW(1): !ADD SINGLE ENTRY SW(4): !ADD ALL ENTRIES IN FILE SW(7): !ADD ONLY PROCEDURE ENTRIES SW(5): !UNLOAD CALL - CURGLA IN TYPE SW(8): !REPLACE VALUE OF DR0 PRINTSTRING("Illegal call on MODDIRFILE ") FLAG=1001 ERR: %IF CONMODE#0 %THEN CHANGEACCESS(DIRFILE,1,CONMODE); !Change back to READ - ignore flag %END; !OF MODDIRFILE ! ! !*********************************************************************** !* * !* End of temporary routines * !* * !*********************************************************************** ! ! End of tempcode required to handle old style directories %FINISH ! %IF PDFNFC#0 %THEN %START ! %EXTERNALROUTINE PD(%STRING(255) S) %RECORD(RF) RR %STRING(7) TMPL %INTEGER FLAG TMPL="PDFILE" SSOWN_RCODE=0 %IF S="?" %THEN PRINTSTRING(SSOWN_PDPREFIX) %AND %RETURN UCTRANSLATE (ADDR(S)+1,LENGTH(S)) FILPS(TMPL,S) S = SPAR (1) %IF S#"" %THEN %START CONNECT(S,1,0,0,RR,FLAG) %IF FLAG#0 %THEN ->ERR %IF NEWCONNECT#0 %THEN %START SETUSE (LAST, -1, 0) %FINISH %IF RR_FILETYPE#SSPDFILETYPE %THEN FLAG=267 %AND ->ERR %FINISH SSOWN_PDPREFIX=S %RETURN ERR: PRINTSTRING("PD fails - ".FAILUREMESSAGE(FLAG)) SSOWN_RCODE=FLAG %RETURN %END; ! OF PD ! ! %FINISH ! %ENDOFFILE Œ Œ