!__________________________________________________________________________________ ! ! COBOLE COMMAND IS EQUIVALENT TO ICLMACRO COBOLCOMPILE. IT PASSES ! THE PARAMETERS ON TO COBCOLCOMPILE, WHICH IS AN ENTRY IN THE ! COMPILER MODULE, COBOLY. THIS THEN CALLS ICL9HNCOMPILESUPPORT WHICH ! PROCESSES THE OPTIONS AND CALLS THE COMPILER VIA A LINK ! DESCRIPTOR. AFTER COMPLETION OF THE COMPILATION THE ! UTILITY COMF IS CALLED TO CONVERT THE OMF FILE TO EMAS ! OBJECT FORMAT, MARKING THE PROGRAM I.D. AS THE MAIN ENTRY. ! !_____________________________________________________________________________ !********************************************************************** !* !* C O B O L !* !* COMPILER ENVIRONMENT ROUTINES !* AND CTM RUN TIME SUPPORT !* !********************************************************************** ! ! %RECORDFORMAT JSVFORMAT( %LONGINTEGER IVALUE, %C %INTEGER SIZE,KPOS,MAXREC, %C %STRING(32) LNAME, %STRING(48) NAME, %C %BYTEINTEGER FORMAT,ORG,KLEN,ACCESS,PACKING,DUM1) %OWNRECORDARRAYFORMAT JSVAF(0:20)(JSVFORMAT) %OWNRECORDARRAYNAME JSV(JSVFORMAT) %OWNLONGINTEGERNAME JSN %OWNINTEGER JSMAX=20 %OWNINTEGER QUITLNB,QUITCTB,QUITXNB,CREG34,CREG36 %RECORDFORMAT RF(%INTEGER CONAD,FILETYPE,DATASTART,DATAEND) ! ! GLOBAL DECLARATIONS ! %OWNSTRING(16) LIBFILNAME="COBLIB" %OWNSTRING(16) COBRUNFN="COBRUNY" %CONSTINTEGER FCMAX=10; ! MAXIMUM NUMBER OF FILE CONTROL BLOCKS %CONSTINTEGER EBCDICSPACE=64 %OWNINTEGER FCN ! ! FILE CONTROL BLOCKS ETC. ! %RECORDFORMAT FCBFORMAT(%LONGINTEGER CAPABILITY,KEYBUFFER,ACCESS1, %C ACCESS2,LISP1, %C %INTEGER CONNECTADDRESS,STARTOFDATA,ENDOFDATA,PTR, %C RECORDCOUNT,ENDOFFILE,MAXREC,KEYPOSN,KEYLENGTH,RECORDVIEW, %C MAXSIZE,BUFFERLENGTH,BUFFERADDRESS,CURRENTLENGTH,RECSIZEADD, %C RECORDBUFF0,RECORDBUFF1, %C ACTION,DISPLACEMENT,POSITION,NUMBUFF,SETACTION,JSVPTR,ISP3,ISP4, %C %INTEGER OPEN,BSINDEX, %C FILETYPE,BISP1,BISP2) %OWNRECORDARRAY FCB(1:10)(FCBFORMAT) ! !************************************************************** ! ! CONSTANTS ! !*********************************************************************** %CONSTINTEGER NO=0,YES=1 %CONSTINTEGER NIL=-1 %CONSTINTEGER DUMMYSTREAM=10 %CONSTSTRING(1) %ARRAY HEX TAB(0:15)="0","1","2","3", %C "4","5","6","7","8","9","A","B","C","D","E","F" ! !********************************************************************* ! ! GLOBALS ! !********************************************************************** %EXTERNALBYTEINTEGERARRAY ICL9HNDATE(1:10)= %C 'Y','Y','Y','Y','/','M','M','/','D','D' %EXTERNALBYTEINTEGERARRAY ICL9HNTIME(1:8)= %C 'H','H',':','M','M',':','S','S' %OWNINTEGER TRACECOUNT %OWNINTEGER TRACE STREAM %OWNINTEGER LOG STREAM %OWNSTRING(6) USER NAME ! !******************************************************************** ! ! LOCAL ROUTINE SPECS ! !******************************************************************************* %ROUTINESPEC PP(%INTEGER INDEX,PDR0,PDR1) %INTEGERFNSPEC ACCESS1(%INTEGER INDEX,PDR0,PDR1) %INTEGERFNSPEC ACCESS2(%INTEGER INDEX) %INTEGERFNSPEC PERFORMIO(%INTEGER INDEX) %INTEGERFNSPEC DESELECTRAM(%INTEGER INDEX) !************************************************************************ ! ! EXTERNAL ROUTINE SPECS ! ! !*************************************************************************** %EXTERNALROUTINESPEC PARM(%STRING(255) S) %EXTERNALROUTINESPEC RUN(%STRING(255) S) %EXTERNALROUTINESPEC NEWSMFILE(%STRING(255) S) %EXTERNALINTEGERFNSPEC SMADDR(%INTEGER AD, %INTEGERNAME L) %EXTERNALROUTINESPEC CLOSESM(%INTEGER CHAN) %SYSTEMROUTINESPEC CHANGEFILESIZE(%STRING(31) FILE, %C %INTEGER NEWSIZE, %INTEGERNAME FLAG) %SYSTEMROUTINESPEC DISCONNECT(%STRING(31) FILE, %INTEGERNAME FLAG) %SYSTEMROUTINESPEC REROUTECONTINGENCY(%INTEGER EP,CLASS, %C %LONGINTEGER MASK, %ROUTINENAME RR, %INTEGERNAME FLAG) %SYSTEMROUTINESPEC FINDENTRY(%STRING(31)NAME, %INTEGER TYPE,DAD, %C %STRINGNAME FILE, %INTEGERNAME DR0,DR1,FLAG) %EXTERNALINTEGERFNSPEC RETURNCODE %EXTERNALINTEGERFNSPEC OUT STREAM %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER I) %EXTERNALROUTINESPEC DEFINE(%STRING(255) PARMS) %EXTERNALROUTINESPEC PROMPT(%STRING(15) NEWPROMPT) %EXTERNALROUTINESPEC DESTROY(%STRING(255)S) %SYSTEMROUTINESPEC CONNECT(%STRING(31) FILE %INTEGER MODE, %C HOLE,PROTECT %RECORDNAME R %INTEGERNAME FLAG) %SYSTEMROUTINESPEC OUTFILE(%STRING(31) FILE NAME, %C %INTEGER SIZE,GAP,PROTECTION, %C %INTEGERNAME CONNECTED ADDR,FLAG) %SYSTEMSTRINGFNSPEC NEXT TEMP %SYSTEMROUTINESPEC MOVE(%INTEGER LENGTH,FROM,TO) %SYSTEMROUTINESPEC ITOE(%INTEGER ADDRESS,LENGTH) %SYSTEMROUTINESPEC ETOI(%INTEGER ADDRESS,LENGTH) %SYSTEMROUTINESPEC FILL(%INTEGER LENGTH,ADDRESS,FILLER) %SYSTEMROUTINESPEC PRINTMESS(%INTEGER MESS) %EXTERNALSTRINGFNSPEC UINFS(%INTEGER ENTRY) ! !********************************************************************** !* !* SERVICE ROUTINES !* !********************************************************************** ! ! %EXTERNALROUTINE PARMSCAN(%STRINGNAME S %INTEGER NPARM %C %STRINGARRAYNAME KEYS,LITS %INTEGERARRAYNAME MODE,PV %C %INTEGERNAME LCNT %INTEGER INITVALUE) ! !S STRING CONTAINING PARAMETER SEQUENCE AS INPUT ! NPARM NMAX NO OF PARAMETERS POSSIBLE ! KEYS LIST OF KEYWORDS ! MODE MODE OF PARAMETERS (0=INTEGER, 1=LITERAL,2=SUPERLITERAL) ! PV POINTER OR VALUE (IF MODE=0 - VALUE, ELSE POINTER TO ! INDEX IN LITS ! LITS ARRAY OF LITERALS, LISTS OF COMPONENTS OF ! SUPERLITERALS ARE TERMINATED WITH ".END" ! ALL VALUES OF PVARE INITIALLY SET TO INITVALUE SO THAT THE ! CALLING ROUTINE CAN IDENTIFY WHICH PARAMETRS HAVE BEEN SET. ! %EXTERNALINTEGERFNSPEC PSTOI(%STRING(63) S) %ROUTINESPEC GETPARM(%STRINGNAME S,P) %ROUTINESPEC SETPARM(%STRINGNAME Q %INTEGER K) ! %STRING(255) STEMP,A,B,P %STRING(3) SNAME %INTEGER I,J,FOUND,POSITION ! ! STEMP=S ; LCNT=1 ;POSITION=1 %UNTIL STEMP = "" %THEN %CYCLE GETPARM(STEMP,P) %IF P->A.("=").B %THEN %START P=B FOUND=0 %CYCLE J=1,1,NPARM SNAME<-KEYS(J) ;! SET 3-CHARACTER ABBREVIATION %IF A=KEYS(J) %OR A=SNAME %THEN FOUND=J %AND %EXIT %REPEAT %IF FOUND=0 %THEN %START NEWLINE;PRINTSTRING("KEYWORD ".A." NOT VALID") %FINISH %C %ELSE POSITION=FOUND %FINISH SETPARM(P,POSITION) POSITION=POSITION + 1 %IF POSITION > NPARM %THEN POSITION = POSITION - NPARM %REPEAT %RETURN ! ! GETPARM EXTRACTS NEXT PARM STRING FROM INPUT STRING S ! %ROUTINE GETPARM(%STRINGNAME S,P) %IF S->P.(",").S %THEN %RETURN P=S ; S="" %END ! ! SETPARM SETS VALUES INTO ARRAYS PV AND LITS ! ACCORDING TO MODE OF PARAMETER ! %ROUTINE SETPARM(%STRINGNAME Q %INTEGER K) %SWITCH SW(0:2) %STRING(255) QS -> SW(MODE(K)) ! ! INTEGER ! SW(0):PV(K)=PSTOI(Q); %RETURN ! ! LITERAL ! SW(1):PV(K)=LCNT;LITS(LCNT)=Q;LCNT=LCNT+1;%RETURN ! ! SUPERLITERAL ! SW(2):PV(K)=LCNT %WHILE Q->QS.("&").Q %THEN LITS(LCNT)=QS %AND LCNT=LCNT+1 LITS(LCNT)=Q;LITS(LCNT+1)=".END";LCNT=LCNT+2;%RETURN %END %END %INTEGERFN CONNECTJSFILE(%STRING(31) FILENAME) %RECORD R(RF) %INTEGER FLAG,START,LEN FLAG=0;CONNECT(FILENAME,3,2047,0,R,FLAG) %IF FLAG#0 %THEN %START %IF FLAG=218 %THEN OUTFILE(FILENAME,2047,2047,0,R_CONAD,FLAG) %C %AND INTEGER(R_CONAD+32)=0 %C %ELSE %RESULT=-1 %IF FLAG#0 %THEN %RESULT=-2 %FINISH %RESULT=R_CONAD+32 %END %SYSTEMSTRING(15)%FN SFROMI (%INTEGER X) %INTEGER REM,NUMB,NF %STRING(15) ANS ANS = '' %IF X < 0 %THEN %START NF = YES X = X*(-1) %FINISH %ELSE NF = NO %CYCLE NUMB = X X = X//10 REM = NUMB - X*10 ANS = TOSTRING(REM+'0').ANS %EXIT %IF X = 0 %REPEAT %IF NF = YES %THEN ANS = "-".ANS %RESULT = ANS %END ;! OF SFROMI ! %INTEGERFN IFROMS (%STRING(20) NUMBER) %INTEGER I,J,K,L,M M=LENGTH(NUMBER) K=ADDR(NUMBER) J=0 %CYCLE I=1,1,M L = BYTEINTEGER(K+I) %IF L<'0' %OR L>'9' %THEN %RESULT = J J=(J*10)+L-'0' %REPEAT %RESULT=J %END ;! OF IFROMS ! %ROUTINE LOG (%STRING(120) MSG) %INTEGER CURRENT STREAM CURRENT STREAM = OUTSTREAM SELECT OUTPUT (LOG STREAM) SPACES(9) PRINTSTRING(MSG) ; NEWLINE SELECT OUTPUT(CURRENT STREAM) %RETURN %END ;! OF LOG %ROUTINE TLOG (%STRING(120) MSG) %INTEGER CURRENT STREAM CURRENT STREAM = OUTSTREAM SELECT OUTPUT (TRACE STREAM) SPACES(9) PRINTSTRING(MSG) ; NEWLINE SELECT OUTPUT(CURRENT STREAM) %RETURN %END ;! OF TLOG ! !?1; %STRING(8)%FN HEXOF (%INTEGER X) !?1; %STRING(8) ANS !?1; %INTEGER I !?1; ANS = '' !?1; %CYCLE I=0,4,28 !?1; ANS = HEXTAB((X>>I)&X'0000000F').ANS !?1; %REPEAT !?1; %RESULT = ANS !?1; %END ;! OF HEXOF %STRING(255)%FN STRING FROM(%INTEGER L,ADDRESS) %STRING(255) S *LB _L *LDA _ADDRESS *LDTB _X'18000000' *LDB _%B *CYD _0 *LD _S *MVL _%L=1 *MV _%L=%DR,0,129 ETOI(ADDR(S)+1,LENGTH(S)) %RESULT = S %END ;! OF STRING FROM ! ! %STRING(160)%FN NEXT LINE %INTEGER I %BYTEINTEGERARRAY LINE (0:160) %WHILE NEXT SYMBOL = NL %THEN SKIP SYMBOL %CYCLE I=1,1,160 READ SYMBOL(LINE(I)) %IF LINE(I) = NL %THEN %EXIT %REPEAT LINE(0) = I-1 %RESULT = STRING(ADDR(LINE(0))) %END ;! OF NEXT LINE ! %STRING(255)%FN DE SPACED (%STRING(255) S) %STRING(255) B,A %WHILE S -> B.(" ").A %THEN S = B.A %RESULT = S %END ;! OF DE SPACED ! ! !?; %ROUTINE POSTREPORT(%STRING(40) RTN,%INTEGER RC) !?; TLOG("RETURNED FROM ".RTN." RESULT= ".SFROMI(RC)) !?; %END; ! OF POST REPORT ! !?; %ROUTINE EXITREP(%STRING(40) RTN,%INTEGER RC) !?; TLOG("ABOUT TO RETURN FROM ".RTN." RESULT = ".SFROMI(RC)) !?; %END; ! OF EXITREP !?1; %ROUTINE ASK FOR STREAM(%INTEGERNAME STREAM,%STRING(15) P) !?1; %INTEGER X,RC !?1; %STRING(80) REPLY !?1; ! !?1; RC = 1 !?1; PROMPT(P) !?1; %WHILE RC > 0 %THEN %CYCLE !?1; REPLY = DESPACED(NEXT LINE) !?1; %IF REPLY = "" %THEN %RETURN !?1; X = IFROMS(REPLY) !?1; %IF X>0 %AND X<80 %THEN STREAM = X %AND %RETURN !?1; DEFINE(SFROMI(STREAM).",".REPLY) !?1; X = RETURN CODE !?1; %IF X = 0 %THEN %RETURN !?1; PRINTSTRING("REPLY NOT VALID") !?1; NEWLINE !?1; %REPEAT !?1; %RETURN !?1; %END ;! OF ASK FOR STREAM ! %ROUTINE XDUMP (%STRING(120) COMMENT,%INTEGER ADDRESS,LEN) %STRING(132) BUFFER %INTEGER I,J,XSTART,XFINISH,YSTART,YFINISH XSTART = (ADDRESS//32)*32 XFINISH = ((ADDRESS+LEN)//32)*32 YSTART = (ADDRESS//4)*4 - 4 YFINISH = ((ADDRESS+LEN)//4)*4 + 4 PRINTSTRING (COMMENT) NEWLINE PRINT STRING ('DUMP OF '.SFROMI(LEN).'(X'.HEXOF(LEN). %C ') BYTES STARTING FROM ADDRESS '.HEXOF(ADDRESS)) %CYCLE I=XSTART,32,XFINISH BUFFER = HEXOF(I).' ' %CYCLE J=I,4,I+28 %IF J > YSTART %AND J < YFINISH %THEN %C BUFFER = BUFFER.HEXOF(INTEGER(J)).' ' %ELSE %C BUFFER = BUFFER.'........ ' %REPEAT NEWLINE PRINTSTRING (BUFFER) %REPEAT NEWLINE PRINTSTRING ('END OF DUMP') %RETURN %END ;! OF DUMP !?2; %ROUTINE TRACE (%STRING(40) RTN,MSG,%INTEGER LNB,N) !?2; %STRING (255) WORKA,WORKB !?2; %INTEGER CURRENT STREAM !?2; TRACE COUNT = TRACE COUNT + 1 !?2; WORKA="TRACE CALL >>".SFROMI(TRACE COUNT)."<< ".RTN." ".MSG !?2; CURRENT STREAM = OUT STREAM !?2; SELECT OUTPUT (TRACE STREAM) !?2; NEWLINES(2) !?2; PRINTSTRING(WORKA) !?2; NEWLINE !?2; WORKB="STACK DUMP STARTING FROM LNB, ".SFROMI(N)." WORDS OF PARMS" !?2; XDUMP(WORKB,LNB,(10+N)*4) !?2; NEWLINE !?2; SELECT OUTPUT(CURRENT STREAM) !?2; %RETURN !?2; %END ;! OF TRACE ! ! ROUTINE TO RETURN DESCRIPTOR TO ANOTHER ROUTINE ! %LONGINTEGERFN RTNDESC(%INTEGERFN R) %LONGINTEGER LI *LSD_(%LNB+5) *ST_LI %RESULT=LI %END %ROUTINE DUMPTCB(%INTEGER INDEX) %RECORDNAME TCB(FCBFORMAT) %INTEGER I,J,CURRENTSTREAM TCB==FCB(INDEX) ! CURRENTSTREAM=OUTSTREAM SELECTOUTPUT(TRACESTREAM) NEWLINE;PRINTSTRING("TCB DUMP INDEX=");WRITE(INDEX,5) NEWLINE PRINTSTRING("PTR=");PRINTSTRING(HEXOF(TCB_PTR)) NEWLINE;PRINTSTRING("CONAD=");PRINTSTRING(HEXOF(TCB_CONNECTADDRESS)) NEWLINE;PRINTSTRING("START,ENDDATA AND ENDFILE=") PRINTSTRING(HEXOF(TCB_STARTOFDATA)) SPACES(5);PRINTSTRING(HEXOF(TCB_ENDOFDATA)) SPACES(5);PRINTSTRING(HEXOF(TCB_ENDOFFILE)) NEWLINE SELECTOUTPUT(CURRENTSTREAM) %RETURN %END !********************************************************************* ! ! ROUTINE PP USED BY CTMSELECTRAM AND ACCESS1 ROUTINES ! !***************************************************************************** %EXTERNALROUTINE PP(%INTEGER INDEX,PDR0,PDR1) ! ! PROCESSES PARAMETER CALLS UPDATING FIELDS IN FCB(INDEX) ! %RECORDNAME TCB(FCBFORMAT) %INTEGER N,A,I,K,ALIGNMENT,CURRENTSTREAM %SWITCH SW(0:30) ! TCB==FCB(INDEX) ! N=(PDR0&X'00FFFFFF')//3 CURRENTSTREAM=OUTSTREAM !?;SELECTOUTPUT(TRACESTREAM);PRINTSTRING("PP-DUMP");NEWLINE %CYCLE I=1,1,N A=PDR1 + 12*(I-1) K=INTEGER(A) !?;WRITE(K,5);SPACES(3);PRINTSTRING(HEXOF(INTEGER(A+4)));SPACES(3) !?;PRINTSTRING(HEXOF(INTEGER(A+8)));NEWLINE ->SW(K) ! ! CAPABILITIES ACCESS1 AND ACCESS2 ! SW(16):MOVE(8,A+4,ADDR(TCB_CAPABILITY)) ; ->ENDLOOP SW(24):MOVE(8,ADDR(TCB_ACCESS1),INTEGER(A+8));->ENDLOOP SW(19):MOVE(8,ADDR(TCB_ACCESS2),INTEGER(A+8)) ; ->ENDLOOP ! ! ALIGNMENT 2=START OF FILE 3=END OF FILE ! SW(29):ALIGNMENT=INTEGER(A+4) %IF ALIGNMENT=2 %THEN TCB_PTR=-1 %IF ALIGNMENT=3 %THEN TCB_PTR=TCB_ENDOFDATA ->ENDLOOP ! ! KEY BUFFER ! SW(3):MOVE(8,A+4,ADDR(TCB_KEYBUFFER)) ; ->ENDLOOP ! ! ACTION DISPLACEMENT AND POSITION ! SW(0): TCB_ACTION=INTEGER(A+4) ; ->ENDLOOP SW(4): TCB_POSITION=INTEGER(A+4) ; ->ENDLOOP SW(5): TCB_DISPLACEMENT=INTEGER(A+4) ; ->ENDLOOP ! ! RECORD AND BUFFER SIZE ! SW(7):TCB_BUFFERLENGTH=INTEGER(A+4)&X'00FFFFFF' TCB_BUFFERADDRESS=INTEGER(A+8);->ENDLOOP SW(9):TCB_RECSIZEADD=INTEGER(A+8); ->ENDLOOP ! ! NUMBER OF IO BUFFERS ! SW(22) : TCB_NUMBUFF=INTEGER(A+4) ; ->ENDLOOP ! ! SETACTION ! SW(12):TCB_SETACTION=INTEGER(A+4);->ENDLOOP ! ENDLOOP:%REPEAT SELECTOUTPUT(CURRENTSTREAM) %RETURN %END !*************************************************************** ! ! ACCESS1X AND ACCESS2X ROUTINES ! !*************************************************************************** ! %INTEGERFN ACCESS11(%INTEGER PDR0,PDR1) %RESULT=ACCESS1(1,PDR0,PDR1) %END %INTEGERFN ACCESS12(%INTEGER PDR0,PDR1) %RESULT=ACCESS1(2,PDR0,PDR1) %END %INTEGERFN ACCESS13(%INTEGER PDR0,PDR1) %RESULT=ACCESS1(3,PDR0,PDR1) %END %INTEGERFN ACCESS14(%INTEGER PDR0,PDR1) %RESULT=ACCESS1(4,PDR0,PDR1) %END %INTEGERFN ACCESS15(%INTEGER PDR0,PDR1) %RESULT=ACCESS1(5,PDR0,PDR1) %END %INTEGERFN ACCESS16(%INTEGER PDR0,PDR1) %RESULT=ACCESS1(6,PDR0,PDR1) %END %INTEGERFN ACCESS17(%INTEGER PDR0,PDR1) %RESULT=ACCESS1(7,PDR0,PDR1) %END %INTEGERFN ACCESS18(%INTEGER PDR0,PDR1) %RESULT=ACCESS1(8,PDR0,PDR1) %END %INTEGERFN ACCESS19(%INTEGER PDR0,PDR1) %RESULT=ACCESS1(9,PDR0,PDR1) %END %INTEGERFN ACCESS21 %RESULT=ACCESS2(1) %END %INTEGERFN ACCESS22 %RESULT=ACCESS2(2) %END %INTEGERFN ACCESS23 %RESULT=ACCESS2(3) %END %INTEGERFN ACCESS24 %RESULT=ACCESS2(4) %END %INTEGERFN ACCESS25 %RESULT=ACCESS2(5) %END %INTEGERFN ACCESS26 %RESULT=ACCESS2(6) %END %INTEGERFN ACCESS27 %RESULT=ACCESS2(7) %END %INTEGERFN ACCESS28 %RESULT=ACCESS2(8) %END %INTEGERFN ACCESS29 %RESULT=ACCESS2(9) %END !************************************************************************ ! ! ACCESS1 ! !***************************************************************************** ! %INTEGERFN ACCESS1(%INTEGER INDEX,PDR0,PDR1) %RECORDNAME TCB(FCBFORMAT) %INTEGER N,A,X,RC %STRING(32) S !?;S=SFROMI(INDEX) !?;*STLN_X !?;TRACE("ACCESS1",S,X,3) TCB==FCB(INDEX) %IF PDR0=-1 %THEN ->PIO ! ! ! PROCESS PARAMETER PAIRS AND CALL PERFORMIO ! TCB_SETACTION=-1 N=PDR0&X'00FFFFFF' A=PDR1 PP(INDEX,N,A) PIO:RC=PERFORMIO(INDEX) %IF TCB_SETACTION#-1 %THEN TCB_ACTION=TCB_SETACTION !?;EXITREP("ACCESS1",RC) %RESULT=RC %END !**************************************************************************** ! ! ACCESS2 ! !*********************************************************************** %INTEGERFN ACCESS2(%INTEGER INDEX) %INTEGER X,RC %STRING(5) S !?S=SFROMI(INDEX) !?*STLN_X !?TRACE("ACCESS2",S,X,1) RC=PERFORMIO(INDEX) !?EXITREP("ACCESS2",RC) %RESULT=RC %END !***************************************************************************** ! ! PERFORMIO ! !***************************************************************************** ! %INTEGERFN PERFORMIO(%INTEGER INDEX) %INTEGER X,RC,ACTION,POSITION,DISP,RECLENGTH,LENGTH %RECORDNAME TCB(FCBFORMAT) %SWITCH ACT(0:16),ACT0POS(0:4),ACT1POS(0:4),ACT2POS(0:4) ! ! ESTABLISH ADDRESS OF FCB IN TCB ! TCB==FCB(INDEX) !?;DUMPTCB(INDEX) ! ACTION=TCB_ACTION %IF ACTION=-1 %THEN RC=0 %AND ->RETURN POSITION=TCB_POSITION ; DISP=TCB_DISPLACEMENT ! ->ACT(ACTION) ! ACT(0):->ACT0POS(POSITION) ACT(1):->ACT1POS(POSITION) ACT(2):->ACT2POS(POSITION) ! ! SELECT PREVIOUS(DISP=-1)=I.A.4 AND SELECT NEXT(DISP=+1)=I.A.3 ! ACT0POS(0):%IF DISP=-1 %THEN %START %IF TCB_PTR=TCB_STARTOFDATA %THEN RC=-9015 %AND ->RETURN %IF TCB_BSINDEX=-1 %THEN RC=200020 %AND ->RETURN TCB_PTR=TCB_BSINDEX ; TCB_BSINDEX=-1 RC=0 ->RETURN %FINISH %IF DISP=+1 %THEN %START %IF TCB_PTR=TCB_ENDOFDATA %THEN RC=-9015 %AND ->RETURN %IF TCB_PTR=-1 %THEN TCB_PTR=TCB_STARTOFDATA %AND %C RC=0 %AND ->RETURN TCB_BSINDEX=TCB_PTR TCB_CURRENTLENGTH=0 MOVE(2,TCB_PTR,ADDR(TCB_CURRENTLENGTH)+2) TCB_PTR=TCB_PTR+TCB_CURRENTLENGTH RC=0 ->RETURN %FINISH RC=200021;->RETURN ! ! SELECT JUST AFTER LAST I.A.=2 ! ACT0POS(1):TCB_PTR=TCB_ENDOFDATA TCB_BSINDEX=-1 RC=-9015 ->RETURN ! ! SELECT JUST BEFORE FIRST ! ACT0POS(2):TCB_PTR=-1 RC=-9015 ->RETURN ! ! SELECT JUST BEFORE CURRENT I.A.5 ! ACT0POS(3):%IF TCB_PTR=TCB_STARTOFDATA %THEN %START TCB_PTR=-1 TCB_BSINDEX=-1 RC=0 ->RETURN %FINISH %IF TCB_BSINDEX=-1 %THEN RC=200020 %AND ->RETURN TCB_PTR=TCB_BSINDEX TCB_BSINDEX=-1 RC=0 ->RETURN ! ! SELECT BY KEY ! ACT0POS(4):RC=9077 ->RETURN ! ! SELECT NEXT AND READ (I.A.=7) AND SELECTPREVIOUS AND READ (I.A.=8) ! ACT1:->ACT1POS(POSITION) ! ACT1POS(0):%IF DISP=+1 %THEN %START %IF TCB_PTR=-1 %THEN TCB_PTR=TCB_STARTOFDATA %ELSE %START TCB_BSINDEX=TCB_PTR TCB_CURRENTLENGTH=0 MOVE(2,TCB_PTR,ADDR(TCB_CURRENTLENGTH)+2) TCB_PTR=TCB_PTR+TCB_CURRENTLENGTH %FINISH ! ! CHECK FOR END OF FILE ! %IF TCB_PTR=TCB_ENDOFDATA %THEN RC=9034 %AND ->RETURN LENGTH=0 MOVE(2,TCB_PTR,ADDR(LENGTH)+2) RECLENGTH=LENGTH-2 ! %IF RECLENGTH > TCB_BUFFERLENGTH %THEN RC=9092 %AND ->RETURN MOVE(TCB_BUFFERLENGTH,TCB_PTR+2,TCB_BUFFERADDRESS) ! ! ITOE FOR ALL AT THE MOMENT ! ITOE(TCB_BUFFERADDRESS,TCB_BUFFERLENGTH) %IF TCB_RECSIZEADD#-1 %THEN %C INTEGER(TCB_RECSIZEADD)=TCB_BUFFERLENGTH RC=0 ->RETURN %FINISH %IF DISP=-1 %THEN %START %IF TCB_PTR=TCB_STARTOFDATA %THEN RC=9034 %AND ->RETURN %IF TCB_BSINDEX=-1 %THEN RC=200020 %AND ->RETURN TCB_PTR=TCB_BSINDEX TCB_BSINDEX=-1 LENGTH=0 MOVE(2,TCB_PTR,ADDR(LENGTH)+2) RECLENGTH=LENGTH-2 ! %IF RECLENGTH>TCB_BUFFERLENGTH %THEN RC=9092 %AND ->RETURN MOVE(TCB_BUFFERLENGTH,TCB_PTR+2,TCB_BUFFERADDRESS) ! ! ITOE FOR THIS ! ITOE(TCB_BUFFERADDRESS,TCB_BUFFERLENGTH) %IF TCB_RECSIZEADD#-1 %THEN %C INTEGER(TCB_RECSIZEADD)=TCB_BUFFERLENGTH RC=0 ->RETURN %FINISH ! ! SELECT BY KEY AND READ I.A.= ! ACT1POS(4):RC=9077;->RETURN ! ! ! SELECT NEXT AND NEWWRITE(AT END) I.A. 10 ! ACT2POS(0):%IF TCB_PTR#TCB_ENDOFDATA %THEN RC=9043 %AND ->RETURN RECLENGTH=0 %IF TCB_RECSIZEADD#-1 %THEN RECLENGTH=INTEGER(TCB_RECSIZEADD) %C %ELSE %C RECLENGTH=TCB_BUFFERLENGTH RECLENGTH=RECLENGTH+2 %IF TCB_PTR+RECLENGTH>TCB_ENDOFFILE %THEN %C RC=9040 %AND ->RETURN MOVE(2,ADDR(RECLENGTH)+2,TCB_PTR) MOVE(RECLENGTH-2,TCB_BUFFERADDRESS,TCB_PTR+2) ! ! ETOI ! ETOI(TCB_PTR+2,RECLENGTH-2) TCB_BSINDEX=TCB_PTR TCB_PTR=TCB_PTR+RECLENGTH TCB_ENDOFDATA=TC B_PTR ! ! UPDATE FILEHEADER INFO EACH TIME ! INTEGER(TCB_CONNECTADDRESS)=TCB_ENDOFDATA-TCB_CONNECTADDRESS INTEGER(TCB_CONNECTADDRESS+28)=INTEGER(TCB_CONNECTADDRESS+28)+1 RC=0 ->RETURN ! ! SELECT BY KEY AND NEWWRITE ! ACT2POS(4):RC=9077;->RETURN ! ! OVERWRITE CURRENT ONLY ALLOWED IF RECORDS EXACTLY SAME LENGTH ! ACT(8):%IF TCB_PTR=TCB_ENDOFDATA %THEN RC=9040 %AND ->RETURN LENGTH=0;MOVE(2,TCB_PTR,ADDR(LENGTH)+2) RECLENGTH=INTEGER(TCB_RECSIZEADD) %IF RECLENGTH # LENGTH %THEN RC=9041 %AND ->RETURN MOVE(RECLENGTH-2,TCB_BUFFERADDRESS,TCB_PTR+2) ! ! ETOI ! ETOI(TCB_PTR+2,RECLENGTH-2) RC=0 ->RETURN ! ! EXTENDED DESTROY FROM CURRENT I.A.=16 ! ACT(11):%IF TCB_PTR=-1 %THEN TCB_PTR=TCB_STARTOFDATA %AND %C RC=0 %AND ->RETURN %IF TCB_PTR#TCB_ENDOFDATA %THEN %START TCB_BSINDEX=TCB_PTR LENGTH=0;MOVE(2,TCB_PTR,ADDR(LENGTH)+2) TCB_PTR=TCB_PTR+LENGTH TCB_ENDOFDATA=TCB_PTR %FINISH ! ! UPDATE LENGTH OF FILE TOO BAD ABOUT RECORD COUNT FOR NOW ! INTEGER(TCB_CONNECTADDRESS)=TCB_ENDOFDATA-TCB_CONNECTADDRESS RC=0 ->RETURN ! ! READ KEY INTO KEY BUFFER ! ACT(16):RC=9077 ->RETURN ! ! DESELECTRAM ! ACT(12):RC=DESELECTRAM(INDEX) ->RETURN ! ! COMMON RETURN POINT ! RETURN:!EXITREP("PERFORMIO",RC) %RESULT=RC %END !***************************************************************** ! ! DESELECTRAM ! !****************************************************************** %INTEGERFN DESELECTRAM(%INTEGER INDEX) ! ! SETS VALUES IN EMAS FILE HEADER TO 'CLOSE' FILE ! %INTEGER CONAD %RECORDNAME TCB(FCBFORMAT) TCB==FCB(INDEX) ! ! CHECK FOR WRITE ACCESS ! %IF JSV(TCB_JSVPTR)_ACCESS&2#0 %THEN %START CONAD=TCB_CONNECTADDRESS INTEGER(CONAD)=TCB_ENDOFDATA-TCB_CONNECTADDRESS !INTEGER(CONAD+32)='DATEANDTIME' !INTEGER(CONAD+40)='NUMBER OF RECORDS' INTEGER(CONAD+8)=(INTEGER(CONAD)+4095)&X'FFFFF000' %FINISH ! ! RESET VALUES IN FCB TO INDICATE FILECLOSED ! TCB_OPEN=0 %RESULT=0 %END !********************************************************************* ! ! CTMJSREAD ! !********************************************************************** %EXTERNALINTEGERFN CTMJSREAD(%INTEGER NAMDR0,NAMDR1,INTDR0,INTDR1, %C STRDR0,STRDR1,DUM0,DUM1) ! ! READS JOBSPACE VARIABLE ! IF INT PARAMETER IS NOT NIL JSV_IVALUE IS RETURNED ! IF STRING PARAMETER IS NOT NIL JSV_NAME IS RETURNED ! THE INDEX IN JSV IS RETURNED TO THE INTEGER WHOSE ! ADRRESS IS GIVEN IN DUM1 ! %STRING(32) NAME %INTEGER I,L,LS,RC %INTEGER X NAME=STRINGFROM(NAMDR0,NAMDR1) ; NAME=DESPACED(NAME) ! !?;*STLN_X !?;TRACE("CTMJSREAD",NAME,X,8) !? %IF JSN#0 %THEN %START %CYCLE I=1,1,JSN %IF NAME=JSV(I)_LNAME %THEN %START %IF DUM1#NIL %THEN MOVE(4,ADDR(I),DUM1) %IF INTDR0#NIL %THEN MOVE(8,ADDR(JSV(I)_IVALUE),INTDR1) %IF STRDR0#NIL %THEN %START L=LENGTH(JSV(I)_NAME) LS=STRDR0&X'00FFFFFF' %IF LS < L %THEN L=LS %AND RC=-9105 FILL(LS,STRDR1,EBCDICSPACE) MOVE(L,ADDR(JSV(I)_NAME)+1,STRDR1) %FINISH RC=0 ->RETURN %FINISH %REPEAT %FINISH RC=0 RETURN:EXITREP("CTMJSREAD",RC) %RESULT=RC %END !********************************************************************* ! ! CTMJSWRITE ! !************************************************************************** ! %EXTERNALINTEGERFN CTMJSWRITE(%INTEGER NAMDR0,NAMDR1,INTDR0,INTDR1, %C STRDR0,STRDR1,DUM0,DUM1) ! ! WRITES JOBSPACE VARIABLES TO JSV_IVALUE OR JSV_NAME ! IF NAME EXISTS OVERWRITE VALUE , IF NAME DOES NOT EXIST ! THENM ADD NAME TO LIST AND INSERT APPROPRIATE VALUE ! %STRING(32) NAME %INTEGER I,J,X,RC NAME=STRINGFROM(NAMDR0,NAMDR1) ; NAME=DESPACED(NAME) !?;*STLN_X !?;TRACE("CTMJSWRITE",NAME,X,8) J=JSN+1 %IF JSN#0 %THEN %START %CYCLE I=1,1,JSN %IF NAME=JSV(I)_LNAME %THEN J=I %AND %EXIT %REPEAT %FINISH ! %IF INTDR0#NIL %THEN %START MOVE(8,INTDR1,ADDR(JSV(J)_IVALUE)) %FINISH %IF STRDR0#NIL %THEN %START JSV(J)_NAME=STRINGFROM(STRDR0,STRDR1) %FINISH ! ! UPDATE NAME ENTRY IF NECESSARY ! %IF J=JSN+1 %THEN JSN=JSN+1 %AND JSV(J)_LNAME=STRINGFROM(NAMDR0,NAMDR1) ! ! TEST FOR OVERFLOW OF TABLE ! %IF JSN=JSMAX %THEN RC=200001 %ELSE RC=0 !?;EXITREP("CTMJSWRITE",RC) %RESULT=RC %END !********************************************************************** ! ! CTMJSDECLARE ! !************************************************************************** ! %EXTERNALINTEGERFN CTMJSDECLARE(%INTEGER NAMDR0,NAMDR1,INTDR0,INTDR1, %C STRDR0,STRDR1,DUM0,DUM1) ! ! CODED AS IDENTICAL TO CTMJSWRITE ! %EXTERNALINTEGERFNSPEC CTMJSWRITE(%INTEGER N0,N1,I0,I1,S0,S1,D0,D1) %RESULT=CTMJSWRITE(NAMDR0,NAMDR1,INTDR0,INTDR1,STRDR0,STRDR1, %C DUM0,DUM1) %END !************************************************************************ ! ! CTMLOG ! !**************************************************************************** ! %EXTERNALINTEGERFN CTMLOG(%INTEGER MESSAGETYPE,DUM0,MESDR0,MESDR1) ! ! ! SENDS MESSAGE TO LOG STREAM ! %STRING(120) MESSAGE %INTEGER I,X,RC,CURRENTSTREAM !?;*STLN_X !?;TRACE("CTMLOG","",X,4) CURRENTSTREAM=OUTSTREAM SELECTOUTPUT(LOGSTREAM) NEWLINE WRITE(MESSAGETYPE,5);SPACES(5) I=MESDR0&X'00FFFFFF' %IF I>120 %THEN I=120 MESSAGE=STRINGFROM(I,MESDR1) ETOI(ADDR(MESSAGE)+1,LENGTH(MESSAGE)) PRINTSTRING(MESSAGE) SELECTOUTPUT(CURRENTSTREAM) RC=0 !?;EXITREP("CTMLOG",RC) %RESULT=RC %END !***************************************************************************** ! ! CTMDATETIME ! !***************************************************************************** ! %EXTERNALINTEGERFN CTMDATETIME(%LONGINTEGER INPUTTIME, %C %INTEGER DATEDR0,DATEDR1,TIMEDR0,TIMEDR1,DUM0) %EXTERNALSTRINGFNSPEC TIME %EXTERNALSTRINGFNSPEC DATE ! ! IF INPUT TIME #0 THE ROUTINE SHOULD CONVERT INPUT TIME ! TO DATE AND TIME IN CHARACTER FORMAT. FOR THE ! THE MOMENT THIS OPTION IS IGNORED AND THE CURRECT DATE AND TIME ! ARE RETURNED . ! %INTEGER X,RC %STRING(10) S,D,M,Y !?;*STLN_X !?;TRACE("CTMDATETIME","",X,6) S=TIME;ITOE(ADDR(S)+1,LENGTH(S)) MOVE(8,ADDR(S)+1,TIMEDR1) ! S=DATE S->D.("/").M.("/").Y S="19".Y."/".M."/".D ITOE(ADDR(S)+1,10) MOVE(10,ADDR(S)+1,DATEDR1) RC=0 !?;EXITREP("CTMDATETIME",RC) %END !************************************************************************* ! ! CTMASSIGNFILE ! !****************************************************************************** %EXTERNALINTEGERFN CTMASSIGNFILE(%INTEGER FRDR0,FRDR1,LNDR0,LNDR1, %C FNDR0,FNDR1,ACCESS,LOCK,NRA,NRB0,NRB1,START,END %C %LONGINTEGER ROUTE,NRC %INTEGER NRD0,NRD1,NRE0,NRE1) ! ! ONLY PARAMETERS USED AT THE MOMENT ARE FILEROUTE,LOCALFILENAME, ! AND FULL FILENAME. I.E. THE FIRST 3 SETS OF DESCRIPTORS. ! THE ROUTINE SETS UP VALUES IN JSV_NAME AND JSV_LNAME ! AND SELECTS NEXT FCB BLOCK FOR USE WITH FILE. ! JSV_LNAME=LOCAL FILENAME , JSV_IVALUE=FCB INDEX AND JSV_NAME=FILENAME ! %LONGINTEGER FCBINDEX %INTEGER RC,FCBDR0,FCBDR1 %EXTERNALINTEGERFNSPEC CTMJSWRITE(%INTEGER NAMDR0,NAMDR1,INTDR0, %C INTDR1,STRDR0,STRDR1,DUM0,DUM1) %STRING(32) NAME %INTEGER X NAME=STRINGFROM(FNDR0,FNDR1) ; NAME=DESPACED(NAME) !?;*STLN_X !?;TRACE("CTMASSIGNFILE",NAME,X,19) !? %IF FCN=FCMAX %THEN RC=200002 %AND ->RETURN FCN=FCN+1 ; FCBINDEX=FCN FCBDR0=X'30000001' ; FCBDR1=ADDR(FCBINDEX) RC=CTMJSWRITE(LNDR0,LNDR1,FCBDR0,FCBDR1,FNDR0,FNDR1,-1,-1) %IF RC=0 %THEN MOVE(8,FCBDR1,FRDR1) RETURN: !?;EXITREP("CTMASSIGNFILE",RC) %RESULT=RC %END !************************************************************************ ! ! CTMSELECTRAM ! !**************************************************************************** %EXTERNALINTEGERFN CTMSELECTRAM(%LONGINTEGER ROUTE %C %INTEGER LNDR0,LNDR1,PDR0,PDR1) ! ! FILE IS INDICATED EITHER BY ROUTE OR LOCALNAME ! IF NO ASSIGNFILE HAS BEEN ISSUED NO FCB INDEX WILL ! HAVE BEEN ALLOCATED AND NO FILE MAY EXIST. ! THE ROUTINE CHECKS IF ROUTE IS NONZERO THEN FCBINDEX=ROUTE ! AND INITIALISATION PROCEEDS. IF ROUTE=0 JSV_LNAME IS SEARCHED ! FOR A MATCH WITH LOCAL NAME. IF IT IS FOUND THEN ! JSV_IVALUE WILL CONTAIN FCBINDEX, IF THE FILE DOES NOT ! EXIST A FILE IS CREATED VIA OUTFILE. ! %EXTERNALROUTINESPEC PP(%INTEGER INDEX,DR0,DR1) %RECORDNAME TCB(FCBFORMAT) %LONGINTEGER LI %INTEGER I,J,INDEX,RC,X,HOLE,PROTECT,FLAG,MODE,FILESIZE,DR0,DR1 %INTEGER ENDOFFILE %STRING(32) NAME %RECORDFORMAT RF(%INTEGER CONAD,FILETYPE,DATASTART,DATAEND) %RECORD R(RF) %SWITCH ACC(1:9) NAME=STRINGFROM(LNDR0,LNDR1);NAME=DESPACED(NAME) !?;*STLN_X !?;TRACE("CTMSELECTRAM",NAME,X,5) ! OBTAIN INDEX IN FCB AND IN JSV ! ! PROTECT=0;FLAG=0 %IF ROUTE#0 %THEN INDEX=ROUTE %ELSE %START RC=CTMJSREAD(LNDR0,LNDR1,0,ADDR(LI),-1,-1,-1,ADDR(J)) %IF RC=0 %THEN INDEX=LI %ELSE RC=9087 %AND ->RETURN %FINISH ! ! SET UP TCB TO POINT TO RELEVANT FCB ! TCB==FCB(INDEX) ! ! CHECK FILE EXISTS AND CONNECT IT ! NAME=JSV(J)_NAME MODE=JSV(J)_ACCESS FILESIZE=JSV(J)_SIZE HOLE=FILESIZE CONNECT(NAME,MODE,HOLE,PROTECT,R,FLAG) %IF FLAG=0 %THEN ->FILEEXISTS %IF FLAG=218 %THEN ->CREATEFILE ! ! FAILURE TO CONNECT FILE ! LOG("CONNECT FAILS FOR FILE ".NAME." ".SFROMI(FLAG)) RC=9087;->RETURN CREATEFILE:OUTFILE(NAME,FILESIZE,HOLE,PROTECT,R_CONAD,FLAG) %IF FLAG=0 %THEN %START INTEGER(R_CONAD+12)=4 INTEGER(R_CONAD+24)=X'4000002' R_FILETYPE=INTEGER(R_CONAD+12) R_DATASTART=INTEGER(R_CONAD+4) R_DATAEND=INTEGER(R_CONAD) %FINISH %ELSE %START LOG("FAILURE TO CREATE FILE".NAME." ".SFROMI(FLAG)) RC=9087;->RETURN %FINISH FILEEXISTS:ENDOFFILE=R_CONAD+FILESIZE-1 ! ! INITIALISE FURTHER FIELDS IN FCB ! ! ACCESS 1 AND ACCESS 2 ADDRESSES VIA RTNDESC ROUTINE ! ->ACC(INDEX) ACC(1):TCB_ACCESS1=RTNDESC(ACCESS11) TCB_ACCESS2=RTNDESC(ACCESS21) ->CONT ACC(2):TCB_ACCESS1=RTNDESC(ACCESS12) TCB_ACCESS2=RTNDESC(ACCESS22) ->CONT ACC(3):TCB_ACCESS1=RTNDESC(ACCESS13) TCB_ACCESS2=RTNDESC(ACCESS23) ->CONT ACC(4):TCB_ACCESS1=RTNDESC(ACCESS14) TCB_ACCESS2=RTNDESC(ACCESS24) ->CONT ACC(5):TCB_ACCESS1=RTNDESC(ACCESS15) TCB_ACCESS2=RTNDESC(ACCESS25) ->CONT ACC(6):TCB_ACCESS1=RTNDESC(ACCESS16) TCB_ACCESS2=RTNDESC(ACCESS26) ->CONT ACC(7):TCB_ACCESS1=RTNDESC(ACCESS17) TCB_ACCESS2=RTNDESC(ACCESS27) ->CONT ACC(8):TCB_ACCESS1=RTNDESC(ACCESS18) TCB_ACCESS2=RTNDESC(ACCESS28) ->CONT ACC(9):TCB_ACCESS1=RTNDESC(ACCESS19) TCB_ACCESS2=RTNDESC(ACCESS29) ->CONT CONT:TCB_CONNECTADDRESS=R_CONAD TCB_STARTOFDATA=R_CONAD+R_DATASTART TCB_ENDOFDATA=R_CONAD+R_DATAEND TCB_OPEN=1 TCB_BSINDEX=-1 TCB_FILETYPE=4 TCB_ENDOFFILE=ENDOFFILE ! ! SET UP DEFAULTS AS IN TABLE 8 OF CTM DEFINITION ! TCB_ACTION=-1 TCB_POSITION=0 TCB_DISPLACEMENT=1 TCB_RECORDBUFF0=-1 TCB_RECORDBUFF1=-1 TCB_KEYBUFFER=-1 TCB_RECSIZEADD=-1 TCB_MAXREC=1024 TCB_PTR=-1 ;! SET PTR TO START OF FILE BY DEFAULT ! ! PROCESS PARAMETER PAIRS ! PP(INDEX,PDR0,PDR1) RC=0 RETURN:EXITREP("CTMSELECTRAM",RC) %RESULT=RC %END !*************************************************************************** ! ! CTMREADDESC ! !**************************************************************** %EXTERNALINTEGERFN CTMREADDESC(%LONGINTEGER ROUTE, %C %INTEGER LNDR0,LNDR1,FNDR0,FNDR1,PDR0,PDR1) ! ! IDENTIFY FCB INDEX VIA ROUTE OR LOCALFILENAME ! ONLY PARAMETERS RECOGNISED ARE 104 106 107 126 ! %STRING(32) NAME %INTEGER I,J,K,RC,X,N,A,CURRENTSTREAM %LONGINTEGER LI NAME=STRINGFROM(LNDR0,LNDR1) ; NAME=DESPACED(NAME) !?;*STLN_X !?;TRACE("CTMREADDESC",NAME,X,7) ! %IF ROUTE#0 %THEN I=ROUTE %ELSE %START %IF LNDR0#NIL %THEN %START RC=CTMJSREAD(LNDR0,LNDR1,0,ADDR(LI),-1,-1,-1,-1) %IF RC#0 %OR LI=0 %THEN RC=9087 %AND ->RETURN I=LI %FINISH %ELSE %START NAME=STRINGFROM(FNDR0,FNDR1);NAME=DESPACED(NAME) LI=-1 %IF JSN=0 %THEN RC=9087 %AND ->RETURN %CYCLE J=1,1,JSN %IF NAME=JSV(J)_NAME %THEN LI=JSV(J)_IVALUE %AND %EXIT %REPEAT %IF LI=-1 %THEN RC=9087 %AND ->RETURN I=LI %FINISH %FINISH ! ! I NOW CONTAINS INDEX IN FCB ARRAY ! LOOK AT PARAMETER PAIRS ! N=(PDR0&X'00FFFFFF')//3 !?;CURRENTSTREAM=OUTSTREAM;SELECTOUTPUT(TRACESTREAM) %CYCLE J=1,1,N A=PDR1+12*(J-1) K=INTEGER(A) %IF K=104 %THEN INTEGER(A+4)=1024 %IF K=106 %THEN INTEGER(A+4)=FCB(I)_KEYPOSN %IF K=107 %THEN INTEGER(A+4)=FCB(I)_KEYLENGTH %IF K=126 %THEN INTEGER(A+4)=FCB(I)_RECORDVIEW !?;NEWLINE;WRITE(K,5);PRINTSTRING(HEXOF(INTEGER(A+4))); !?;PRINTSTRING(HEXOF(INTEGER(A+8))); %REPEAT !?;SELECTOUTPUT(CURRENTSTREAM);NEWLINE RC=0 RETURN:EXITREP("CTMREADDESC",RC) %RESULT=RC %END !************************************************************************ ! ! CTMSTOP ! !***************************************************************************** %EXTERNALINTEGERFN CTMSTOP(%LONGLONGREAL LL %INTEGER RESPONSE) %INTEGER RC,X,I,J,K,L !?;*STLN_X !?;TRACE("CTMSTOP","",X,1) ! RETURN TO CALLER ! COMREG(34)=CREG34 COMREG(36)=CREG36 I=QUIT LNB K=QUIT CTB L=QUIT XNB *LCT_K *LXN_L *LLN_I *LSS_0 *EXIT_-64 %RESULT=0 %END !***************************************************************************** ! ! CTMDUMP ! %EXTERNALINTEGERFN CTMDUMP(%LONGINTEGER MESSAGE, %C %INTEGER DUM0,DUM1,ADDR0,ADDR1,DUM2,DUM3,OPTIONS, %C %LONGINTEGER DUMPROUTE) ! %INTEGER RC,X !?;*STLN_X !?;TRACE("CTMDUMP","",X,9) %MONITOR ;%STOP %END !****************************************************************************** ! ! CTMSETVSATT ! !**************************************************************************** %EXTERNALINTEGERFN CTMSETVSATT(%LONGINTEGER DESCRIPTOR, %C %INTEGER PDR0,PDR1) ! ! CHANGES PROPERTIES OF AREAS ! JUST TRACE IT FOR THE MOMENT ! !*************************************************************************** %INTEGER RC,X !?;*STLN_X !?;TRACE("CTMSETVSATT","",X,3) ! RC=0 !?;EXITREP("CTMSETVSATT",RC) %RESULT=RC %END !**************************************************************************** ! ! CTMINFORM ! !**************************************************************************** %EXTERNALINTEGERFN CTMINFORM(%INTEGER CLASS, %LONGINTEGER INTPROC, %C %INTEGER MASK,INSTLIMIT) ! ! SETS UP ENTRIES TO INTERRUPT P[ROCEDURES ! %INTEGER RC,X !?;*STLN_X !?;TRACE("CTMINFORM","",X,4) ! ! DUMMY ROUTINE FOR THE MOMENT ! RC=0 EXITREP("CTMINFORM",RC) %RESULT=0 %END !*************************************************************************** ! ! CTMSIGNAL ! !**************************************************************************** %EXTERNALINTEGERFN CTMSIGNAL(%INTEGER CONTINGENCY, %C %LONGINTEGER MESSAGE,NRA %INTEGER NRB0,NRV1) ! ! USED TO SIMULATE EFFECT OF A CINTNGENCY ! %INTEGER RC,X !?;*STLN_X !?;TRACE("CTMSIGNAL","",X,5) RC=0 EXITREP("CTMSIGNAL",RC) %RESULT=RC %END !***********************************************************************! ! CTMLOAD ! !****************************************************************************** %EXTERNALINTEGERFN CTMLOAD(%INTEGER MDR0,MDR1,DSC0,DSC1,OPTIONS) ! ! THIS ASSUMES THAT THE REQUIRED MODULES ARE LOADED AND ! INSPECTS THE LOADER TABLES VIA FINDENTRY ROUTINE ! PREFIXES ARE STRIPPED FROM NAMES BEFORE SEARCH ! %INTEGER X,RC,NMNAMES,NDSCS ! ! DTOSTRING - CREATES STRING IN S CORRESPONDING TO BYTE ! DESCRIPTOR IN D ! %ROUTINE DTOSTRING(%LONGINTEGER D %STRINGNAME S) %LONGINTEGER TEMP %INTEGER L,AD,I %IF D&X'FF00000000000000'#X'1800000000000000' %C %THEN S="" %AND %RETURN L=(X'00FFFFFF00000000'&D)>>32 BYTEINTEGER(ADDR(S))=L TEMP=X'00000000FFFFFFFF'&D AD=TEMP %IF L=0 %THEN %RETURN %CYCLE I=1,1,L BYTEINTEGER(ADDR(S)+I)=BYTEINTEGER(AD+I-1) %REPEAT %END ! ! DTOSARRAY - CREATES STRING ARRAY FROM REF() REF() BYTE ! DESCRIPTOR IN D ! %ROUTINE DTOSARRAY(%LONGINTEGER D %STRINGARRAYNAME S %INTEGERNAME COUNT) %LONGINTEGER TEMP %INTEGER L,AD,I COUNT=0 %IF D&X'FF00000000000000'#X'B000000000000000' %C %THEN %RETURN L=(X'00FFFFFF00000000'&D)>>32 TEMP=X'00000000FFFFFFFF'&D AD=TEMP %IF L=0 %THEN %RETURN %CYCLE I=1,1,L MOVE(8,AD+8*(I-1),ADDR(TEMP)) DTOSTRING(TEMP,S(I)) %REPEAT COUNT=L %END !?;*STLN_X !?;TRACE("CTMLOAD","",X,5) NMNAMES=X'000000FF'&MDR0 NDSCS=X'000000FF'&DSC0 %IF NMNAMES>NDSCS %THEN NMNAMES=NDSCS %BEGIN %LONGINTEGER LI %INTEGER I,FLAG,L0,L1 %STRING(32) %ARRAY MNAMES(1:NMNAMES) %STRING(32)S,T LI=(LENGTHENI(MDR0)<<32)!MDR1 DTOSARRAY(LI,MNAMES,I) !?;SELECTOUTPUT(TRACESTREAM) !?;NEWLINE;PRINTSTRING("CTMLOAD LIST");NEWLINE !?;%CYCLE I=1,1,NMNAMES;PRINTSTRING(MNAMES(I));NEWLINE;%REPEAT RC=0 %CYCLE I=1,1,NMNAMES MNAMES(I)->S.(".").T ;!REMOVE PREFIX L0=X'30000001';L1=ADDR(LI) FINDENTRY(T,0,0,LIBFILNAME,L0,L1,FLAG) %IF FLAG=0 %THEN MOVE(8,ADDR(LI),DSC1+8*(I-1)) %C %ELSE RC=-9101 %REPEAT %END !?;EXITREP("CTMLOAD",RC) %RESULT=RC %END !************************************************************************* !******************************************************************************* ! ! OPEH INTERFACE SYSTEM ! !**************************************************************************** !***************************************************************************** %EXTERNALINTEGERFN ICL9HEPROLOG(%INTEGER I) %INTEGER X,RC !?;*STLN_X !?;TRACE("ICL9HEPROLOG","",X,1) RC=0 !?;EXITREP("ICL9HEPROLOG",RC) %RESULT=0 %END !**************************************************************************** ! ! ICL9HECOMPERR ! !***************************************************************************** %EXTERNALINTEGERFN ICL9HECOMPERR(%INTEGER LANGUAGE,ERRORNO) %INTEGER X,RC !?;*STLN_X !?;TRACE("ICL9HECOMPERR","",X,2) SELECTOUTPUT(TRACESTREAM) NEWLINE;PRINTSTRING(HEXOF(LANGUAGE)) WRITE(ERRORNO,10);NEWLINE %MONITOR %STOP RC=0 %RESULT=0 %END !**************************************************************************** ! ! ICL9HEFATALCOMPERR ! !**************************************************************************** %EXTERNALINTEGERFN ICL9HEFATALCOMPERR(%INTEGER LANGUAGE,ERRORNO) %INTEGER X,RC,CURRENTSTREAM !?;*STLN_X !?;TRACE("ICL9HEFATALCOMPERR","",X,2) CURRENTSTREAM=OUTSTREAM SELECTOUTPUT(TRACESTREAM) NEWLINE;PRINTSTRING(HEXOF(LANGUAGE)) WRITE(ERRORNO,10);NEWLINE %MONITOR %STOP %RESULT=0 %END !***************************************************************************** ! ! ICL9HERROR(%INTEGER DUMMY) ! !***************************************************************************** ! ! NOT REQUIRED JUST YET ! !**************************************************************************** ! ! ICL9HEREPORT ! !******************************************************************************* ! ! NOT REQUIRED ! !******************************************************************************** ! ! ICL9LDLIBPROC ! !**************************************************************************** !***************************************************************************** ! ! ICL9HEINTPROC ! !**************************************************************************** !**************************************************************************** ! ! ICL9HENOMDESC ! !***************************************************************************** %EXTERNALINTEGERFN ICL9HENOMDESC(%INTEGER PDR0,PDR1, %C %LONGLONGREAL REFPROC) %INTEGER RC,X !?;*STLN_X !?;TRACE("ICL9HENOMDESC","",X,3) RC=0 !?;EXITREP("ICL9HENOMDESC",RC) %RESULT=RC %END !**************************************************************************** ! ! ICL9HEFILETIDYPROC ! !**************************************************************************** %EXTERNALINTEGERFN ICL9HEFILETIDYPROC(%LONGINTEGER FILETIDYPROC) %INTEGER RC,X !?;*STLN_X !?;TRACE("ICL9HEFILETIDYPROC","",X,1) RC=0 !@?;EXITREP("ICL9HEFILETIDYPROC",RC) %RESULT=0 %END !*************************************************************************** ! ! ICL9HETIDYUP ! !****************************************************************************** %EXTERNALINTEGERFN ICL9HETIDYUP %INTEGER RC,X !?;*STLN_X !?;TRACE("ICL9HETIDYUP","",X,1) ! NOTE THIS ROUTINE HAS NO PARAMETERS WHEN CALLED ! WILL NEED FIDDLING. ! RC=0 !?;EXITREP("ICL9HETIDYUP",RC) %RESULT=RC %END !***************************************************************** ! ! COBRUN ! !*************************************************************************** %EXTERNALROUTINE COBRUN(%STRING(255) S) %OWNSTRING(31) JSFILENAME="COB#JSV" %INTEGER I,J,K,L ! ! SAVE REGISTERS FOR A RETURN TO CALLER ! *STCT_I *STXN_J QUITCTB=I QUITXNB=J *STLN_K QUITLNB=K CREG34=COMREG(34) CREG36=COMREG(36) ! ! SET UP LOGSTREAM AND TRACESTREAM ! LOGSTREAM=0 TRACESTREAM=79 DEFINE("79,COB#TRACE") ! ! CONNECT JSV FILE ! I=CONNECTJSFILE(JSFILENAME) %IF I<0 %THEN ->FAULT1 JSV==ARRAY(I,JSVAF) JSN==JSV(0)_IVALUE ! ! PRINT OUT JOBSPACE VARIABLES ! SELECTOUTPUT(LOGSTREAM) %IF JSN#0 %THEN %START NEWLINE PRINTSTRING("JOB SPACE VARIABLES ARE SET AS FOLLOWS:") NEWLINE %CYCLE I=1,1,JSN PRINTSTRING(JSV(I)_LNAME);SPACES(2); PRINTSTRING(JSV(I)_NAME);SPACES(2) WRITE(JSV(I)_IVALUE,5) WRITE(JSV(I)_SIZE,5);WRITE(JSV(I)_KPOS,5); WRITE(JSV(I)_MAXREC,5);WRITE(JSV(I)_FORMAT,3);WRITE(JSV(I)_ORG,3) WRITE(JSV(I)_KLEN,3);WRITE(JSV(I)_ACCESS,3);WRITE(JSV(I)_PACKING,3) NEWLINE %REPEAT %FINISH ! ! ASSIGN FILES TO SET UP LINK FROM JSV_IVALUE TO FCBINDEX ! ! AT THE MOMENT ALL 'ASSIGNS' ARE CLEARED , AND THEN ALL FILES ! WHICH HAVE BEEN DEFINED VIA COBDEFINE ARE ALLOCCATED ! AN INDEX POSITION IN FCB. JSV_FORMAT=0 FOR JOB- ! SPACE VARIABLES WHICH ARE NOT FILES. ! FCN=0 %CYCLE I=1,1,JSN %IF JSV(I)_FORMAT#0 %THEN %START FCN=FCN+1 JSV(I)_IVALUE=FCN FCB(FCN)_JSVPTR=I ;!SET LINK FROM FCB TO JSV %FINISH %REPEAT PARM("LET") RUN(S) %STOP FAULT1:LOG("FAILED TO CONNECT COB#JSV") %STOP %END !************************************************************************ ! ! COBDEFINE ! !************************************************************************** %EXTERNALROUTINE COBDEFINE(%STRING(127) S) ! ! SETS UPTABLE OF UNIT DEFINITIONS AND CHANNEL ASSIGNMENTS ! IN RECORD ARRAY JSV. ! THIS IS ALSO USED FOR JOBSPACE VARIABLES DEFINED BU ! COBJSVAR COMMAND, AND IS ACCESSED BY THE COBOL RUN TIME ! SYSTEM VIA CTMJSREAD ETC. ! %EXTERNALROUTINESPEC PARMSCAN(%STRINGNAME S ,%INTEGER NPARM, %C %STRINGARRAYNAME KEYS,LITS, %INTEGERARRAYNAME MODE,PV, %C %INTEGERNAME LCNT, %INTEGER INITVALUE) %OWNSTRING(10) %ARRAY KEYS(1:9)="LNAME","NAME","SIZE","RECFM", %C "ACC","ORG","KPOS","KLEN","PACKING" %OWNINTEGERARRAY MODE(1:9)=1,1,0,1,1,1,0,0,0 %OWNINTEGERARRAY INTPARM(1:9) %STRING(32) %ARRAY LITS(1:10) %INTEGERARRAY PV(1:9) %OWNINTEGER INITVALUE=-1 %INTEGER J,LCNT,I,RC %STRING(32) S2,JSFILENAME %STRING(1) S1 %INTEGER START,HOLE,PROTECT,CONMODE,FLAG %OWNSTRING(31) FILENAME="COB#JSV" JSFILENAME=FILENAME ! ! ! ! ! CHECK FOR EXISTENCE OF FILE COB#JSV , CREATE ONE IF NOT ! ALREADY IN EXISTENCE. THEN CONNECT AND MAP RECORD ARRAY ON TO IT ! NOTE JSV(0)_IVALUE CONTAINS COUNT OF VARIABLES DEFINED ! I=CONNECTJSFILE(JSFILENAME) %IF I<0 %THEN ->FAULT1 JSV==ARRAY(I,JSVAF) ! JSN==JSV(0)_IVALUE ! ! CHECK FOR PRESENCE OF EACH FILED AND SET RECORD ACCORDINGLY ! ! FIRST TEST IF JSVAR IS ALREADY SET. I.E. CHECK LNAME FIELD FOR MATCH ! %CYCLE I=1,1,9;PV(I)=INITVALUE;%REPEAT PARMSCAN(S,9,KEYS,LITS,MODE,PV,LCNT,INITVALUE) ! ! LNAME ! %IF PV(1)=INITVALUE %THEN ->JSVFAULT S2=LITS(PV(1)) J=-1 %IF JSN#0 %THEN %START %CYCLE I=1,1,JSN %IF S2=JSV(I)_LNAME %THEN J=I %AND %EXIT %REPEAT %FINISH %IF J=-1 %THEN JSN=JSN+1 %AND J=JSN JSV(J)_LNAME=S2 ! ! NAME ! %IF PV(2)#INITVALUE %THEN JSV(J)_NAME=LITS(PV(2)) ! ! SIZE ! %IF PV(3)=INITVALUE %THEN JSV(J)_SIZE=262124 %C %ELSE JSV(J)_SIZE=INTPARM(3)*1024 ! ! RECORDFORMAT INPUT IN FORM ! E.G. F2048 ! FIXED = 1 VARIABLE =2 NOTE: FORMAT=0 IMPLIES JOBSPACE ! VARIABLE NOT FILE ! %IF PV(4)=INITVALUE %THEN JSV(J)_FORMAT=2 %AND JSV(J)_MAXREC=1024 %C %ELSE %START S1<-LITS(PV(4));LITS(PV(4))->(S1).S2 %IF S1="F" %THEN JSV(J)_FORMAT=1 %IF S1="V" %THEN JSV(J)_FORMAT=2 JSV(J)_MAXREC=IFROMS(S2) %FINISH ! ! ACCESS READ=1 WRITE=2 ! JSV(J)_ACCESS=1 %IF PV(5)#INITVALUE %AND LITS(PV(5))->("W").S2 %THEN JSV(J)_ACCESS=2 ! ! ORGANISATION SERIAL=1 RANDOM=2 INDEXSEQUENTIAL=3 ! JSV(J)_ORG=1 %IF PV(6)#INITVALUE %THEN %START %IF LITS(PV(6))->("R").S2 %OR LITS(PV(6))->("H").S2 %THEN %C JSV(J)_ORG=2 %IF LITS(PV(6))->("I").S2 %THEN JSV(J)_ORG=3 %FINISH ! ! KEYPOSITION ! JSV(J)_KPOS=1 %IF PV(7)#INITVALUE %THEN JSV(J)_KPOS=PV(7) ! ! KEYLENGTH ! %IF JSV(J)_ORG=1 %THEN JSV(J)_KLEN=0 %C %ELSE JSV(J)_KLEN=8 %IF PV(8)#INITVALUE %THEN JSV(J)_KLEN=PV(8) ! ! PACKING ! %IF PV(9)=INITVALUE %THEN JSV(J)_PACKING=90 %ELSE %C JSV(J)_PACKING=PV(9) ! ! RETURN ! RC=0 ;->RETURN ! ! FAULT ! FAULT1:LOG("ERROR IN CONNECTING COB#JSV FILE") JSVFAULT:RC=1; LOG("COBDEFINE : NO LOCAL NAME SPECIFIED") RETURN:%END !*********************************************************************** ! ! COBJSVAR ! !****************************************************************************** %EXTERNALROUTINE COBJSVAR(%STRING(63) S) ! ! FORMAT OF COMMAND IS : COBJSVAR 'JSNAME'!<=,,>! ! ! %INTEGER J,I,RC %OWNSTRING(31) JSFILENAME="COB#JSV" %STRING(32) A,B I=CONNECTJSFILE(JSFILENAME) %IF I<0 %THEN ->FAULT1 JSV==ARRAY(I,JSVAF) JSN==JSV(0)_IVALUE ! %IF S->A.(",").B %OR S->A.("=").B %THEN %START ! ! LOOK FOR A IN JSV(J)_LNAME J=-1 %IF JSN#0 %THEN %START %CYCLE I=1,1,JSN ; %IF A=JSV(I)_LNAME %THEN J=I %AND %EXIT %REPEAT %FINISH %IF J=-1 %THEN JSN=JSN+1 %AND J=JSN %AND JSV(J)_LNAME=A ! ! SET JSV_FORMAT=0 TO INDICATE VARIABLE RATHER THAN FILE ! JSV(J)_FORMAT=0 ! ! CHECK FOR INTEGER OR STRING ! %IF '0'<= BYTEINTEGER(ADDR(B)+1)<='9' %THEN %C JSV(J)_IVALUE=LENGTHENI(IFROMS(B)) %C %ELSE JSV(J)_NAME=B %FINISH %ELSE %START NEWLINE;PRINTSTRING("COBJSVAR : INCORRECT FORMAT"); NEWLINE;RC=1 %FINISH ->RETURN ! ! FAULT ! FAULT1:LOG("ERROR IN CONNECTING JSVFILE") RC=2 RETURN:%END !*********************************************************************** ! ! COBCLEAR ! !**************************************************************************** %EXTERNALROUTINE COBCLEAR %INTEGER FLAG DESTROY("COB#JSV") %END !********************************************************************** !* !* CONSTANTS !* !********************************************************************** ! %CONSTSTRING(4) VERSION = "1.1" %CONSTINTEGER SEGMENT=262144, %C SEGMENTK=256 %CONSTINTEGER PAGELEN=60 %CONSTINTEGER FILED=0, %C LOCAL=1, %C ROMF =2 %CONSTINTEGER FILE =1, %C VSAREA=0 ! ! ! !********************************************************************** !* !* GLOBALS !* !********************************************************************** ! %OWNINTEGER LISTING,SOURCESTREAM %OWNSTRING(255) SOURCELIST %OWNINTEGER FILEOPENFLAG,LINECOUNT,NEWPAGECOUNT,INFILEDEPTH %OWNINTEGER MAXLINES,MAXCHARS %OWNINTEGER LISTDIR,SUBHDLEN,PAGEHDLEN %OWNINTEGERARRAY SEQCOUNT(0:15) %OWNBYTEINTEGERARRAY FILETYPE(0:15) %OWNSTRING(255) SUBHEADING,PAGEHEADING %OWNINTEGER NEWPAGEFLAG,EBCDICFLAG %OWNBYTEINTEGERARRAY OUTBUFF(0:160) %OWNINTEGER CURRENTMODULETYPE,OUTFILEPTR,OUTFILELEN,MAXOUTFILELEN, %C MODULE ACTIVE,OUTFILECONADDR,CODE %OWNSTRING(64) OMFLIBNAME %OWNSTRING(32) OMFMODULENAME %OWNSTRING(3) DIRECTIVE ! !********************************************************************** !* !* EXTERNAL REFERENCES - SUBSYSTEM !* !********************************************************************** ! %EXTERNALSTRINGFNSPEC DATE %EXTERNALSTRINGFNSPEC TIME %SYSTEMSTRINGFNSPEC CONFILE (%INTEGER ADDRESS) %EXTERNALROUTINESPEC OPENSQ(%INTEGER STREAM) %EXTERNALROUTINESPEC CLOSESQ(%INTEGER STREAM) %EXTERNALROUTINESPEC WRITESQ(%INTEGER STREAM,%NAME FROM,TO) %EXTERNALROUTINESPEC METER ! %ROUTINE PRINT PAGE HEADING PRINTSTRING(PAGEHEADING) WRITE(NEWPAGECOUNT,4) NEWLINE %END ! %ROUTINE PRINT SUB HEADING %IF NEWPAGEFLAG=0 %THEN %START %IF LINECOUNT+SUBHDLEN>MAXLINES %THEN %START NEWPAGEFLAG=1 %RETURN %FINISH %FINISH PRINTSTRING(SUBHEADING) NEWLINE LINECOUNT=LINECOUNT+SUBHDLEN %END ! !###################################################################### !# !# COMPILER ENVIRONMENT ROUTINES !# !###################################################################### ! ! !*********************************************************************** !* !* INIT CENV !* !************************************************************************ ! %EXTERNALINTEGERFN INITCENV(%STRINGNAME SOURCE,OBJ,DIRTRIGCHAR, %C SAVELIST, COMPILERIDEN, INITSUBHD, %INTEGER OMFCODE,EBCDIC,LISTDIRS, %C NLINES,NCHARS) %STRING(32) INFILE,LISTFILE %INTEGER X ! !?; *STLN_X ! LOG("EMAS 2900 -- COMPILER ENVIRONMENT VERSION ".VERSION) ! MAXLINES=NLINES MAXCHARS=NCHARS EBCDICFLAG=EBCDIC SOURCELIST=SOURCE %IF EBCDICFLAG=1 %THEN ETOI(ADDR(SOURCELIST)+1,LENGTH(SOURCELIST)) %UNLESS SOURCELIST->INFILE.("&").SOURCELIST %THEN INFILE=SOURCELIST SOURCESTREAM=20 !?; !LOG("ABOUT TO CALL DEFINE(ST20,".INFILE.")") DEFINE("ST20,".INFILE) LISTING=40 %IF SAVELIST="" %THEN LISTFILE="T#LIST" %C %ELSE %START %IF EBCDICFLAG=1 %THEN %C ETOI(ADDR(SAVELIST)+1,LENGTH(SAVELIST)) LISTFILE=SAVELIST %FINISH !?; !LOG("ABOUT TO CALL DEFINE(ST40,".LISTFILE.")") DEFINE("ST40,".LISTFILE) !?; !LOG("ABOUT TO CALL DEFINE(ST10,.NULL)") DEFINE("ST10,.NULL") SELECTINPUT(SOURCESTREAM) INFILEDEPTH=0 DIRECTIVE=DIRTRIGCHAR LISTDIR=LISTDIRS CODE=OMFCODE OMFLIBNAME=OBJ %IF EBCDICFLAG=1 %THEN ETOI(ADDR(COMPILERIDEN)+1,LENGTH(COMPILERIDEN)) %IF EBCDICFLAG=1 %THEN ETOI(ADDR(OMFLIBNAME)+1,LENGTH(OMFLIBNAME)) MODULEACTIVE=NO OUTFILEPTR=0 SUBHEADING=INITSUBHD ! SET UP PAGE HEADING PAGE HEADING=" USER ".UINFS(1)." JOB 12CHARJOBNAM ". %C COMPILERIDEN." COMPILATION ".DATE." ".TIME." PAGE " NEWPAGECOUNT=0 NEWPAGEFLAG=1 %RESULT=0 %END ! ! !*********************************************************************** !* !* ICL9HN ALTER VS !* !*********************************************************************** ! %EXTERNALINTEGERFN ICL9HN ALTERVS(%INTEGER ADR0,ADR1,SIZE) ! ! AN EXTRA PARAM (MODE) MAY BE ADDED IN THE FUTURE %STRING(15) FILENAME %INTEGER RC,X ! !?; *STLN_X !?;TRACE("ALTERVS","",X,3) ! FILENAME=CONFILE(ADR1) %IF FILENAME=".NULL" %THEN %RESULT=1 %IF SIZE>-1 %THEN %START CHANGE FILE SIZE(FILENAME,SIZE,RC) !?; POSTREPORT("CHANGE FILE SIZE",RC) %IF RC#0 %THEN RC=1 %FINISH !? EXITREP("ALTERVS",RC) %RESULT=RC %END; !OF ALTERVS !* !***************************************************************** !* !* ICL9HN CREATE MODULE !* !****************************************************************** ! %EXTERNALINTEGERFN ICL9HN CREATE MODULE(%INTEGER NAMDR0,NAMDR1, %C FULLNAMDR0,FULLNAMDR1,SIZE) %STRING(32) FILENAME,FULLNAME,AREANAME,DEFINESTR %INTEGER X,AREAADDR,FLAG,RC RC=0 %IF SIZE<0 %THEN MAXOUTFILELEN=SEGMENTK %C %ELSE MAXOUTFILELEN=(SIZE+1023)//1024 %IF NAMDR0=NIL %THEN FILENAME="T#".NEXTTEMP %ELSE %START FILENAME=STRINGFROM(NAMDR0,NAMDR1) ! %IF EBCDICFLAG=1 %THEN ETOI(ADDR(FILENAME)+1,LENGTH(FILENAME)) FILENAME=DESPACED(FILENAME) %FINISH OMFMODULENAME=FILENAME ! !?; *STLN_X !?;TRACE("CREATE MODULE", %C " ".FILENAME." SIZE=".SFROMI(MAXOUTFILELEN*1024),X,5) ! %IF CODE=FILED %THEN %START MODULEACTIVE=YES !LOG("CREATE FILE") %UNLESS FULLNAMDR0=NIL %THEN %START FULLNAME=FILENAME."#" FILL(FULLNAMDR0&X'00FFFFFF',FULLNAMDR1,' ') ITOE(ADDR(FULLNAME)+1,LENGTH(FULLNAME)) %IF EBCDICFLAG=1 MOVE(LENGTH(FULLNAME),ADDR(FULLNAME)+1,FULLNAMDR1) %FINISH %IF FILEOPENFLAG=1 %THEN CLOSESQ(50) %AND FILEOPENFLAG=0 DEFINESTR="SQ50,".FILENAME."#,". %C SFROMI(MAXOUTFILELEN).",V4096" !LOG("CALLING DEFINE(".DEFINESTR.")") DEFINE(DEFINESTR) FILEOPENFLAG=0 OUTFILELEN=0 CURRENT MODULE TYPE = FILE RC=0 %FINISH %ELSE %START %IF MODULEACTIVE=YES %THEN %START %IF CURRENT MODULE TYPE=FILE %THEN RC=511 OUTFILEPTR=OUTFILECONADDR OUTFILELEN=0 RC=0 %FINISH %ELSE %START MODULEACTIVE=YES AREANAME="T#".NEXTTEMP !LOG("CREATE VS AREA") OUTFILE(AREANAME,SIZE,SEGMENT,0,AREAADDR,FLAG) !?; POSTREPORT("OUTFILE",RC) %IF FLAG#0 %THEN %START LOG("FAILED TO CREATE VS AREA. FLAG= ".SFROMI(FLAG)) RC=510 %FINISH %ELSE %START OUTFILEPTR=AREAADDR OUTFILECONADDR=AREAADDR OUTFILELEN=0 CURRENT MODULE TYPE = VSAREA RC=0 %FINISH %FINISH %FINISH !? EXITREP("CREATE MODULE",RC) %RESULT=RC %END ! ! !******************************************************************* !* !* ICL9HN CREATE VS !* !*********************************************************************** ! %EXTERNALINTEGERFN ICL9HN CREATEVS(%INTEGER NAMDR0,NAMDR1,SIZE, %C MODE,DESCDR0,DESCDR1) %STRING(32) AREANAME %INTEGER X,FLAG,AREAADDR,AREASIZE,RC %IF NAMDR0=NIL %THEN AREANAME="T#".NEXTTEMP %ELSE %START AREANAME=STRINGFROM(NAMDR0,NAMDR1) ! %IF EBCDICFLAG=1 %THEN %C ! ETOI(ADDR(AREANAME)+1,LENGTH(AREANAME)) AREANAME=DESPACED(AREANAME) AREANAME="T#".AREANAME %FINISH AREASIZE=SIZE ! !?; *STLN_X !?;TRACE("CREATEVS",AREANAME,X,6) ! OUTFILE(AREANAME,AREASIZE,SEGMENT,0,AREAADDR,FLAG) %IF FLAG#0 %THEN %START !LOG("RETURNED FROM OUTFILE, FLAG=".SFROMI(FLAG)) RC=1 %FINISH %ELSE %START INTEGER(DESCDR1)=X'18000000' ! AREASIZE INTEGER(DESCDR1+4)=AREAADDR RC=0 %FINISH !? EXITREP("CREATEVS",RC) %RESULT=RC %END ! !*********************************************************************** !* !* ICL9HN END MODULE !* !************************************************************* ! %EXTERNALINTEGERFN ICL9HN ENDMODULE %INTEGER X,RC ! RC=0 !?; *STLN_X !?;TRACE("ENDMODULE", %C "ACTUALSIZE=".SFROMI(OUTFILELEN).":REQSIZE=". %C SFROMI(MAXOUTFILELEN*1024),X,1) ! %IF MODULEACTIVE=NO %THEN %START LOG("NO MODULE ACTIVE") RC=1 %FINISH %ELSE %START MODULEACTIVE=NO %IF CURRENTMODULETYPE=FILE %THEN %START %IF FILEOPENFLAG=1 %THEN CLOSESQ(50) %AND FILEOPENFLAG=0 %FINISH %FINISH !? EXITREP("ENDMODULE",RC) %RESULT=RC %END ! !************************************************************ !* !* ICL9HN LOG !* !************************************************************ ! %EXTERNALINTEGERFN ICL9HN LOG(%INTEGER MESSDR0,MESSDR1,DESTINATION) ! ! SID D403 FOR CTM INTERFACE DEFN OF MESSAGE TYPE VALUES ! %INTEGER L,CURRENTSTREAM,X,RC %STRING(138) S %UNLESS -1<=DESTINATION<=15 %THEN %RESULT=1 RC=0 ! !?; *STLN_X !?;TRACE("LOG","MSG LOGGED TO APPROPRIATE LOG STREAM",X,3) ! L=MESSDR0&X'000000FF' %IF L>108 %THEN L=108 CURRENT STREAM=OUTSTREAM SELECT OUTPUT(LOGSTREAM) S=STRINGFROM(L,MESSDR1) ! ETOI(ADDR(S)+1,L) %IF EBCDICFLAG=1 PRINTSTRING(TIME.S) NEWLINE SELECT OUTPUT(CURRENT STREAM) %RESULT=0 %END ! !************************************************************ !* !* ICL9HN MONITOR !* !************************************************************ ! %EXTERNALINTEGERFN ICL9HN MONITOR(%INTEGER TAG) %INTEGER CURRENT STREAM,X ! !?; *STLN_X !?;TRACE("MONITOR","",X,1) ! CURRENTSTREAM=OUTSTREAM SELECT OUTPUT(LOGSTREAM) PRINTSTRING(SFROMI(TAG)."METERING INFORMATION FOLLOWS") NEWLINE METER NEWLINE SELECTOUTPUT(CURRENT STREAM) !? EXITREP("MONITOR",0) %RESULT=0 %END ! !************************************************************ !* !* ICL9HN NEW SUBHEADING !* !************************************************************ ! %EXTERNALINTEGERFN ICL9HN NEW SUBHEADING(%INTEGER SUBHDDR0,SUBHDDR1, %C LINES,NEWPAGE) %INTEGER X,L,RC ! RC=0 L=SUBHDDR0&X'000000FF' SUBHEADING=STRINGFROM(L,SUBHDDR1) ! %IF EBCDICFLAG=1 %THEN ETOI(ADDR(SUBHEADING)+1,LENGTH(SUBHEADING)) SUBHDLEN=LINES ! !?; *STLN_X !?;TRACE("NEW SUBHEADING",">>".SUBHEADING."<<",X,4) ! %IF LINECOUNT+LINES>MAXLINES %THEN NEWPAGEFLAG=1 %IF NEWPAGE>0 %THEN %START %IF LINECOUNT>(MAXLINES-1/NEWPAGE*MAXLINES) %THEN NEWPAGEFLAG=1 %FINISH %IF NEWPAGE<=-1 %THEN NEWPAGEFLAG=1 %IF NEWPAGEFLAG=1 %THEN RC=-1 !? EXITREP("NEWSUBHD",RC) %RESULT=RC %END ! !************************************************************** !* !* ICL9HN NEWLINE !* !************************************************************* ! %EXTERNALINTEGERFN ICL9HN NEWLINE(%INTEGER LINES) %INTEGER X,CURRENTSTREAM ! !?; *STLN_X !?;TRACE("NEWLINE","",X,1) ! %IF LINECOUNT+LINES>MAXLINES %THEN NEWPAGEFLAG=1 %ELSE %START CURRENTSTREAM=OUTSTREAM SELECT OUTPUT(LISTING) NEWLINES(LINES) LINECOUNT=LINECOUNT+LINES SELECT OUTPUT(CURRENT STREAM) %FINISH %RESULT=0 !? EXITREP("NEWLINE",0) %END ! !************************************************************* !* !* ICL9HN NEWPAGE !* !************************************************************ ! %EXTERNALINTEGERFN ICL9HN NEWPAGE %INTEGER X ! !?; *STLN_X !?;TRACE("NEWPAGE","",X,0) ! NEWPAGEFLAG=1 !? EXITREP("NEWPAGE",0) %RESULT=0 %END ! !************************************************************ !* !* ICL9HN OUTPUTLINE !* !************************************************************ ! %EXTERNALINTEGERFN ICL9HN OUTPUT LINE(%INTEGER BUFFDR0,BUFFDR1) %INTEGER CURRENTSTREAM,X,LEN,LINES ! !?; *STLN_X !?;TRACE("OUTPUTLINE","",X,2) ! CURRENTSTREAM=OUTSTREAM SELECT OUTPUT(LISTING) %IF NEWPAGEFLAG=1 %OR LINECOUNT=MAXLINES %THEN %START !LOG("ABOUT TO THROW NEWPAGE. NUM. LINES ON CURRPAGE=".SFROMI(LINECOUNT)) NEWPAGE !??; NEWLINES(4) NEWPAGECOUNT=NEWPAGECOUNT+1 LINECOUNT=0 PRINT PAGE HEADING PRINT SUBHEADING NEWPAGEFLAG=0 LINECOUNT=LINECOUNT+PAGEHDLEN+SUBHDLEN %FINISH LEN=BUFFDR0&X'00FFFFFF' MOVE(LEN,BUFFDR1,ADDR(OUTBUFF(1))) OUTBUFF(2)=LEN-2 %IF EBCDICFLAG=1 %THEN ETOI(ADDR(OUTBUFF(3)),LEN-2) NEWLINE;PRINTSTRING(STRING(ADDR(OUTBUFF(2)))) LINECOUNT=LINECOUNT+1 SELECT OUTPUT(CURRENT STREAM) !? EXITREP("OUTPUTLINE",0) %RESULT=0 %END ! !*********************************************************************** !* !* ICL9HN OUTPUT RECORD !* !*********************************************************************** ! %EXTERNALINTEGERFN ICL9HN OUTPUT RECORD(%INTEGER BUFFDR0,BUFFDR1) %BYTEINTEGERARRAYNAME OMFARRAY %BYTEINTEGERARRAYFORMAT OMFREC(1:262144) %INTEGER RECLEN,X,RC RECLEN=BUFFDR0&X'00FFFFFF' OUTFILELEN=OUTFILELEN+RECLEN+2 ! !?; *STLN_X !?;TRACE("OUTPUTRECORD","LENGTH=".SFROMI(RECLEN),X,2) ! OMFARRAY==ARRAY(BUFFDR1,OMFREC) %IF CURRENTMODULE TYPE=FILE %THEN %START %IF FILEOPENFLAG=0 %THEN OPENSQ(50) %AND FILEOPENFLAG=1 !LOG("OUTPUT RECORD TO FILE") WRITESQ(50,OMFARRAY(1),OMFARRAY(RECLEN)) RC=0 %FINISH %ELSE %START !LOG("OUTPUT RECORD TO VS AREA") %IF OUTFILELEN>SEGMENT %THEN %START LOG("SIZE OF OMF WRITTEN EXCEEDS ONE SEG ".SFROMI(OUTFILELEN)) RC=1 %FINISH %ELSE %START MOVE(2,ADDR(RECLEN)+2,OUTFILEPTR) OUTFILEPTR=OUTFILEPTR+2 MOVE(RECLEN,BUFFDR1,OUTFILEPTR) OUTFILEPTR=OUTFILEPTR+RECLEN RC=0 %FINISH %FINISH !? EXITREP("OUTPUTRECORD",RC) %RESULT=RC %END ! !**************************************************************** !* !* ICL9HN READ CARD !* !************************************************************ ! %EXTERNALINTEGERFN ICL9HNREADCARD(%INTEGER BUFFDR0,BUFFDR1, %C SEQDR0,SEQDR1) %INTEGER SP,RC,LINES,PTR,X %STRING(32) NEXT %STRING(3) TRIG %STRING(5) DIR %STRING(2) NUMLINES %STRING(160) LINE %INTEGER BUFFLEN %STRING(15) SEQNUM %STRING(2) DEPTH %BYTEINTEGERARRAYNAME CARD %BYTEINTEGERARRAYFORMAT CARDFORM(0:160) %STRING(5)%FNSPEC READDIR(%INTEGERNAME PTR) %STRING(32)%FNSPEC READDIRPARM(%INTEGERNAME PTR) %SWITCH SW(0:2) %ON %EVENT 9 %START !?; !LOG("INPUT ENDED - TYPE & DEPTH ".SFROMI(FILETYPE(INFILEDEPTH)) %C ! .SFROMI(INFILEDEPTH)) RC=0 ->SW(FILETYPE(INFILEDEPTH)) SW(0): %RESULT=-3 ! %UNLESS SOURCELIST->NEXT.("&").SOURCELIST %THEN NEXT=SOURCELIST ! SELECTINPUT(DUMMYSTREAM) ! CLOSESTREAM(SOURCESTREAM) !!?; !LOG("ABOUT TO CALL DEFINE(ST20,".NEXT.")") ! DEFINE("ST20,".NEXT) ! SELECT INPUT(SOURCESTREAM) ! %RESULT=-2 SW(1): RC=-1 SW(2): INFILEDEPTH=INFILEDEPTH-1 SOURCESTREAM=SOURCESTREAM-1 SELECT INPUT(SOURCESTREAM) CLOSESTREAM(SOURCESTREAM+1) %IF RC<0 %THEN %RESULT=RC ->READ %FINISH ! RC=0 !?; *STLN_X !?;TRACE("READ CARD","",X,6) ! %IF EBCDICFLAG=1 %THEN SP=C' ' %ELSE SP=' ' BUFFLEN=BUFFDR0&X'00FFFFFF' FILL(BUFFLEN,BUFFDR1,SP) READ: LINE=NEXT LINE %IF SEQDR0#NIL %THEN %START SEQNUM=SFROMI(SEQCOUNT(INFILEDEPTH)) DEPTH=SFROMI(INFILEDEPTH) SEQNUM=DEPTH."/".SEQNUM MOVE(LENGTH(SEQNUM),ADDR(SEQNUM)+1,SEQDR1) %FINISH SEQCOUNT(INFILEDEPTH)=SEQCOUNT(INFILEDEPTH)+1 %IF EBCDICFLAG=1 %THEN ITOE(ADDR(LINE)+1,LENGTH(LINE)) MOVE(LENGTH(LINE),ADDR(LINE)+1,BUFFDR1) ! %IF LENDR0#NIL %THEN INTEGER(LENDR1)=LENGTH(LINE) %IF LENGTH(LINE)<3 %THEN TRIG="" %ELSE TRIG=FROMSTRING(LINE,1,3) %IF TRIG=DIRECTIVE %THEN %START PTR=4 CARD==ARRAY(ADDR(LINE),CARDFORM) DIR=READ DIR(PTR) %IF DIR="READ" %THEN %START NEXT=READ DIRPARM(PTR) INFILEDEPTH=INFILEDEPTH+1 FILETYPE(INFILEDEPTH)=2 SOURCESTREAM=SOURCESTREAM+1 SEQCOUNT(INFILEDEPTH)=1 !?; !LOG("ABOUT TO CALL DEFINE(ST".SFROMI(SOURCESTREAM).",".NEXT.")") DEFINE("ST".SFROMI(SOURCESTREAM).",".NEXT) SELECTINPUT(SOURCESTREAM) %IF LISTDIR=YES %THEN RC=-512 %ELSE RC=511 %FINISH %ELSE %START %IF DIR="LINES" %THEN %START NUMLINES=READ DIRPARM(PTR) LINES=IFROMS(NUMLINES) %IF LINES<=0 %THEN %RESULT=RC %IF LINECOUNT+LINES>MAXLINES %THEN NEWPAGEFLAG=1 %ELSE %START LINECOUNT=LINECOUNT+LINES NEWLINES(LINES) %FINISH RC=0 %FINISH %ELSE %START %IF DIR="PAGE" %THEN %START NEWPAGEFLAG=1 RC=0 %FINISH %ELSE LOG("INVALID DIRECTIVE".DIR) %FINISH %FINISH %FINISH !? EXITREP("READ CARD",RC) %RESULT=RC ! ! %STRING(5)%FN READDIR(%INTEGERNAME PTR) %INTEGER J %STRING(5) S S="" %WHILE CARD(PTR)=' ' %THEN PTR=PTR+1 %CYCLE J=PTR,1,PTR+4 %EXIT %UNLESS 'A'<=CARD(J)<='Z' S=S.TOSTRING(CARD(J)) %REPEAT PTR=J %RESULT=S %END %STRING(32)%FN READ DIRPARM(%INTEGERNAME PTR) %STRING(32) S %INTEGER J S="" %WHILE CARD(PTR)#'(' %THEN PTR=PTR+1 %CYCLE J=PTR+1,1,PTR+32 %EXIT %IF CARD(J)=')' %UNLESS CARD(J)=' ' %THEN S=S.TOSTRING(CARD(J)) %REPEAT %IF J=PTR+32 %AND CARD(J)#')' %THEN LOG("NAME TOO LONG IN DIR") PTR=J+1 %RESULT=S %END %END ! !*********************************************************************** !* !* ICL9HN READ LINE !* !****************************************************************** ! %EXTERNALINTEGERFN ICL9HN READLINE(%INTEGER BUFFDR0,BUFFDR1, %C SIZEDR0,SIZEDR1) %INTEGER BUFFLEN,RC,X %STRING(32) NEXT %STRING(160) LINE %SWITCH SW(0:2) %ON %EVENT 9 %START !?; !LOG("INPUT ENDED - TYPE & DEPTH ".SFROMI(FILETYPE(INFILEDEPTH)) %C .SFROMI(INFILEDEPTH)) RC=0 ->SW(FILETYPE(INFILEDEPTH)) SW(0): %IF SOURCELIST="" %THEN %RESULT=-3 %UNLESS SOURCELIST->NEXT.("&").SOURCELIST %THEN NEXT=SOURCELIST SELECTINPUT(DUMMYSTREAM) CLOSESTREAM(20) !?; !LOG("ABOUT TO CALL DEFINE(ST20,".NEXT.")") DEFINE("ST20,".NEXT) SELECTINPUT(20) %RESULT=-2 SW(1): RC=-1 INFILEDEPTH=INFILEDEPTH-1 SOURCESTREAM=SOURCESTREAM-1 SELECT INPUT(SOURCESTREAM) CLOSESTREAM(SOURCESTREAM+1) %IF RC<0 %THEN %RESULT=RC ->READ SW(2): LOG("INVALID FILETYPE") %RESULT=1 %FINISH ! !?; *STLN_X !?;TRACE("READ LINE","",X,4) ! RC=0 READ: LINE = NEXT LINE BUFFLEN=BUFFDR0&X'00FFFFFF' %IF LENGTH(LINE)>BUFFLEN %THEN LENGTH(LINE)=BUFFLEN %AND RC=-255 %IF EBCDICFLAG=1 %THEN ITOE(ADDR(LINE)+1,LENGTH(LINE)) MOVE(LENGTH(LINE),ADDR(LINE)+1,BUFFDR1) %IF SIZEDR0#NIL %THEN INTEGER(SIZEDR1)=LENGTH(LINE) !? EXITREP("READLINE",RC) %RESULT=RC %END ! !************************************************************************ !* !* NOT YET USED FNS --- SIMPLY TRACE CALLS !* !*********************************************************************** %EXTERNALINTEGERFN ICL9HNQUOTA %INTEGER X ! !?; *STLN_X !?;TRACE("QUOTA","",X,0) ! %RESULT=300 %END ! ! %EXTERNALINTEGERFN ICL9HN CREATEALIAS(%INTEGER NAMDR0,NAMDR1, %C DUMDR0,DUMDR1) %INTEGER X ! !?; *STLN_X !?;TRACE("CREATE ALIAS","",X,4) ! %RESULT=0 %END ! ! %EXTERNALINTEGERFN ICL9HN COPYFILE(%INTEGER NAMDR0,NAMDR1,FULLDR0, %C FULLDR1,PREFDR0,PREFDR1) %INTEGER X ! !?; *STLN_X !?;TRACE("COPYFILE","",X,6) ! %RESULT=0 %END ! ! %EXTERNALINTEGERFN ICL9HN SETDUMPER(%INTEGER DUMPLNB,DPROCDR0,DPROCDR1) %INTEGER X ! !?; *STLN_X !?;TRACE("SETDUMPER","",X,3) ! %RESULT=0 %END ! %EXTERNALINTEGERFN READKERNELVMMETERS %RESULT=0 %END %EXTERNALINTEGERFN GIVEPROCESSTIME %RESULT=0 %END ! !! %EXTERNALINTEGERFN FCWORKFILESUPPORT(%INTEGER DUM) %END %EXTERNALINTEGERFN LOAD(%INTEGER DUM) %END %EXTERNALINTEGERFN JSWRITE(%INTEGER DUM) %END %EXTERNALINTEGERFN ICL9DDLTCOBOLLINK(%INTEGER DUM) %END %EXTERNALINTEGERFN JSREAD(%INTEGER DUM) %END %EXTERNALINTEGERFN CTMREPLACEVS(%INTEGER DUM) %END !************************************************************************** ! ! ICL9HNCOMPILESUPPORT ! !***************************************************************************** %EXTERNALINTEGERFN ICL9HNCOMPILESUPPORT(%LONGINTEGER FLAGS %C %INTEGER LINK %LONGINTEGER INPUT,OUTPUT,RUN,LISTINGS,MESSAGES, %C SAVELIST,DIAGNOSTICS,RTCHECKS,SHARE,OPT,LIBPROC,LENGTHS, %C ARGUMENTS,TRACE,CANCEL,TESTENV,TP,SEPARATEAREAS,ITEMSONSTACK, %C ERRORCLASS,IGNORE,CATCH,EMESS,ROUTE,REPORT,COUNT,DEPTH, %C RDIAG,ARRAYSIZE,CONTINUE,TRIES,DFILE,DEBUG,RTRACE,TFILE, %C BUFFER,MAXLINES,CDIAG,DUMP,TEMP,CODE,GENERATIONSKEPT, %C PROCEDURE,DIRECTIVES,TARRAYSIZE,UINDICATORS,DISPLAY) %SYSTEMROUTINESPEC ITOE(%INTEGER ADDR,LENGTH) %SYSTEMROUTINESPEC ETOI(%INTEGER ADDR,LENGTH) %SYSTEMROUTINESPEC MOVE(%INTEGER LENGTH,FROM,TO) ! ! ! STRING TO I CONVERTS STRING TO INTEGER ! %ROUTINE STRINGTOI(%STRINGNAME X %INTEGERNAME N) %INTEGER L,I L=LENGTH(X) N=0 %CYCLE I=1,1,L N=10*N+(BYTEINTEGER(ADDR(X)+I)-'0') %REPEAT %END ! ! DTOSTRING - CREATES STRING IN S CORRESPONDING TO BYTE ! DESCRIPTOR IN D ! %ROUTINE DTOSTRING(%LONGINTEGER D %STRINGNAME S) %LONGINTEGER TEMP %INTEGER L,AD,I %IF D&X'FF00000000000000'#X'1800000000000000' %C %THEN S="" %AND %RETURN L=(X'00FFFFFF00000000'&D)>>32 BYTEINTEGER(ADDR(S))=L TEMP=X'00000000FFFFFFFF'&D AD=TEMP %IF L=0 %THEN %RETURN %CYCLE I=1,1,L BYTEINTEGER(ADDR(S)+I)=BYTEINTEGER(AD+I-1) %REPEAT %END ! ! DTOSARRAY - CREATES STRING ARRAY FROM REF() REF() BYTE ! DESCRIPTOR IN D ! %ROUTINE DTOSARRAY(%LONGINTEGER D %STRINGARRAYNAME S %INTEGERNAME COUNT) %LONGINTEGER TEMP %INTEGER L,AD,I COUNT=0 %IF D&X'FF00000000000000'#X'B000000000000000' %C %THEN %RETURN L=(X'00FFFFFF00000000'&D)>>32 TEMP=X'00000000FFFFFFFF'&D AD=TEMP %IF L=0 %THEN %RETURN %CYCLE I=1,1,L MOVE(8,AD+8*(I-1),ADDR(TEMP)) DTOSTRING(TEMP,S(I)) %REPEAT COUNT=L %END %LONGINTEGERFN CDSCA(%STRINGNAME S) %LONGINTEGER BOUND BOUND=LENGTH(S) %RESULT=((X'18000000'!BOUND)<<32)!(ADDR(S)+1) %END ! DECLARATIONS FOR COMPILE SUPPORT ! %EXTERNALROUTINESPEC COMF(%STRING(63) S) %LONGINTEGER A %INTEGER I,J,K,NINFILES,N,NLINES,NCHARS,OPPTR %LONGINTEGER DOPARRAY,CALLD,LL %STRING(32) SSAVELIST,SOBJECT,SDIRECTIVES,INITSUBHD,SOMF,STEMP %STRING(255) TITLE %STRING(32) %ARRAY SINPUT(1:6) ! SET OPTIONS ARRAY ! %STRING(20) %ARRAY SA(1:20) %STRING(255) SS,X,Y,Z %OWNBYTEINTEGERARRAY DEFOPT(0:93)= %C 3,2,0,2,1,0,0,0,0,0,2,0,0,0,0,0, %C 1,1,0,0,0,0,0,4,8,2,0,4,8,1,0,4, %C 8,16,4,0,2,0,0,0,0,0,0,0,0,0,2,66, %C 0,0,0,0,0,0,0,255,120,0,0,0,0,0,1,1, %C 1,0,0,0,0,0,0,0,0,0,0,0,0, %C 0,0,0,255,0,66,120,0,0,255,0,0,0, %C 0,0,0,0 %OWNBYTEINTEGERARRAY OP(0:255) %OWNSTRING(1) %ARRAY LSPECS(1:12)= %C "I","J","K","X","L","M","N","X","E","D","Q","R" ! %CYCLE I=0,1,255 OP(I)=0 %REPEAT ! ! TEMPORARY SETTINGS SUPPLIED FORM ARRAY DEFOPT ! %CYCLE I=0,1,93 OP(I)=DEFOPT(I) %REPEAT ! ! COLLECT SAVELIST,OMFFILE AND DIRECTIVE VALUES ! SOMF=".NULL";SSAVELIST=".NULL" ; SDIRECTIVES="#*#";SOBJECT=".NULL" %IF SAVELIST#-1 %THEN DTOSTRING(SAVELIST,SSAVELIST) %IF OUTPUT#-1 %THEN DTOSTRING(OUTPUT,SOBJECT) %AND SOMF="T#COBOMF" ITOE(ADDR(SOMF)+1,LENGTH(SOMF)) OP(22)=94;OP(53)=94 MOVE(LENGTH(SOMF)+1,ADDR(SOMF),ADDR(OP(94))) OPPTR=95+LENGTH(SOMF) %IF DIRECTIVES#-1 %THEN DTOSTRING(DIRECTIVES,SDIRECTIVES) ! ! SET UP PLEX SPACE FOR PROCEDURE NAME ! OP(2)=OPPTR ; OP(OPPTR)=0 ; OPPTR=OPPTR+33 ! ! COLLECT ARRAY OFINPUT FILES ! %IF INPUT#-1 %THEN DTOSARRAY(INPUT,SINPUT,NINFILES) ! ! SET OPTIONS ARRAY BY INSPECTING PARAMETER LIST ! !LISTINGS PARAMETER ! DTOSARRAY(LISTINGS,SA,N) SS="&" %IF N#0 %THEN %START %CYCLE I=1,1,N ETOI(ADDR(SA(I))+1,LENGTH(SA(I))) SS=SS.SA(I)."&" %REPEAT ! ! LISTINGS=ALL ! %IF SS->X.("&ALL&").Y %THEN %START OP(5)=1;OP(6)=1;OP(7)=1;OP(8)=1;OP(9)=1 OP(37)=1;OP(58)=1;OP(59)=1;OP(1)=2 OP(56)=120;OP(63)=1;OP(64)=1;OP(47)=66 ->MESSAGES %FINISH ! %IF SS->X.("&XREF&").Y %THEN OP(5)=1 %IF SS->X.("&ERL&").Y %THEN OP(6)=1 %IF SS->X.("&MAPS&").Y %THEN OP(7)=1 %IF SS->X.("&STATMAP&").Y %THEN OP(7)=1 %IF SS->X.("&ATTR&").Y %THEN OP(8)=1 %IF SS->X.("&OBJECT&").Y %THEN OP(9)=1 %IF SS->X.("&OPTEXT&").Y %THEN OP(9)=1 %IF SS->X.("&OPTEXT&").Y %THEN OP(37)=1 %IF SS->X.("&VALUES&").Y %THEN OP(58)=1 %IF SS->X.("&DIRECTIVES&").Y %THEN OP(59)=1 %IF SS->X.("&NONE&").Y %THEN OP(63)=0 %IF SS->X.("&NOOPTIONS&").Y %THEN OP(64)=0 %IF SS->X.("&NOSOURCE&").Y %THEN OP(1)=0 %IF SS ->X.("&SOURCE&").Y %AND SS->X.("&NOCOPY&").Y %THEN OP(1)=1 %IF SS->X.("&SOURCE&").Y %AND SS->X.("©&").Y %THEN OP(1)=2 %IF SS->X.("&ERRORLINES&").Y %THEN OP(1)=3 ! ! LINES AND CHARS PARAMETERS ! %IF SS-> X.("CHARS&").Y %THEN %START NCHARS:%WHILE X->Y.("&").X %THEN ->NCHARS STRINGTOI(X,N) OP(56)=N NCHARS=N %FINISH %IF SS->X.("LINES&").Y %THEN %START NLINES:%WHILE X->Y.("&").X %THEN -> NLINES STRINGTOI(X,N) OP(47)=N NLINES=N %FINISH %FINISH ! ! ! MESSAGES PARAMETER ! MESSAGES:DTOSARRAY(MESSAGES,SA,N) %IF N#0 %THEN %START SS="&" %CYCLE I=1,1,N ETOI(ADDR(SA(I))+1,LENGTH(SA(I))) SS=SS.SA(I)."&" %REPEAT %IF SS->X.("&SHORT&").Y %THEN OP(3)=0 %IF SS->X.("&INTERLEAVED&").Y %THEN OP(4)=0 %IF SS->X.("&NOCOMMENTS&").Y %THEN OP(16)=0 %IF SS->X.("&ALL&").Y %THEN OP(57)=255 %FINISH ! ! LENGTHS ! LENGTHS:DTOSARRAY(LENGTHS,SA,N) %IF N#0 %THEN %START SS="&" %CYCLE I=1,1,N ETOI(ADDR(SA(I))+1,LENGTH(SA(I))) SS=SS.SA(I)."&" %REPEAT %CYCLE I=1,1,12 %IF SS->X.(LSPECS(I)).Y %THEN %START Y->X.("&").Z OP(22+I)<-IFROMS(X) %FINISH %REPEAT %FINISH ! ! CODE ! DTOSTRING(CODE,SS) ETOI(ADDR(SS)+1,LENGTH(SS)) %IF SS="NO" %THEN OP(0)=0 %IF SS="NOTIFWARNINGS" %THEN OP(0)=1 %IF SS="NOTIFERRORS" %THEN OP(0)=2 %IF SS="YES" %THEN OP(0)=3 ! ! SHARE LIBPROC CANCEL AND TESTENV ! DTOSTRING(SHARE,SS) ; ETOI(ADDR(SS)+1,LENGTH(SS)) %IF SS="YES" %THEN OP(12)=1 DTOSTRING(LIBPROC,SS) ; ETOI(ADDR(SS)+1,LENGTH(SS)) %IF SS="YES" %THEN OP(13)=1 DTOSTRING(CANCEL,SS) ; ETOI(ADDR(SS)+1,LENGTH(SS)) %IF SS="YES" %THEN OP(20)=1 DTOSTRING(TESTENV,SS) ; ETOI(ADDR(SS)+1,LENGTH(SS)) %IF SS="YES" %THEN OP(21)=1 ! ! TP ARGUMENTS ITEMSONSTACK RUN ! DTOSTRING(TP,SS) ; ETOI(ADDR(SS)+1,LENGTH(SS)) %IF SS="YES" %THEN OP(38)=1 DTOSTRING(ITEMSONSTACK,SS); ETOI(ADDR(SS)+1,LENGTH(SS)) %IF SS="YES" %THEN OP(45)=1 %AND OP(62)=1 DTOSTRING(RUN,SS) ; ETOI(ADDR(SS)+1,LENGTH(SS)) %IF SS="NO" %THEN OP(46)=0 %IF SS="NOTIFWARNINGS" %THEN OP(46)=1 %IF SS="NOTIFERRORS" %THEN OP(46)=2 %IF SS="YES" %THEN OP(46)=3 DTOSARRAY(ARGUMENTS,SA,N) %IF N#0 %THEN %START SS="&" %CYCLE I=1,1,N ETOI(ADDR(SA(I))+1,LENGTH(SA(I))) SS=SS.SA(I)."&" %REPEAT %IF SS->X.("&MISMATCH&").Y %THEN OP(35)=1 %IF SS->X.("&VARIABLE&").Y %THEN OP(35)=2 %IF SS->X.("&INTERFERENCE&").Y %THEN OP(44)=1 %FINISH ! ! DISPLAY ! DTOSARRAY(DISPLAY,SA,N) %IF N#0 %THEN %START SS="&" %CYCLE I=1,1,N ETOI(ADDR(SA(I))+1,LENGTH(SA(I))) SS=SS.SA(I)."&" %REPEAT %IF SS->X.("&NONE&").Y %THEN OP(66)=0 %AND -> NUMERICS OP(66)=1 %IF SS->X.("&SOURCE&").Y %THEN OP(67)=1 %IF SS->X.("&SOURCE&").Y %AND SS->X.("©&").Y %THEN OP( 67)=2 %IF SS->X.("&ERRORLINES&").Y %THEN OP(67)=3 %IF SS->X.("&OPTIONS&").Y %THEN OP(68)=1 %IF SS->X.("&DIRECTIVES&").Y %THEN OP(69)=1 %IF SS->X.("&OBJECT&").Y %THEN OP(70)=1 %IF SS->X.("&OPTEXT&").Y %THEN OP(71)=1 %IF SS->X.("&XREF&").Y %THEN OP(72)=1 %IF SS->X.("&ATTR&").Y %THEN OP(73)=1 %IF SS->X.("&ERL&").Y %THEN OP(74)=1 %IF SS->X.("&MAPS&").Y %OR SS->X.("&STATMAP&").Y %THEN OP(75)=1 %IF SS->X.("&VALUES&").Y %THEN OP(76)=1 %FINISH ! ! NUMERIC PARAMETERS ! ! DIAGNOSTICS TRACE CDIAG SEPARATE AREAS LINES ! NUMERICS:%IF DIAGNOSTICS=-1 %THEN -> LTRACE A=DIAGNOSTICS&X'00000000FFFFFFFF' OP(10)=A&X'000000FF' LTRACE:%IF TRACE=-1 %THEN ->LCDIAGS A=TRACE&X'00000000FFFFFFFF' !OP(15)=A&X'000000FF' OP(15)=0 LCDIAGS: %IF CDIAG=-1 %THEN -> LSEPAR A=CDIAG&X'00000000FFFFFFFF' OP(18)=(A&X'0000FF00')>>8 ; OP(19)=A&X'000000FF' A=-1 ; OP(49)=A&X'000000FF' LSEPAR: %IF SEPARATEAREAS=-1 %THEN ->LDIREC A=SEPARATEAREAS&X'00000000FFFFFFFF' OP(39)=A&X'000000FF' ! DIRECTIVES ! LDIREC:MOVE(3,ADDR(SDIRECTIVES)+1,ADDR(OP(50))) ! ! COPY VALUES OF OP ! OP(82)=OP(47) OP(83)=OP(56) ! ! COLLECT TITLE VIA LINK ! MOVE(8,LINK,ADDR(LL)) DTOSTRING(LL+LINK,TITLE) INITSUBHD=" " ! ! DUMP OPTIONS BIT ARRAY AND OPTIONS MATRIX ! !%CYCLE I=0,1,93 !WRITE(OP(I),8) !J=I//10;!%IF I-J*10=0 %THEN NEWLINE !%REPEAT !NEWLINE ! MOVE(4,LINK+12,ADDR(J)) J=J+LINK+8 !NEWLINE;!PRINTSTRING("OPTIONS BIT LIST");!NEWLINE !%CYCLE I=1,1,6 !HEXPRINT(INTEGER(J+4*(I-1))) !%REPEAT ! ! PASS FIRST INPUT FILE AND INITIALISE ENVIRONMENT ! ! ! SET SAVELIST PLEX IN ARRAY OP ! ! ! ! I=INITCENV(SINPUT(1),SOBJECT,SDIRECTIVES,SSAVELIST,TITLE, %C INITSUBHD,0,1,0,NLINES,NCHARS) ! ! CREATE DESCRIPTOR FOR OPTIONS ARRAY , LOAD IT ON STACK ! AND ENTER COMPILER VIA DESCRIPTOR IN LINK+16 ! DOPARRAY=X'1800010000000000'!ADDR(OP(0)) MOVE(8,LINK+16,ADDR(CALLD)) !NEWLINE;!PRINTSTRING("CALLD=");!DHEXPRINT(CALLD) !NEWLINE;!PRINTSTRING("DOPARRAY=");!DHEXPRINT(DOPARRAY) *STLN_%TOS *ASF_4 *LD_DOPARRAY *STD_%TOS *LD_CALLD *RALN_7 *CALL_(%DR) LOG(" FORTRAN COMPILATION COMPLETE") !I=OP(2);MOVE(OP(I)+1,ADDR(OP(I)),ADDR(STEMP)) !ETOI(ADDR(STEMP)+1,OP(I)) !ETOI(ADDR(SOMF)+1,LENGTH(SOMF)) !ETOI(ADDR(SOBJECT)+1,LENGTH(SOBJECT)) ! ! CONVERT OMF MODULE TO EMAS OBJECT FORMAT. ! THE PROCEDURE NAME RETURNED BY THE COMPILER WILL ! BE SET AS THE MAIN ENTRY ! %STOP %END !*********************************************************************** ! ! FORTRAN MACRO !***************************************************************************** %EXTERNALROUTINE FOPTE(%STRING(255) S) ! ! READS PARAMETER SEQUENCE USING PARMSCAN AND ! FROM TABLE CONSTRUCTS CALLING SEQUENCE FOR FOPT ! %EXTERNALINTEGERFNSPEC FOPT(%LONGINTEGER DINP,DOMF, %C DTEMP,DCODE %LONGINTEGER DGKPT %LONGINTEGER DNUM,DPROC,DLIST, %C DDISPLAY,DMESS,DSAVE,DDIAG,DRTCH,DSHARE,DOPT,DLIB, %C DLENGTHS,DARGS,DITEMS,DTRACE,DTFILE,DBUFFER,DMAXLINES, %C DTARRAYSIZE,DFILE,DDIR,DCDIAG) ! %OWNSTRING(32) %ARRAY KEYS(1:27)="INPUT","OMF","TEMP","CODE", %C "GENERATIONSKEPT","RUN","PROCEDURE","LISTINGS","DISPLAY", %C "MESSAGES","SAVELIST","DIAGNOSTICS","RTCHECKS","SHARE","OPT", %C "LIBPROC","LENGTHS","ARGUMENTS","ITEMSONSTACK","TRACE", %C "TFILE","BUFFER","MAXLINES","TARRAYSIZE","DFILE","DIRECTIVES", %C "CDIAG" ! %OWNINTEGERARRAY MODE(1:27)=2,1,1,1,0,1,1,2,2,2,1, %C 0,2,1,0,1,2,2,1,2,1,0,0,0,1,1,1 ! %OWNSTRING(11) %ARRAY DEFPARM(1:27) = "",".NULL", %C "NO","YES","","NOTIFERRORS","","","","LONG",".LP","", %C "ALL","NO","","NO","","","YES","0","","","","","","#*#","" %OWNINTEGERARRAY INTPARM(1:6) = 255,2,2,1,2000,100 %OWNSTRING(12) %ARRAY DEFLIST(1:11) = "SOURCE","NOATTR", %C "NOXREF","NOERL","NOOBJECT","NOPTEXT","NOMAPS","NODIRECTIVES", %C "120CHARS","66LINES",".END" ! %OWNSTRING(10) %ARRAY ALTLIST(1:8) = "NOSOURCE","ATTR","XREF", %C "ERL","OBJECT","OPTEXT","MAPS","DIRECTIVES" %OWNSTRING(4) %ARRAY DLTHLIST(1:11) = %C "E4","D8","Q16","R4","L4","M8","N1","I4","J8","K2",".END" ! ! DP IS AN ARRAY OF DESCRIPTORS USED FOR PARAMETERS TO FOPT ! %LONGINTEGERARRAY DP(0:27) %LONGINTEGERARRAY DSP(1:60) %OWNSTRING(2) FLAGBYTE="F " %OWNLONGINTEGER DUMMY=-1 ! %INTEGERARRAY PV(1:27) %OWNINTEGER INITVALUE=-1 %INTEGER I,J,K,L,DSPPTR,LCNT,MARKER,NEWPTR,DDB,IDLIST,PTR %STRING(32) ST,SS,A %STRING(32) %ARRAY LITS(1:60) %INTEGER RESPONSE,ID5,ID12,ID15,ID22,ID23,ID24 %EXTERNALROUTINESPEC PARMSCAN(%STRINGNAME S %C %INTEGER NPARM %STRINGARRAYNAME KEYS,LITS %C %INTEGERARRAYNAME MODE,PV %INTEGERNAME LCNT %INTEGER INITVALUE) %LONGINTEGERFN CDSCA(%STRINGNAME S) %SYSTEMROUTINESPEC ITOE(%INTEGER ADDRESS,LENGTH) %LONGINTEGER BOUND BOUND=LENGTH(S) %IF BOUND=0 %THEN %RESULT=-1 ITOE(ADDR(S)+1,BOUND) %RESULT=((X'18000000'!BOUND)<<32)!(ADDR(S)+1) %END %LONGINTEGERFN CDSCB(%INTEGER BOUND %LONGINTEGERNAME D) %LONGINTEGER TEMP TEMP=BOUND %RESULT=((X'B0000000'!TEMP)<<32)!(ADDR(D)) %END ! ! ! %LONGINTEGERFN SUPERLIT(%INTEGERNAME INDEX) J=INDEX SS=LITS(J) ; K=DSPPTR %UNTIL SS=".END" %THEN %CYCLE DSP(DSPPTR)=CDSCA(LITS(J)) J=J+1;DSPPTR=DSPPTR+1 SS=LITS(J) %REPEAT %RESULT=CDSCB(DSPPTR-K,DSP(K)) %END ! %SWITCH SWD(0:2) ! ! INITIALISE JSV FILE ETC. ! %OWNSTRING(31) JSFILENAME="COB#JSV" ! I=CONNECTJSFILE(JSFILENAME) %IF I<0 %THEN ->FAULT1 JSV==ARRAY(I,JSVAF) JSN==JSV(0)_IVALUE %CYCLE I=1,1,27 ; PV(I)=INITVALUE ; %REPEAT PARMSCAN(S,27,KEYS,LITS,MODE,PV,LCNT,INITVALUE) ! ! SYSTEM INITIALISATION ! ! SET LOGSTREAM AND TRACE STREAM IF REQUESTED (CTRACE=YES) ! TRACESTREAM=79 %IF PV(20)#INITVALUE %THEN DEFINE("79,COB#TRACE") %C %ELSE DEFINE("79,.NULL") ! ! ! CREATE DESCRIPTORS , SET DEFAULT FOR INTEGER PARAMETERS IF ! NECESSARY AND CREATE THOSE DESCRIPTORS. MODE INDICATES ! PROCESSING REQUIRED. INPUT(1) AND LISTINGS(8) ARE SPECIAL CASES ! FOR FORTRAN RTCHECKS(12) LENGTHS(15) AND ARGS(16) ALSO ! DP(0)=CDSCA(FLAGBYTE) ; IDLIST=1 ; DSPPTR=1 %CYCLE I=1,1,27 ->SWD(MODE(I)) ! ! INTEGER MODE ! SWD(0): %IF PV(I)=INITVALUE %THEN PV(I)=INTPARM(IDLIST) %C %AND IDLIST=IDLIST+1 DP(I)=((X'28000001')<<32)!ADDR(PV(I)) ->ENDCYD ! ! SINGLE LITERAL ! SWD(1): %IF PV(I)=INITVALUE %THEN DP(I)=CDSCA(DEFPARM(I)) %C %ELSE DP(I)=CDSCA(LITS(PV(I))) ->ENDCYD ! ! SUPERLITERAL ! ALL BUT 1 AND 8 HAVE ONLY ONE LITERAL DEFINED IN DEF PARM ! BUT NEED DESCRIPTOR DESCRIPTOR ! SWD(2): %IF I=1 %THEN ->INPUT %IF I=8 %THEN ->LISTINGS %IF I=13 %THEN ->RTCHECKS %IF I=17 %THEN ->LENGTHS %IF I=18 %THEN ->ARGUMENTS %IF PV(I)=INITVALUE %THEN DSP(DSPPTR)=CDSCA(DEFPARM(I)) %C %ELSE DSP(DSPPTR)=CDSCA(LITS(PV(I))) DP(I)=CDSCB(1,DSP(DSPPTR)) DSPPTR=DSPPTR+1 ->ENDCYD ! ! INPUT IF NOT DEFINED SET DEFAULT=.IN AS A SUPER LITERAL ! INPUT:%IF PV(1)=INITVALUE %THEN %START PV(1)=LCNT;LITS(LCNT)=".IN" LITS(LCNT+1)=".END";LCNT=LCNT+2 %FINISH J=PV(1);SS=LITS(J);K=DSPPTR %UNTIL SS=".END" %THEN %CYCLE DSP(DSPPTR)=CDSCA(LITS(J)) J=J+1 ; DSPPTR=DSPPTR+1 SS=LITS(J) %REPEAT DP(I)=CDSCB(DSPPTR-K,DSP(K)) ->ENDCYD ! !LISTINGS OPTION. A NON CONTRADICTORY LIST IS CREATED. ARRAYS ! DEFLIST AND ALTLIST CONTAIN DEFAULT AND ALTERNATIVE LISTS OF ! THE MINOR OPTIONS. NONE OR ALL OVERRIDE ALL THESE. CHARS AND LINES ! ARE SPECIAL CASES TO BE CHECKED IF NONE IS NOT PRESENT. ! THE STANDARD DEFAULT LIST IS SET IN LITS AND THEN MODIFIED ! WHEN ACTUAL INPUT LIST IS SCANNED ! LISTINGS:PTR=PV(8) ; PV(8)=LCNT ; K=DSPPTR %CYCLE L=1,1,11 LITS(LCNT)=DEFLIST(L) LCNT=LCNT+1 %REPEAT NEWPTR=PV(8) ! ! SCAN AND MODIFY IF NECESSARY ! %IF PTR=INITVALUE %THEN DDB=10 %AND ->SETD MARKER=0 ; ST=LITS(PTR) %UNTIL ST=".END" %CYCLE %IF ST="NONE" %THEN MARKER=1 %AND %EXIT %IF ST="ALL" %THEN MARKER=2 %IF ST->A.("CHARS") %THEN LITS(NEWPTR+8)=ST %IF ST->A.("LINES") %THEN LITS(NEWPTR+9)=ST %CYCLE J=1,1,8 %IF ST=DEFLIST(J) %THEN ->CEND %IF ST=ALTLIST(J) %THEN LITS(NEWPTR+J)=ST CEND:%REPEAT PTR=PTR+1;ST=LITS(PTR) %REPEAT ! DDB=10 %IF MARKER=1 %THEN LITS(NEWPTR)="NONE" %AND LITS(NEWPTR+1)=".END" %C %AND DDB=1 %IF MARKER=2 %THEN %START LITS(NEWPTR)="ALL" LITS(NEWPTR+1)=LITS(NEWPTR+8) LITS(NEWPTR+2)=LITS(NEWPTR+9) LITS(NEWPTR+3)=".END" DDB=3 %FINISH SETD:%CYCLE L=1,1,DDB DSP(DSPPTR)=CDSCA(LITS(PV(8)+L-1)) DSPPTR=DSPPTR+1 %REPEAT DP(I)=CDSCB(DDB,DSP(K)) ->ENDCYD ! ! RTCHECKS ! RTCHECKS: %IF PV(I) =INITVALUE %THEN %START PV(I)=LCNT;LITS(LCNT)="ALL";LITS(LCNT+1)=".END" LCNT=LCNT+2 %FINISH DP(I)=SUPERLIT(PV(I)) ->ENDCYD ! ! LENGTHS ! LENGTHS: %IF PV(I)=INITVALUE %THEN %START PV(I)=LCNT %CYCLE J=1,1,11 LITS(LCNT)=DLTHLIST(J) LCNT=LCNT+1 %REPEAT %FINISH DP(I)=SUPERLIT(PV(I)) ->ENDCYD ! ! ARGUMENTS ! ARGUMENTS:%IF PV(I)=INITVALUE %THEN %START PV(I)=LCNT;LITS(LCNT)="NOMISMATCH" LITS(LCNT+1)=".END";LCNT=LCNT+2 %FINISH DP(I)=SUPERLIT(PV(I)) ->ENDCYD ENDCYD:%REPEAT ! ! ! ! RESET INTEGER PARAMS TO *4 INTEGERS ! ID5=PV(5) ; ID12=PV(12) ; ID15=PV(15) ; ID22=PV(22) ID23=PV(23) ; ID24=PV(24) I=FOPT(DP(1),DP(2),DP(3),DP(4),ID5,DP(6),DP(7), %C DP(8),DP(9),DP(10),DP(11),ID12,DP(13),DP(14),ID15, %C DP(16),DP(17),DP(18),DP(19),DP(20),DP(21),ID22,ID23,ID24, %C DP(25),DP(26),DP(27)) %STOP ! ! SHOULD NEVER RETURN HERE ! FAULT1:NEWLINE;PRINTSTRING("FAILED TO CONNECT COB#JSV") NEWLINE %STOP %END %ENDOFFILE