! MODIFIED 18/06/81 -  VERSION 20.10
! MOD AMENDS APPLIED TO COMPILE & JCLPR - NEW CTPASCAL
!**********************************************************************
!*
!*                         P A S C A L
!*
!*                COMPILER ENVIRONMENT ROUTINES
!*
!**********************************************************************
!
!
!**********************************************************************
!*
!*                            CONSTANTS
!*
!**********************************************************************
!
%CONSTINTEGER SEGMENTK=256,SEGMENT=262144
%CONSTINTEGER NIL=-1
%CONSTINTEGER NO=0,YES=1
%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
!*
!**********************************************************************
!
%EXTERNALBYTEINTEGERARRAY ICL9HNDATE(0:10)
%EXTERNALBYTEINTEGERARRAY ICL9HNTIME(0:8)
!?2  %OWNINTEGER TRACE COUNT
!?2  %OWNINTEGER TRACE STREAM
%OWNINTEGER LOG STREAM=0,LISTING=82
%OWNSTRING(255)SUBHEADING
%OWNBYTEINTEGERARRAY OUTBUFF(0:160)
%OWNINTEGER OUTFILELEN,MAXOUTFILELEN
%OWNSTRING(255) SOURCE
%OWNSTRING(31) OBJECT,SLIST
!
!**********************************************************************
!*
!*                      EXTERNAL  REFERENCES - SUBSYSTEM
!*
!**********************************************************************
!
%EXTERNALINTEGERFNSPEC ICL9HEPROLOG(%INTEGER N)
%EXTERNALINTEGERFNSPEC OUT STREAM
%EXTERNALLONGREALFNSPEC CPUTIME
%SYSTEMROUTINESPEC CONNECT(%STRING(31) NAME,%INTEGER A,B,C, %C
           %RECORDNAME P,%INTEGERNAME FLAG)
%EXTERNALROUTINESPEC DISCONNECT(%STRING(63) FILE)
%SYSTEMROUTINESPEC OUTFILE(%STRING(31)FILENAME,%INTEGER SIZE,GAP, %C
                             PROT,%INTEGERNAME CONADDR,FLAG)
%SYSTEMROUTINESPEC    MOVE      (%INTEGER LENGTH,FROM ADDR,TO ADDR)
%SYSTEMROUTINESPEC    ITOE      (%INTEGER ADDRESS,LENGTH)
%SYSTEMROUTINESPEC    ETOI      (%INTEGER ADDRESS,LENGTH)
%SYSTEMROUTINESPEC    FILL      (%INTEGER LENGTH,ADDRESS,FILLER)
%SYSTEMINTEGERFNSPEC DATEANDTIME(%STRINGNAME DATE,TIME)
%SYSTEMSTRINGFNSPEC NEXT TEMP
%EXTERNALROUTINESPEC METER
%SYSTEMROUTINESPEC PSYSMES(%INTEGER ROOT,FLAG)
%SYSTEMROUTINESPEC COMPILE(%STRING(255)S,%STRING(32)ENTRY, %C
                                %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC SETPAR(%STRING(255)S)
%SYSTEMSTRINGFNSPEC SPAR(%INTEGER N)
%SYSTEMINTEGERFNSPEC PARMAP
%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N)
!
!*********************************************************************
!
!*                        SERVICE  ROUTINES
!*
!**********************************************************************
!

!
%STRING(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
!
%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
!
 %STRING(8)%FN HEXOF (%INTEGER X)
 %STRING(8) ANS
 %INTEGER I
 ANS = ''
 %CYCLE I=0,4,28
     ANS = HEXTAB((X>>I)&X'0000000F').ANS
 %REPEAT
 %RESULT = ANS
 %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)
%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
!
!?1  %ROUTINE POSTREPORT(%STRING(40) RTN,%INTEGER RC)
!?1  LOG("RETURNED FROM ".RTN." RESULT= ".SFROMI(RC))
!?1  %END;         ! OF POST REPORT
!
%ROUTINE EXITREP(%STRING(40) RTN,%INTEGER RC)
LOG("ABOUT TO RETURN FROM ".RTN." RESULT = ".SFROMI(RC))
%END;          ! OF EXITREP
!
!?2  %ROUTINESPEC XDUMP(%STRING(12)COM,%INTEGER ADDR,LEN)
!?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 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
!
!######################################################################
!#
!#                     COMPILER ENVIRONMENT ROUTINES
!#
!######################################################################
!
!
!*****************************************************************
!*
!*                      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
!?1  LOG('ENTERING CREATEMODULE')
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)
ETOI(ADDR(FILENAME)+1,LENGTH(FILENAME))
FILENAME=DESPACED(FILENAME)
%FINISH
!
!?2  *STLN_X
!?2  TRACE("CREATE MODULE",                    %C
          "  ".FILENAME."  SIZE=".SFROMI(MAXOUTFILELEN*1024),X,5)
