! MODIFIED 12/11/81 - VERSION 20.13
! RESET NOPDEFS IN INIT

!**********************************************************************
!*
!*                    RUN TIME PASCAL
!*
!**********************************************************************
!
!
!**********************************************************************
!*
!*                            CONSTANTS
!*
!**********************************************************************
!
%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
!*
!**********************************************************************
!
%EXTERNALINTEGER ICL9HERRADDR
%EXTERNALBYTEINTEGERARRAY ICL9LPGLICL9LPLIBNUC(1:X'0224')
%EXTERNALBYTEINTEGERARRAY ICL9LPGLICL9LPREALIO(1:X'0020')
%EXTERNALBYTEINTEGERARRAY ICL9LPGLICL9LPPMPACKAGE(1:X'3914')
!?2  %OWNINTEGER TRACE COUNT
!?2  %OWNINTEGER TRACE STREAM
%OWNINTEGER LOG STREAM=0,LISTING=82
%OWNINTEGER CURFD,CAREC,CBUFFADDR
%OWNINTEGER NOPDEFS=0
%OWNINTEGER FCBPTR
%OWNINTEGERARRAY PFDMAP(1:99)
%OWNINTEGER STARTBUFF
%OWNINTEGERARRAY BUFFADDR(0:99)
%OWNBYTEINTEGERARRAY DEFBUFF(1:164); ! DEFAULT BUFFER
!?3   %OWNINTEGERARRAY FDTRACE(1:99)
%RECORDFORMAT NRFDFMT(%INTEGER LINK, DSNUM,  %C
   %BYTEINTEGER STATUS, ACCESS ROUTE, VALID ACTION, CUR STATE,  %C
   %BYTEINTEGER MODEOFUSE, MODE, FILE ORG, DEV CODE,  %C
   %BYTEINTEGER REC TYPE, FLAGS, LM, RM,  %C
   %INTEGER ASVAR, AREC, RECSIZE, MINREC, MAXREC, MAXSIZE,  %C
   LASTREC, CONAD, CURREC, CUR, END, TRANSFERS, DARECNUM,  %C
   CURSIZE, DATASTART, %STRING (31) IDEN)
%OWNRECORDNAME CF(NRFDFMT)
%OWNSTRINGARRAYNAME DEFFILES
%OWNSTRING(32) %ARRAYFORMAT FILFMT(1:64)
!
!**********************************************************************
!*
!*                      EXTERNAL  REFERENCES - SUBSYSTEM
!*
!**********************************************************************
!
%EXTERNALROUTINESPEC ICL9LPLIBNUC
%EXTERNALINTEGERFNSPEC OUT STREAM
%EXTERNALROUTINESPEC DEFINE(%STRING(255) S)
%EXTERNALINTEGERFNSPEC ICL9HEFATALCOMPERR(%INTEGER LANG,ERRNO)
%SYSTEMROUTINESPEC CONNECT(%STRING(31)FILE,%INTEGER MODE,HOLE,PLOT, %C
          %RECORDNAME R,%INTEGERNAME FLAG)
%SYSTEMROUTINESPEC    ITOE      (%INTEGER ADDRESS,LENGTH)
%SYSTEMROUTINESPEC    ETOI      (%INTEGER ADDRESS,LENGTH)
%SYSTEMLONGREALFNSPEC CPUTIME
%SYSTEMROUTINESPEC MOVE(%INTEGER LENGTH, FROM, TO)
%SYSTEMINTEGERFNSPEC NEWFILEOP(%INTEGER DSNUM,ACTION,TYPE, %C
                    %INTEGERNAME AFD)
%SYSTEMINTEGERFNSPEC INREC
%SYSTEMINTEGERFNSPEC OUTREC(%INTEGER LEN)
%SYSTEMROUTINESPEC SETWORK(%INTEGERNAME A,F)
%SYSTEMROUTINESPEC OUTFILE(%STRING(31) FNAME,%INTEGER SIZE,GAP,PROT, %C
                    %INTEGERNAME CONADDR,FLAG)
