!*
!*E; %EXTERNALLONGLONGREAL ICL9LDLIBPROC
!*NE %EXTRINSICINTEGER ICL9CEDOBEGIN
EXTRINSICLONGINTEGER ICL9CEAUXST
!*NE %EXTRINSICINTEGER ICL9CEFAC
EXTERNALINTEGER ICL9CEFDMAP
EXTERNALINTEGER ICL9CETC
EXTERNALINTEGER ICL9CEMAINLNB
!*NE %EXTERNALINTEGER OPEHMODE=0;! SET TO 1 IF OPEH INITIALISED
!*NE !*B %EXTRINSICINTEGER ICL9CEAVOLS
!*
!*
!*E; %CONSTINTEGER OPSYS = 0
!*B %CONSTINTEGER OPSYS = 1
!*K %CONSTINTEGER OPSYS = 2
!*
!*
!*NE %OWNINTEGER INITIALISED=0;! SET TO 1 AFTER BASIC INITIALISATION
!*
!*
!*NE %OWNINTEGER ROUTE=1
!*NE %OWNINTEGER REPORT=1
!*NE %OWNINTEGER DEPTH=8
!*NE %OWNINTEGER DIAGNOSTICS=4
!*NE %OWNINTEGER ARRAYSIZE
!*E; %EXTRINSICINTEGER BATCH OPTIONS
!*NE %OWNINTEGER BATCH OPTIONS
!*NE %OWNINTEGER BATCH NOPTIONS
!*NE %OWNINTEGER FACILITY
!*NE %OWNINTEGER OPEHINHIB=0
OWNINTEGER MONCPU
OWNINTEGER LAST MODE=0;! 1 COMPILE 2 RUN
!*
!*
OWNINTEGER RUNFLAG
!*NE %OWNSTRING(64) CINPUT=''
!NE %OWNSTRING(64) OMFNAME=''
!*E; %OWNSTRING(64) OMFNAME="SS#TMPOB"
!*NE %OWNSTRING(64) COPTIONS=''
!*NE%OWNSTRING(64) CRUN=''
!*NE %OWNSTRING(64) CSAVELIST=""
!*NE %OWNSTRING(64) CLIBNAME=''
!*
!*NE %OWNSTRING(35) VERSION
!*
!*
OWNLONGINTEGERARRAY COMPS(1:6)=0(6)
!*
!*
!*
!****** BBASE FUNCTIONS
!*
!*NE %SYSTEMINTEGERFNSPEC LOAD MODULE(%STRING(64) MODULE, %C
!*NE %LONGINTEGERNAME ENTRY)
SYSTEMINTEGERFNSPEC OPEN FILE( C
INTEGER CURRENCY, ACCESS TYPE, ABUFF,LBUFF,ARECSIZE, C
AD REC CCY)
SYSTEMINTEGERFNSPEC CLOSE FILE(INTEGER ROUTECCY,AD REC CCY)
!*NE %SYSTEMINTEGERFNSPEC SET SQ MODE(%INTEGER AD REC CCY,ACCESS TYPE,MODE)
!*NE %SYSTEMINTEGERFNSPEC POSITION SQ FILE(%INTEGER ADR,POS)
SYSTEMINTEGERFNSPEC DEFINE FILE(INTEGER TYPE, P, C
STRING (32) IDEN, C
INTEGERNAME CURRENCY, FILE ORG, DEVCLASS, RECTYPE, FE, C
MINREC, MAXREC)
!*NE %SYSTEMINTEGERFNSPEC READ FILE DESCRIPTION(%INTEGER CCY, %C
!*NE %INTEGERNAME ORG,CLASS,TYPE,MIN,MAX)
!*NE %SYSTEMINTEGERFNSPEC READ JS VAR(%STRING(31) NAME, %C
!*NE %INTEGER OPTION,RADDR)
SYSTEMROUTINESPEC STOPBASE
!*NE %SYSTEMINTEGERFNSPEC INIT BASE(%INTEGER MODE,%STRING(63) S)
SYSTEMINTEGERFNSPEC READ CPU TIME
!*B %SYSTEMINTEGERFNSPEC PRIME CONTINGENCY(%ROUTINE CONTPROC)
!*NE %SYSTEMROUTINESPEC SET R LEVEL(%INTEGER LEVEL)
!*NE %SYSTEMROUTINESPEC READ ERROR DATA(%STRINGNAME S,%INTEGERNAME N)
!*B %SYSTEMINTEGERFNSPEC JSEND
!*
!****** OPEH PROCEDURES
!*
!*NE %EXTERNALROUTINESPEC ICL9HEPROLOG(%INTEGER N)
!%SYSTEMINTEGERFNSPEC NOMTIDYPROC(%ROUTINE PROC)
!*NE %SYSTEMINTEGERFNSPEC NOMDESC(%INTEGER D0,D1,%ROUTINE PROC)
!*NE %EXTERNALROUTINESPEC ICL9CERRPROCL
!*NE %EXTERNALROUTINESPEC ICL9CERRPROCR
!*NE %EXTERNALROUTINESPEC ICL9HERRMESSG
!*NE %EXTERNALROUTINESPEC ICL9HERRMESSL
!%EXTERNALROUTINESPEC ICL9CETIDYUP
!*NE %EXTERNALINTEGERFNSPEC ICL9HEAET(%INTEGER OLD0,OLD1,NEW0,NEW1, %C
!*NE IGNORE,CATCH,EMESS,ROUTE,REPORT,COUNT,DEPTH, %C
!*NE DIAGNOSTICS,ARRAYSIZE,CONTINUE,AREAS,OVERRIDE,DUMP)
!*NE %EXTERNALROUTINESPEC ICL9HERESET
!*NE %EXTERNALINTEGERFNSPEC ICLCTM JSWRITE(%INTEGER N0,N1,I0,I1,S0,S1,B0,B1)
!*NE %EXTERNALROUTINESPEC ICLCTM LOG MESSAGE(%INTEGER JTYPE,MTYPE,DR0,DR1)
!*NE %EXTERNALROUTINESPEC ICLCTM SEND MESSAGE(%INTEGER DR0,DR1)
!*E; %SYSTEMROUTINESPEC LOG(%INTEGER MSG ADDR, MSG LENGTH)
!*
!****** MAIN
!*
!*E; %SYSTEMROUTINESPEC SSMESSA(%INTEGER F, %STRING(17) M)
!*NE %SYSTEMROUTINESPEC LOG99
SYSTEMROUTINESPEC PHEX(INTEGER N)
SYSTEMINTEGERMAPSPEC COMREG(INTEGER I)
!*NE %SYSTEMROUTINESPEC MOVE(%INTEGER L, FROM, TO)
SYSTEMROUTINESPEC FILL(INTEGER L,FROM,FILLER)
!*NE %SYSTEMROUTINESPEC ETOI(%INTEGER ADDR,LEN)
!*NE %SYSTEMROUTINESPEC ITOE(%INTEGER ADDR,LEN)
!*NE %SYSTEMROUTINESPEC DATIME(%STRINGNAME DATE,TIME)
SYSTEMROUTINESPEC INITMAIN(INTEGER OPSYS,MODE)
SYSTEMROUTINESPEC IOCP(INTEGER I,J)
!*NE %SYSTEMINTEGERFNSPEC RUNCOMP(%INTEGER FACILITY,OPSYS, %C
!*NE %LONGINTEGERNAME ENTRYDR,%STRINGNAME TEXT)
SYSTEMROUTINESPEC GET AREA DESCS(ROUTINE MAIN,FILE,DIAG,OMF,LPUT, C
FLIB,ALIB)
!*
!****** AREA
!*
!*NE %ROUTINESPEC INITAREAS
!*NE %ROUTINESPEC OUTFILE(%STRING(31) S,%INTEGER LEN,MAXLEN,USE, %C
!*NE %INTEGERNAME CONAD,FLAG)
!*E; %SYSTEMROUTINESPEC OUTFILE(%STRING(31) S, %INTEGER LEN, %C
MAXLEN,USE, INTEGERNAME CONAD,FLAG)
!*
!****** JBR
!*
SYSTEMROUTINESPEC INIT JBR
SYSTEMINTEGERFNSPEC GET ROUTE(INTEGER AFD)
!*E; %SYSTEMROUTINESPEC JBR CLI(%INTEGERNAME I)
!*NE %INTEGERFNSPEC JBR CALL(%INTEGER ENTRY,%INTEGERNAME PARAM)
!*
!****** DIAG
!*
!*E; %SYSTEMROUTINESPEC SSERR(%INTEGER N)
SYSTEMROUTINESPEC ICL MATHS ERROR ROUTINE(INTEGER ADDRESS OF 5 BYTES)
!*K %SYSTEMROUTINESPEC ONTRAP(%INTEGER SUBCLASS,CLASS)
!*NE %SYSTEMROUTINESPEC ONTRAPB(%INTEGER EVENT,SUBCLASS,CLASS)
!%SYSTEMSTRINGFNSPEC RELEASE
!*
SYSTEMROUTINESPEC LPUT
SYSTEMROUTINESPEC FIO1
SYSTEMROUTINESPEC GETSQ
SYSTEMROUTINESPEC ONTRAPACT
!*NE %SYSTEMROUTINESPEC NROBJ
ROUTINESPEC STOP
!*
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
INTEGER C0, C1, C2, C3, TRANSFERS, C
INTEGER DARECNUM,LASTREC,RECORDS, C
STRING (31) IDEN)
!*
!%RECORDFORMAT TCFMT(%INTEGER PAGE COUNT,USER TRANSFER COUNT, %C
! USER PRINT COUNT,TOTAL PRINT COUNT, %C
! OUTPUT LIMIT,PAGE SIZE)
!*
OWNINTEGERARRAY SSFDMAP(0:109)
!*
INTEGERFNSPEC PARM(STRING (63) S)
INTEGERFNSPEC NEW DESC(INTEGER DSNUM,TYPE,ACCESS ROUTE, C
MODE,IDENTYPE,STRING (31) IDEN,INTEGERNAME AFD)
INTEGERFNSPEC RESETFDS
EXTERNALINTEGERFNSPEC LOAD COMPILER(INTEGER C
TYPE,STRING (31) ENTRY, INTEGERNAME AENTRY)
!*NE %INTEGERFNSPEC RESET BUFFERS
!*
!***********************************************************************
!* *
!* INITIALISATION *
!* *
!***********************************************************************
!*
!*NE %CONSTSTRING(13) PROCL=E'ICL9CERRPROCL'
!*NE %CONSTSTRING(13) PROCR=E'ICL9CERRPROCR'
!*NE %CONSTSTRING(13) MESSG=E'ICL9HERRMESSG'
!*NE %CONSTSTRING(13) MESSL=E'ICL9HERRMESSL'
!*
!* SSLEVEL NOW IN COMREG(1)
!%OWNINTEGER SSLEVEL; !-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!
!*
!*
!*NE %OWNINTEGER MSGLEVEL = 1
OWNINTEGER L99=0
!*
!*
OWNINTEGER STARTCPU
!*NE %OWNINTEGER ENDCPU
!*
OWNINTEGERARRAY SIGDATA(-3 : 65) = M'SIGD',M'ATA ',0(67)
! 3*88 BYTE RECORDS
!*
!*
!****** FILE
!*
!*NE %ROUTINESPEC CONNECT(%STRING (15) S, %C
!*NE %INTEGER ACCESS, MAXBYTES, USE, %RECORDNAME R, %C
!*NE %INTEGERNAME FLAG)
!*NE %ROUTINESPEC TIDY AREAS(%INTEGER N)
!*
!*
ROUTINE LOG MESS(INTEGER TYPE,STRING (63) TEXT)
!*NE %INTEGER I,J
!*NE %IF TEXT='' %THEN %RETURN
!*NE I=LENGTH(TEXT)
!*NE J=ADDR(TEXT)+1
!*NE ITOE(J,I)
!*NE %IF TYPE=4 %THENSTART
!*NE ICLCTM SEND MESSAGE(X'18000000'!I,J)
!*NE %FINISHELSESTART
!*NE ICLCTM LOG MESSAGE(TYPE,0,X'18000000'!I,J)
!*NE %FINISH
!*E; LOG(ADDR(TEXT),LENGTH(TEXT))
END ;! LOG MESS
!*
ROUTINE INITFILE(ROUTINE ICL MATHS ERROR ROUTINE)
INTEGER I, J,K,L
LONGLONGREAL RRRR
CONSTBYTEINTEGERARRAY P(0:19)= C
108,1,X'D', 0,
99,2,X'2', 0,
101,6,X'D',108,
102,6,X'2', 99,
100,3,2,0
!*NE %CONSTSTRING(16)%ARRAY KEY(0:2)= %C
!*NE 'ICL9CEDEFOPTIONS',
!*NE 'ICL9CEMOPTIONS',
!*NE 'OPTIONS'
!*NE %STRING(255) OPTIONS
STRING (63) S
*LSQ_(LNB +5)
*ST_RRRR
!*NE OPEHMODE=0
!*NE OPEHINHIB=0
MONCPU=0
ICL9CEMAINLNB=0
!*NE ICL9CEFAC=FACILITY
ICL9CEFDMAP=ADDR(SSFDMAP(0))
!*NE SET R LEVEL(0)
!*NE %IF FACILITY=4 %THEN I=3 %ELSE I=0
!*E; I=0;! SPECIAL ACTION FOR EXEC.
INITMAIN(OPSYS,I)
ICL9CEJSTATE=0
COMREG(33)=ADDR(SIGDATA(0))
SIGDATA(1)=-1;! WILL GIVE DIAGS AFTER ICL9CEJINIT
! %IF FACILITY=4 %THEN %C
! VERSION=''
! VERSION='EDINBURGH SOFTWARE ENVIRONMENT B40'
! PRINTSTRING(VERSION)
! NEWLINE
!*NE %IF FACILITY=0 %THEN %C
!*NE LOGMESS(4,VERSION)
!*
!****** PREPARE BASE AND CONTINGENCY TRAPS
!*
S=''
!*NE I=INITBASE(FACILITY,CSAVELIST)
!*NE SET R LEVEL(0)
COMREG(25)=2;! MINIMUM DIAGS AS DEFAULT
L99=0
IOCP(11,-2);! INITIALISE OUTPUT
!*
!*B I=PRIME CONTINGENCY(ONTRAPB)
!*K I=PRIME CONTINGENCY(ONTRAP)
!*
!****** INITIALISE AREAS,OPTIONS,FILE DESCRIPTORS
!*
!*NE INITAREAS
I=RESET FDS
ICL9CETC=COMREG(49);! TRANSFER COUNT RECORD
COMREG(60)=RUNFLAG
!*NE BATCH OPTIONS=X'81400001';! STACK LIMIT DEFINED,EBCDIC,QUOTES
!*NE COMREG(26)=X'80800000'
COMREG(27)=BATCH OPTIONS
! %UNLESS ICL9CEFAC=4 %THENSTART
!*B; K=0
!*B; L=1
!*
!*K L=2
!*K K=2
!*NE %CYCLE J=K,1,L
!*NE I=READ JS VAR(KEY(J),2,ADDR(OPTIONS))
!*NE %IF I=0 %THEN I=PARM(OPTIONS)
!*NE BATCH OPTIONS=COMREG(27)
!*NE BATCH NOPTIONS=COMREG(26)
!*NE %REPEAT
!*NE %IF ICL9CEFAC=0 %THEN OPTIONS='' %ELSE OPTIONS=COPTIONS
!*NE I=PARM(OPTIONS)
!*NE BATCH NOPTIONS=COMREG(26)
!*NE BATCH OPTIONS=COMREG(27);! SETS USER OPTIONS (STAND-ALONE)
! %FINISH
!*
!*
IF MONCPU#0 THEN STARTCPU=READ CPU TIME
I=ADDR(SSFDMAP(0))
FILL(440,I,0)
ICL9CEFDMAP=I
COMREG(17) = I
!*
I=COMREG(21);! ADDR(BASICFDS(0))
FILL(448,I,0)
!*
! SSFDMAP(108)=I
! SSFDMAP(101)=I+112
! SSFDMAP(102)=I+224
! SSFDMAP(99)=I+336
! J=NEW DESC(108,1,1,X'D',0,'',I)
! J=NEW DESC(99,1,2,2,0,'',I)
! J=NEW DESC(101,1,6,X'D',108,'',I)
! J=NEW DESC(102,1,6,2,99,'',I)
!*
!*NE %CYCLE J=0,4,12
!*E; %CYCLE J=0,4,16
SSFDMAP(P(J))=I
I=I+112
K=NEW DESC(P(J),1,P(J+1),P(J+2),P(J+3),'',L)
REPEAT
!*
!*
COMREG(52)=ADDR(OMFNAME)
!*NE COMREG(58)=ADDR(CLIBNAME)
COMREG(59)=ADDR(COMPS(1))
!*
!****** PREPARE AUXILIARY %IF STACK FOR IMP/ALGOL
!*
OUTFILE('SS#AUXST',X'40000',0,0,I,J)
!*E; %IF J#0 %THEN SSERR(J)
COMREG(37) = I; ! ADDRESS OF AUX STACK
J=ADDR(ICL9CEAUXST)
INTEGER(J)=X'28040000'
INTEGER(J+4)=I
COMREG(41)=J;! FOR USE BY LOAD FILLING SZAUXST REFS
INTEGER(I) = I+16
INTEGER(I+8) = I+X'40000'
!*
!*
!****** INITIALISE JOBBER
!*
!*NE !*SJ %IF FACILITY=0 %THENSTART;! INIT JOBBER
!*NE !*SJ COMREG(58)=ADDR(VERSION)
!*SJ; COMREG(60)=ADDR(RRRR)
!*NE !*SJ J=OPSYS
!*E; I=ADDR(ICL9LDLIBPROC)
!*E; LONGINTEGER(I)=LONGINTEGER(COMREG(60))
!*E; LONGINTEGER(I+8)=0
!*E; INIT JBR
!*NE !*SJ I=JBR CALL(0,J)
!*NE !*SJ %FINISH
IF L99=0 THEN INITMAIN(OPSYS,2);! SET 'NO CURRENT STREAM'
!*NE !*B %UNLESS FACILITY = 4 %THEN %START
!*E; GET AREA DESCS(INITMAIN,STOP,ONTRAPACT,LPUT,LPUT,FIO1,GETSQ)
!*NE !*B GET AREA DESCS(INITMAIN,STOP,ONTRAPACT,NROBJ,LPUT,FIO1,GETSQ)
!*NE !*B %FINISH
END ;! INITFILE
!*
!*NE %ROUTINE OPEH DEFAULTS(%INTEGER MODE);! MODE#0 SET ERROR TABLE
!*NE %CONSTSTRING(14) ID=E'ICL9HEJSERRTAB'
!*NE %INTEGERARRAY VAL(0:11)
!*NE %INTEGER I,J
!*NE %IF OPEHINHIB=0 %THENSTART
!*NE ! I=NOMTIDYPROC(ICL9CETIDYUP)
!*NE I=NOMDESC(X'1800000D',ADDR(PROCL)+1,ICL9CERRPROCL)
!*NE I=NOMDESC(X'1800000D',ADDR(PROCR)+1,ICL9CERRPROCR)
!*NE I=NOMDESC(X'1800000D',ADDR(MESSG)+1,ICL9HERRMESSG)
!*NE I=NOMDESC(X'1800000D',ADDR(MESSL)+1,ICL9HERRMESSL)
!*NE !*
!*NE %IF MODE#0 %THEN %C
!*NE J=ICL9HEAET(-1,-1,X'30000006',ADDR(VAL(0)), %C
!*NE 0,-1,-1,-1,-1,-1,DEPTH,DIAGNOSTICS,ARRAYSIZE, %C
!*NE -1,-1,-1,-1)
!*NE %IF J>0 %THENSTART
!*NE -> NOMESS
!*NE SELECTOUTPUT(100)
!*NE PRINTSTRING('ICL9HEAET RESPONSE =')
!*NE WRITE(J,1)
!*NE NEWLINE
!*NE %FINISHELSESTART
!*NE I=ICLCTM JSWRITE(X'1800000E',ADDR(ID)+1,-1,-1, %C
!*NE X'18000030',ADDR(VAL(0)),-1,-1)
!*NE %FINISH
!*NE NOMESS: ->L1
!*NE ICL9HERESET
!*NE L1: ICL9HEPROLOG(0)
!*NE OPEHMODE=1
!*NE %FINISH
!*NE %END;! OPEH DEFAULTS
EXTERNALROUTINE ICL9CEJINIT
INTEGER I
*STLN_I
!*NE FACILITY=4
!*NE ICL9CEAVOLS=1
INITFILE(ICL MATHS ERROR ROUTINE)
!*NE OPEH DEFAULTS(0)
COMREG(36)=INTEGER(I);! LNB VALUE TO STOP DIAGNOSTICS
!*E; %IF COMREG(36)&4=0 %THEN COMREG(36)=COMREG(36)!1
END ;! ICL9CEJINIT
!*
!*
!*
!*NE %ROUTINE END TEXT(%STRING(31) TEXT)
!*NE %INTEGER I
!*NE %IF COMREG(23)=99 %THEN I=0 %ELSE I=-1
!*NE IOCP(11,-1);! TO LOSE ANY TEXT LEFT IN BUFFER
!*NE LOG MESS(4,TEXT)
!*NE %IF MONCPU=1 %THENSTART
!*NE ENDCPU=READ CPU TIME
!*NE SELECT OUTPUT(100)
!*NE PRINTSTRING(' CPU USED:')
!*NE PRINT((ENDCPU-STARTCPU)/1000.0,3,2)
!*NE PRINTSTRING(' SECS')
!*NE NEWLINE
!*NE %FINISH
!*NE %END;! ENDTEXT
!*NE !*
SYSTEMROUTINE TIDY EXIT
!*NE %INTEGER I
!*NE I=CLOSE FILE(COMREG(54),0)
!*NE I=CLOSE FILE(0,COMREG(55));! DESELECT PRINT FILE
!*NE TIDY AREAS(0)
STOP BASE
END ;! TIDY EXIT
!*
ROUTINE MAIN
!*NE %STRING(31) TEXT,NAME
LONGINTEGER ENTRYDR
INTEGER I
SWITCH S(0:10)
*STLN_I
ICL9CEMAINLNB=I
COMREG(36)=I
COMREG(48)=X'E000';! STACK LIMIT
!*NE TEXT=''
->S(ICL9CEJSTATE)
!*
!****** INITIAL ENTRY
S(0): COMREG(24)=X'81000000';! TO AVOID SPURIOUS MESSAGE IF FIRST COMP. FAILS
IF MONCPU=1 THEN START CPU = READ CPU TIME
COMREG(1)=1
CALL BCI:
!*NE %IF FACILITY=0 %THENSTART;! JOBBER
SELECTOUTPUT(99)
!*E; JBRCLI(ICL9CEJSTATE)
!*NE I=JBR CALL(1,ICL9CEJSTATE);! == JBRCLI(ICL9CEJSTATE)
!*NE TEXT='BATCH COMPLETED'
!*NE %FINISHELSESTART;! SOLO MODE
!*NE %IF ICL9CEJSTATE#0 %THEN STOPBASE
!*NE ICL9CEJSTATE=1
!*NE %IF FACILITY#4 %THENSTART
!*NE I=RUNCOMP(FACILITY,OPSYS,ENTRYDR,NAME)
!*NE %IF I=0 %THENSTART;! ENTER COMPILED PROGRAM
!*NE LOG MESS(4,'PROGRAM '.NAME.' ENTERED')
!*NE TEXT='RUN COMPLETED'
!*NE !*NE OPEH DEFAULTS(1)
!*NE SELECTOUTPUT(99)
!*NE LAST MODE=2
!*NE *LD_ENTRYDR
!*NE *STLN_%TOS
!*NE *ASF_4
!*NE *RALN_5
!*NE *CALL_(%DR)
!*NE ! SELECTOUTPUT(99)
!*NE ! NEWPAGE
!*NE ! NEWLINE
!*NE %FINISH
!*NE %FINISH
!*NE %FINISH
!*NE I=CLOSE FILE(COMREG(54),0)
!*NE I=CLOSE FILE(0,COMREG(55));! DESELECT PRINT FILE
!*NE ENDTEXT(TEXT)
!*E; IOCP(11,-1)
!*E; LOGMESS(4,"BATCH COMPLETE")
EXIT:
!*NE TIDY AREAS(0)
STOP BASE
!*
!****** FAILURE IN USER JOB
S(1):
!*
!****** JOB ABORTING
S(2):
!*
!****** TIME EXCEEDED/OP TERMINATION
S(3):
!*
!****** OUTPUT EXCEEDED
S(4): ->CALL BCI
!*
!****** USER PROG DIAGS FAILURE
S(5):
!*
!****** SOFTWARE DETECTED ERROR
S(6): !ICL9CEJSTATE=1
->CALL BCI
!*
!****** IO ERROR ON PRIMARY OUTPUT STREAM
S(7): ->EXIT
!*
!****** HARDWARE DETECTED ERROR IN SUBSYSTEM
S(8):
!*
!****** SUBSYSTEM LOGICAL ERROR
S(9):
COMREG(25)=0
ICL9CEJSTATE=10
->EXIT
!*
!****** ABORT (FAILURE WHILE DIAGNOSING SUBSYSTEM ERROR)
S(10): ->EXIT
END ;! MAIN
!*
!*
ROUTINE CONTROL(INTEGER FAC)
!*NE FACILITY=FAC
!*NE !*B ICL9CEDOBEGIN = 1
INITFILE(ICL MATHS ERROR ROUTINE)
ICL9CEJSTATE=0
LOOP: MAIN
->LOOP
END ;! CONTROL
!*
SYSTEMROUTINE STOP
INTEGER I,J
!*NE %IF FACILITY=4 %THEN TIDY EXIT
I=COMREG(36)
*STLN_J
UNLESS J>>18 = I>>18 THENSTART
STOPBASE
FINISH
*LLN_I
*EXIT_-64
END ;! STOP
!*
!*
EXTERNALINTEGERFN ICL9CESUBS(INTEGER ENTRY)
CONTROL(ENTRY)
STOPBASE
END ;! ICL9CESUBS
!*NE !*
!*NE %SYSTEMINTEGERFN JBR CALL(%INTEGER ENTRY,%INTEGERNAME PARAM)
!*NE %LONGINTEGER DESC
!*NE DESC=COMPS(4)
!*NE *STLN_%TOS
!*NE *ASF_4
!*NE *LSS_ENTRY
!*NE *SLSD_PARAM
!*NE *ST_%TOS
!*NE *LD_DESC
!*NE *RALN_8
!*NE *CALL_(%DR)
!*NE *EXIT_-64
!*NE %RESULT=0
!*NE %END;! JBR CALL
!*
!*
SYSTEMINTEGERMAP FDMAP(INTEGER I)
RESULT =ADDR(SSFDMAP(I))
END ;! FDMAP
!*
!*
!***********************************************************************
!* *
!* AREA MANAGEMENT *
!* *
!***********************************************************************
!*
!*K %EXTERNALINTEGERFNSPEC DELETE AREA(%INTEGER DR0,DR1)
!*
!****** BASE FUNCTIONS
!*
!*NE %SYSTEMINTEGERFNSPEC NEWAREA(%STRING(15) NAME,%INTEGER AREA SIZE, %C
!*NE MAXSIZE,AMODE,%INTEGERNAME AREADR0,AREADR1)
!*NE %SYSTEMINTEGERFNSPEC CHANGE AREA PROPERTIES( %C
!*NE %INTEGER AREA DR0,AREA DR1,REL RACR,REL WACR,EXEC, %C
!*NE AMODE,SIZE,CONTENT)
!*NE !*
!*NE !*
!*NE %CONSTINTEGER VFMAX = 16
!*NE %CONSTINTEGER VFSIZE = 44
!*NE !*
!*NE %OWNINTEGER VFHEAD, FREEFHEAD
!*NE %OWNINTEGERARRAY VFDESCRIPTORS(0 : 175); ! 16 VIRTUAL FILES
!*NE !*
!*NE %RECORDFORMAT VFDESC(%STRING (15) S, %C
!*NE %INTEGER CONAD, CURL, MAXL, LINK,MODE,DESC0,DESC1)
!*NE !*
!*NE %RECORDFORMAT RF(%INTEGER CONAD, FILESIZE,DATASTART,DATAEND)
!*NE !*
!*NE !*
!*NE %ROUTINE INITAREAS
!*NE %INTEGER I, J
!*NE %RECORDNAME VF(VFDESC)
!*NE VFHEAD = 0
!*NE J = ADDR(VFDESCRIPTORS(0))
!*NE FILL(VFMAX*VFSIZE,J,0)
!*NE FREEFHEAD = J
!*NE COMREG(31) = J; ! FOR DIAGNOSTICS
!*NE %CYCLE I = 0,1,VFMAX-2
!*NE VF == RECORD(J)
!*NE J = J+VFSIZE
!*NE VF_LINK = J
!*NE %REPEAT
!*NE %END; ! INITK
!*
!*
!*NE %SYSTEMROUTINE TIDY AREAS(%INTEGER N)
!*NE %INTEGER I,J
!*NE %RECORDNAME VF(VFDESC)
!*K ICL9CEAUXST=0
!*K I=VFHEAD
!*K %WHILE I#0 %CYCLE
!*K VF==RECORD(I)
!*K J=DELETE AREA(VF_DESC0,VF_DESC1)
!*K I=VF_LINK
!*K %REPEAT
!*B;! I=JS END
!*NE %END;! TIDY AREAS
!*
!*
!*NE %SYSTEMROUTINE CHANGE USE(%STRING(15) S,%INTEGER NEW USE, %C
!*NE %INTEGERNAME FLAG)
!*NE !* NEW USE = 0 READ/WRITE
!*NE !* 1 EXECUTE/READ
!*NE %RECORDNAME VF(VFDESC)
!*NE %INTEGER I,J
!*NE %UNLESS 0<=NEW USE<=1 %THEN FLAG=1 %AND %RETURN
!*NE I=VFHEAD
!*NE %WHILE I#0 %CYCLE
!*NE VF==RECORD(I)
!*NE %IF VF_S=S %THENSTART
!*NE %UNLESS VF_MODE=NEW USE %THENSTART
!*NE %IF NEW USE=0 %THEN J=1 %ELSE J=0
!*NE FLAG=CHANGE AREA PROPERTIES(VF_DESC0,VF_DESC1, %C
!*NE 1,J,NEWUSE,2,-1,-1)
!*NE %RETURN %IF FLAG>0
!*NE VF_MODE=NEW USE
!*NE %FINISH
!*NE FLAG=0
!*NE %RETURN
!*NE %FINISH
!*NE I=VF_LINK
!*NE %REPEAT
!*NE FLAG=3;! FILE DOES NOT EXIST
!*NE %END;! CHANGE USE
!*NE !*
!*NE %SYSTEMINTEGERFN SET CONTENT LIMIT(%STRING(15) S,%INTEGER NEW LIMIT)
!*NE %RECORDNAME VF(VFDESC)
!*NE %INTEGER I
!*NE I=VFHEAD
!*NE %WHILE I#0 %CYCLE
!*NE VF==RECORD(I)
!*NE %IF VF_S=S %THENSTART
!*NE %RESULT=CHANGE AREA PROPERTIES(VF_DESC0,VF_DESC1, %C
!*NE -1,-1,-1,-1,-1,NEW LIMIT)
!*NE %FINISH
!*NE I=VF_LINK
!*NE %REPEAT
!*NE %RESULT=3;! FILE DOES NOT EXIST
!*NE %END;! SET CONTENT LIMIT
!*NE !*
!*NE %SYSTEMROUTINE REMOVE AREA(%STRINGNAME S)
!*NE %INTEGER I
!*NE I=SET CONTENT LIMIT(S,0)
!*NE %END;! REMOVE AREA
!*NE !*
!*NE %SYSTEMINTEGERFN CHFSIZE(%STRING(15) S,%INTEGER CHANGE, %C
!*NE %INTEGERNAME NEWSIZE,FLAG)
!*NE %RECORDNAME VF(VFDESC)
!*NE %INTEGER I
!*NE I=VFHEAD
!*NE %WHILE I#0 %CYCLE
!*NE VF==RECORD(I)
!*NE %IF VF_S=S %THENSTART
!*NE NEWSIZE=VF_MAXL
!*NE FLAG=0
!*NE %RESULT=0
!*NE %FINISH
!*NE I=VF_LINK
!*NE %REPEAT
!*NE FLAG=1
!*NE %RESULT=1
!*NE %END;! CHFSIZE
!*NE !*
!*NE %SYSTEMROUTINE OUTFILE(%STRING (15) S, %C
!*NE %INTEGER LENGTH, MAXBYTES, USE, %INTEGERNAME CONAD,FLAG)
!*NE %INTEGER I, J, D0,D1
!*NE %STRING(15) T,U,V
!*NE %RECORDNAME VF(VFDESC)
!*NE %IF MAXBYTES < LENGTH %THEN MAXBYTES = LENGTH
!*NE I = VFHEAD
!*NE J = ADDR(VFHEAD)
!*NE %WHILE I # 0 %CYCLE
!*NE VF == RECORD(I)
!*NE %IF S = VF_S %THENSTART
!*NE %IF MAXBYTES <= VF_MAXL %THENSTART
!*NE CONAD = VF_CONAD
!*NE ! I=SET CONTENT LIMIT(S,0)
!*NE -> OUT
!*NE %FINISHELSESTART
!*NE FLAG=1
!*NE %RETURN
!*NE %FINISH
!*NE %FINISH
!*NE J = ADDR(VF_LINK)
!*NE I = VF_LINK
!*NE %REPEAT
!*NE !* CREATE A NEW AREA
!*NE %UNLESS 0 < MAXBYTES <= X'80000' %THEN FLAG=17 %AND %RETURN
!*NE ! INVALID FILE SIZE
!*NE MAXBYTES = (MAXBYTES+1023)&X'FFC00'; ! ROUND TO PAGE BOUNDARY
!*NE %IF S->T.("#").U %THEN V=T."Z".U %ELSE V=S
!*NE I=NEWAREA(V,MAXBYTES,MAXBYTES,2,D0,D1)
!*NE %IF I # 0 %THEN FLAG=-1 %AND %RETURN
!*NE I = FREEFHEAD
!*NE J = ADDR(FREEFHEAD)
!*NE %WHILE I # 0 %CYCLE
!*NE VF == RECORD(I)
!*NE %IF VF_CONAD = 0 %THENSTART
!*NE VF_S = S
!*NE VF_MAXL = MAXBYTES
!*NE VF_CONAD = D1
!*NE VF_DESC0=D0
!*NE VF_DESC1=D1
!*NE VF_MODE=0
!*NE INTEGER(J) = VF_LINK
!*NE VF_LINK = VFHEAD
!*NE VFHEAD = I
!*NE -> OUT
!*NE %FINISH
!*NE J = ADDR(VF_LINK)
!*NE I = VF_LINK
!*NE %REPEAT
!*NE FLAG = 5 ; ! TOO MANY ENTRIES
!*NE %RETURN
!*NE !*
!*NE OUT: VF_CURL = LENGTH
!*NE CONAD = VF_CONAD
!*NE %IF VF_MODE#0 %THENSTART
!*NE CHANGE USE(VF_S,0,FLAG)
!*NE %IF FLAG>0 %THEN %RETURN
!*NE %FINISH
!*NE COMREG(30) = VFHEAD
!*NE COMREG(32) = FREEFHEAD
!*NE FLAG=0
!*NE %IF USE=-1 %THEN %RETURN;! AVOID WRITING TO AREA AT THIS STAGE
!*NE I=CONAD
!*NE INTEGER(CONAD)=16
!*NE INTEGER(CONAD+4)=16
!*NE INTEGER(CONAD+8)=LENGTH
!*NE INTEGER(CONAD+12)=0
!*NE %RETURN
!*NE %END;! INITAREA
!*NE !*
!*NE !*
!*NE %SYSTEMROUTINE CONNECT(%STRING(15) S,%INTEGER ACCESS, %C
!*NE MAXBYTES,USE,%RECORDNAME R,%INTEGERNAME FLAG)
!*NE %RECORDNAME VF(VFDESC)
!*NE %RECORDSPEC R(RF)
!*NE %INTEGER I
!*NE !*
!*NE I = VFHEAD
!*NE %WHILE I # 0 %CYCLE
!*NE VF == RECORD(I)
!*NE %IF VF_S = S %THENSTART
!*NE R_CONAD = VF_CONAD
!*NE R_FILESIZE = VF_CURL
!*NE FLAG=0
!*NE %RETURN
!*NE %FINISH
!*NE I = VF_LINK
!*NE %REPEAT
!*NE FLAG = 3; ! FILE DOES NOT EXIST
!*NE %RETURN
!*NE %END;! CONNECT AREA
!*
!*
!*
!*
!***********************************************************************
!* *
!* OPTION PROCESSING *
!* *
!***********************************************************************
!*
CONSTSTRING (9)ARRAY PARMS(0:29)= C
'QUOTES','NOLIST','NODIAG','STACK',
'NOCHECK','NOARRAY','NOTRACE','SMAP',
'NORUN','INHIBIOF','ZERO','XREF',
'LABELS','LET','CODE','ATTR',
'OPT','INHIBOPEH','####','FREE',
'####','####','EBCDIC','NOLINE',
'####','MAXKEYS','I8','L8',
'R8','MISMATCH'
!*
CONSTSTRING (10)ARRAY ALTPARMS(0:29)= C
'PERCENT','LIST','DIAG','NOSTACK',
'CHECK','ARRAY','TRACE','####',
'RUN','####','####','NOXREF',
'NOLABELS','NOLET','NOCODE','NOATTR',
'####','####','####','FIXED',
'####','####','ISO','LINE',
'####','MINKEYS','I4','L4',
'R4','NOMISMATCH'
!*
!*NE %CONSTSTRING(9)%ARRAY NPARMS(0:13)= %C
!*NE 'OMFMAP','FIXUPS','MAXKEYS','NOCASCADE',
!*NE 'LIBRARY','CASCADE','MAP','TEST1',
!*NE 'TEST2','TEST3','TEST4','LOCAL','SPARSE',
!*NE 'MONCPU'
!*
ROUTINESPEC PRINT OPTIONS(INTEGER COMP)
!*
SYSTEMINTEGERFN PARM(STRING (63) S)
STRING (63) T
INTEGER I, J, K, FLAG, NOPT
!*NE %SWITCH NSW(5:13)
FLAG = 0
I = BATCH OPTIONS
!*NE NOPT=BATCH NOPTIONS
IF S="?" THENSTART
PRINT OPTIONS(0)
RESULT =0
FINISH
L1: IF S = '' THEN START
COMREG(27) = I
!*NE COMREG(26)=NOPT
RESULT =0
FINISH
UNLESS S -> T.(",").S THEN START
UNLESS S->T.("&").S THENSTART
T = S
S = ''
FINISH
FINISH
CYCLE J = 0,1,29
IF PARMS(J) = T THEN START
!*NE %IF J=17 %THEN OPEHINHIB=1 %AND ->L1
I = I!(1<<J)
-> L1
FINISH
IF ALTPARMS(J)=T THENSTART
K=(-1)!!(1<<J)
I=I&K
->L1
FINISH
REPEAT
!*NE %CYCLE J=0,1,13
!*NE %IF NPARMS(J)=T %THENSTART
!*NE %IF J<=4 %THENSTART
!*NE NOPT=NOPT!(1<<J)
!*NE ->L1
!*NE %FINISHELSE ->NSW(J)
!*NE %FINISH
!*NE %REPEAT
PRINTSTRING('***INVALID OPTION '.T.' IGNORED
')
->L1
!*NE NSW(5): NOPT=NOPT&X'FFFFFFF7';! NOCASCADE
!*NE ->L1
!*NE NSW(6): I=I!X'8000';! MAP
!*NE ->L1
!*NE L3:
!*NE NSW(7): K=3;! TEXT1
!*NE L2: SET R LEVEL(K)
!*NE ->L1
!*NE NSW(9): LOG99;! TEST3
!*NE L99=1
!*NE ->L3
!*NE NSW(8): K=4;! TEST2
!*NE ->L2
!*NE NSW(10):
!*NE OPEHINHIB=1;! TEST4
!*NE COMREG(25)=0
!*NE ->L1
!*NE NSW(11): NOPT=NOPT!X'15800000';! LOCAL
!*NE ->L1
!*NE NSW(12): NOPT=NOPT!X'AA800000';! SPARSE
!*NE ->L1
!*NE NSW(13): MONCPU=1
!*NE ->L1
END ; !OF PARM
!*
ROUTINE PRINT OPTIONS(INTEGER COMP)
INTEGER I,J,K,L,M
CONSTBYTEINTEGERARRAY INDEX(0:17)= C
1, 4, 5,23, 2,16, 6,12,15,11,14, 0,22,28,26,27, 9,29
CONSTBYTEINTEGERARRAY MASK(0:17)= C
7,14, 7, 7, 7,21, 1, 4, 4, 4,20, 3, 8, 4, 4, 4,20, 4
ROUTINESPEC P(STRING (15) S)
PRINTSTRING('
COMPILATION OPTIONS: ')
J=COMREG(27)
K=0
CYCLE I=0,1,17
M=MASK(I)
IF COMP=2 THEN M=M>>2
L=INDEX(I)
IF J&(1<<L)=0 THENSTART
UNLESS J&X'10000'#0 AND (4<=L<=6 OR L=23) START
IF M&2#0 OR (COMP=0 AND M&16=0) THEN P(ALTPARMS(L))
FINISH
FINISHELSESTART
IF M&1#0 OR (COMP=0 AND M&16=0) THEN P(PARMS(L))
FINISH
REPEAT
!*NE J=COMREG(26)
!*NE %CYCLE J=0,1,4
!*NE %IF J&(1<<I)#0 %THEN P(NPARMS(I))
!*NE %REPEAT
IF K=0 THEN PRINTSTRING('DEFAULTS')
NEWLINES(2)
RETURN
!*
ROUTINE P(STRING (15) S)
IF K#0 THEN PRINTSYMBOL(',')
PRINTSTRING(S)
K=K+1
END ;! P
END ;! PRINT OPTIONS
!*
SYSTEMINTEGERFN SETPARS(INTEGER COUNT, C
STRING (255) PARSTRING, STRINGARRAYNAME PAR, KEY)
!* PROCESSES THE TOTAL PARAMETER STRING PARSTRING TO EXTRACT COUNT
!* PARAMETERS, WHICH MAY BE POSITIONAL AS IDENTIFIER BY KEYWORDS
STRING (255) CURPAR, CURKEY, TEST
INTEGER I
CYCLE I=1,1,COUNT
PAR(I)=''
REPEAT
I=0
WHILE PARSTRING#'' CYCLE
UNLESS PARSTRING->CURPAR.(",").PARSTRING C
THEN CURPAR=PARSTRING AND PARSTRING=''
IF LENGTH(CURPAR)>63 THEN LENGTH(CURPAR)=63
IF CURPAR->CURKEY.("=").CURPAR THEN START
CYCLE I=1,1,COUNT
IF CURKEY=KEY(I) THEN START
FOUND: PAR(I)=CURPAR
->NEXTPAR
FINISH
REPEAT
IF LENGTH(CURKEY)=3 THEN START ; ! MATCH ON FIRST 3 CHARS ALLOWED
CYCLE I=1,1,COUNT
TEST=KEY(I)
IF LENGTH(TEST)>3 THEN START
LENGTH(TEST)=3
IF CURKEY=TEST THEN ->FOUND
FINISH
REPEAT
FINISH
RESULT =214; ! INVALID KEYWORD
FINISH ELSE START
IF I=COUNT THEN RESULT =215; ! TOO MANY PARAMS
I=I+1
PAR(I)=CURPAR
FINISH
NEXTPAR:
REPEAT
RESULT =0
END ; ! SETPARS
!*
!%SYSTEMROUTINE SOLOPARS(%STRING(255) S)
!%CONSTSTRING(8)%ARRAY KEY(1:10)= %C
! 'INPUT','OMF','OPTIONS','RUN','SAVELIST','IN','OM','OP','RU','SA'
!%STRING(63)%ARRAY PAR(1:10)
!%STRING(63) LIB
!%INTEGER I
!*K I=SETPARS(10,S,PAR,KEY)
!*K %CYCLE I=1,1,5
!*K %IF PAR(I)='' %AND PAR(I+5)#'' %THENSTART
!*K PAR(I)=PAR(I+5)
!*K %FINISH
!*K %REPEAT
!*K CINPUT=PAR(1)
!*K OMFNAME=PAR(2)
!*K %UNLESS OMFNAME->CLIBNAME.('.').OMFNAME %THEN CLIBNAME=''
!*K COPTIONS=PAR(3)
!*K S=PAR(4)
!*K %IF S='NO' %OR S='N' %THEN I=0 %ELSE I=1
!*K RUNFLAG=I
!*K CSAVELIST=PAR(5)
!%END;! SOLOPARS
!*
!*
!*NE %SYSTEMROUTINE BSOLOPARS(%LONGINTEGER %C
!*NE INPUT,OMF,RUN,OPTIONS,SAVELIST,PROUTE,PREPORT, %C
!*NE %INTEGER PDEPTH,DIAGS,ARRAY,%LONGINTEGER AVOLS)
!*NE %LONGINTEGERARRAY A(0:6)
!*NE %STRING(63) S,LIB
!*NE %SWITCH V(0:6)
!*NE %INTEGER I,J,LEN,ADDRS
!*NE !*B A(0)=INPUT
!*NE !*B A(1)=OMF
!*NE !*B A(2)=RUN
!*NE !*B A(3)=OPTIONS
!*NE !*B A(4)=SAVELIST
!*NE !*B A(5)=PROUTE
!*NE !*B A(6)=PREPORT
!*NE !*B %CYCLE I=0,1,4
!*NE !*B LEN = (A(I)<<8)>>40
!*NE !*B ADDRS = A(I)&X'00000000FFFFFFFF'
!*NE !*B J=ADDR(S)+1
!*NE !*B MOVE(LEN,ADDRS,J)
!*NE !*B ETOI(J,LEN)
!*NE !*B LENGTH(S)=LEN
!*NE !*B ->V(I)
!*NE REP:
!*NE !*B %REPEAT
!*NE !*B ICL9CEAVOLS = (AVOLS<<8)>>40
!*NE !*B DEPTH = PDEPTH
!*NE !*B DIAGNOSTICS = DIAGS
!*NE !*B ARRAYSIZE = ARRAY
!*NE !*B %RETURN
!*NE !*B !*
!*NE V(0):
!*NE !*B CINPUT=S
!*NE !*B ->REP
!*NE !*B !*
!*NE V(1):
!*NE !*B OMFNAME=''
!*NE !*B %IF S='' %THENSTART;! NO LIBRARY SPECIFIED
!*NE !*B CLIBNAME=''
!*NE !*B %FINISHELSESTART
!*NE !*B %IF S->CLIBNAME.('.').OMFNAME %THENSTART
!*NE !*B %CYCLE
!*NE !*B %EXIT %UNLESS OMFNAME->LIB.('.').OMFNAME
!*NE !*B CLIBNAME=CLIBNAME.'.'.LIB
!*NE !*B %REPEAT
!*NE !*B %FINISHELSE CLIBNAME=S
!*NE !*B %FINISH
!*NE !*B ->REP
!*NE !*B !*
!*NE V(2):
!*NE !*B CRUN=S
!*NE !*B %IF S='NO' %OR S='N' %THEN RUNFLAG=0 %ELSE RUNFLAG=1
!*NE !*B ->REP
!*NE !*B !*
!*NE V(3):
!*NE !*B COPTIONS=S
!*NE !*B ->REP
!*NE !*B !*
!*NE V(4):
!*NE !*B CSAVELIST=S
!*NE !*B ->REP
!*NE V(5):
!*NE !*B %IF S = "NO" %OR S = "N" %THEN ROUTE = 0 %ELSE ROUTE = 1
!*NE !*B -> REP
!*NE V(6):
!*NE !*B %IF S = "NO" %OR S = "N" %THEN REPORT = 0 %ELSE REPORT = 1
!*NE !*B -> REP
!*NE %END ! OF BSOLOPARS
!*
!*
!***********************************************************************
!* *
!* COMPILATION INITIALISATION *
!* *
!***********************************************************************
!*
!*
!*NE %INTEGERFN SET INPUT(%STRING(63) IDEN)
!*NE %INTEGER I,AFD,FILEORG,DEVCLASS,RECTYPE,FE
!*NE %RECORDNAME F(NRFDFMT)
!*NE I=NEWDESC(101,1,4,1,0,IDEN,AFD)
!*NE F==RECORD(AFD)
!*NE I=DEFINE FILE(0,1,IDEN,F_ROUTECCY,FILEORG,DEVCLASS, %C
!*NE RECTYPE,FE,F_MINREC,F_MAXREC)
!*NE %IF I>0 %THEN %RESULT=I
!*NE F_STATUS=1
!*NE F_MODE=2;! READ FORWARDS ONLY
!*NE F_DEVCLASS=DEVCLASS
!*NE %IF DEVCLASS=9 %THEN F_MODE=0;! CONTROL STREAM
!*NE F_FILEORG=FILEORG
!*NE F_RECTYPE=RECTYPE
!*NE F_RECSIZE=F_MAXREC
!*NE COMREG(54)=F_ROUTECCY
!*NE %RESULT=0
!*NE %END;! SET INPUT
!*
INTEGERFNSPEC GET SLOW ROUTE (INTEGER AFD)
!*
SYSTEMINTEGERFN INITCOMP(INTEGER COMP,MODE,NEWP)
OWNLONGINTEGER ALIGN
!*NE %INTEGER AFD
INTEGER I,F,MAX
INTEGER J
!*NE %STRING(10) D,T
! 4 - ALGOL
! 5 - FORTRAN
! 6 - IMP
CONSTSTRING (14) ARRAY CN(4:6)= C
"ICL9CEZALGOL","ICL9CEZFORTRAN","ICL9CEZIMP"
COMREG(24)=COMREG(27)
!*NE %IF OPSYS=2 %THEN MAX=X'40000' %ELSE MAX=X'80000';! 1 SEG ON K
!*E; MAX=X'80000'
IF COMP=0 THEN ->SET;! JOBBER INITIALISATION
!*NE %IF FACILITY#0 %THENSTART
!*NE %IF CSAVELIST#'' %THENSTART
!*NE SELECT OUTPUT(100)
!*NE I=NEW DESC(99,1,2,13,0,CSAVELIST,AFD)
!*NE I = GET SLOW ROUTE(AFD)
!*NE %IF I # 0 %THEN %START
!*NE PRINTSTRING('
!*NE ***FAILED TO OPEN LISTING FILE - WORK FILE SELECTED
!*NE ')
!*NE I = NEW DESC(99,1,2,X'2',0,'',AFD)
!*NE %FINISH
!*NE %FINISH
!*NE SELECTOUTPUT(99)
!*NE %IF LAST MODE=2 %THEN NEWPAGE
!*NE !*K %IF CINPUT='' %THEN CINPUT='*INPUT'
!*NE I=SET INPUT(CINPUT)
!*NE %IF I>0 %THEN %RESULT=I
!*NE PRINTSTRING('
!*NE SOURCE FILE: '.CINPUT)
!*NE SPACES(77-LENGTH(CINPUT))
!*NE MODE=1
!*NE DATIME(D,T)
!*NE PRINTSTRING('COMPILED '.D.' '.T.'
!*NE ')
!*NE %FINISH
IF NEWP#0 THEN NEWPAGE
IF MODE#0 THENSTART ;! USER FILE SPECIFIED
SELECT INPUT(101)
FINISHELSE SELECTINPUT(108)
!*E; PRINT OPTIONS(COMP-3)
LAST MODE=1
!*
SET: COMREG(40)=-1 ;! DISABLE COMPILER DIAGNOSTIC OUTPUT
OUTFILE('SS#WRK',MAX,0,0,I,F)
IF F=0 THEN COMREG(14)=I ELSE RESULT =F
OUTFILE('SS#TMPOB',MAX,0,0,I,F)
IF COMP>0 START
IF COMPS(COMP)=0 START
F=LOADCOMPILER(COMP,CN(COMP),J)
INTEGER(ADDR(COMPS(COMP)))=X'B1000000'
INTEGER(ADDR(COMPS(COMP))+4)=J
FINISH
FINISH
IF F=0 THEN COMREG(15)=I ELSE RESULT =F
RESULT =0
END ;! INITCOMP
!*
!*
!***********************************************************************
!* *
!* FILE DESCRIPTORS *
!* *
!***********************************************************************
!*
!*
CONSTINTEGER FDSPACE=2048
CONSTINTEGER FDSIZE=112
OWNINTEGER FDBASE
OWNINTEGER FDFREE
OWNINTEGER FDMAX
!*
!*
!*
SYSTEMINTEGERFN RESET FDS
!*E; %INTEGER I
INTEGER F
!*NE OUTFILE('SS#FDS', FDSPACE, FDSPACE, -1, FDBASE, F)
!*E; OUTFILE("SS#FDS",FDSPACE,0,0,FDBASE,F)
IF F=0 START
!*E; %CYCLE I=0,4,28
!*E; INTEGER(FDBASE+I)=0
!*E; %REPEAT
FDFREE=FDBASE
FDMAX=FDBASE+FDSPACE
FINISHELSE FDBASE=0
!*E; %IF F#0 %THEN SSMESSA(F,"SS #FDS")
!*NE %IF F<=0 %THEN F=RESET BUFFERS
RESULT =F
END ; ! RESET FDS
SYSTEMINTEGERFN NEW DESC(INTEGER DSNUM, TYPE, ACCESS ROUTE, C
MODE,IDENTYPE, STRING (31)IDEN, INTEGERNAME AFD)
INTEGER I
RECORDNAME F(NRFDFMT)
UNLESS 0<DSNUM<=109 THENRESULT =164
!INVALID DATA SET NUMBER
I=FDMAP(DSNUM)
IF I#0 THENSTART
F==RECORD(I)
UNLESS F_STATUS<2 OR DSNUM=99 THENRESULT =1001
!LOGICAL ERROR-FILE NOT CLOSED
FINISHELSESTART
IF FDBASE=0 THEN I=RESET FDS
! DESCRIPTOR AREA NOT INITIALISED
IF I#0 THENRESULT =1002; ! FAILED TO INITIALISE
I=FDFREE
UNLESS FDFREE+FDSIZE<=FDMAX THENRESULT =165
! TOO MANY FILES DEFINED
FDMAP(DSNUM)=FDFREE
FDFREE=I+FDSIZE
F==RECORD(I)
F_LINK=COMREG(19)
COMREG(19)=I
FINISH
FILL(76, I+4, 0)
AFD=I
F_DSNUM=DSNUM
F_VALID ACTION=MODE
F_MODE OF USE=TYPE
F_ACCESS ROUTE=ACCESS ROUTE
IF ACCESS ROUTE=6 THEN F_ASVAR=IDENTYPE;! MAPPED FILE
F_MODE=11
F_IDEN=IDEN
F_LM=1
F_RM=132
! %IF ACCESS ROUTE=2 %THEN F_RM=132 %ELSE F_RM=80
F_ROUTECCY=I;! ADDRESS OF FD(USED IN EMAS INTERFACE)
RESULT =0
END ; !NEW DESC
!*
!*
!***********************************************************************
!* *
!* BUFFER ALLOCATION *
!* *
!***********************************************************************
!*
!*
!*NE %CONSTINTEGER BUFFER SPACE=X'10000'
!*NE %OWNINTEGER BUFFER BASE
!*NE %OWNINTEGER BUFFER FREE
!*NE %OWNINTEGER BUFFER MAX
!*NE %OWNINTEGER BUFFER LIST
!*
!*NE %INTEGERFN RESET BUFFERS
!*NE %INTEGER F
!*NE %IF OPSYS=0 %THEN %RESULT=0;! NOT NECESSARY ON EMAS
!*NE OUTFILE('SS#BUFF', BUFFER SPACE, BUFFER SPACE, -1, BUFFER BASE, F)
!*NE %IF F=0 %THENSTART
!*NE BUFFER FREE=BUFFER BASE
!*NE BUFFER MAX=BUFFER BASE+BUFFER SPACE
!*NE BUFFER LIST=0
!*NE %FINISHELSE BUFFER BASE=0
!*NE %RESULT =F
!*NE %END ; !RESET BUFFERS
!*NE !*
!*NE
!*NE
!*NE %INTEGERFN GIVE BUFFER(%INTEGER LENGTH, %INTEGERNAME ADDRESS)
!*NE %INTEGER F
!*NE %IF OPSYS=0 %THEN %RESULT=0;! NOT NECESSARY ON EMAS
!*NE %IF BUFFER BASE=0 %THENSTART
!*NE F=RESET BUFFERS
!*NE %IF F#0 %THENRESULT =1003
!*NE %FINISH
!*NE %IF LENGTH+BUFFER FREE>BUFFER MAX %THENRESULT =1004
!*NE ! EXTEND LATER
!*NE ADDRESS=BUFFER FREE
!*NE BUFFER FREE=BUFFER FREE+(LENGTH+7)&X'FFFFFFF8'
!*NE %RESULT =0
!*NE %END ; ! GIVE BUFFER
!*
!*
!***********************************************************************
!* *
!* OPEN/CLOSE FILES *
!* *
!***********************************************************************
!*
!*
INTEGERFN GET SLOW ROUTE(INTEGER AFD)
RECORDNAME F(NRFDFMT)
INTEGER I, J, K, FILEORG, DEVCLASS, RECTYPE, FE, MINREC, MAXREC
F==RECORD(AFD)
IF F_ACCESS ROUTE=1 THEN START
J=1
K=1; ! READ ACCESS ONLY
FINISH ELSE START
K=2; ! READ/WRITE ACCESS
IF F_ACCESS ROUTE=2 THEN J=2 ELSE J=0
FINISH
F_ROUTECCY=AFD
I=DEFINE FILE(J,K,F_IDEN,F_ROUTECCY,FILEORG,DEVCLASS, C
RECTYPE,FE,MINREC,MAXREC)
IF I>0 THEN RESULT =I
F_STATUS=1
F_DEV CLASS=DEVCLASS
IF RECTYPE = 1 THEN START ;! FIXED LENGTH RECS
IF F_MODE = 11 OR F_MODE = 9 OR F_MODE = 6 OR F_MODE = 2 C
THEN F_MODE = F_MODE - 1
FINISH
IF F_DEVCLASS=9 THEN F_MODE=0; ! CONTROL STREAM
F_FILEORG=FILEORG
F_REC TYPE=RECTYPE
! PROCESS FORMAT EFFECTORS
F_MINREC=MINREC
F_MAXREC=MAXREC
F_RECSIZE=MAXREC
RESULT =0
END ; ! GET SLOW ROUTE
!*
SYSTEMINTEGERFN OPEN(INTEGER AFD, MODE)
!*
!* MODE = 1 INPUT
!* 2 OUTPUT
!*
RECORDNAME F(NRFDFMT)
!*NE %OWNBYTEINTEGERARRAY BUFF(0 : 132)
!*NE %OWNBYTEINTEGERARRAY CBUFF(0:80)
!*NE %STRING(63) SS
INTEGER I,J,K
!*E; %SWITCH A(0:9)
!*NE %SWITCH A(0:6)
F==RECORD(AFD)
I=F_ACCESS ROUTE
UNLESS 0<=I<=4 OR 8<=I<=9 THEN RESULT =1008
->A(I)
!*
!****** LOG OUTPUT
!A(0): ->OPENED
!*
!****** PRIMARY INPUT
A(1):
I=GET SLOW ROUTE(AFD)
IF I>0 THEN RESULT =I
!*NE F_AREC=ADDR(CBUFF(0))
F_MINREC=80
F_MAXREC=80
F_RECSIZE=80
->OPENIT
!*
!****** PRIMARY OUTPUT
A(0):
A(2):
I=GET SLOW ROUTE(AFD)
IF I>0 THENSTART
WFERR: SELECT OUTPUT(100)
!*NE READ ERROR DATA(SS,I)
PRINTSTRING('
***FAILURE TO OPEN LISTING FILE(REPLY =')
WRITE(I,1)
!*NE PRINTSTRING(' FROM '.SS.")")
!*NE %IF FACILITY#0 %THENSTART
!*NE PRINTSTRING(' - JOURNAL SELECTED')
!*NE NEWLINE
!*NE LOG99
!*NE %RESULT=0
!*NE %FINISHELSESTART
NEWLINE
STOPBASE
!*^E %FINISH
FINISH
!*NE F_AREC=ADDR(BUFF(0))
F_MINREC=1
F_MAXREC=133
->OPENIT
!*
!****** MAPPED FILE
A(3):
IF MODE=2 THEN RESULT =171;! INVALID OPERATION
A(8):A(9): F_C2=F_C1;! RESET CUR POINTER TO START
->OPENED IF I=3
!*NE !*
!****** CONVENTIONAL FILE
A(4): UNLESS F_STATUS>0 THENSTART
!*E; I=GET ROUTE(AFD)
!*NE I=JBR CALL(2,AFD);! ==GET ROUTE(AFD)
IF I>0 THEN RESULT =I
FINISH
IF F_MODE=13 AND F_RECTYPE#1 THEN RESULT =179;! RECORDS
! MUST BE FIXED LENGTH FOR D.A.
!*NE I=GIVE BUFFER(F_MAXREC,F_AREC)
!*NE %IF I#0 %THEN %RESULT=I
OPENIT: F_RECSIZE=F_MAXREC
! %IF F_DEVCLASS=9 %OR F_RECTYPE=1 %OR F_MODE=2 %THENSTART;! ALIEN DATA OR FIXED
J=F_AREC
K=F_MAXREC
! %FINISHELSESTART
! J=0
! K=0
! %FINISH
!*B; %IF F_DEVCLASS = 9 %THEN %START
!*B; %IF MODE = 2 %THEN F_MODE = 4
!*B; %FINISH
I=OPEN FILE(F_ROUTECCY,F_MODE,J,K,ADDR(F_RECSIZE), C
ADDR(F_C0))
IF I>0 THENSTART
IF F_ACCESS ROUTE=2 THEN ->WFERR
RESULT =I
FINISH
IF I = -1 THEN START
F_VALID ACTION = F_VALID ACTION & X'ED'
IF F_MODE < 12 THEN F_MODE = F_MODE - 2 C
ELSE F_MODE = F_MODE - 1
FINISH
! %IF F_ACCESS ROUTE=2 %THENSTART
! I=POSITION SQ FILE(ADDR(F_C0),1);! AT END OF FILE
!*K COMREG(55)=ADDR(F_C0)
! %FINISHELSESTART
!*NE %UNLESS F_MODE=6 %THEN I=SET SQ MODE(ADDR(F_C0),F_MODE,MODE)
! %FINISH
!*E; %IF 1<=F_ACCESS ROUTE<=2 %OR F_ACCESS ROUTE=9 %START
!*E; F_AREC=F_C1
!*E; %FINISHELSE %START
!*E; F_AREC=F_C1+2
!*E; %FINISH
!*E; F_RECORDS=0
!*E; F_LASTREC=0
IF F_ACCESS ROUTE=1 THEN COMREG(54)=F_ROUTE CCY
!*
OPENED:
F_STATUS=3
F_CUR STATE=1
RESULT =0
END ; !OF OPEN
!*
SYSTEMINTEGERFN CLOSE(INTEGER AFD)
RECORDNAME F(NRFDFMT)
INTEGER I
SWITCH A(0:9)
F==RECORD(AFD)
I=F_ACCESS ROUTE
UNLESS 0<=I<=4 OR 8<=I<=9 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
A(8): A(9):
F_STATUS=1
F_CURSTATE = 0
RESULT =CLOSE FILE(F_ROUTECCY,ADDR(F_C0))
!*
!****** MAPPED FILE
A(3): F_STATUS=0
RESULT =0
!*
! A(8):A(9): F_STATUS=1
!F_CURSTATE=0
! %RESULT=0
END ; ! CLOSE
!*
!*NE %SYSTEMINTEGERFN LOCATE CHANNEL(%INTEGER CHAN)
!*NE %RECORDNAME F(NRFDFMT)
!*NE %STRING(15) S,ROOT
!*NE %BYTEINTEGERARRAY T(0:2)
!*NE %INTEGER I,J,AFD,DSNUM
!*NE %INTEGER FILEORG,DEVCLASS,RECTYPE
!*NE %LONGINTEGER KK
!*NE !*B ROOT='ICL9CE'
!*
!*K ROOT='UNIT'
!*NE %UNLESS 1<=CHAN<=99 %THEN %RESULT=164
!*NE DSNUM=CHAN
!*NE %IF CHAN>9 %THENSTART
!*NE I=CHAN//10
!*NE CHAN=CHAN-10*I
!*NE T(2)=CHAN+'0'
!*NE CHAN=I
!*NE T(0)=2
!*NE %FINISHELSE T(0)=1
!*NE T(1)=CHAN+'0'
!*NE S=ROOT.STRING(ADDR(T(0)))
!*NE I=READ JS VAR(S,1,ADDR(KK))
!*NE %IF I#0 %THEN %RESULT=151
!*NE I=NEWDESC(DSNUM,1,4,X'3F',1,'',AFD)
!*NE %IF I#0 %THEN %RESULT=I
!*NE F==RECORD(AFD)
!*NE J=KK
!*NE F_ROUTECCY=J
!*NE I=READ FILE DESCRIPTION(J,FILEORG,DEVCLASS,RECTYPE, %C
!*NE F_MINREC,F_MAXREC)
!*NE %IF I>0 %THEN %RESULT=I
!*NE F_STATUS=1
!*NE F_FILEORG=FILEORG
!*NE F_DEVCLASS=DEVCLASS
!*NE %IF RECTYPE = 1 %THEN %START; ! FIXED LENGTH RESC
!*NE %IF F_MODE=11 %OR F_MODE=9 %OR F_MODE=6 %OR F_MODE=2 %C
!*NE %THEN F_MODE = F_MODE - 1
!*NE %FINISH
!*NE %IF DEVCLASS=9 %THEN F_MODE=0
!*NE F_RECTYPE=RECTYPE
!*NE F_RECSIZE=F_MAXREC
!*NE %RESULT=0
!*NE %END;! LOCATE CHANNEL
!*
!*
!*
!*
!********************************************************************
!*
!* ICL9CEEXEC
!*
!********************************************************************
!*
!*NE %EXTERNALROUTINE ICL9CEEXEC(%LONGINTEGER PROCEDURE,PROUTE,PREPORT, %C
!*NE %INTEGER PDEPTH,PDIAGS,PARRAY, %C
!*NE %LONGINTEGER AVOLS)
!*NE %LONGINTEGERARRAY A(0:2)
!*NE %INTEGER I,J,LEN,ADDRS
!*NE %STRING(32) MODULE
!*NE %STRING(63) S
!*NE %SWITCH V(0:2)
!*NE %LONGINTEGER ENTRYDR
!*NE !*B A(0)=PROCEDURE
!*NE !*B A(1)=PROUTE
!*NE !*B A(2)=PREPORT
!*NE !*B %CYCLE I=0,1,2
!*NE !*B LEN=(A(I)<<8)>>40
!*NE !*B ADDRS=A(I)&X'00000000FFFFFFFF'
!*NE !*B J=ADDR(S)+1
!*NE !*B MOVE(LEN,ADDRS,J)
!*NE !*B ETOI(J,LEN)
!*NE !*B LENGTH(S)=LEN
!*NE !*B -> V(I)
!*NE REP:
!*NE !*B %REPEAT
!*NE !*B ICL9CEAVOLS =(AVOLS<<8)>>40
!*NE !*B DEPTH=PDEPTH
!*NE !*B DIAGNOSTICS=PDIAGS
!*NE !*B ARRAYSIZE=PARRAY
!*NE !*B ->ENTER
!*NE V(0):
!*NE !*B MODULE = S
!*NE !*B -> REP
!*NE V(1):
!*NE !*B %IF S = "NO" %OR S = "N" %THEN ROUTE = 0 %ELSE ROUTE = 1
!*NE !*B -> REP
!*NE V(2):
!*NE !*B %IF S = "NO" %OR S = "N" %THEN REPORT = 0 %ELSE REPORT = 1
!*NE !*B -> REP
!*NE ENTER:
!*NE !*B FACILITY = 4
!*NE !*B ICL9CEDOBEGIN = 1
!*NE !*B INITFILE(ICL MATHS ERROR ROUTINE); ! INITIALISE SUBSYSTEM
!*NE !*B I = LOAD MODULE(MODULE,ENTRYDR)
!*NE !*B %IF I > 0 %THEN %START
!*NE !*B SELECTOUTPUT(100)
!*NE !*B PRINTSTRING('LOAD FAILED')
!*NE !*B WRITE(I,10)
!*NE !*B NEWLINE
!*NE !*B ->ABORT
!*NE !*B %FINISH
!*NE !*B OPEH DEFAULTS(1);! ALSO CALLS ICL9HEPROLOG
!*NE LAST MODE=2
!*NE !*B *LD_ENTRYDR
!*NE !*B *STLN_%TOS
!*NE !*B *ASF_4
!*NE !*B *RALN_5
!*NE !*B *CALL_(%DR)
!*NE !*B END TEXT('RUN COMPLETED')
!*NE ABORT:
!*NE !*B TIDYEXIT
!*NE !*B %END; ! OF ICL9CEEXEC
ENDOFFILE