!
!?1  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,MAXSIZE,RC
!?1 LOG('ENTERINGCREATEVS')
%IF NAMDR0=NIL %THEN AREANAME="T#".NEXTTEMP %ELSE %START 
  AREANAME=STRINGFROM(NAMDR0,NAMDR1)
  ETOI(ADDR(AREANAME)+1,LENGTH(AREANAME))
  AREANAME=DESPACED(AREANAME)
!?1  LOG("CREATEVS - AREANAME IS ".AREANAME)
  %IF AREANAME ='ICL9CEWRK' %THENSTART
    AREANAME='T#WRK'
    AREAADDR=COMREG(14)
    MAXSIZE=SEGMENT
    ->STADDR
  %FINISH
  %IF AREANAME='ICL9LPHEAPCT' %THENSTART
    AREANAME="T#HEAP"
    SIZE=SEGMENT
    MAXSIZE=SEGMENT
    ->CREATEFILE
  %FINISH
  %IF AREANAME='ICL9CETMPOBJ' %THEN AREANAME=OBJECT %ELSE %C
            AREANAME ='T#'.AREANAME
%FINISH
MAXSIZE=SIZE
SIZE=4096
!
CREATEFILE:
!?2  *STLN_X
!?2 TRACE("CREATEVS",AREANAME,X,6)
!
!?1  LOG('CALLING OUTFILE')
!?3 PRINTSTRING('MAXSIZE =')
!?3 WRITE(MAXSIZE,10)
!?3 NEWLINE
OUTFILE(AREANAME,SIZE,MAXSIZE,0,AREAADDR,FLAG) 
%IF FLAG#0 %THEN %START
!?1 LOG("RETURNED FROM OUTFILE, FLAG=".SFROMI(FLAG))
!?1  EXITREP("CREATEVS",FLAG)
%RESULT=FLAG 
%FINISH
STADDR:
INTEGER(DESCDR1)=X'18000000' ! MAXSIZE
INTEGER(DESCDR1+4)=AREAADDR
RC=0
!?1   EXITREP("CREATEVS",RC)
%RESULT=RC
%END
!
!************************************************************************
!*
!*                           ICL9HN DUMP
!*
!***************************************************************************
!
%EXTERNALINTEGERFN ICL9HNDUMP(%LONGINTEGER MESS,AREAS)
%INTEGER X
!?1  LOG('ENTERING DUMP')
!
!?2  *STLN_X
!?2  TRACE("ICL9HNDUMP","",X,4)
!
!?1  EXITREP("ICL9HNDUMP",0)
%RESULT=0
%END
!
!************************************************************************
!*
!*                    ICL9HN END MODULE
!*
!*************************************************************
!
%EXTERNALINTEGERFN ICL9HN ENDMODULE(%INTEGER DELETE)
%INTEGER X,RC
!
!?1  LOG('ENTERING ENDMODULE')
RC=0
!?2  *STLN_X
!?2  TRACE("ENDMODULE",                              %C
 "ACTUALSIZE=".SFROMI(OUTFILELEN).":REQSIZE=".      %C
  SFROMI(MAXOUTFILELEN*1024),X,1)
!?1  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(120) S
!?1  LOG('ENTERING LOG')
%UNLESS -1<=DESTINATION<=15 %THEN %RESULT=1
RC=0
!
!?2  *STLN_X
!?2  TRACE("LOG","MSG LOGGED TO APPROPRIATE LOG STREAM",X,3)
!
L=MESSDR0&X'000000FF'
%IF L>120 %THEN L=120
CURRENT STREAM=OUTSTREAM
SELECT OUTPUT(LOGSTREAM)
S=STRINGFROM(L,MESSDR1)
ETOI(ADDR(S)+1,L)
%IF S->('OMF').S %THEN S='OBJECT'.S
%IF S->('aaaaaa').S %THEN S=OBJECT
PRINTSTRING(S)
NEWLINE
SELECT OUTPUT(CURRENT STREAM)
!?1 EXITREP("LOG",0)
%RESULT=0
%END

