%CONTROL X'0FFFFFFF' !* RTENV - FOR PASCAL 20 (RUN-TIME) !* !* MAINLY DIAGNOSTICS SIMPLIFICATIONS !* !* T.MOORE APRIL 1980 !* !* MODIFIED 07/06/79 !* %EXTERNALLONGINTEGER ICL9CEAUXST !* %EXTERNALINTEGER ICL9CECTM32=1 !* %OWNINTEGER DIAGROUTE;! 0 OPEH 1 LOG 2 JOBBER %OWNINTEGER DIAGMODE=1;! 1 OPEH 0 OWN(STAND-ALONE) -1 JOBBER %OWNINTEGER MONCPU;! 0 NO REPORT 1 REPORT %EXTERNALINTEGER CTMREPORT;! 0 NO REPORT 1 REPORT %OWNINTEGER CETOLF;! 0 ICL9CE FILE TAG ONLY 1 ALLOW ICL9LF AS WELL %OWNINTEGER FACILITY=4 %OWNINTEGER INITLANG=0 %OWNINTEGER OUTSTREAM ACTIVE;! 0 NO 1 YES (TIDY CALL REQUIRED) %OWNINTEGER AUXSTSIZE=1 %OWNINTEGER FASTEST;! %IF #0 USE ACCESS2 %OWNINTEGER ERR REPORT=0 !* %OWNLONGINTEGERARRAY SERVICE PROC(0:9) !* !* %OWNINTEGERARRAY SSCOMREG(0:64)=240,0(41),1,0(22) !* %OWNINTEGERARRAY SSFDMAP(0:109) !* %OWNINTEGERARRAY BASICFDS(0:63);! FOR STREAMS 108,109 !* !* SSLEVEL NOW IN COMREG(1) !-1 ABORTING ! 0 INITIALISING ! 1 COMMAND PROCESSOR ! 2 TRUSTED FACILITY(E.G. COMPILER) ! 3 USER PROGRAM !* %EXTERNALINTEGER ICL9CEJSTATE; ! 0 NO CURRENT USER JOB ! 1 PROCESSING USER JOB ! 2 JOB ABORTING (E.G. ! REQUEST FOR UNAVAIL. RESOURCE ! 3 TIME EXCEEDED ! 4 OUTPUT EXCEEDED ! 5 USER PROG DIAGS FAILURE ! 6 SOFTWARE DETECTED ERROR ! (SUBSYS IN CONTROL) ! 7 I/0 ERROR ON PRIMARY OUTPUT STREAM ! 8 HARDWARE DETECTED ERROR ! WHILE IN SUBSYS ! 9 SUBSYSTEM LOGICAL ERROR !10 ABORTING! !* %OWNINTEGER STARTCPU,ENDCPU !* %OWNINTEGERARRAY SIGDATA(-3 : 65) = M'SIGD',M'ATA ',0(67) ! 3*88 BYTE RECORDS !* !* %CONSTINTEGER VFMAX = 16 %CONSTINTEGER VFSIZE = 36 !* %OWNINTEGER VFINDEX,VFBASE %OWNINTEGERARRAY VFDESCRIPTORS(0 : 143); ! 16 VIRTUAL FILES !* %RECORDFORMAT VFDESC(%STRING(15) S,%INTEGER CURL,MAXL,MODE,DESC0,CONAD) !* %OWNINTEGER BUFF FREE,BUFF MAX !* %CONSTINTEGER IMPERROR = 10000 %CONSTSTRING(64) SWERRMESS=E"FAILURE OF PASCAL SUPPORT SOFTWARE" %CONSTSTRING(13) PROCL=E"ICL9CERRPROCL" %CONSTSTRING(13) PROCR=E"ICL9LPCEPROCR" %CONSTSTRING(13) MESSG=E"ICL9HERRMESSG" %CONSTSTRING(13) MESSL=E"ICL9HERRMESSL" !* !* %CONSTBYTEINTEGERARRAY ITOETAB(0 : 255) = %C 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, 64, 79, 127, 123, 91, 108, 80, 125, 77, 93, 92, 78, 107, 96, 75, 97, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 122, 94, 76, 126, 110, 111, 124, 193, 194, 195, 196, 197, 198, 199, 200, 201, 209, 210, 211, 212, 213, 214, 215, 216, 217, 226, 227, 228, 229, 230, 231, 232, 233, 74, 224, 90, 95, 109, 121, 129, 130, 131, 132, 133, 134, 135, 136, 137, 145, 146, 147, 148, 149, 150, 151, 152, 153, 162, 163, 164, 165, 166, 167, 168, 169, 192, 106, 208, 161, 7, 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62, 225, 65, 66, 67, 68, 69, 70, 71, 72, 73, 81, 82, 83, 84, 85, 86, 87, 88, 89, 98, 99, 100, 101, 102, 103, 104, 105, 112, 113, 114, 115, 116, 117, 118, 119, 120, 128, 138, 139, 140, 141, 142, 143, 144, 154, 155, 156, 157, 158, 159, 160, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 202, 203, 204, 205, 206, 207, 218, 219, 220, 221, 222, 223, 234, 235, 236, 237, 238, 239, 250, 251, 252, 253, 254, 255 %CONSTBYTEINTEGERARRAY ETOITAB(0 : 255) = %C 0, 1, 2, 3, 156, 9, 134, 127, 151, 141, 142, 11, 12, 13, 14, 15, 16, 17, 18, 19, 157, 10, 8, 135, 24, 25, 146, 143, 28, 29, 30, 31, 128, 129, 130, 131, 132, 133, 23, 27, 136, 137, 138, 139, 140, 5, 6, 7, 144, 145, 22, 147, 148, 149, 150, 4, 152, 153, 154, 155, 20, 21, 158, 26, 32, 160, 161, 162, 163, 164, 165, 166, 167, 168, 91, 46, 60, 40, 43, 33, 38, 169, 170, 171, 172, 173, 174, 175, 176, 177, 93, 36, 42, 41, 59, 94, 45, 47, 178, 179, 180, 181, 182, 183, 184, 185, 124, 44, 37, 95, 62, 63, 186, 187, 188, 189, 190, 191, 192, 193, 194, 96, 58, 35, 64, 39, 61, 34, 195, 97, 98, 99, 100, 101, 102, 103, 104, 105, 196, 197, 198, 199, 200, 201, 202, 106, 107, 108, 109, 110, 111, 112, 113, 114, 203, 204, 205, 206, 207, 208, 209, 126, 115, 116, 117, 118, 119, 120, 121, 122, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 123, 65, 66, 67, 68, 69, 70, 71, 72, 73, 232, 233, 234, 235, 236, 237, 125, 74, 75, 76, 77, 78, 79, 80, 81, 82, 238, 239, 240, 241, 242, 243, 92, 159, 83, 84, 85, 86, 87, 88, 89, 90, 244, 245, 246, 247, 248, 249, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 250, 251, 252, 253, 254, 255 !* %SYSTEMROUTINESPEC DUMP(%INTEGER START,LEN) %SYSTEMINTEGERFNSPEC OPEN FILE( %INTEGER AFD,MODE) %SYSTEMINTEGERFNSPEC READ FILE DESC(%INTEGER AFD) %SYSTEMINTEGERFNSPEC FILE ACT(%INTEGER AFD,ACT) %SYSTEMINTEGERFNSPEC WORKFILE(%INTEGER AFD,SIZE,TYPE) %SYSTEMINTEGERFNSPEC READ JS VAR(%STRING(31) NAME, %C %INTEGER OPTION,RADDR) %SYSTEMROUTINESPEC QUIT %SYSTEMROUTINESPEC DATETIME(%LONGINTEGER I, %C %INTEGER D0,D1,T0,T1,NR) %SYSTEMINTEGERFNSPEC READ CPU TIME %SYSTEMINTEGERFNSPEC PRIME CONTINGENCY(%ROUTINE CONTPROC) %SYSTEMINTEGERFNSPEC DA FILE OP(%INTEGER AFD,OP,REC) !* !****** OPEH PROCEDURES !* %EXTERNALROUTINESPEC ICL9HEPROLOG(%INTEGER N) %SYSTEMINTEGERFNSPEC NOMTIDYPROC(%ROUTINE PROC) %SYSTEMINTEGERFNSPEC NOMDESC(%INTEGER D0,D1,%INTEGERFN PROC) %ROUTINESPEC ERRPROCS ! %ROUTINESPEC ICL9CETIDYUP %EXTERNALROUTINESPEC ICL9HERESET %EXTERNALROUTINESPEC ICL9HEDIAGOUT(%INTEGERNAME POS,%INTEGER D0,D1) %EXTERNALROUTINESPEC ICL9HEFATALCOMPERR(%INTEGER LANG,ERRNO) %EXTERNALROUTINESPEC ICL9HETIDYUP %SYSTEMROUTINESPEC LOG(%INTEGER TYPE,NR,DR0,DR1) !* !****** MAIN !* %SYSTEMROUTINESPEC IOCP(%INTEGER I,J) !* !* !****** DIAG !* %SYSTEMROUTINESPEC NDIAG(%INTEGER PC,LNB,FAULT,EXTRA) %SYSTEMROUTINESPEC SSMESS(%INTEGER N) !* %SYSTEMROUTINESPEC ONTRAPACT(%INTEGER MODE,CLASS,SUBCLASS, %C OLDPL,OLDLNB) %SYSTEMROUTINESPEC ONTRAPB(%INTEGER EVENT,SUBCLASS,CLASS) !* %RECORDFORMAT NRFDFMT(%INTEGER LINK,DSNUM, %C %BYTEINTEGER STATUS, ACCESS ROUTE, VALID ACTION, CUR STATE, %C %BYTEINTEGER MODEOFUSE, MODE, FILE ORG, DEV CLASS, %C %BYTEINTEGER REC TYPE, FLAGS, LM, RM, %C %INTEGER ASVAR, AREC, RECSIZE, MINREC, MAXREC, MAXSIZE,ROUTECCY, %C %LONGINTEGER ACCESS1,ACCESS2, %C %INTEGER TRANSFERS,DARECNUM, %C %LONGINTEGER REC CCY,NEW CCY,FT CCY, %C %STRING(31) IDEN) !* %ROUTINESPEC OUTFILE(%STRING(15) S,%INTEGER L,M,U, %C %INTEGERNAME CONAD,FLAG) %INTEGERFNSPEC NEW DESC(%INTEGER DSNUM,TYPE,ACCESS ROUTE, %C MODE,IDENTYPE,%STRING(31) IDEN,%INTEGERNAME AFD) !* !* !* !* %EXTERNALROUTINE ICL9CESETRES(%INTEGERNAME N) %END !* !* %CONSTBYTEINTEGERARRAY C(0 : 15) = '0','1','2','3', '4','5','6','7','8','9','A','B','C','D','E','F' %ROUTINE PX(%INTEGER H) %INTEGER I,J %CYCLE I = 0,1,3 J=BYTEINTEGER(I+H) PRINTSYMBOL(C(J>>4)) PRINTSYMBOL(C(J&15)) %REPEAT %END; !OF PX !* %SYSTEMROUTINE PHEX(%INTEGER N) PX(ADDR(N)) %END; !PHEX !* %SYSTEMROUTINE MOVE(%INTEGER LENGTH, FROM, TO) %INTEGER I %RETURNIF LENGTH <= 0 I = X'18000000'!LENGTH *LSS_FROM *LUH_I *LDTB_I *LDA_TO *MV_%L=%DR %END; !OF MOVE !* %SYSTEMROUTINE FILL(%INTEGER LENGTH, FROM,FILLER) %INTEGER I %RETURNIF LENGTH <= 0 I = X'18000000'!LENGTH *LDTB_I *LDA_FROM *LB_FILLER *MVL_%L=%DR %END !* %SYSTEMROUTINE ETOI(%INTEGER AD, L) %INTEGER I, J, K I = ADDR(ETOITAB(0)) %RETURNIF L <= 0 J = X'18000100' K = X'18000000'!L *LSS_I *LUH_J *LDTB_K *LDA_AD *TTR_%L=%DR %END; ! ETOI !* %SYSTEMROUTINE ITOE(%INTEGER AD, L) %INTEGER I, J, K I = ADDR(ITOETAB(0)) %RETURNIF L <= 0 J = X'18000100' K = X'18000000'!L *LSS_I *LUH_J *LDTB_K *LDA_AD *TTR_%L=%DR %END; ! ITOE !* !* %SYSTEMLONGREALFN CPUTIME %INTEGER I I = READ CPU TIME %IF STARTCPU=0 %THEN STARTCPU=I %RESULT = (I-STARTCPU)*0.001 %END; ! CPUTIME !* %SYSTEMINTEGERFN DATEANDTIME(%STRINGNAME DATE,TIME) %INTEGER I,J %STRING (10) D, T, U, V D='YYYY.MM.DD' T='HH:MM:SS' I=ADDR(D)+1 J=ADDR(T)+1 DATETIME(0,X'1800000A',I,X'18000008',J,1) ETOI(I,10) ETOI(J,8) TIME=T DATE=D %RESULT=0 %END;! DATIME !* %SYSTEMINTEGERMAP COMREG(%INTEGER I) %RESULT=ADDR(SSCOMREG(I)) %END;! COMREG !* !* %SYSTEMINTEGERMAP FDMAP(%INTEGER I) %RESULT=ADDR(SSFDMAP(I)) %END;! FDMAP !* !* %INTEGERFN JBRCALL(%INTEGER EP,P1,P2) %LONGINTEGER DESC %INTEGER I DESC=SERVICE PROC(0) %IF DESC=0 %THEN %RESULT=1;! JOBBER INIT CALL NOT MADE *PRCL_4 *LSS_EP *SLSD_P1 *ST_%TOS *LD_DESC *RALN_8 *CALL_(%DR) *ST_I %RESULT=I %END;! JBRCALL !* !* !* %SYSTEMROUTINE SSERR(%INTEGER N) !* ROUTE FOR SOFTWARE DETECTED ERRORS %INTEGER I %IF N=0 %THEN ->EXIT %IF (COMREG(1)=3 %OR FACILITY#0) %AND N<256 %THENSTART; ! ERROR WHILE EXECUTING USER PROG. SSCOMREG(1)=1;! IN CASE OF ERROR ON ERROR *STLN_I NDIAG(0,I,N,0) %FINISHELSESTART;! REPORT ERROR AND RETURN TO MAIN CONTROL %IF N>=256 %THEN COMREG(1)=-1;! TO ENSURE ABORT SELECTOUTPUT(107) %UNLESS ICL9CEJSTATE>1 %OR 230<=N<=231 %THEN ICL9CEJSTATE=6 SSMESS(N) EXIT: I=SSCOMREG(36) %IF I=0 %THENSTART ! ALLDIAGS(0) QUIT %FINISH *LLN_I *EXIT_-64 %FINISH %END;! SSERR !* !* %EXTERNALROUTINESPEC ICLCTM SEND MESSAGE(%INTEGER D0,D1) %EXTERNALROUTINE ICL9CEDIAGOUT(%INTEGER AD,L) %INTEGER I,J %IF L<=0 %THEN L=1 %AND BYTEINTEGER(AD)=' ' %IF DIAGROUTE=2 %THENSTART;! JOBBER I=JBRCALL(6,AD,L) %FINISHELSESTART %IF L>120 %THEN L=120 ITOE(AD,L) I=X'18000000'!L %IF DIAGROUTE=0 %THENSTART;! OPEH MODE J=-1 ICL9HEDIAGOUT(J,I,AD) %FINISHELSE ICLCTM SENDMESSAGE(I,AD) %FINISH %END;! ICL9CEDIAGOUT !* !* %OWNINTEGER LE CODE,LE PROC !* %CONSTSTRING(12)%ARRAY PROC TEXT(0:21)= %C "", "RAM", "SELECT RAM", "WORKFILE", "WORKAREA", "SET VS ATT", "READ DESC", "QUIT", "JS BEGIN", "JS END", "INFORM", "READ ID", "DISCARD ID", "JS WRITE", "JS READ", "DATE TIME", "PROC TIME", "LOG", "DELETE FILE", "MAKE FILE", "WRITE DESC", "ASSIGN FILE" !* %SYSTEMINTEGERFN PROC ERR(%INTEGER RC,PROC) %CONSTINTEGER LAST=78 %CONSTINTEGERARRAY RC MAP (0:79) = -31753, 0, -31500, 300, -9015, 153, 9006, 162, 9029, 170, 9030, 171, 9034, 153, 9040, 169, 9041, 172, 9087, 153, 9114, 152, 9509, 175, 9510, 174, 9512, 171, 9518, 182, 30461, 251, 30554, 253, 31308, 252, 31482,1009, 31484,1010, 31491,1011, 31495,1012, 31496,1012, 31501, 152, 31530, 184, 31756, 173, 33540, 151, 33686, 300, 34595, 232, 39371, 152, 50110, 220, 50111, 220, 50138, 167, 50140, 168, 50144, 152, 50145, 174, 50185, 152, 0,0,0,0,0,0 %INTEGER I,J,NEG LE CODE=RC LE PROC=PROC %IF ERR REPORT#0 %THENSTART PRINTSTRING("RC=") WRITE(RC,1) PRINTSTRING(" FROM ") %IF 1<=PROC<=21 %THENSTART PRINTSTRING(PROC TEXT(PROC)) %FINISHELSESTART PRINTSTRING("VME/B INTERFACE") WRITE(PROC,4) %FINISH NEWLINE %FINISH %IF RC>2300000 %THENSTART;! RAM WITH N<<256!M %IF RC>0 %THEN NEG=1 %ELSE NEG=-1 %AND RC=RC-256 RC=((RC*NEG)>>8)*NEG %FINISH %CYCLE I=0,1,LAST %IF RC MAP(I)=RC %THEN %RESULT=RC MAP(I+1) %REPEAT %IF RC>0 %THEN %RESULT=1000 %ELSE %RESULT=-1 !* %RESULT=0 %END;! PROC ERR !* %SYSTEMROUTINE READ ERROR DATA (%STRINGNAME LAST ERRING PROC, %C %INTEGERNAME LAST ERROR CODE) %IF 1<=LE PROC<=21 %THEN LAST ERRING PROC=PROC TEXT(LE PROC) %ELSE %C LAST ERRING PROC = "" LAST ERROR CODE = LE CODE %END ;! OF READ ERROR DATA !* !*********************************************************************** !* * !* INITIALISATION * !* * !*********************************************************************** !* %ROUTINE CHECK ROPTIONS %CONSTSTRING(6)%ARRAY ROPTION(0:8)= %C "CPU","FAST","DIAG1","RTRACE","CETOLF","AUX2","AUX4","AUX8","REPORT" %STRING(255) ROPTIONS,S %INTEGER I %SWITCH SW(0:8) I=READ JS VAR("ICL9CEROPTIONS",2,ADDR(ROPTIONS)) %IF I=0 %THENSTART %WHILE ROPTIONS#"" %CYCLE %UNLESS ROPTIONS->S.("&").ROPTIONS %THENSTART S=ROPTIONS ROPTIONS="" %FINISH %CYCLE I=0,1,8 %IF S=ROPTION(I) %THEN ->SW(I) %REPEAT NEXT: %REPEAT %FINISH %RETURN !* SW(0):MONCPU=1;! CPU ->NEXT SW(1):FASTEST=1;! FAST ->NEXT SW(2):SSCOMREG(25)=0;! DIAG1 DIAGMODE=0;! DIAG0 ->NEXT SW(3):CTMREPORT=1;! RAMTRACE ->NEXT SW(4):CETOLF=1;! CETOLF ->NEXT SW(5): ! AUX2 SW(6): ! AUX4 SW(7): ! AUX8 AUXSTSIZE=1<<(I-4) ->NEXT SW(8): ! REPORT ERR REPORT=1 ->NEXT %END;! CHECK ROPTIONS !* !* !* %EXTERNALINTEGERFN ICL9CEZINIT(%INTEGER LANG,LNB,%ROUTINE PROC) %OWNSTRING(26) SJTEXT=E"SCIENTIFIC JOBBER B50 (01)" %LONGINTEGER PR %INTEGER I, J,K,L SSCOMREG(22)=0;! TO ENSURE CORRECT SELECTION EFFECTS IN ALIB OUTSTREAM ACTIVE=0;! WILL BE CHANGED IF POSSIBILITY OF INCOMPLETE BUFFER *LSD_(%LNB+7) *ST_PR %IF LANG<0 %THEN INITLANG=-LANG %ELSE INITLANG=LANG %IF 0<=INITLANG<=9 %THEN SERVICE PROC(INITLANG)=PR %IF LANG<0 %THEN %RESULT=2;! JOBBER MODE LANGUAGE INIT ERR REPORT=0 FASTEST=0 !* !* I=ADDR(SSCOMREG(0)) FILL(256,I+4,0) SSCOMREG(29)=I SSCOMREG(11)=ADDR(ETOITAB(0)) SSCOMREG(12)=ADDR(ITOETAB(0)) !* ICL9CEJSTATE=0 SSCOMREG(33)=ADDR(SIGDATA(0)) SIGDATA(1)=-1;! WILL GIVE DIAGS AFTER ICL9CEJINIT !* !****** PREPARE BASE AND CONTINGENCY TRAPS !* SSCOMREG(25)=0;! MINIMUM DIAGS AS DEFAULT IOCP(11,-2);! INITIALISE OUTPUT DIAGROUTE=1;! LOG DIAGMODE=1;! OPEH FACILITY=4 %IF LANG=0 %THENSTART;! JOBBER FACILITY=0 DIAGROUTE=2 DIAGMODE=-1 SSCOMREG(25)=2;! MIN DIAGS BY DEFAULT IN JOBBER %FINISH MONCPU=0 CTMREPORT=0 CETOLF=0;! ICL9CE BASE FOR FILE IDENTS AUXSTSIZE=1 !* CHECK ROPTIONS !* %IF CTMREPORT#0 %THEN DIAGROUTE=1 SSCOMREG(42)=DIAGMODE;! READ BY NDIAG %IF DIAGMODE<=0 %THEN I=PRIME CONTINGENCY(ONTRAPB) !* !****** INITIALISE AREA CREATION AND BUFFER ALLOCATION !* VFINDEX = 0 J = ADDR(VFDESCRIPTORS(0)) VFBASE=J FILL(VFMAX*VFSIZE,J,0) SSCOMREG(31) = J; ! FOR DIAGNOSTICS BUFF FREE=0 BUFF MAX=0 !* !* !****** PREPARE AUXILIARY STACK FOR IMP/ALGOL !* ! %UNLESS LANG=2 %THENSTART;! EXCEPT FORTRAN ! K=AUXSTSIZE<<18 ! OUTFILE("AUXST",K,K,0,I,J) ! SSCOMREG(37) = I; ! ADDRESS OF AUX STACK ! J=ADDR(ICL9CEAUXST) ! INTEGER(J)=X'28000000'!K ! INTEGER(J+4)=I ! SSCOMREG(41)=J;! FOR USE BY LOAD FILLING SZAUXST REFS ! INTEGER(I) = I+16 ! INTEGER(I+8)=I+K ! %FINISH !* STARTCPU=READ CPU TIME I=ADDR(SSFDMAP(0)) FILL(440,I,0) SSCOMREG(17) = I !* I=ADDR(BASICFDS(0)) SSCOMREG(21)=I FILL(232,I,0) !* SSFDMAP(108)=I SSFDMAP(109)=I+128 J=NEW DESC(108,1,1,X'D',0,"",I) J=NEW DESC(109,1,2,2,0,"",I) !* !* SSCOMREG(36)=LNB %IF DIAGMODE=1 %THENSTART;! OPEH DIAGNOSTICS %IF LNB>0 %THENSTART;! NOT A JINIT CALL ICL9HERESET ICL9HEPROLOG(0) ! I=NOMTIDYPROC(ICL9CETIDYUP) SKIP: ERRPROCS %FINISH %FINISH %IF LANG=0 %THENSTART ICLCTMSENDMESSAGE(X'1800001A',ADDR(SJTEXT)+1) %FINISH %RESULT=DIAGMODE %END;! INITENV !* !* %CONSTINTEGER MAXSIGLEVEL=2 !* %RECORDFORMAT SIGDATAFMT(%INTEGER PC, LNB, CLASS, SUBCLASS, %C %INTEGERARRAY A(0 : 17)) !* %SYSTEMROUTINE SGNL(%INTEGER EP, P1, P2, %INTEGERNAME F) !*********************************************************************** !* EP = 0 STACK RECOVERY INFO * !* P1 = PC * !* P2 = LNB !* 1 UNSTACK RECOVERY INFORMATION * !* P1 = 0 ONE LEVEL * !* 1 ALL LEVELS * !* 2 SIGNAL ERROR OF CLASS P1 AND SUBCLASS P2 AT CURRENT LEVEL * !* 3 DITTO AT OUTER LEVEL * !* 4 REPEAT LATEST CONTINGENCY AT CURRENT LEVEL * !* 5 RETURN TO USER MODE WITH NOMINATED ENVIRONMENT * !* 6 SET INTEGER AT P1 TO CURRENT NUMBER OF LEVELS * !*********************************************************************** %RECORDNAME D(SIGDATAFMT) %INTEGER I,J,SIGLEVEL %SWITCH SW(-1 : 9) F = 0 J=ADDR(SIGDATA(0)) SIGLEVEL=SSCOMREG(34) -> SW(EP) !* SW(9): SW(0): %UNLESS FACILITY=0 %THENSTART %IF INTEGER(P2+4)>>28#X'E' %THEN I=INTEGER(P2) %ELSE I=P2 COMREG(36)=I %FINISH SW(-1): ! CALL FROM NDIAG %IF SIGLEVEL>=MAXSIGLEVEL %THEN F=1 %AND %RETURN SIGLEVEL =SIGLEVEL+1 D == RECORD(J+88*SIGLEVEL) D_PC = P1 D_LNB = P2 OUT: SSCOMREG(34)=SIGLEVEL INTEGER(J+4)=0;! ENSURE FALLBACK TRAP EFFECTIVE %RETURN !* SW(1): %IF SIGLEVEL <= 0 %THEN F = 1 %ANDRETURN %IF P1 = 0 %THEN SIGLEVEL = SIGLEVEL-1 %C %ELSE SIGLEVEL = 0 -> OUT !* SW(2): !* SW(3): *STLN_I ONTRAPACT(EP,P1,P2,INTEGER(I+8),INTEGER(I)) !* SW(4): ONTRAPACT(4,P1,P2,0,0) !* SW(5): %MONITOR;%STOP !* SW(6): INTEGER(P1) = SIGLEVEL %END; ! SGNL !* !* !* !* !* %SYSTEMROUTINE STOP %INTEGER I,J -> SKIP %IF FACILITY#0 %THENSTART;! NOT JOBBER MODE %IF DIAGMODE=3 %THENSTART;! REPABLE IF NEEDED ICL9HETIDYUP %FINISH; ! ELSE ICL9CETIDYUP ICL9HERESET QUIT %FINISH SKIP: QUIT I=SSCOMREG(36) *STLN_J %UNLESS J>>18 = I>>18 %THENSTART QUIT %FINISH *LLN_I *EXIT_-64 %END;! STOP !* !* !* !*********************************************************************** !* * !* AREA MANAGEMENT * !* * !*********************************************************************** !* !* %SYSTEMINTEGERFNSPEC NEWAREA(%INTEGER AREA SIZE, %C MAXSIZE,AMODE,%LONGINTEGERNAME DESC,%INTEGER N0,N1) %SYSTEMINTEGERFNSPEC CHANGE AREA PROPERTIES( %C %INTEGER ADR0,ADR1,RACR,WACR,EXEC,AMODE,SIZE,CONTENT) !* %RECORDFORMAT RF(%INTEGER CONAD, FILESIZE,DATASTART,DATAEND) !* !* %INTEGERFN LOCATE AREA(%STRING(15) S,%INTEGERNAME AREC) %INTEGER I,J %RECORDNAME VF(VFDESC) J=VFBASE I=1 %WHILE I<=VFINDEX %CYCLE VF==RECORD(J) %IF VF_S=S %THENSTART AREC=J %RESULT=0 %FINISH J=J+VFSIZE I=I+1 %REPEAT %RESULT=1;! AREA NOT RECORDED %END;! LOCATE AREA !* !* %SYSTEMROUTINE REMOVE AREA(%STRINGNAME S) %INTEGER I %IF LOCATE AREA(S,I)#0 %THENSTART !! I=SET CONTENT LIMIT(S,0) %FINISH %END;! REMOVE AREA !* %SYSTEMINTEGERFN EXTEND AREA(%STRING(15) S,%INTEGER REQ SIZE, %C %INTEGERNAME NEWSIZE) %RECORDNAME VF(VFDESC) %INTEGER I,J %IF LOCATE AREA(S,I)#0 %THENSTART VF==RECORD(I) %IF REQ SIZE<=VF_CURL %THEN %RESULT=0 %IF REQ SIZE>VF_MAXL %THENSTART %IF VF_CURL=VF_MAXL %THEN %RESULT=3;! NO CHANGE REQ SIZE=VF_MAXL J=-1;! NOT AS BIG AS REQUESTED %FINISHELSE J=0 !! CHANGE SIZE VF_CURL=REQ SIZE INTEGER(VF_CONAD+8)=REQ SIZE %RESULT=J %FINISH %RESULT=1 %END;! CHFSIZE !* %ROUTINESPEC CHANGE USE(%STRING(15) S,%INTEGER NEWUSE, %C %INTEGERNAME FLAG) !* %SYSTEMROUTINE OUTFILE(%STRING (15) S, %C %INTEGER LEN, MAXBYTES, USE, %INTEGERNAME CONAD,FLAG) %INTEGER I, J, D0,D1 %LONGINTEGER DESC %STRING(31) V %RECORDNAME VF(VFDESC) %IF MAXBYTESOK %FINISH FLAG=EXTEND AREA(S,LEN,VF_CURL) ->INIT %FINISH !* CREATE A NEW AREA MAXBYTES = (MAXBYTES+1023)&X'FFC00'; ! ROUND TO PAGE BOUNDARY V="ICL9CEX".S J=ADDR(V)+1 ITOE(J,31) I=NEWAREA(MAXBYTES,MAXBYTES,2,DESC,X'18000000'!LENGTH(V),J) %IF I # 0 %THEN FLAG=-1 %AND %RETURN %IF VFINDEX>=VFMAX %THENSTART FLAG=2 %RETURN %FINISH J=VFBASE+VFINDEX*VFSIZE VFINDEX=VFINDEX+1 VF==RECORD(J) VF_S = S VF_CURL=LEN VF_MAXL=MAXBYTES LONGINTEGER(ADDR(VF_DESC0))=DESC VF_MODE=0 CONAD=VF_CONAD OK: FLAG=0 INIT: %IF VF_MODE#0 %THENSTART CHANGE USE(VF_S,0,FLAG) %FINISH I=CONAD INTEGER(I)=16 INTEGER(I+4)=16 INTEGER(I+8)=LEN INTEGER(I+12)=0 %RETURN %END;! INITAREA !* !* %SYSTEMROUTINE CONNECT(%STRING(15) S,%INTEGER ACCESS, %C MAXBYTES,USE,%RECORDNAME R,%INTEGERNAME FLAG) %RECORDNAME VF(VFDESC) %RECORDSPEC R(RF) %INTEGER I !* %IF LOCATE AREA(S,I)=0 %THENSTART VF == RECORD(I) R_CONAD = VF_CONAD R_FILESIZE = VF_CURL FLAG=0 %RETURN %FINISH FLAG = 1; ! FILE DOES NOT EXIST %RETURN %END;! CONNECT AREA !* %SYSTEMROUTINE CHANGE USE(%STRING(15) S,%INTEGER NEWUSE, %C %INTEGERNAME FLAG) !* NEWUSE = 0 READ/WRITE !* 1 EXEC/READ %RECORDNAME VF(VFDESC) %INTEGER I,J %IF LOCATE AREA(S,I)=0 %THENSTART VF==RECORD(I) %UNLESS VF_MODE=NEWUSE %THENSTART %IF NEW USE=0 %THEN J=1 %ELSE J=0 FLAG=CHANGE AREA PROPERTIES(VF_DESC0,VF_CONAD, %C 1,J,NEWUSE,2,-1,-1) %RETURN %IF FLAG>0 VF_MODE=NEWUSE %FINISH FLAG=0 %RETURN %FINISHELSE FLAG=3 %END;! CHANGE USE !* !* !* !*********************************************************************** !* * !* BUFFER ALLOCATION * !* * !*********************************************************************** !* !* %OWNSTRING(7) BUFFID !* %INTEGERFN GIVE BUFFER(%INTEGER LENGTH, %INTEGERNAME ADDRESS) %INTEGER F,I,J I=X'40000' LENGTH=((LENGTH+7)>>3)<<3 %IF LENGTH>I %THEN %RESULT=1004;! TOO BIG %IF BUFF FREE+LENGTH>BUFF MAX %THENSTART;! CREATE A NEW AREA %IF BUFF FREE=0 %THENSTART;! FIRST TIME BUFFID="BUFF0" %FINISHELSESTART J=ADDR(BUFFID)+5 BYTEINTEGER(J)=BYTEINTEGER(J)+1 %FINISH OUTFILE(BUFFID,I,I,0,BUFF FREE,F) %IF F>0 %THEN %RESULT=1003 BUFF MAX=BUFF FREE+I %FINISH ADDRESS=BUFF FREE BUFF FREE=BUFF FREE+LENGTH %RESULT =0 %END ; ! GIVE BUFFER !* !* !*********************************************************************** !* * !* FILE DESCRIPTORS * !* * !*********************************************************************** !* !* %CONSTINTEGER FDSIZE=128 !* !* !* %SYSTEMINTEGERFN NEW DESC(%INTEGER DSNUM, TYPE, ACCESS ROUTE, %C MODE,IDENTYPE, %STRING (31)IDEN, %INTEGERNAME AFD) %INTEGER I,J %RECORDNAME F(NRFDFMT) %UNLESS 00 %THEN %RESULT =I F_STATUS=1 %RESULT =0 %END; ! GET SLOW ROUTE !* %SYSTEMINTEGERFN OPEN(%INTEGER AFD, MODE) !* !* MODE = 1 INPUT !* 2 OUTPUT !* %STRING(31) FILENAME %RECORDNAME F(NRFDFMT) %OWNBYTEINTEGERARRAY DEF OBUFF(0 : 132) %OWNBYTEINTEGERARRAY DEF IBUFF(0:132) %STRING(63) SS %INTEGER I,J,K %SWITCH A(0:6) %IF FACILITY=0 %THEN %C %RESULT=JBRCALL(4,AFD,MODE) F==RECORD(AFD) !PRINTSTRING("OPEN MODE=") !WRITE(MODE,1) !NEWLINE !DUMP(AFD,FDSIZE) I=F_ACCESS ROUTE %UNLESS 0<=I<=4 %THEN %RESULT=1008 ->A(I) !* !****** DEFAULT INPUT A(1): I=GET SLOW ROUTE(AFD) %IF I>0 %THEN %RESULT=I F_AREC=ADDR(DEF IBUFF(0)) F_MINREC=80 F_MAXREC=80 ->OPENIT !* !****** DEFAULT OUTPUT A(2): I=GET SLOW ROUTE(AFD) %IF I>0 %THEN %RESULT=I F_AREC=ADDR(DEF OBUFF(0)) F_MINREC=1 F_MAXREC=133 ->OPENIT !* !****** CONVENTIONAL FILE A(4): %IF F_MODE=13 %AND F_RECTYPE#1 %THEN %RESULT=179;! RECORDS ! MUST BE FIXED LENGTH FOR D.A. I=GIVE BUFFER(F_MAXREC,F_AREC) %IF I#0 %THEN %RESULT=I OPENIT: F_RECSIZE=F_MAXREC J=F_AREC K=F_MAXREC I=OPEN FILE(AFD,MODE) %IF I>0 %THEN %RESULT=I %IF F_IDEN#"" %THENSTART %IF F_DSNUM=INDEFAULT %THENSTART FILENAME="INPUT" %FINISHELSESTART %IF F_DSNUM=OUTDEFAULT %THENSTART FILENAME="OUTPUT" %FINISHELSESTART FILENAME=F_IDEN %FINISH %FINISH PRINTSTRING("FILE ".FILENAME." OPENED ") %FINISH !* OPENED: F_STATUS=3 F_CUR STATE=1 %IF F_ACCESS ROUTE=2 %THENSTART F_REC CCY=SET PROC DESC(DEFOUT PROC) %FINISHELSESTART F_REC CCY=SET PROC DESC(FAST PROC) %FINISH F_FT CCY=F_REC CCY %RESULT=0 %END; !OF OPEN !* %SYSTEMINTEGERFN CLOSE(%INTEGER AFD) %STRING(31) FNAME %RECORDNAME F(NRFDFMT) %INTEGER I %SWITCH A(0:6) %IF FACILITY=0 %THEN %C %RESULT=JBRCALL(5,AFD,0) F==RECORD(AFD) I=F_ACCESS ROUTE %UNLESS 0<=I<=4 %THEN %RESULT=1008 F_FLAGS=F_FLAGS&X'FC';! CLEAR STREAM MARKERS F_MODEOFUSE= 0;! SQ/DA MARKER %IF F_STATUS#3 %THEN F_STATUS=0 %AND %RESULT=0 ->A(I) !* !****** LOG A(0): !* !****** PRIMARY INPUT A(1): !* !****** PRIMARY OUTPUT A(2): !****** CONVENTIONAL FILE A(4): %IF F_STATUS<=1 %THEN %RESULT=0 F_STATUS=1 F_CURSTATE = 0 I=FILE ACT(AFD,7);! DESELECT %IF I=0 %AND F_IDEN#"" %THENSTART %IF F_DSNUM = INDEFAULT %THENSTART FNAME="INPUT" %FINISHELSESTART %IF F_DSNUM = OUTDEFAULT %THENSTART FNAME="OUTPUT" %FINISHELSESTART FNAME=F_IDEN %FINISH %FINISH PRINTSTRING("FILE ".FNAME." CLOSED ") %FINISH %RESULT=I !* !****** MAPPED FILE A(3): F_STATUS=0 %RESULT=0 !* %END; ! CLOSE !* %SYSTEMINTEGERFN LOCATE CHANNEL(%INTEGER CHAN) %RECORDNAME F(NRFDFMT) %STRING(15) S,ROOT %BYTEINTEGERARRAY T(0:2) %INTEGER I,J,AFD,DSNUM %INTEGER FILEORG,DEVCLASS,RECTYPE %LONGINTEGER KK !*B; ROOT="ICL9LP" !* !*K ROOT="UNIT" %UNLESS 1<=CHAN<=99 %THEN %RESULT=164 DSNUM=CHAN %IF CHAN>9 %THENSTART I=CHAN//10 CHAN=CHAN-10*I T(2)=CHAN+'0' CHAN=I T(0)=2 %FINISHELSE T(0)=1 T(1)=CHAN+'0' J=0 LOOK: S=ROOT.STRING(ADDR(T(0))) I=READ JS VAR(S,1,ADDR(KK)) !DUMP(ADDR(CHAN),108) %IF I#0 %THENSTART %IF CETOLF#0 %AND J=0 %THENSTART J=1 ROOT="ICL9LF" ->LOOK %FINISH %RESULT=151;! FILE NOT ASSIGNED %FINISH I=NEWDESC(DSNUM,1,4,X'3F',1,S,AFD) %IF I#0 %THEN %RESULT=I SSFDMAP(DSNUM)=AFD F==RECORD(AFD) F_NEW CCY=KK I=READ FILE DESC(AFD) %IF I>0 %THEN %RESULT=I F_STATUS=1 %RESULT=0 %END;! LOCATE CHANNEL !* %SYSTEMROUTINE OPENSQ(%INTEGER CHAN) %RECORDNAME SQFD(NRFDFMT) %INTEGER AFD, I SSERR(164) %UNLESS 1<=CHAN<=99; ! INVALID DATA SET NUMBER LOOK: AFD=SSFDMAP(CHAN) %IF AFD=0 %START %IF FACILITY=4 %START; ! STAND-ALONE I=LOCATE CHANNEL(CHAN) %IF I=0 %THEN ->LOOK %FINISHELSE I=151 SSERR(I) %FINISH SQFD==RECORD(AFD) SSERR(176) %UNLESS SQFD_STATUS<2 ! FILE ALREADY OPEN %IF SQFD_STATUS = 0 %THEN %START I=OPEN(AFD,1);! INPUT IN FIRST INSTANCE %IF I # 0 %THEN SSERR(I) SQFD_CURSTATE=2;! READ MODE %FINISH SQFD_STATUS=2; ! SET OPEN %RETURN %END; ! OF OPENSQ ! !* %SYSTEMROUTINE CLOSESQ (%INTEGER CHAN) %INTEGER FLAG, AFD SSERR(164) %UNLESS 1 <= CHAN <= 99; ! INVALID DATA SET NUMBER FLAG = NEW FILE OP (CHAN, 32, 2, AFD) SSERR(FLAG) %UNLESS FLAG <= 0; ! FILE NOT OPEN %RETURN %END; ! OF CLOSESQ !* %SYSTEMROUTINE OPENDA(%INTEGER CHAN) %RECORDNAME DAFD(NRFDFMT) %INTEGER AFD, I SSERR(164) %UNLESS 1<=CHAN<=99; ! INVALID FILE NUMBER LOOK: AFD=SSFDMAP(CHAN) %IF AFD=0 %START %IF FACILITY=4 %START; ! STAND-ALONE I=LOCATE CHANNEL(CHAN) %IF I=0 %THEN ->LOOK %FINISHELSE I=151 SSERR(I) %FINISH DAFD==RECORD(AFD) %UNLESS DAFD_STATUS<2 %THENSTART SSERR(176) %UNLESS DAFD_MODE=13 %RETURN %FINISH ! %IF DAFD_STATUS = 0 %THEN %START DAFD_MODE=13;! FOR CORRECT I/O OPERATIONS I=OPEN(AFD,4);! OPEN FOR DA %IF I # 0 %THEN SSERR(I) %ELSE DAFD_CURSTATE=2 ! %FINISH DAFD_STATUS=2 %END ! !* %SYSTEMROUTINE CLOSEDA (%INTEGER CHAN) %INTEGER FLAG, AFD SSERR(164) %UNLESS 1 <= CHAN <= 99; ! INVALID DATA SET NUMBER !*B; %RETURN; !*PENDING CLEARANCE OF B BUG FLAG = NEW FILE OP (CHAN, 32, 2, AFD) SSERR(FLAG) %UNLESS FLAG <= 0; ! FILE NOT OPEN %RETURN %END; ! OF CLOSE DA !* !* !* !* !*********************** DIAGNOSTICS ********************************* !* !* %SYSTEMROUTINESPEC INDIAG(%INTEGER OLDLNB,LANG,PC,MODE,DIAG,ASIZE, %C %INTEGERNAME FIRST,OLDLNB) %SYSTEMROUTINESPEC OPEHMESS(%INTEGER N,%STRINGNAME V,S) !* !* !* !* !%CONSTSTRING(10)%ARRAY LANGTEXT(0:7)="ALGOL(E)","IMP","FORTRAN(G)", ! "IMP","","ALGOL(E)","IMP","PASCAL" %CONSTSTRING(15)%ARRAY LIB(1:5)="MATHEMATICAL","COMMERCIAL", "GENERAL","STRING HANDLING","DIGITAL PLOTTER" !* !* %OWNINTEGER OPEHFIRST %OWNINTEGER LASTDIAGS %OWNINTEGER LANGUAGE %OWNINTEGER ADD INF !* !* %ROUTINE CALL DIAGPROC(%INTEGER LANG,EP,N) %LONGINTEGER DR DR=SERVICEPROC(LANG) %IF DR#0 %THENSTART *PRCL_4 *LSD_EP *ST_%TOS *LD_DR *RALN_7 *CALL_(%DR) %FINISH %END;! CALL DIAGPROC !* !* %SYSTEMROUTINE FDIAG(%INTEGER OLD LNB,PCOUNT,MODE,DIAG,ASIZE %C %INTEGERNAME FIRST ,NEW LNB ) ! ! ! ! A SYSTEM ROUTINE TO RECEIVE CONTROL FROM THE ! ! ICL 2900 OBJECT PROGRAM ERROR HANDLER (OPEH) ! ! AND TO PRODUCE A TRACE-BACK OF SUBPROGRAMS ! ! ENTERED. ! ! ! %INTEGER PARM0 OF FIO1,PARM1 OF FIO1,PARM2 OF FIO1,PARM3 OF FIO1 %INTEGER PARM4 OF FIO1,PARM5 OF FIO1,PARM6 OF FIO1,PARM7 OF FIO1 ! ! ! PARM0 OF FIO1= X'00090000' ; !FIO1 ENTRY= GIVE DIAGNOSTICS PARM1 OF FIO1= OLD LNB ; ! PARM1= %INTEGER OLD LNB PARM2 OF FIO1= PCOUNT ; ! PARM2= %INTEGER PCOUNT PARM3 OF FIO1= MODE ; ! PARM3= %INTEGER MODE PARM4 OF FIO1= DIAG ; ! PARM4= %INTEGER DIAG PARM5 OF FIO1= ASIZE ; ! PARM5= %INTEGER ASIZE PARM6 OF FIO1= ADDR(FIRST) ; ! PARM6= %INTEGERNAME FIRST PARM7 OF FIO1= ADDR(NEW LNB) ; ! PARM7= %INTEGERNAME NEW LNB CALL DIAGPROC (2,1,ADDR(PARM0 OF FIO1));! FIO1 %RETURN %END; !OF FDIAG !* !* %SYSTEMROUTINE OPEH USER ERROR(%INTEGER ERRNO,ADD INFO,LANG, %C STACK LEVELS) !* LANG = 0 NOT DETERMINED !* 1 IMP !* 2 FORTRAN(G) !* 3 IMPS !* 4 ASSEMBLER !* 5 ALGOL(E) !* 6 IMP(OPT CODE) !* 7 PASCAL !* !* ADD INFO = 1 CALL FORTRAN I/O ROUTINE !* 2 CALL FORTRAN FORMAT ROUTINE !* !* STACK LEVELS = NUMBER OF STACK FRAMES TO RETREAT TO USER LEVEL %INTEGER I LANGUAGE=LANG ADD INF=ADD INFO %IF LANG=2 %THEN I=C'G' %ELSESTART %IF LANG=7 %THEN I=C'P' %ELSE I=C'L' %FINISH ICL9HEFATALCOMPERR(I,IMPERROR) STOP %END;! OPEH USER ERROR !* %EXTERNALINTEGERFN ICL9CERRPROCL(%INTEGER ERRNO,PROCNO,GROUP, %C EMESS0,EMESS1,LANG0,LANG1,DISPLACEMENT,DIAGREC0,DIAGREC1, %C MODCHAIN0,MODCHAIN1,AREAENTRY0,AREAENTRY1,OVERRIDE,ERROR VALUE) %ROUTINESPEC SET TEXT IN S %INTEGER I,J,N,SAVE %STRING(100) V,S %STRING(15) ROOT DIAGROUTE=0 SAVE=ADD INF ADD INF=0 ! LOG99 OPEHFIRST=0 LASTDIAGS=1 IOCP(11,-1) %IF GROUP=0 %THENSTART;! PROGRAM OR INTERRUPT ERROR %IF ERRNO>0 %THENSTART I=BYTEINTEGER(LANG1) %IF I=C'G' %THEN ROOT="FORTRAN(G)" %ELSESTART %IF I=C'L' %THENSTART !FOR OPEH7RS BUSH/GLASGOW ! ROOT="IMP/ALGOL(E)" ROOT="ALGOL(E)" %FINISHELSESTART;! SOME OTHER LANGUAGE I=LANG0&15-1 J=ADDR(ROOT) MOVE(I,LANG1+1,J+1) ETOI(J+1,I) BYTEINTEGER(J)=I %FINISH %FINISH OPEHMESS(ERRNO,V,S) %IF ERRNO=1000 %THEN ROOT="" %FINISHELSESTART %IF ERRNO=0 %THEN %RESULT=0 ROOT="INTERRUPT" SET TEXT IN S %FINISH NEWLINES(2) PRINTSTRING(ROOT." ERROR:") WRITE(ERRNO,1) PRINTSTRING(" DESCRIPTION: ".S) NEWLINE %IF SAVE=1 %THEN CALL DIAGPROC(2,2,0);! PRINT FIO BUFFER %IF SAVE=2 %THEN CALL DIAGPROC(2,3,0);! PRINT FORMAT %FINISHELSESTART;! LIBRARY ERROR PRINTSTRING("LIBRARY ERROR:") I=GROUP<<16+PROCNO<<8+ERRNO WRITE(I,1) PRINTSTRING(" (") %IF GROUP<=20 %THENSTART %IF GROUP<=5 %THEN PRINTSTRING(LIB(GROUP)." LIBRARY, ") %FINISHELSE PRINTSTRING("USER LIBRARY, ") PRINTSTRING("GROUP") WRITE(GROUP,1) SET TEXT IN S PRINTSTRING(") DESCRIPTION: ".S) NEWLINE %FINISH DIAGROUTE=1 %RESULT=0 %ROUTINE SET TEXT IN S %INTEGER I,J %IF EMESS0=-1 %THEN S="" %AND %RETURN I=(EMESS0<<8)>>8 %IF I>100 %THEN I=100 J=ADDR(S) MOVE(I,EMESS1,J+1) ETOI(J+1,I) BYTEINTEGER(J)=I %END;! SET TEXT IN S %END;! ICL9CERRPROC !* %EXTERNALINTEGERFN ICL9LPCEPROCR(%INTEGER DIAGNOSTICS,ARRAYSIZE, %C DISPLACEMENT,STACK0,STACK1,DIAGREC0,DIAGREC1, %C MODCHAIN0,MODCHAIN1,AREAENTRY0,AREAENTRY1, %C AREASOFMODULE0,AREASOFMODULE1) %CONSTBYTEINTEGERARRAY LANGSW(0:7)=0,1,2,1,0,1,0,0 %INTEGER I,J,GLA,LANGFLAG %STRING(32) NAME %SWITCH DIAGSW(0:2) I=INTEGER(MODCHAIN1)&255 -> SKIP %IF INTEGER(MODCHAIN1+I<<2-4)=C'ENV ' %THEN %RESULT=0 SKIP: DIAGROUTE=0 %IF DIAGNOSTICS>0 %THENSTART;! MODULE NAME REQUIRED NAME=STRING(MODCHAIN1+31) ETOI(ADDR(NAME)+1,32) ARRAYSIZE=ADDR(NAME) PRINTSTRING("PASCAL SUPPORT PROCEDURE (MODULE ".NAME.")") PRINTSTRING(" AT BYTE DISPLACEMENT X") PHEX(DISPLACEMENT) NEWLINE %RESULT=0 %FINISHELSE %RESULT=0 %IF LASTDIAGS=1 %THEN OPEHFIRST=1 %ELSE OPEHFIRST=0 LASTDIAGS=DIAGNOSTICS GLA=INTEGER(STACK1+16) *LDTB_X'18000020' *LDA_GLA *VAL_(%LNB+1) *JCC_3, LANGFLAG=INTEGER(GLA+16)>>24 %IF LANGFLAG>7 %THEN LANGFLAG=0 ->DIAGSW(LANGSW(LANGFLAG)) !* !****** UNKNOWN,IMP(OPT),PASCAL !* DIAGSW(0): NODIAGS: PRINTSTRING('PROCEDURE COMPILED WITHOUT DIAGNOSTICS ') ->EXIT !* !****** IMP,ALGOL(E) !* DIAGSW(1): INDIAG(STACK1,LANGFLAG,DISPLACEMENT,1,DIAGNOSTICS,ARRAYSIZE, %C OPEHFIRST,J) ->EXIT !* !****** FORTRAN(G) !* DIAGSW(2): FDIAG(STACK1,DISPLACEMENT,1,DIAGNOSTICS,ARRAYSIZE,OPEHFIRST,J) EXIT: DIAGROUTE=1;! REVERT TO LOG OUTPUT %RESULT=0 %END;! ICL9CERRPROCR !* %EXTERNALINTEGERFN ICL9HERRMESSG(%INTEGERNAME ERRNO, %C %LONGINTEGERNAME EMESS DESC) %INTEGER I %RESULT=0 %END;! ICL9HERRMESSG !* %EXTERNALINTEGERFN ICL9HERRMESSL(%INTEGERNAME ERRNO, %C %LONGINTEGERNAME EMESS DESC) %LONGINTEGER I EMESSDESC=X'FFFFFFFFFFFFFFFF' %IF ERRNO=IMPERROR %THENSTART I=X'18000000'+LENGTH(SWERRMESS) I=I<<32 EMESSDESC=I+ADDR(SWERRMESS)+1 %FINISH %RESULT=0 %END;! ICL9HERRMESSL !* %EXTERNALROUTINE ICL9CEZTIDY %INTEGER I,J,K %LONGINTEGER DR %IF OUTSTREAM ACTIVE#0 %THENSTART;! EMPTY IOCP BUFFER DR=SERVICE PROC(1) %IF DR#0 %THENSTART *LD_DR *PRCL_4 *LSS_0 *ST_%TOS *RALN_6 *CALL_(%DR) %FINISH %FINISH %CYCLE I=1,1,99 K=SSFDMAP(I) %IF K#0 %THEN J=CLOSE(K) %REPEAT J=CLOSE(SSFDMAP(109)) %END;! ICL9CETIDYUP !* %ROUTINE ERRPROCS %INTEGER I I=NOMDESC(X'1800000D',ADDR(PROCR)+1,ICL9LPCEPROCR) I=NOMDESC(X'1800000D',ADDR(MESSL)+1,ICL9HERRMESSL) %END;! ERRPROCS !* !* !*********************************************************************** !* * !* FORTRAN DATE AND TIME ROUTINES * !* * !*********************************************************************** !* %ENDOFFILE