!__________________________________________________________________________________
!
!    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
!*
!**********************************************************************
!
!
!**********************************************************************
!*
!*                            CONSTANTS
!*
!**********************************************************************
!
%CONSTSTRING(4) VERSION = "1.1"
%CONSTINTEGER SEGMENT=262144,   %C
              SEGMENTK=256
%CONSTINTEGER PAGELEN=60
%CONSTINTEGER NO = 0,         %C
              YES = 1
%CONSTINTEGER FILED=0,          %C
              LOCAL=1,          %C
              ROMF =2
%CONSTINTEGER FILE  =1,        %C
              VSAREA=0
%CONSTINTEGER NIL = -1
%CONSTINTEGER DUMMYSTREAM=10
%CONSTSTRING(1)%ARRAY HEX TAB(0:15)="0","1","2","3","4","5","6","7", %C
              "8","9","A","B","C","D","E","F"
!
!
!
!**********************************************************************
!*
!*                            GLOBALS
!*
!**********************************************************************
!
!?2; %OWNINTEGER TRACE COUNT
!?2; %OWNINTEGER TRACE STREAM
%OWNINTEGER LOG STREAM,LISTING,SOURCESTREAM
%OWNSTRING(6) USER NAME
%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
!*
!**********************************************************************
!
!?1; %EXTERNALINTEGERFNSPEC RETURN CODE
%EXTERNALINTEGERFNSPEC OUT STREAM
%EXTERNALROUTINESPEC DEFINE (%STRING(255) PARMS)
%EXTERNALROUTINESPEC PROMPT(%STRING(15) NEW PROMPT)
%EXTERNALSTRINGFNSPEC DATE
%EXTERNALSTRINGFNSPEC TIME
%SYSTEMROUTINESPEC    DESTROY   (%STRING(31) FILE NAME,              %C
                                %INTEGERNAME FLAG)
%SYSTEMSTRINGFNSPEC   CONFILE   (%INTEGER ADDRESS)
%SYSTEMROUTINESPEC    CHANGE FILE SIZE (%STRING(31) FILENAME,     %C
                                %INTEGER NEW SIZE,                   %C
                                %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 ADDR,TO ADDR)
%SYSTEMROUTINESPEC    ITOE      (%INTEGER ADDRESS,LENGTH)
%SYSTEMROUTINESPEC    ETOI      (%INTEGER ADDRESS,LENGTH)
%SYSTEMROUTINESPEC    FILL      (%INTEGER LENGTH,ADDRESS,FILLER)
%EXTERNALROUTINESPEC OPENSQ(%INTEGER STREAM)
%EXTERNALROUTINESPEC CLOSESQ(%INTEGER STREAM)
%EXTERNALROUTINESPEC WRITESQ(%INTEGER STREAM,%NAME FROM,TO)
%EXTERNALROUTINESPEC METER
%EXTERNALSTRINGFNSPEC UINFS(%INTEGER ENTRY)
!
!*********************************************************************
!
!*                        SERVICE  ROUTINES
!*
!**********************************************************************
!

!
%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
K=ADDR(NUMBER)
J=0
%CYCLE I=1,1,20
    L = BYTEINTEGER(K+I)
    %IF L<'0' %OR L>'9' %THEN %RESULT = J
    J=(J*10)+L-'0'
%REPEAT
%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
!
!?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 LENGTH,ADDRESS)
%STRING(255) S
*LB   _LENGTH
*LDA  _ADDRESS
*LDTB _X'18000000'
*LDB  _%B
*CYD  _0
*LD   _S
*MVL  _%L=1
*MV   _%L=%DR,0,129
%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 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
!
!?; %ROUTINE POSTREPORT(%STRING(40) RTN,%INTEGER RC)
!?; LOG("RETURNED FROM ".RTN." RESULT= ".SFROMI(RC))
!?; %END;         ! OF POST REPORT
!
!?; %ROUTINE EXITREP(%STRING(40) RTN,%INTEGER RC)
!?; LOG("ABOUT TO RETURN FROM ".RTN." RESULT = ".SFROMI(RC))
!?; %END;          ! OF EXITREP
!
!?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
!
!
%EXTERNALROUTINE 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
%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 ".SNAME." 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
!######################################################################
!#
!#                     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=OMFLIBNAME.".".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.",".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 TO VS 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,LENDR0,LENDR1)
%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 CTMJSREAD(%INTEGER JSNAMB,JSNAMA,RESB,RESA, %C
SRESB,SRESA,NRB,NRA)
!
!   DUMMY TYPE ROUTINE RETURNS 0 AND SPACES  WITHOUT LOOKING
!   AT JSNAME , FOR THE MOMENT
!
%INTEGER X,I,LSR,RC
%LONGINTEGER LONGZERO
!?; *STLN_X
!?TRACE("CTMJSREAD","",X,8)
!?;
%IF RESB=-1 %THEN -> STRINGENTRY
LONGZERO=0
LONGINTEGER(RESA)=LONGZERO
->EXITCTMJSR
STRINGENTRY:LSR=SRESB&X'FFFFFF'
%CYCLE I=1,1,LSR
BYTEINTEGER(SRESA+I-1)=' '
%REPEAT
EXITCTMJSR:RC=0
!?;EXITREP("CTMJSREAD",RC)
%RESULT=0
%END
%EXTERNALINTEGERFN FCWORKFILESUPPORT(%INTEGER DUM)
%END
%EXTERNALINTEGERFN LOAD(%INTEGER DUM)
%END
%EXTERNALINTEGERFN JSWRITE(%INTEGER DUM)
%END
%EXTERNALINTEGERFN ICL9DDLTCOBOLLINK(%INTEGER DUM)
%END
%EXTERNALINTEGERFN ICL9HNTIME(%INTEGER  DUM)
%END
%EXTERNALINTEGERFN CTMJSDECLARE(%INTEGER DUM)
%END
%EXTERNALINTEGERFN ICL9HNDATE(%INTEGER DUM)
%END
%EXTERNALINTEGERFN JSREAD(%INTEGER DUM)
%END
%EXTERNALINTEGERFN CTMLOAD(%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,LINES,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=-1 %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=-1 %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
%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
      255,0,0,0,0,0,0,255,120,0,0,0,0,0,0,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)