!
!************************************************************
!* 
!*                           ICL9HN MONITOR
!*
!************************************************************
!
%EXTERNALINTEGERFN ICL9HN MONITOR(%INTEGER TAG)
%INTEGER CURRENT STREAM,X
!
!?1  LOG('ENTERING MONITOR')
!?2  *STLN_X
!?2  TRACE("MONITOR","",X,1)
!
CURRENTSTREAM=OUTSTREAM
SELECT OUTPUT(LOGSTREAM)
PRINTSTRING(SFROMI(TAG)."METERING INFORMATION FOLLOWS")
NEWLINE
METER
NEWLINE
SELECTOUTPUT(CURRENT STREAM)
!?1  EXITREP("MONITOR",0)
%RESULT=0
%END
!
!************************************************************
!*
!*                         ICL9HN NEW SUBHEADING
!*
!************************************************************
!
%EXTERNALINTEGERFN ICL9HN NEW SUBHEADING(%INTEGER SUBHDDR0,SUBHDDR1,  %C
                                                  LINES,NEWPAGE)
%INTEGER X,L,RC
!?1  LOG('ENTERING NEWSUBHEADING')
!
RC=0
L=SUBHDDR0&X'000000FF'
SUBHEADING=STRINGFROM(L,SUBHDDR1)
ETOI(ADDR(SUBHEADING)+1,LENGTH(SUBHEADING))
!
!?2  *STLN_X
!?2  TRACE("NEW SUBHEADING",">>".SUBHEADING."<<",X,4)
!
!?1  EXITREP("NEWSUBHD",RC)
%RESULT=RC
%END
!
!**************************************************************
!*
!*                ICL9HN NEWLINE
!*
!*************************************************************
!
%EXTERNALINTEGERFN ICL9HN NEWLINE(%INTEGER LINES)
%INTEGER X,CURRENTSTREAM
!
!?1  LOG('ENTERING NEWLINE')
!?2  *STLN_X
!?2  TRACE("NEWLINE","",X,1)
!
  CURRENTSTREAM=OUTSTREAM
  SELECT OUTPUT(LISTING)
  NEWLINES(LINES)
  SELECT OUTPUT(CURRENT STREAM)
!?1  EXITREP("NEWLINE",0)
%RESULT=0
%END
!
!*************************************************************
!*
!*                    ICL9HN NEWPAGE
!*
!************************************************************
!
%EXTERNALINTEGERFN ICL9HN NEWPAGE
%INTEGER X
!?1  LOG('ENTERING NEWPAGE')
!
!?2  *STLN_X
!?2  TRACE("NEWPAGE","",X,0)
!
!?1  EXITREP("NEWPAGE",0)
%RESULT=0
%END
!
!************************************************************
!*
!*                     ICL9HN OUTPUTLINE
!*
!************************************************************
!
%EXTERNALINTEGERFN ICL9HN OUTPUT LINE(%INTEGER BUFFDR0,BUFFDR1)
%INTEGER CURRENTSTREAM,X,LEN,LINES
%STRING(120) LS,RS
%STRINGNAME LINE
!
!?1  LOG('ENTERING OUTPUTLINE')
!?2  *STLN_X
!?2  TRACE("OUTPUTLINE","",X,2)
!
CURRENTSTREAM=OUTSTREAM
SELECT OUTPUT(LISTING)
LEN=BUFFDR0&X'00FFFFFF'
MOVE(LEN,BUFFDR1,ADDR(OUTBUFF(1)))
OUTBUFF(2)=LEN-2
ETOI(ADDR(OUTBUFF(3)),LEN-2)
LINE==STRING(ADDR(OUTBUFF(2)))
%IF LINE->LS.('OMF').RS %THEN LINE=LS.'OBJECT'.RS
%IF LINE ->LS.('aaaaaa').RS %THEN LINE=LS.OBJECT."
"
NEWLINE;PRINTSTRING(LINE)
SELECT OUTPUT(CURRENT STREAM)
!?1  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
!?1  LOG('ENTERING OUTPUTRECORD')
RECLEN=BUFFDR0&X'00FFFFFF'
OUTFILELEN=OUTFILELEN+RECLEN+2
!
!?2  *STLN_X
!?2  TRACE("OUTPUTRECORD","LENGTH=".SFROMI(RECLEN),X,2)
!
!?1  EXITREP("OUTPUTRECORD",0)
%RESULT=0
%END
!
!****************************************************************
!*
!*                          ICL9HN READ CARD
!*
!************************************************************
!
%EXTERNALINTEGERFN ICL9HNREADCARD(%INTEGER BUFFDR0,BUFFDR1,      %C
                                           SEQDR0,SEQDR1,LENDR0,LENDR1)