%SYSTEMINTEGERFNSPEC FDMAP(%INTEGER CHAN)
%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N)
!
!*********************************************************************
!
!*                        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
!
%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(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
!
%INTEGERFN GETAD(%ROUTINE FRED)
! RETURNS ADDRESS OF FRED
%INTEGER I
   *LSS_(%LNB+6)
   *ST_I
%RESULT=I
%END; ! GETAD
%INTEGERFN HASHFUN(%STRING(32) NAME)
! GENERATES A VALUE BETWEEN 1 AND 32
%BYTEINTEGERNAME HASH1,HASH2
HASH1==BYTEINTEGER(ADDR(NAME)+1)
HASH2==BYTEINTEGER(ADDR(NAME)+LENGTH(NAME))
%RESULT=(HASH1+HASH2)&X'1F' +1
%END; ! HASHFUN
!
%EXTERNALINTEGERFN SEARCHFILE(%STRINGARRAYNAME DEFFILES,%C
                      %STRING(32) FILE)
! SEARCHES THE ARRAY DEFFILES FOR THE ENTRY FILE
! RESULT IS THE INDEX VALUE OR ZERO
%INTEGER INDEX,SAVIND,FULLMARK
INDEX=HASHFUN(FILE)
SAVIND=INDEX
FULLMARK=0
%CYCLE
  %IF DEFFILES(INDEX)=FILE %OR DEFFILES(INDEX)="" %THEN %C
                                 %RESULT=INDEX
  INDEX=INDEX+1
  %IF INDEX=FULLMARK %THEN %RESULT=0
  %IF INDEX=33 %THEN FULLMARK=SAVIND %AND INDEX=1
%REPEAT
%END; ! SEARCHFILE
!
!?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
!
!######################################################################
!#
!#                    OPEH ROUTINES
!#
!######################################################################
!
%EXTERNALINTEGERFN ICL9HEDIAGOUT(%INTEGER POSDR0,POSDR1,DIAGDR0,DIAGDR1)
%STRING(120) TEXT
%OWNSTRING(120) BUFF
%INTEGER POSN,CS,LEN,TXTLEN
%OWNINTEGER BUFFPTR,NOPRINT
!
!?1  LOG('ENTERING ICL9HEDIAGOUT')
!
POSN=INTEGER(POSDR1)
!?3  PRINTSTRING('POSITION = ')
!?3  WRITE(POSN,4)
!?3  NEWLINE
TXTLEN=DIAGDR0&X'000000FF'
!?3  PRINTSTRING('TEXT LENGTH = ')
!?3  WRITE(TXTLEN,6)
!?3  NEWLINE
%IF TXTLEN>1024 %THEN TXTLEN=1024
%IF POSN>0 %THENSTART
  %IF POSN<=BUFFPTR %THEN PRINTSTRING(BUFF) %AND NEWLINE
  BUFFPTR=POSN-1
  LENGTH(BUFF)=POSN-1
%FINISH
REP1:
%IF TXTLEN>(120-BUFFPTR) %THENSTART
  LEN=120-BUFFPTR
  TXTLEN=TXTLEN-LEN
%FINISHELSE LEN=TXTLEN
CS=OUTSTREAM
SELECTOUTPUT(LOGSTREAM)
%IF POSN<0 %THENSTART
  %UNLESS NOPRINT=1 %THEN PRINTSTRING(BUFF) %AND NEWLINES(-POSN)
  BUFFPTR=0
  BUFF=""
%FINISH
TEXT=STRINGFROM(LEN,DIAGDR1)
ETOI(ADDR(TEXT)+1,LEN)
BUFF=BUFF.TEXT
%IF BUFF='HEAP' %OR BUFF='STACK FRAME' %THEN NOPRINT=1
! SWITCH OFF PRINITING OF HEAP AND STACK FRAME
%IF BUFF->('PASCAL').BUFF %THEN NOPRINT=0 %AND BUFF='PASCAL'.BUFF
! SWITCH ON PRINTING AGAIN AFTER STACK FRAME OR HEAP O/P
%IF BUFFPTR+LEN=120 %THENSTART
  DIAGDR1=DIAGDR1+LEN
  %UNLESS NOPRINT=1 %THEN PRINTSTRING(BUFF) %AND NEWLINE
  BUFFPTR=0
  BUFF=""
  ->REP1
%FINISH
SELECTOUTPUT(CS)
!
!?1  EXITREP('ICL9HEDIAGOUT',0)
! 
%RESULT=0
%END; ! ICL9HEDIAGOUT
!
!
!##########################################################################
!#
!#                               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
%LONGINTEGERNAME TIME
!
!?1  LOG("GIVEPROCESSTIME ENTERED")
!?2 *STLN_X
!?2 TRACE("GIVEPROCESSTINE","",X,3)
!
TIME==LONGINTEGER(PTIM1)
TIME=INT(CPUTIME*1000000)
!
!?3  PRINTSTRING('TIME = ')
!?3  WRITE(TIME,6)
!?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
!
!##########################################################################
!#
!#                    SYSTEM ROUTINES
!#
!#######################################################################
!
!*************************************************************************
!*
!*                            INIT
!*
!***********************************************************************
!
%SYSTEMINTEGERFN INIT(%INTEGER LANG,LNB,%ROUTINE PROC)
%INTEGER I,TADDR,FLAG
!
!?1  LOG('ENTERING INIT')
!?3  PRINTSTRING('LANG = ')
!?3  WRITE(LANG,4)
!?3  NEWLINE
%CYCLE I=1,1,99
  PFDMAP(I)=0; ! CLEAR MAP FOR FILE DESCRIPTOR ADDRESS POINTERS
  !?3  FDTRACE(I)=0
%REPEAT
NOPDEFS=0; ! INITIALISE PDEFINE FLAG
BUFFADDR(0)=ADDR(DEFBUFF(1)); ! SET PRIVATE BUFFER ADDRESS
! SET UP T#WRK TO HOLD ANY BUFFERS NEEDED FOR DATA FILES
! SETWORK RETURNS THE ADDRESS OF T#WRK IN ITS 1ST PARAM
STARTBUFF=X'40000'
SETWORK(STARTBUFF,FLAG)
%IF FLAG#0 %THEN %RESULT=FLAG
!?3  PRINTSTRING('ADDRESS OF T#WRK =');
!?3  WRITE(STARTBUFF,10)
!?3  NEWLINE
STARTBUFF=STARTBUFF+INTEGER(STARTBUFF+4)
!?3  PRINTSTRING('ADDRESS OF STARTBUFF=')
!?3  WRITE(STARTBUFF,10)
!?3  NEWLINE
!
! GET ADDRESS OF POINTER TO ADDRESS OF THE 1ST FCBLOCK RECORD IN THE
! CHAIN OF RECORDS, DEFINED IN ICL9LPLIBNUC, WHICH HOLDS PASCAL
! EXTERNAL FILE NAMES AND THEIR CORRESPONDING CHANNEL NUMBERS
!
TADDR=GETAD(ICL9LPLIBNUC) +36
FCBPTR=INTEGER(TADDR)+X'214'
!
EXIT:
!?1 EXITREP('INIT',0)
! 
%RESULT=0
%END; ! INIT
!
%SYSTEMROUTINE TIDY
!
!?1  LOG('ENTERING TIDY')
!
%END; ! TIDY
!
%SYSTEMINTEGERFN READJSVAR(%STRING(32) NAME,%INTEGER OPTION,RADDR)
%LONGINTEGERNAME VALUE
!
!?1   LOG('ENTERING READJSVAR')
!?3  PRINTSTRING('OPTION = ')
!?3  WRITE(OPTION,4)
!?3  NEWLINE
!?3  LOG('NAME IS '.NAME)
!
VALUE==LONGINTEGER(RADDR)
%IF NAME='ICL9LPRHEAP' %THEN VALUE=64 %ELSESTART
   LOG('WARNING - UNRECOGNISED JSV READ - '.NAME)
  VALUE=0
%FINISH
!
!?1  EXITREP('READJSVAR',0)
!
%RESULT=0
%END;! READJSVAR
!
%SYSTEMINTEGERFN WRITEJSVAR(%STRING(32) NAME,%INTEGER OPTION,RADDR)
%LONGINTEGERNAME VALUE
!
!?1  LOG('ENTERING WRITEJSVAR')
!?3  PRINTSTRING('OPTION = ')
!?3  WRITE(OPTION,4)
!?3  NEWLINE
!?3  LOG('NAME IS '.NAME)
!
VALUE==LONGINTEGER(RADDR)
!?3  PRINTSTRING('VALUE = ')
!?3  WRITE(VALUE,4)
!?3  NEWLINE
!?1  EXITREP('WRITEJSVAR',0)
!
%RESULT=0
%END; ! WRITEJSVAR
!
!
%SYSTEMINTEGERFN READCPUTIME
%INTEGER RES
!
!?1  LOG('ENTERING READCPUTIME')
!
RES=INT(CPUTIME*1000)
!
!?1  EXITREP('READCPUTIME',RES)
!
%RESULT=RES
%END; ! READCPUTIME
!
%EXTERNALINTEGERFN MYINREC
%INTEGER RC,LENGTH,I
!?3  %INTEGERARRAYNAME FD
!?3  %INTEGERARRAYFORMAT FDFORM(1:20)
!?3  %STRING(8) FDSTRING
!?4  %STRING(255) BUFFER
!
!?1  LOG('ENTERING INREC')
!
!?4  PRINTSTRING('BEFORE CALLING INREC - ')
!?4  NEWLINE
!?4  PRINTSTRING('AREC IS '.HEXOF(CF_AREC))
!?4  NEWLINE
RC=INREC; ! INREC SETS CF_AREC
%IF RC#0 %THEN ->EXIT
!?3  %IF FDTRACE(CF_DSNUM)>0 %THENSTART
!?3    FDTRACE(CF_DSNUM)=-FDTRACE(CF_DSNUM)
!?3     FD==ARRAY(CURFD,FDFORM)
!?3     %CYCLE I=1,1,20
!?3       FDSTRING=HEXOF(FD(I))
!?3       LOG(FDSTRING)
!?3     %REPEAT
!?3  %FINISH
!
LENGTH=CF_RECSIZE
%IF CF_MODEOFUSE#1 %OR CF_ACCESSROUTE=8 %OR CF_ACCESSROUTE=11 %START
! CF_AREC MAPS DIRECTLY ON TO FILE IN ABOVE CASES, SO MUST TRANSFER 
! TO PRIVATE BUFFER, SET UP IN NEWFILEOP WITH ADDRESS CBUFFADDR
  MOVE(LENGTH,CF_AREC,CBUFFADDR)
  CF_AREC=CBUFFADDR
%FINISH
!?4 PRINTSTRING('AFTER CALLING INREC - LENGTH =')
!?4  WRITE(LENGTH,6)
!?4  NEWLINE
!?4  PRINTSTRING('AREC IS '.HEXOF(CF_AREC))
!?4  NEWLINE
!?4  BUFFER =STRINGFROM(LENGTH,CF_AREC)
!?4  PRINTSTRING('BUFFER CONTAINS '.BUFFER)
!?4  NEWLINE
!
%IF CF_MODEOFUSE=1 %THEN ITOE(CF_AREC,LENGTH); ! CONVERT TO EBCDIC 
!
EXIT:
!?1  EXITREP('INREC',RC)
!
%RESULT=RC
%END; ! INREC
!
%EXTERNALINTEGERFN MYOUTREC(%INTEGER LEN)
%INTEGER RC,I,DR0,DR1,CUROUTSTREAM
%BYTEINTEGERARRAYNAME CURBUFF
%BYTEINTEGERARRAYFORMAT BUFFORM(1:161)
!?3  %INTEGERARRAYNAME FD
!?3  %INTEGERARRAYFORMAT FDFORM(1:20)
!?3  %STRING(8)FDSTRING
!?4  %STRING(255) BUFFER,SYSBUF
!
!?1  LOG('ENTERING OUTREC')
!
! A RECORED OF LENGTH LEN IS IN THE BUFFER AT CF_AREC
! %RESULT=169 IF THE OUTPUT FILE IS FULL
!
%IF LEN>160 %AND CF_MODEOFUSE=1  %THEN %C
  LOG('OUTREC - BUFFER LENGTH>160') %AND %RESULT=1
!
!?4  PRINTSTRING('BEFORE CALLING OUTREC - LEN =')
!?4  WRITE(LEN,6)
!?4  NEWLINE
!?4  PRINTSTRING('AREC IS '.HEXOF(CF_AREC))
!?4  NEWLINE
!?4  BUFFER=STRINGFROM(LEN,CF_AREC)
!?4  PRINTSTRING('BUFFER CONTAINS '.BUFFER)
!?4  NEWLINE
!
%IF CF_MODEOFUSE=1 %THENSTART; ! CHARACTER I/O
  ETOI(CF_AREC,LEN); ! CONVERT CHAR. FILES TO ISO
  %IF CF_DSNUM=91 %OR CF_FLAGS&16=16 %THEN LEN=LEN+1
          ! ADD EXTRA BYTE TO ALLOW FOR FE CHAR.
%FINISHELSESTART
  %IF LEN<CF_RECSIZE %AND CF_RECTYPE=1 %THEN %C
      RC=ICL9HEFATALCOMPERR(0,1403) %AND ->EXIT
    ! CHECK FIXED LENGTH RECORD IS NOT TOO BIG
   MOVE(LEN,CBUFFADDR,CAREC); ! TRANSFER FROM PRIVATE BUFFER
%FINISH
!
RC=OUTREC(LEN)
!
%IF RC#0 %THEN ->EXIT
%IF CF_MODEOFUSE=2 %THENSTART ; ! RESET AREC
  CAREC=CF_AREC
  CF_AREC=CBUFFADDR
%FINISH
!?4  PRINTSTRING('AFTER CALLING OUTREC -')
!?4  NEWLINE
!?4  PRINTSTRING('AREC IS '.HEXOF(CF_AREC))
!?4  NEWLINE
!
!?3  %IF FDTRACE(CF_DSNUM)>0 %THENSTART
!?3    FDTRACE(CF_DSNUM)=-FDTRACE(CF_DSNUM)
!?3     FD==ARRAY(CURFD,FDFORM)
!?3  %CYCLE I=1,1,20
!?3    FDSTRING=HEXOF(FD(I))
!?3    LOG(FDSTRING)
!?3  %REPEAT
!?3  %FINISH
!
EXIT:
!?1  EXITREP('OUTREC',RC)
!
%RESULT=RC
%END; ! OUTREC
!
%EXTERNALINTEGERFN MYNEWFILEOP(%INTEGER DSNUM,ACTION,TYPE, %C
                    %INTEGERNAME AFD)
%INTEGER RES,FCBADDR,INDEX,I,FLAG
%BYTEINTEGER SLENSAV
%STRING(32) PFILE
%STRING(2) CHANNO
%RECORDFORMAT FCBFMT(%INTEGER LINK,DUMA,CHANNEL,DUMB, %C
        %BYTEINTEGER DUMC,DUMD,DUME,%STRING(32) LNAME)
%RECORDNAME FCBLOCK(FCBFMT)
%RECORDFORMAT RF(%INTEGER CONAD,TYPE,START,END)
%RECORD PFILES(RF)
!
!?3  %INTEGERARRAYNAME FD
!?3  %INTEGERARRAYFORMAT FDFORM(1:20)
!?3  %STRING(8) FDSTRING
!
!?1  LOG('ENTERING NEWFILEOP')
!
!?3   PRINTSTRING('TYPE = ')
!?3   WRITE(TYPE,4)
!?3   PRINTSTRING('   DSNUM = ')
!?3   WRITE(DSNUM,4)
!?3   PRINTSTRING('   ACTION = ')
!?3   WRITE(ACTION,4)
!?3   NEWLINE
!
%IF DSNUM=98 %OR DSNUM=99 %THEN DSNUM=DSNUM-8; ! SET DEFAULT I/O STREAMS
REP1:
%IF PFDMAP(DSNUM)#0 %THENSTART
  CF==RECORD(PFDMAP(DSNUM))
!?3  PRINTSTRING('MODEOFUSE = ')
!?3  WRITE(CF_MODEOFUSE,4)
!?3  NEWLINE
%FINISHELSESTART
! FIRST CALL OF NEWFILEOP FOR THIS CHANNEL
! CHECK IF A FILE HAS BEEN PDEFINED FOR THIS CHANNEL
%IF DSNUM<=80 %THENSTART
  %IF NOPDEFS=0 %THENSTART ; ! T#PFILES NOT CONNECTED
    CONNECT('T#PFILES',2,0,0,PFILES,FLAG)
    %IF FLAG#0 %THEN ->CONT; ! NO FILES PDEFINED
    DEFFILES==ARRAY(PFILES_CONAD,FILFMT)
    NOPDEFS=1
  %FINISH
  FCBADDR=INTEGER(FCBPTR)
  FCBLOCK==RECORD(FCBADDR)
  %CYCLE
    %IF FCBLOCK_CHANNEL=0 %THEN ->CONT
    %IF FCBLOCK_CHANNEL=DSNUM %THENSTART
      SLENSAV=LENGTH(FCBLOCK_LNAME)
      LENGTH(FCBLOCK_LNAME)=32
      PFILE=FCBLOCK_LNAME
      LENGTH(FCBLOCK_LNAME)=SLENSAV
      ETOI(ADDR(PFILE)+1,32)
      %WHILE PFILE->PFILE.(" ") %CYCLE; %REPEAT
      INDEX=SEARCHFILE(DEFFILES,PFILE)
      %IF INDEX#0 %AND DEFFILES(INDEX)=PFILE %THENSTART
         CHANNO=SFROMI(FCBLOCK_CHANNEL)
        DEFINE(CHANNO.",".DEFFILES(INDEX+32))
      %FINISH
    ->CONT
    %FINISH
    FCBLOCK==RECORD(FCBLOCK_LINK)
  %REPEAT
%FINISH
CONT:
! NOW CHECK IF A FILE HAS BEEN DEFINED FOR THIS CHANNEL
  AFD=FDMAP(DSNUM)
!?3  PRINTSTRING('AFD ='.HEXOF(AFD))
!?3  NEWLINE
  %IF AFD=0 %THEN RES=151 %AND ->EXIT
  CF==RECORD(AFD)
!
!?3  PRINTSTRING('DSNUM = ')
!?3  WRITE(DSNUM,4)
!?3  PRINTSTRING('   MODEOFUSE = ')
!?3  WRITE(CF_MODEOFUSE,4)
!?3  NEWLINE
!?3 PRINTSTRING('FILE DESC BEFORE CALLING NEWFILEOP - ')
!?3 NEWLINE
!?3 FD==ARRAY(AFD,FDFORM)
!?3 %CYCLE I=1,1,20
!?3    FDSTRING=HEXOF(FD(I))
!?3   LOG(FDSTRING)
!?3 %REPEAT
!
  %IF CF_ACCESSROUTE=1 %THEN DSNUM=90 %AND ->REP1
  %IF CF_ACCESSROUTE=2 %THEN DSNUM=91 %AND ->REP1
        ! REFERENCING DEFAULT INPUT
  PFDMAP(DSNUM)=AFD
! SET MODEOFUSE IN FILE DESC. ACCORDING TO PASCAL TYPE
%IF TYPE=11 %THENSTART
  %IF CF_MODEOFUSE=1 %THEN RES=ICL9HEFATALCOMPERR(0,1400) %AND ->EXIT
  CF_MODEOFUSE=2
%FINISHELSESTART
  %IF CF_MODEOFUSE>1 %THEN RES=ICL9HEFATALCOMPERR(0,1400) %AND ->EXIT
  CF_MODEOFUSE=1
%FINISH
%IF CF_MODEOFUSE=2 %THENSTART; ! DATA FILES
!CF_AREC MAPS DIRECTLY ON TO A DATA FILE, SO EACH FILE MUST HAVE
! ITS OWN INTERMEDIATE BUFFER FROM T#WRK
  BUFFADDR(DSNUM)=STARTBUFF; ! SAVE PRIVATE BUFF ADDR
  STARTBUFF=STARTBUFF+CF_MAXREC; ! INCREMENT FOR NEXT BUFFER
!?3  PRINTSTRING('ASSIGNING NEW BUFFER- NEW STARTBUFF=')
!?3  WRITE(STARTBUFF,10)
!?3  NEWLINE
%FINISHELSE BUFFADDR(DSNUM)=BUFFADDR(0)
! SET DEFAULT BUFFER (FOR CHAR. FILE I/P)
! CHAR. FILES ALREADY HAVE AN INTERMEDIATE BUFFER IN THE PASCAL
! SUBSYSTEM TO WHICH INFO. IS TRANSFERRED ON EXIT FROM INREC (I THINK)
! SO ONLY 1 BUFFER, FOR ITOE CONVERSION, IS REQUIRED FOR ALL CHAR FILES
%FINISH
!
RES=NEWFILEOP(DSNUM,ACTION,TYPE,AFD)
!
!?3  PRINTSTRING('AFTER NEWFILEOP, RES = ')
!?3  WRITE(RES,4)
!?3  NEWLINE
%IF RES#0 %THENSTART
  %IF RES#151 %THEN RES=ICL9HEFATALCOMPERR(0,1400)
  ->EXIT
%FINISH
%IF PFDMAP(DSNUM)#AFD %THEN %C
LOG('NEWFILEOP - CONFLICTING FILE DESCRIPTORS - HELP!!!') %ANDRESULT=100
CURFD=AFD
CBUFFADDR=BUFFADDR(DSNUM); ! SET CURRENT BUFFER ADDRESS
%IF ACTION=2 %THENSTART ; !  OUTPUT
  %IF DSNUM=91 %OR CF_FLAGS&16=16 %THENSTART; ! DEFAULT O/P
    BYTEINTEGER(CF_AREC)=0; ! SET FE CHAR. FOR OUTREC
    CF_AREC=CF_AREC+1
  %FINISH
  %IF CF_MODEOFUSE#1 %THENSTART; ! SEQUENTIAL OUTPUT
    CAREC=CF_AREC; ! SAVE AREC FOR USE BY OUTREC
    CF_AREC=CBUFFADDR; ! SET AREC TO PRIVATE BUFFERR ADDRESS
  %FINISH
%FINISH
!?4  PRINTSTRING('AFTER CALLING NEWFILEOP - ')
!?4  NEWLINE
!?4  PRINTSTRING('AREC IS '.HEXOF(CF_AREC))
!?4  NEWLINE
!
!
!?3  %IF IMOD(FDTRACE(DSNUM))#ACTION %THENSTART
!?3    FDTRACE(DSNUM)=ACTION
!?3      FD==ARRAY(AFD,FDFORM)
!?3      %CYCLE I=1,1,20
!?3       FDSTRING=HEXOF(FD(I))
!?3       LOG(FDSTRING)
!?3      %REPEAT
!?3  %FINISH
! 
EXIT:
!?1  EXITREP('NEWFILEOP',RES)
!
%RESULT=RES
%END; ! NEWFILEOP
!
%EXTERNALINTEGERFN MYOUTFILE(%STRING(31)FNAME,%INTEGER SIZE,GAP,PROT, %C
                   %INTEGERNAME CONADDR,FLAG)
!
!?1  LOG('ENTERING OUTFILE')
!?3  LOG('OUTFILE- NAME IS '.FNAME)
!?3  PRINTSTRING('SIZE = ')
!?3  WRITE(SIZE,12)
!?3  NEWLINE
%IF FNAME='ICL9LPHEAPRT' %THEN FNAME='T#HEAP'
!
OUTFILE(FNAME,SIZE,GAP,PROT,CONADDR,FLAG)
!?1  EXITREP('OUTFILE',FLAG)
!
%RESULT=FLAG
%END; ! MYOUTFILE
!
!
%ENDOFFILE