%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
%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.("&COPY&").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
!
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
!
!    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.("&COPY&").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'
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(" COBOL 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
!
COMF(SOMF.",".SOBJECT.",#".STEMP)
LOG("CONVERSION TO EMAS OBJECT FORMAT COMPLETE")
LOG("FILENAME=".SOBJECT."   ENTRY=".STEMP)
%STOP
%END
!***********************************************************************
!
!                              COBOLE
!*****************************************************************************
%EXTERNALROUTINE COBOLE(%STRING(255) S)
!
!   READS PARAMETER SEQUENCE USING PARMSCAN AND
!   FROM TABLE CONSTRUCTS CALLING SEQUENCE FOR COBOLCOMPILE
!
%EXTERNALINTEGERFNSPEC COBOLCOMPILE(%LONGINTEGER DINP,DOMF, %C
DTEMP,DCODE %LONGINTEGER DGKPT %LONGINTEGER DNUM,DPROC,DLIST,DLINES, %C
DMESS,DSAVE %LONGINTEGER DDIAG %LONGINTEGER DRTCH,DSHARE,DLIB,DCAN, %C
DTEST,DTP %LONGINTEGER DSEP %LONGINTEGER DITE,DDFILE,DDEBUG,DDIR, %C
DCD,DISPLAY )
!
%OWNSTRING(32) %ARRAY KEYS(1:26)="INPUT","OMF","TEMP","CODE", %C
      "GENERATIONSKEPT","RUN","PROCEDURE","LISTINGS","MESSAGES", %C
      "SAVELIST","DIAGNOSTICS","RTCHECKS","SHARE","LIBPROC", %C
      "CANCEL","TESTENV","TP","SEPARATEAREAS","ITEMSONSTACK", %C
      "DFILE","DEBUG","DIRECTIVES","CDIAG","LINES","DISPLAY", %C
      "CTRACE"

!
%OWNINTEGERARRAY MODE(1:26)=2,1,1,1,0,1,1,2,2,1, %C
    0,2,1,1,1,1,1,0,1,1,1,1,1,0,2,1
!
%OWNSTRING(11) %ARRAY DEFPARM(1:26) = "",".NULL", %C
      "NO","YES","","NOTIFERRORS","","","LONG",".LP","", %C
      "ALL","NO","NO","NO","NO","NO","","NO",".OUT","OFF","#*#","","", %C
      "NONE","NO"
%OWNINTEGERARRAY INTPARM(1:4) = 255,2,0,4000
%OWNSTRING(12) %ARRAY DEFLIST(1:11) = "SOURCE","NOATTR", %C
      "NOXREF","NOERL","NOOBJECT","COPY","NOSTATMAP","NODIRECTIVES", %C
      "120CHARS","66LINES",".END"
!
%OWNSTRING(10) %ARRAY ALTLIST(1:8) = "NOSOURCE","ATTR","XREF", %C
      "ERL","OBJECT","NOCOPY","STATMAP","DIRECTIVES"
!
!   DP IS AN ARRAY OF DESCRIPTORS USED FOR PARAMETERS TO COBOLCOMPILE
!
%LONGINTEGERARRAY DP(0:25)
%LONGINTEGERARRAY DSP(1:20)
%OWNSTRING(2) CB="CB"
!
%INTEGERARRAY PV(1:26)
%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:40)
%INTEGER RESPONSE,ID5,ID11,ID18,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
!
!
%SWITCH SWD(0:2)
%CYCLE I=1,1,26 ; PV(I)=INITVALUE ; %REPEAT
PARMSCAN(S,26,KEYS,LITS,MODE,PV,LCNT,INITVALUE)
!
!     SYSTEM INITIALISATION
!
!   SET LOGSTREAM AND TRACE STREAM IF REQUESTED (CTRACE=YES)
!
TRACESTREAM=79
%IF PV(26)#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
!
DP(0)=CDSCA(CB) ; IDLIST=1 ; DSPPTR=1
%CYCLE I=1,1,25
->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 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 OVERRIODE 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:%REPEAT
!
!
! 
! RESET INTEGER PARAMS TO *4 INTEGERS
!
ID5=PV(5) ; ID11=PV(11) ; ID18=PV(18) ; ID24=PV(24)
I=COBOLCOMPILE(DP(1),DP(2),DP(3),DP(4),ID5,DP(6),DP(7), %C
DP(8),ID24,DP(9),DP(10),ID11,DP(12),DP(13),DP(14),DP(15),DP(16), %C
DP(17),ID18,DP(19),DP(20),DP(21),DP(22),DP(23),DP(25))
%STOP
!
! SHOULD NEVER RETURN HERE
!
%END

%ENDOFFILE