%INTEGER SP,RC,X
%STRING(160) LINE
%INTEGER BUFFLEN
!?1  LOG('ENTERING READCARD')
%ON %EVENT 9 %START
!?1  LOG("INPUT ENDED ")
     %RESULT=-3;! END OF SOURCE FILES
%FINISH
!
RC=0
!?2  *STLN_X
!?2  TRACE("READ CARD","",X,6)
!
BUFFLEN=BUFFDR0&X'00FFFFFF'
FILL(BUFFLEN,BUFFDR1,C' ')
READ:
LINE=NEXT LINE
%IF LENGTH(LINE)>BUFFLEN %OR LENGTH(LINE)>160 %THEN %C
      RC=-255 %AND ->EXIT
ITOE(ADDR(LINE)+1,LENGTH(LINE))
MOVE(LENGTH(LINE),ADDR(LINE)+1,BUFFDR1)
%IF LENDR0#NIL %THEN INTEGER(LENDR1)=LENGTH(LINE)
EXIT:
!?1  EXITREP("READ CARD",RC)
%RESULT=RC
%END
!
!************************************************************************
!*
!*                             ICL9HN SETDUMPER
!*
!**************************************************************************
!
%EXTERNALINTEGERFN ICL9HNSETDUMPER(%INTEGER DUMPLNB, %C
                                 %LONGINTEGER DPROC,MESS,REGS)
%INTEGER X
!?1  LOG('ENTERING SETDUMPER')
!
!?2  *STLN_X
!?2  TRACE("ICL9HNSETDUMPER","",X,7)
!
!?1  EXITREP("ICL9HNSETDUMPER",0)
%RESULT=0
%END
!
!***************************************************************************
!*
!*                              ICL9HN SUBHEAD
!*
!***********************************************************************
!
%EXTERNALINTEGERFN ICL9HNSUBHEAD(%INTEGER SUBHDDRO,SUBHDDR1,LNO, %C
                                 NP,LF,INHIB)
%INTEGER X
!
!?1  LOG('ENTERING SUBHEAD')
!?2  *STLN_X
!?2  TRACE("ICL9HNSUBHEAD","",X,6)
!
!?1  EXITREP("ICL9HNSUBHEAD",0)
%RESULT=0
%END
!
!************************************************************************
!*
!*                           ICL9HNCREATEALIAS
!*
!***********************************************************************
!
%EXTERNALINTEGERFN ICL9HN CREATEALIAS(%INTEGER NAMDR0,NAMDR1,         %C
                                               DUMDR0,DUMDR1)
%INTEGER X
!?1  LOG('ENTERING CREATEALIAS')
!
!?2  *STLN_X
!?2  TRACE("CREATE ALIAS","",X,4)
!
%RESULT=0
%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,LINES)
!
!   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
!
!    DECLARATIONS FOR COMPILE SUPPORT
!
%INTEGER I,J,RC,AD,AT,OPPTR
%LONGINTEGER DOPARRAY,CALLD
%INTEGER OPTIONS0
%STRING(31) OMF,OBJECT,SAVLIST
%STRING(10) DATE
%STRING(8)TIME
!
!?1  LOG("ICL9HNCOMPILESUPPORT ENTERED")
!
!   SET ICL9HNDATE,ICL9HNTIME
! 
J=DATEANDTIME(DATE,TIME)
AD=ADDR(DATE);AT=ADDR(TIME)
%CYCLE J=1,1,8
  ICL9HNDATE(J)=BYTEINTEGER(AD+J)
  ICL9HNTIME(J)=BYTEINTEGER(AT+J)
%REPEAT
ICL9HNDATE(9)=BYTEINTEGER(AD+9)
ICL9HNDATE(10)=BYTEINTEGER(AD+10)
!
!   SET OPTIONS ARRAY TO DEFAULT OPTIONS
!
! THE FOLLOWING ARRAY CONTAINS ENCODED VALUES OF THE DEFAULT COMPILATION
! OPTIONS FOR PASCAL. THE VALUES ARE AS DEFINED FOR THE COMPILER OPTIONS
! ARRAY IN VME/B COMPILER ENVIRONMENT MANUAL.
%OWNBYTEINTEGERARRAY DEFOPT(0:93)= %C
      3,2,0,2,1,0,0,0,0,0,4,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,0,66, %C
      0,0,0,0,0,0,0,255,120,0,0,0,0,0,0,1, %C
0,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=94,1,255
OP(I)=0
%REPEAT
!
!  TEMPORARY SETTINGS SUPPLIED FORM ARRAY DEFOPT
!
%CYCLE I=0,1,93
OP(I)=DEFOPT(I)
%REPEAT
!
!
! SET UP OBJECT FILE NAME IN THE OPTIONS ARRAY
!
DTOSTRING(OUTPUT,OMF)
OP(22)=94;OP(53)=94
MOVE(LENGTH(OMF)+1,ADDR(OMF),ADDR(OP(94)))
OPPTR=95+LENGTH(OMF)
OBJECT=OMF
ETOI(ADDR(OBJECT)+1,LENGTH(OBJECT))
!
! SET UP PLEX SPACE FOR THE PROCEDURE NAME IN THE OPTIONS ARRAY
!
OP(2)=OPPTR
OP(OPPTR)=0
OPPTR=OPPTR+33
!
! SET OPTIONS ARRAY FROM PARAMETER LIST
!
%IF OBJECT =".NULL" %THEN OP(0)=0;! CODE=NO
DTOSTRING(SAVELIST,SAVLIST)
ETOI(ADDR(SAVLIST)+1,LENGTH(SAVLIST))
%IF SAVLIST=".NULL" %THEN OP(63)=0;! LISTINGS=NONE
!
! SET OPTION ARRAY FROM COMREG
!
OPTIONS0=COMREG(27)
%IF OPTIONS0&2#0 %THEN OP(1)=0; !LISTING=NOSOURCE
%IF OPTIONS0&X'4000'#0 %THEN OP(9)=1; ! LISTINGS=OBJECT
%IF OPTIONS0&X'10004'#0 %THEN OP(10)=0
                                                        ! DIAGNOSTICS=0
!
!   COPY VALUES OF OP
!
OP(82)=OP(47)
OP(83)=OP(56)
!
!   DUMP OPTIONS BIT ARRAY AND OPTIONS MATRIX
!
!?3 %CYCLE I=0,1,93
!?3 WRITE(OP(I),8)
!?3 J=I//10;!%IF  I-J*10=0 %THEN NEWLINE
!?3 %REPEAT
!?3 NEWLINE
!?3 
!?3 MOVE(4,LINK+12,ADDR(J))
!?3 J=J+LINK+8
!?3 NEWLINE
!?3 PRINTSTRING("OPTIONS BIT LIST")
!?3 NEWLINE
!?3 %CYCLE I=1,1,6
!?1 HEXPRINT(INTEGER(J+4*(I-1)))
!?3 %REPEAT
!
!   CREATE DESCRIPTOR FOR OPTIONS ARRAY, LOAD IT ON STACK
 !  AND ENTER COMPILER VIA DESCRIPTOR IN LINK+16
!
!?1 LOG('ENTERING COMPILER')
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)
*ST_RC
!
! STORE RESULT CODE IN COMREG
!
COMREG(24)=RC
!?1 LOG("ICL9HNCOMPILESUPPORT - PASCAL COMPILATION COMPLETE")
!?1  EXITREP('ICL9HNCOMPILESUPPORT',RC)
%RESULT=RC
%END
!##########################################################################
!#
!#                               CTM ROUTINES
!#
!###########################################################################
!
!
!***************************************************************************
!*
!*                            CTM ASSIGNFILE
!*
!*****************************************************************************
!*
%EXTERNALINTEGERFN CTMASSIGNFILE(%INTEGER FRDR0,FRDR1,LNDR0,LNDR1, %C
                                  FNDR0,FNDR1,ACCESS,LOCK,NRA, %C
                                   NRB0,NRB1,START,END, %C
                                  %LONGINTEGER ROUTE,NRC,NRD,NRE)
%STRING(32)NAME
%INTEGER X
!
!?1  LOG('ENTERING CTMASSIGNFILE')
NAME=STRINGFROM(FNDR0,FNDR1)
ETOI(ADDR(NAME)+1,LENGTH(NAME))
NAME=DESPACED(NAME)
!
!?2  *STLN_X
!?2  TRACE("CTMASSIGNFILE",NAME,X,19)
!
!?3  LOG("CTMASSIGNFILE - NAME IS ".NAME)
!?1  EXITREP("CTMASSIGNFILE",0)
%RESULT=0
%END
!
!************************************************************************
!*
!*                                   CTM DUMP
!*
!************************************************************************
!
%EXTERNALINTEGERFN CTMDUMP(%LONGINTEGER MESSAGE, %C
%INTEGER DUM0,DUM1,ADDR0,ADDR1,DUM2,DUM3,OPTIONS, %C
%LONGINTEGER DUMPROUTE)
!
%INTEGER RC,X
!?1  LOG('ENTERING CTMDUMP')
!?2 *STLN_X
!?2 TRACE("CTMDUMP","",X,9)
!
!?1  LOG("CTMDUMP ENTERED")
!
%MONITOR ;%STOP
%END
!************************************************************************
!*
!*                           CTM JSBEGIN
!*
!************************************************************************
!
%EXTERNALINTEGERFN CTMJSBEGIN(%INTEGER DR0,DR1)
%INTEGER X
!
!?1  LOG("ENTERING CTMJSBEGIN")
!
!?2  *STLN_X
!?2  TRACE("CTMJSBEGIN","",X,0)
!
!?1  EXITREP("CTMJSBEGIN",0)
%RESULT=0
%END
!
!***********************************************************************
!*
!*                          CTM JSEND
!*
!************************************************************************
!
%EXTERNALINTEGERFN CTMJSEND(%INTEGER DR0,DR1)
%INTEGER X
!?1  LOG('ENTERING CTMJSEND')
!
!?2  *STLN_X
!?2  TRACE("CTMJSEND","",X,0)
!
!?1  EXITREP("CTMJSEND",0)
%RESULT=0
%END
!
!***************************************************************************
!*
!*                            CTM JSWRITE
!*
!*************************************************************************
!
%EXTERNALINTEGERFN CTMJSWRITE(%INTEGER NAMDR0,NAMDR1,INTDR0,INTDR1, %C
                                    STRDR0,STRDR1,DUM0,DUM1)
%INTEGER X
%STRING(32) JSVNAM
!?1  LOG('ENTERING CTMJSWRITE')
!
JSVNAM=STRINGFROM(NAMDR0,NAMDR1)
ETOI(ADDR(JSVNAM)+1,LENGTH(JSVNAM))
JSVNAM=DESPACED(JSVNAM)
!
!?2  *STLN_X
!?2  TRACE("CTMJSWRITE","",X,8)
!
!?3  LOG("JSVNAME IS ".JSVNAM)
!
!?1  EXITREP("CTMJSWRITE",0)
%RESULT=0
%END
!
!*************************************************************************
!*
!*                             CTM RMLD
!*
!*************************************************************************
!
%EXTERNALINTEGERFN CTMRMLD(%INTEGER ADDR,NAMDR0,NAMDR1, %C
      GNDR0,GNDR1,IINDR0,IINDR1,FRDR0,FRDR1, %C
      MIINDR0,MIINDR1,AMDR0,AMDR1)
%INTEGER X
!
!?1  LOG('ENTERING CTMRMLD')
!?2  *STLN_X
!?2  TRACE("CTMRMLD","",X,13)
!
!?1  EXITREP("CTMRMLD",0)
%RESULT=0
%END
!
!***********************************************************************
!*
!*                           GIVEPROCESSTIME
!*
!****************************************************************************
!*
%EXTERNALINTEGERFN GIVEPROCESSTIME(%INTEGER OPT,PTIM0,PTIM1)
%INTEGER X
%LONGINTEGER CPUTIM
%LONGINTEGERNAME TIME
!
!?1  LOG("GIVEPROCESSTIME ENTERED")
!
!?2  *STLN_X
!?2  TRACE("GIVEPROCESSTIME","",X,3)
!
TIME==LONGINTEGER(PTIM1)
TIME=INT(CPUTIME*1000000)
!
!?3  PRINTSTRING('PTIM0 = '.HEXOF(PTIM0))
!?3  PRINTSTRING('    PTIM1 = '.HEXOF(PTIM1))
!?3  NEWLINE
!?3  PRINTSTRING('TIME = ')
!?3  WRITE(TIME,10)
!?3  NEWLINE
!
!
!?1  EXITREP("GIVEPROCESSTIME",0)
%RESULT=0
%END
!
!*****************************************************************************
!*
!*                           SENDMESSAGE
!*
!************************************************************************
!
%EXTERNALINTEGERFN SENDMESSAGE(%INTEGER MSGDR0,MSGDR1)
%INTEGER X,OS
%STRING(255) MSGTXT
!
!?1  LOG("SENDMESSAGE ENTERED")
MSGTXT=STRINGFROM(MSGDR0,MSGDR1)
ETOI(ADDR(MSGTXT)+1,LENGTH(MSGTXT))
!
!?2  *STLN_X
!?2 TRACE("SENDMESSAGE",MSGTXT,X,4)
!
OS=COMREG(23)
SELECTOUTPUT(LOGSTREAM)
PRINTSTRING(MSGTXT);NEWLINE
SELECTOUTPUT(OS)
!
!?1  EXITREP("SENDMESSAGE",0)
%RESULT=0
%END
!
!**********************************************************************
!*
!                              PASCAL
!
!************************************************************************
!
%EXTERNALROUTINE PASCAL(%STRING(255)S)
%INTEGER FLAG
%STRING(255) FILE
%RECORDFORMAT RF(%INTEGER CONAD,A,B,C,D,E,F,G,H,I, %STRING(6) J, %C
            %STRING(8) K,L, %INTEGER M,O,P)
%RECORD R(RF)
!
FLAG=ICL9HEPROLOG(0); ! CALL TO LOAD DIAGNOSTIC ROUTINES
! SPLIT S INTO PARAMS
SETPAR(S)
%UNLESS PARMAP&3=3 %AND PARMAP<16 %THEN FLAG=263 %AND ->ERR
SOURCE=SPAR(1)
OBJECT=SPAR(2)
SLIST=SPAR(3)
%IF SLIST="" %THEN SLIST="T#SLIST"
%IF SOURCE ->FILE.("+").FILE %THEN SOURCE='T#SRCE'
!
!
! CALL COMPILE AND ENTER COMPILER SUPPORT MODULE
!?1  LOG('CALLING PACSM')
!
FLAG=0
COMPILE(S,"PACSM",FLAG)
! NOW SET WORD 4 OF GLA FOR USE BY DIAGNOSTIC ROUTINES
%IF FLAG=0 %AND OBJECT # ".NULL" %THEN %START
   CONNECT(OBJECT,3,0,0,R,FLAG)
   INTEGER(INTEGER(INTEGER(R_CONAD+28)+R_CONAD+16)+R_CONAD+16)= %C
                                    X'070AFFFF'
  DISCONNECT(OBJECT)
%FINISH
ERR:
!?1  EXITREP('PACSM',FLAG)
%IF FLAG#0 %THEN PSYSMES(98,FLAG)
%END
!
!***********************************************************************
!
!                               PACSM
!
!***********************************************************************
!
%EXTERNALROUTINE PACSM
%EXTERNALINTEGERFNSPEC PASCALCOMPILE(%LONGINTEGER INPUT,OMF,RUN, %C
         LISTINGS,SAVELIST,RANGCHKS,CHARCODE,CODE,LIBPROC,GNSKEPT, %C
         HEAPSIZE,RTINPUT,RTOUTPUT,FLOWANAL,RETROBUFSIZE, %C
         STARTFWD,STOPFWD,DIAGS,DFILE,PROC,DIRECTIVES,CDIAG)
!
%LONGINTEGERFN CDSCA(%STRINGNAME S)
%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; ! END OF CDSCA
!
%LONGINTEGERFN CDSCB(%INTEGER BND,%LONGINTEGERNAME D)
%RESULT=((X'B0000000'!BND)<<32)!(ADDR(D))
%END; ! CDSCB
!
%OWNINTEGERARRAY MODE(1:22)=2,1,1,2,1,1,1,1,1,0,0,1,1, %C
                    2,0,0,0,0,1,1,1,1
%OWNSTRING(2) NO="NO"
%OWNSTRING(3) YES="YES"
%OWNSTRING(4) NONE="NONE"
%OWNSTRING(3) ISO="ISO"
%OWNSTRING(6) EBCDIC="EBCDIC"
%OWNSTRING(0) EMPTY=""
%OWNSTRING(6) RTIO="*STDAD"
! VALUES FOR THOSE LITERAL MODE PARAMTETERS WHICH HAVE TO BE SET HERE
%OWNLONGINTEGERARRAY INTPARMS(1:6)=-1,256,50,1,2,-1
!                          VALUES FOR INTEGER MODE PARAMETERS
!
! DP IS AN ARRAY OF DESCRIPTORS USED FOR PARAMTETERS TO PASCALCOMPILE
! DP(1),(2) & (5) ARE SET UP FROM SOURCE,OBJECT & SLIST RESPECTIVELY.
! DP(6),(7),(11),(14),(15),(16) & (17) MUST BE  SET UP HERE AS THEY
! ARE NOT PASSED ON AS PARAMTETERS TO ICL9HNCOMPILESUPPORT.
! ALL OTHER PARAMTETERS ARE SET UP AS -1(OR ""), MEANING THAT THEIR 
! VALUES ARE TO BE USED, AS THEY ARE PASSED ON TO ICL9HNCOMPILESUPPORT,
! WHERE A TABLE OF THEIR DEFAULTS IS SET UP AND ANY OVERRIDING
! PARM OPTIONS CHECKED FOR.
!
%LONGINTEGERARRAY DP(1:22)
%LONGINTEGERARRAY DSP(1:3)
!
!
%INTEGER RC,I,IDLIST,DSPPTR
%INTEGER ADDRHEAD
%STRING(160) HEADING
%OWNSTRING(255) ESOURCE
%OWNSTRING(31) EOBJECT,ESLIST
%SWITCH SWD(0:2)
!
!?1  LOG("PACSM ENTERED")
!
! OUTPUT HEADING
ADDRHEAD=ADDR(HEADING)+1
HEADING=E"                                 PASCAL VERSION 20.10
"
RC=ICL9HNOUTPUTLINE(LENGTH(HEADING),ADDRHEAD)
!
! SET UP PARAMS FOR PASCALCOMPILE
!
ESOURCE=SOURCE;EOBJECT=OBJECT;ESLIST=SLIST
IDLIST=1;DSPPTR=1;
%CYCLE I=1,1,22
->SWD(MODE(I))
!
SWD(0):; !INTEGER MODE
! VALUES FOR THESE PARAMS ARE HELD IN INTPARMS
DP(I)=INTPARMS(IDLIST)
IDLIST=IDLIST+1
->ENDCYD
!
SWD(1):; !LITERAL MODE
! LITERALS FOR DP(2) & (5) COME FROM EOBJECT & ESLIST RESPECTIVELY.
! LITERALS FOR DP(6) & (7) ARE SET UP ACCORDING TO COMREG(27).
! LITERALS FOR DP(12) & (13) ARE ALWAYS "*STDAD"
! ALL OTHER LITERALS ARE SET TO "".
!
%IF I=2 %THEN DP(2)=CDSCA(EOBJECT) %AND ->ENDCYD
%IF I=5 %THEN DP(5)=CDSCA(ESLIST) %AND ->ENDCYD
%IF I=6 %THENSTART
 %IF COMREG(27)&X'10010'#0 %THEN DP(6)=CDSCA(NO) %ELSE DP(6)=CDSCA(YES)
  ->ENDCYD
%FINISH 
%IF I=7 %THENSTART
  %IF COMREG(27) & X'400000'#0 %THEN DP(7)=CDSCA(EBCDIC) %C
                                       %ELSE DP(7)=CDSCA(ISO)
  ->ENDCYD
%FINISH
%IF I=12 %OR I=13 %THEN DP(I)=CDSCA(RTIO) %AND ->ENDCYD
DP(I)=CDSCA(EMPTY)
->ENDCYD
!
SWD(2):; !SUPERLITERAL MODE
! HERE, ALL SUPERLITERALS HAVE ONLY ONE LITERAL DEFINED
! BUT NEED DESCRIPTOR DESCRIPTOR
!
! VALUE FOR DP(1) COMES FROM ESOURCE
! VALUE FOR DP(14) IS SET TO "NONE".
! ALL OTHER VALUES ARE "".
!
%IF I=1 %THEN DSP(DSPPTR)=CDSCA(ESOURCE) %ELSESTART
  %IF I=14 %THEN DSP(DSPPTR)=CDSCA(NONE) %ELSE %C
                         DSP(DSPPTR)=CDSCA(EMPTY)
%FINISH
DP(I)=CDSCB(1,DSP(DSPPTR))
DSPPTR=DSPPTR+1
!
ENDCYD: %REPEAT
!
!?1  LOG("CALLING PASCALCOMPILE")
!
RC=PASCALCOMPILE(DP(1),DP(2),DP(3),DP(4),DP(5),DP(6),DP(7),DP(8), %C
            DP(9),DP(10),DP(11),DP(12),DP(13),DP(14),DP(15),DP(16), %C
            DP(17),DP(18),DP(19),DP(20),DP(21),DP(22))
!?1  EXITREP('PASCALCOMPILE',RC)
!?1  LOG('EXIT FROM PACSM')
%END
!
%ENDOFFILE