%CONSTSTRING(31) DEFAULT ROUTE = "PLULB1.CTMY_ROUTE"
%CONSTSTRING(31)%ARRAY STD ROUTE(1:4) =  %C
      "PLULB1.CTMY_CROUTE",
      "PLULB1.CTMY_VROUTE",
      "PLULB1.CTMY_FROUTE",
      "PLULB1.CTMY_TTYROUTE"
%CONSTSTRING(31) DEFAULT RAM = "PLULB1.RAMY"
!
%EXTERNALSTRING(255)%FNSPEC ETOS(%INTEGER DR0, DR1)
%EXTERNALSTRINGFNSPEC HEX(%INTEGER I)
%EXTERNALROUTINESPEC ECTM SET TRAP
%EXTERNALROUTINESPEC ECTM REPORT INT(%STRING(63) MESS, %INTEGER I)
%EXTERNALROUTINESPEC ECTM REPORT STRING(%STRING(63) MESS,  %C
      %INTEGER DR0, DR1)
%EXTERNALROUTINESPEC ECTM REPORT LONG(%STRING(63) MESS,  %C
      %INTEGER DR0, DR1)
%EXTERNALROUTINESPEC ECTM DUMP PPAIRS(%INTEGER LEN, ADR)
%EXTERNALSTRING(255)%FNSPEC ETON(%INTEGER DR0, DR1)
%EXTERNALSTRINGFNSPEC EMAS NAME(%STRING(255) CTM NAME, %INTEGER QNEW)
%EXTERNALSTRING(63)%FNSPEC NEXT NAME(%STRING(63) NAME)
%EXTERNALINTEGERFNSPEC CE CHAN(%STRING(31) NAME)
%EXTERNALSTRING(15)%FNSPEC ITOS(%LONGINTEGER I)
%EXTERNALROUTINESPEC CALL ACCESS(%LONGINTEGER ACCESS1,  %C
      %INTEGER PPLEN, PPADDR)
%EXTERNALINTEGERFNSPEC ECTM PPI(%INTEGER PPLEN, PPADDR, ID)
%EXTERNALLONGINTEGERFNSPEC ECTM PPL(%INTEGER PPLEN, PPADDR, ID)
%EXTERNALSTRINGFNSPEC ECTM PPS(%INTEGER PPLEN, PPADDR, ID)
%EXTERNALROUTINESPEC ADD PARAM(%INTEGER ID, %INTEGERNAME PPLEN,  %C
      %INTEGER PPADDR, DR0, DR1, %LONGINTEGERNAME AREA DESC)
%EXTERNALINTEGERFNSPEC MERGE PP(%INTEGER OLD DR0, OLD DR1,  %C
      %INTEGERNAME NEW DR0, NEW DR1)
%EXTERNALINTEGERFNSPEC CALL RAM(%INTEGER CALL DR0, CALL DR1,  %C
      %LONGINTEGER ROUTE, %INTEGER PP DR0, PP DR1)
%EXTERNALINTEGERFNSPEC ECTM FILE ROUTE(%LONGINTEGER ROUTE,  %C
      %INTEGER OPERATION)
%CONSTINTEGER CREATE = 1, ASSIGN = 2, DELETE = 3, DEASSIGN = 4
%CONSTINTEGER CHOOSE RAM = 5
%EXTERNALLONGINTEGERFNSPEC ROUTE DESCRIPTOR(%STRING(31) FILE,  %C
      %STRINGNAME TEMP)
%EXTERNALINTEGERFNSPEC RAM DESCRIPTORS(%STRING(31) FILE,  %C
      %STRINGNAME TEMP,  %C
      %INTEGERNAME RAM0, RAM1, ACC10, ACC11, ACC20, ACC21)
!
!-----------------------------------------------------------------------
%OWNSTRING(31) JOBNAME = ""
%OWNINTEGER CTM INITIALISED = 0
%OWNSTRING(15) STD HOOK = ""
!
! This flag is checked by all top-level CTM routines, which call
! 'ECTM ENTER' to connect or create the CTM if necessary.
!
!-----------------------------------------------------------------------
%EXTERNALINTEGER ECTM CHECK = 0, ECTM TRACE = 0, ECTM MONITOR = 0
!
!-----------------------------------------------------------------------
%OWNSTRING(31) CTM ROUTINE NAME
%OWNINTEGER LEVEL = 0
%OWNSTRING(31)%ARRAY ROUTINE NAME(1:10)
!
! Set by each top-level routine to hold its own name, for use in
! error messages etc.
!
!-----------------------------------------------------------------------
%OWNINTEGER JS FILE, NAME BASE, TYPE BASE, DESC BASE, JS BASE
%OWNINTEGER MAXIMUM JS VARS = 100
!
! Pointers and limits for the JS stack structure, set up by
! 'ECTM ENTER', and accessed by the mapping functions
! 'JS NAME', 'JS TYPE"  etc., below.
!
!-----------------------------------------------------------------------
%OWNINTEGER NIL = -1
%OWNLONGINTEGER DUMMY = -1
%OWNINTEGER STRING DESC = X'58000000'
%OWNINTEGER WORD DESC = X'28000000'
%OWNINTEGER LONG DESC = X'30000000'
%OWNLONGINTEGER ADDRESS MASK = X'00000000FFFFFFFF'
%OWNINTEGER LENGTH MASK = X'00FFFFFF'
!
%CONSTINTEGER MINIMUM RECORD SIZE = 105
%CONSTINTEGER MAXIMUM RECORD SIZE = 104
%CONSTINTEGER KEY POSITION = 106
%CONSTINTEGER KEY LENGTH = 107
%CONSTINTEGER ACTUAL FILE SIZE = 150
%CONSTINTEGER SYSTEM FILE DETAILS = 115
%CONSTINTEGER RECORD VIEW = 126
%CONSTINTEGER CONTROL DATA HEADER = 152
%CONSTINTEGER CONTROL DATA TRAILER = 153
%CONSTINTEGER MAXIMUM FILE SIZE = 151
%CONSTINTEGER FILE ORGANISATION = 101
%CONSTINTEGER BLOCK SIZE = 111
%CONSTINTEGER FORM LENGTH = 155
%CONSTINTEGER LINE WIDTH = 154
%CONSTINTEGER DDL FILE DESC = 156
%CONSTINTEGER RECORDING MODE = 157
%CONSTINTEGER TRACKS = 158
%CONSTINTEGER COMPRESS EXPAND = 159
%CONSTINTEGER RECORDING DENSITY = 160
%CONSTINTEGER EXTENSION INCREMENT = 162
%CONSTINTEGER DATA CONTENT SIZE = 163
%CONSTINTEGER CHARACTER CATEGORY = 164
%CONSTINTEGER REDUCTION = 220
%CONSTINTEGER AUTO PAGE = 222
%CONSTINTEGER PLACEMENT = 130
%CONSTINTEGER EMAS CHANNEL = 132
%CONSTINTEGER CONAD = 133
%CONSTINTEGER CURRENT LENGTH = 134
%CONSTINTEGER RAM NAME = 135
%CONSTINTEGER ROUTE NAME = 136
%CONSTINTEGER INITIAL FILE SIZE = 137
%CONSTINTEGER ACCESS TYPE = 138
%CONSTINTEGER ACCESS LOCK = 139
%CONSTINTEGER TEMP ROUTE = 140
%CONSTINTEGER TEMP RAM = 141
%CONSTINTEGER RAM CAPABILITIES = 142
!
! Assorted useful constants.
!
!-----------------------------------------------------------------------
%OWNINTEGER STDM PP LENGTH = 39
%OWNINTEGERARRAY STDM PP(0:38) =  %C
      101, 0, 0,
      104, 2048, 0,
      105, 1, 0,
      106, 1, 0,
      107, 0, 0,
      111, 2048, 0,
      114, 0, 0,
      115, 0, 0,
      126, 3, 0,
      150, 0, 0,
      151, 0, 0,
      152, 0, 0,
      153, 0, 0
!
! File description parameter pairs for (STD).STDM files.
!
!-----------------------------------------------------------------------
!
! Assigned File Record format -
!
! One such record is pushed onto the JS stack for each newly assigned,
! or created file.  The record is pointed at by the 'JS ADDR' field of
! a special type of 'JS variable' which has no name.  File routes
! point in turn to this JS variable, allowing careful checks for
! double assignments and easy retrieval of full file names.
! The AFR exists only on the JS stack, but corresponds with the less
! transient index entry record in the CTM catalogue.
!
! NAME:           ISO string containing the full CTM filename.
!
! ASSIGN ID:      Unique arbitrary integer associated with this
!                 assignment.  Also forms part of 'file route'
!                 value, to allow check for valid and currently
!                 assigned file routes.
!
! QAVAILABLE:     Set false (zero) by file creation routines,
!                 set true (one) by CTM ASSIGN or by first JS END
!                 after creation.  Used to inhibit SELECT RAM calls
!                 in the same way as VME/B.
!
! QTEMP:          Set true (non-zero) by FORM FILE, WORK FILE, DELETE
!                 FILE to indicate that the file should be destroyed
!                 at the end of the containing JS block.
!
! ROUTE:          Code descriptor to the 'file route' routine for
!                 this type of file - called to create, assign, etc.
!                 the 'resources' defined by the file description.
!
! ACCESS1:        Code descriptor to RAM, saved by a SELECT RAM call
!                 to allow detection of open files, and to allow
!                 DEASSIGN FILE (or JS END) to call 'deselect ram'
!                 entry for open files.
!
! DESC DR0:       A bounded word descriptor to the parameter pair array
! DESC DR1:       representing the non-default elements of the CTM
!                 file description.  Note that this includes EMAS-
!                 specific fields (e.g. character/data file) for
!                 which the CTM book makes allowances, and fields
!                 (such as connect address) which only exist in
!                 'stacked' descriptions.
!
! AREA DESC:      String descriptor of the area to hold strings (file
!                 names etc.) pointed at by descriptors in the PPair
!                 array.  This descriptor will be 'modified' (i.e. the
!                 length decreased and the address increased) every
!                 time a string is added (by ADD PARAM).
!
! DESC AREA:      The PPair array, followed by the area described above.
!
%RECORDFORMAT AFRFMT(%STRING(63) NAME, %INTEGER ASSIGN ID,  %C
      QAVAILABLE, QTEMP, %LONGINTEGER ROUTE, ACCESS1,  %C
      %INTEGER DESC DR0, DESC DR1, %LONGINTEGER AREA DESC,  %C
      %BYTEINTEGERARRAY DESC AREA(0:1023))
!
!-----------------------------------------------------------------------
!
! CTM file index entry format:  contains most of the same information
! as the AFR record on the stack, but could be more permanent.  An index
! entry is 'faked' in the case of assigning an existing EMAS file, and
! is filled from the EMAS file's characteristics.  The entry will be
! saved in the index file only when a newly created file is saved
! (at block end) with other than the default EMAS placement (filename
! and EMAS file label type).
!
%RECORDFORMAT INDEXFMT(%STRING(63) NAME,  %C
      %INTEGER ENTRY LENGTH, LINK, DESC DR0, DESC DR1,  %C
      %LONGINTEGER AREA DESC, %BYTEINTEGERARRAY DESC AREA(0:1023))
%OWNRECORD DUMMY INDEX(INDEXFMT)
!
!-----------------------------------------------------------------------
%EXTERNALSTRINGFNSPEC UINFS(%INTEGER MODE)
%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER I)
%SYSTEMROUTINESPEC CHANGE FILE SIZE(%STRING(31) FILE,  %C
      %INTEGER NEW SIZE, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC CONNECT(%STRING(31) FILE, %INTEGER A, B, C,  %C
      %RECORDNAME R, %INTEGERNAME FLAG)
%RECORDFORMAT CONREC(%INTEGER CONAD, FILETYPE, DATASTART, DATAEND)
%SYSTEMROUTINESPEC OUTFILE(%STRING(31) FILE, %INTEGER SIZE, HOLE, %C
      PROT, %INTEGERNAME CONAD, FLAG)
%EXTERNALINTEGERFNSPEC EXIST(%STRING(31) FILE)
%SYSTEMROUTINESPEC PRINTMESS(%INTEGER FLAG)
%EXTERNALROUTINESPEC CLOSEF(%INTEGERNAME CHAN)
%EXTERNALROUTINESPEC DEFINE(%STRING(255) S)
%EXTERNALROUTINESPEC CLEAR(%STRING(255) S)
%EXTERNALROUTINESPEC DEFINFO(%INTEGER CHAN, %STRINGNAME FILE,  %C
      %INTEGERNAME STATUS)
%SYSTEMROUTINESPEC UNLOAD(%INTEGER GLA)
%SYSTEMROUTINESPEC MOVE(%INTEGER BYTES, FROM, TO)
%SYSTEMROUTINESPEC ITOE(%INTEGER ADDR, LEN)
%EXTERNALSTRINGFNSPEC DATE
%EXTERNALSTRINGFNSPEC TIME
%SYSTEMROUTINESPEC SETUSE(%STRING(31) FILE, %INTEGER MODE, VALUE)
%SYSTEMROUTINESPEC DESTROY(%STRING(31) FILE, %INTEGERNAME FLAG)
!
! Commonly used EMAS system routines and foreground commands.
!
!-----------------------------------------------------------------------
!
! The following mapping functions are too uniformly boring to comment
! individually - they all check that the CTM has been initialised (and
! give up if it hasn't), and return the address of the relevant
! element of the JS stack structure created by 'ECTM ENTER' and
! defined by the global pointers 'NAME BASE', 'TYPE BASE' etc.
! The JS structure comes in two parts: the 'stack' - a structured table
! of name against type and descriptor, and an un-structured area
! containing JS variable values and (for 'assigned file' variables)
! FCB records pointed at by the 'descriptor' field in the stack.
!
%STRING(32)%MAP JS NAME(%INTEGER I)
!
! Name of JS variable or full CTM filename.  Held as standard Imp
! string, ISO characters, no blanks or underlines.
! Note that the variable name is limited (by the CTM definition) to a
! maximum of 16 characters - this requires an Imp string(32) to include
! the length byte within the string.
!
%RESULT = NAME BASE + (I-1)*32
%END
!
%INTEGERMAP JS TYPE(%INTEGER I)
!
! JS 'variable' type -
!        0     JS begin or 'profile' marker
!        1     Integer (8-byte)
!        2     String (up to 256 bytes)
!        3     Boolean (1 byte)
!        4     Assigned file entry
!
%RESULT = TYPE BASE + (I-1)*4
%END
!
%LONGINTEGERMAP JS DESC(%INTEGER I)
!
! String descriptor to the value of a JS variable within the
! unstructured half of the JS area.  Holds a simple address in the
! case of 'begin', 'profile', and 'assigned file' entries.
!
%RESULT = DESC BASE + (I-1)*8
%END
!
%INTEGERMAP JS STACK TOP
!
! Index of top of JS stack in JS NAME, JS TYPE, JS DESC.
! First word in temporary work area.
!
%RESULT = JS FILE
%END
!
%INTEGERMAP JS FREE
!
! Address of next free byte in JS area.
! Second word in area.
!
%RESULT = JS FILE + 4
%END
!
%INTEGERMAP ASSIGN ID
!
! Unique large integer to identify the next successful assignment.
! Third word in JS area.
!
%RESULT = JS FILE + 8
%END
!
%INTEGERMAP SIZE OF JS AREA
!
! Number of bytes in the 'array' JS.
!
%RESULT = JS FILE + 12
%END
!
%BYTEINTEGERMAP JS(%INTEGER I)
!
! Accesses the area of JS where variable values and AFR's are held.
! Next free byte is JS(JS FREE).
!
%RESULT = JS BASE + I - 1
%END
!
!-----------------------------------------------------------------------
!
%ROUTINE EXTEND
!
! Extends the JS area by 4Kbytes
!
%INTEGER FLAG
!
SIZE OF JS AREA = SIZE OF JS AREA + 4096
CHANGE FILE SIZE("T#CTMJS",SIZE OF JS AREA+4448,FLAG)
%IF FLAG > 0 %THEN %START
      SELECT OUTPUT(0)
      PRINT STRING("CTM fails - ")
      PRINTMESS(FLAG)
      NEW LINE
      %STOP
      %FINISH
INTEGER(JS FILE - 32) = SIZE OF JS AREA + 4448
%END
!
%EXTERNALINTEGERFN ECTM GET ROUTE(%LONGINTEGER ROUTE)
!
! Checks a given file route for validity, using ASSIGN ID to
! check that the file is still assigned. If all OK, returns the
! AFR address.
!
%RECORDNAME AFR(AFRFMT)
%INTEGER R0, R1
!
R0 = INTEGER(ADDR(ROUTE))
R1 = INTEGER(ADDR(ROUTE)+4)
!
%IF R0 = 0 %AND R1 = 0 %THEN %RESULT = 0
!
! Check second half of route value - JS stack index of assigned
! file 'variable'.
!
%UNLESS 0 < R1 <= JS STACK TOP %THEN %RESULT = 0
%UNLESS JS TYPE(R1) = 4 %THEN %RESULT = 0
!
! Pick up AFR record - pointed at by 'descriptor' field of JS stack
! entry.
!
R1 = ADDRESS MASK & JS DESC(R1)
%UNLESS ADDR(JS(1)) <= R1 < ADDR(JS(JS FREE)) %THEN %RESULT = 0
AFR == RECORD(R1)
!
! Check the 'assign ID' - ensures that the file has not been de-
! assigned and the stack entry reused.
!
%UNLESS AFR_ASSIGN ID = R0 %THEN %RESULT = 0
%IF AFR_ASSIGN ID = 0 %THEN %RESULT = 0
%RESULT = R1
%END
!
%EXTERNALROUTINE ECTM ENTER(%STRING(31) NAME)
!
! This routine 'creates' the CTM - creates or connects a temporary
! EMAS file to contain the JS structures, initialises JS with any
! pre-defined JS variables (standard file descriptions etc.),
! marks JS stack with 'profile' flag (to stop JS END going wild),
! connects CTM file catalogue if any, or sets pointers to indicate
! no (real) CTM catalogue.
!
%EXTERNALINTEGERFNSPEC CTM JS READ(%INTEGER NAME DR0, NAME DR1,  %C
      INT DR0, INT DR1, STR DR0, STR DR1, NOT RANGE DR0, NOT RANGE DR1)
%EXTERNALINTEGERFNSPEC CTM ASSIGN FILE(  %C
      %INTEGER ROUTE DR0, ROUTE DR1,  %C
      LOCAL DR0, LOCAL DR1,  FULL DR0, FULL DR1,  %C
      ACCESS TYPE, LOCK, NOT RANGE A,  %C
      NOTB DR0, NOTB DR1,  %C
      START SECT, END SECT,  %LONGINTEGER EXISTING ROUTE,  %C
      NOT RANGE C,  %INTEGER NOT D DR0, NOT D DR1, NOT E DR0, NOT E DR1)
%SYSTEMROUTINESPEC CONNECT(%STRING(31) FILE, %INTEGER A, B, C,  %C
      %RECORDNAME R, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC OUTFILE(%STRING(31) FILE, %INTEGER SIZE, HOLE,  %C
      PROT, %INTEGERNAME CONAD, FLAG)
!
%INTEGER I, FLAG, QNEW, AFR AD
%STRING(31) ROUTE, TEMP
%OWNSTRING(31) STDAD = E"STDAD"
%OWNSTRING(31) FULLAD = E":STD.STDAD"
%RECORDNAME AFR(AFRFMT)
%RECORDFORMAT CONREC(%INTEGER CONAD, FILETYPE, DATASTART, DATAEND)
%RECORD R(CONREC)
%LONGINTEGER LC, LT, LM
%OWNSTRING(15) TRACE = E"ECTMTRACE", CHECK = E"ECTMCHECK",  %C
      MONITOR = E"ECTMMONITOR"
!
%IF CTM INITIALISED = 0 %THEN %START
      ECTM SET TRAP
!
! Check for existing JS area, create if necessary.
!
      CONNECT("T#CTMJS",3,262144,0,R,FLAG)
      %IF FLAG = 0 %THEN %START
         JS FILE = R_CONAD
         QNEW = 0
         %FINISH  %C
      %ELSE %START
         OUTFILE("T#CTMJS",10000,262144,0,JS FILE,FLAG)
         INTEGER(JS FILE) = 10000
         QNEW = 1
         %FINISH
      %IF FLAG # 0 %THEN %START
         SELECT OUTPUT(0)
         PRINT STRING("CTM fails - ")
         PRINTMESS(FLAG)
         NEW LINE
         %STOP
         %FINISH
!
! Set up pointers required by maps (JS NAME etc.) above.
!
      JS FILE = JS FILE + 32; ! First data byte
      NAME BASE = JS FILE + 16; ! Leave room for JS FREE, JS STACK TOP,
                                        ! ASSIGN ID and SIZE OF JS AREA
      TYPE BASE = NAME BASE + 3200
      DESC BASE = TYPE BASE + 400
      JS BASE = DESC BASE + 800
      STD HOOK = ":".UINFS(1)
      CTM INITIALISED = 1
!
      %IF QNEW = 0 %THEN %START
         FLAG = CTM JS READ(  %C
            STRING DESC ! LENGTH(CHECK), ADDR(CHECK) + 1,  %C
            LONG DESC ! 1, ADDR(LC), NIL, NIL, NIL, NIL)
         FLAG = CTM JS READ(  %C
            STRING DESC ! LENGTH(TRACE), ADDR(TRACE) + 1,  %C
            LONG DESC ! 1, ADDR(LT), NIL, NIL, NIL, NIL)
         FLAG = CTM JS READ(  %C
            STRING DESC ! LENGTH(MONITOR), ADDR(MONITOR) + 1,  %C
            LONG DESC ! 1, ADDR(LM), NIL, NIL, NIL, NIL)
         %IF LC # 0 %THEN ECTM CHECK = 1 %ELSE ECTM CHECK = 0
         %IF LT # 0 %THEN ECTM TRACE = 1 %ELSE ECTM TRACE = 0
         %IF LM # 0 %THEN ECTM MONITOR = 1 %ELSE ECTM MONITOR = 0
!
! Must zip up the stack, re-assigning all files - the EMAS command
! interpreter will have unloaded all file routes.
!
         %CYCLE I = 1, 1, JS STACK TOP
            %IF JS TYPE(I) = 0 %AND JS NAME(I) = "***BEGIN***"  %C
               %THEN JS DESC(I) = COMREG(44)
            %IF JS TYPE(I) = 4 %THEN %START
               AFR == RECORD(JS DESC(I))
               ROUTE = ECTM PPS(AFR_DESC DR0, AFR_DESC DR1,  %C
                  TEMP ROUTE)
               %IF ROUTE # "" %THEN %START
                  AFR_ROUTE = ROUTE DESCRIPTOR(ROUTE,TEMP)
                  %IF AFR_ROUTE # 0 %THEN  %C
   FLAG = ECTM FILE ROUTE((LENGTHENI(AFR_ASSIGN ID) << 32) ! I, ASSIGN)
                  %FINISH
               %FINISH
            %REPEAT
         %FINISH  %C
      %ELSE %START
!
         JS STACK TOP = 0
         JS FREE = 1
         ASSIGN ID = 2900283
         SIZE OF JS AREA = 10000 - 4448
         JS STACK TOP = JS STACK TOP + 1
         JS NAME(JS STACK TOP) = "***PROFILE***"
         JS DESC(JS STACK TOP) = COMREG(44)
         JS TYPE(JS STACK TOP) = 0
         FLAG = CTM ASSIGN FILE(NIL, NIL,  %C
            STRING DESC ! LENGTH(STDAD), ADDR(STDAD) + 1,  %C
            STRING DESC ! LENGTH(FULLAD), ADDR(FULLAD) + 1,  %C
            3,0,0,NIL,NIL,0,0,0,0,NIL,NIL,NIL,NIL)
%IF FLAG # 0 %THEN %MONITOR
         %FINISH
      %FINISH
!
! Entry to new CTM routine - note name and nesting level
!
CTM ROUTINE NAME = NAME
%IF ECTM TRACE = 1 %THEN %START
      SELECT OUTPUT(0)
      SPACES(LEVEL*3)
      PRINT STRING("Entered 'CTM ".NAME."'")
      NEW LINE
      %FINISH
LEVEL = LEVEL + 1
ROUTINE NAME(LEVEL) = NAME
!
%END
!
%EXTERNALROUTINE ECTM RESULT(%INTEGER RC)
!
LEVEL = LEVEL - 1
%IF LEVEL < 0 %THEN %MONITOR
%IF ECTM TRACE = 1 %THEN %START
      SELECT OUTPUT(0)
      SPACES(LEVEL*3)
      PRINT STRING("Return from 'CTM ".CTM ROUTINE NAME."' ")
      WRITE(RC,0);  NEW LINE
      %FINISH
%IF RC > 0 %AND ECTM MONITOR = 1 %THEN %MONITOR
%IF LEVEL = 0 %THEN CTM ROUTINE NAME = ""  %C
      %ELSE CTM ROUTINE NAME = ROUTINE NAME(LEVEL)
%END
!
!-----------------------------------------------------------------------
!
! Assorted service routines.
!
%STRINGFN FULL NAME(%INTEGER DR0, DR1)
!
! Given a descriptor to a CTM filename (EBCDIC), returns an
! ISO string containing the full name.
!
%RECORDNAME AFR(AFR FMT)
%STRING(255) NAME
%STRING(63) SINK1, SINK2, HOOK
%INTEGER I, AFR AD
!
NAME = ETON(DR0,DR1)
%UNLESS NAME -> SINK1.("(").SINK2.(")") %AND SINK1 # ""  %C
      %THEN NAME = NAME."(1)"
%IF NAME -> ("(").HOOK.(").").NAME %THEN %START
      I = JS STACK TOP
      %CYCLE
         %IF I = 0 %THEN %RESULT = ""
         %IF JS NAME(I) = HOOK %AND JS TYPE(I) = 1 %THEN %EXIT
         I = I - 1
         %REPEAT
      AFR AD = ECTM GET ROUTE(JS DESC(I))
      %IF AFR AD = 0 %THEN %RESULT = ""
      AFR == RECORD(AFR AD)
      %RESULT = AFR_NAME.".".NAME
      %FINISH  %C
%ELSE %START
      %IF NAME -> HOOK.(".").NAME %THEN %START
         %UNLESS CHARNO(HOOK,1) = ':' %THEN HOOK = ":".HOOK
         %RESULT = HOOK.".".NAME
         %FINISH
      %RESULT = STD HOOK.".".NAME
      %FINISH
%END
!
%ROUTINE DESELECT RAM(%LONGINTEGER ACCESS1)
!
! Calls the ACCESS1 ram entry, before an open file is de-assigned.
!
%OWNINTEGERARRAY PPAIRS(0:2) = 13, 0, 0
%OWNINTEGER PPLEN = 3
!
CALL ACCESS(ACCESS1,PPLEN,ADDR(PPAIRS(0)))
%END
!
%ROUTINE DEASSIGN FILE(%LONGINTEGER ROUTE)
!
! De-assigns file pointed at by ROUTE, on end of block
! in which the file was first assigned.
!
%STRING(31) FILE
%INTEGER AFR AD, FLAG
%RECORDNAME AFR(AFRFMT)
!
AFR AD = ECTM GET ROUTE(ROUTE)
%IF AFR AD = 0 %THEN %RETURN
AFR == RECORD(AFR AD)
!
! Check for currently selected RAM and de-select, if necessary
!
%IF AFR_ACCESS1 # 0 %THEN DESELECT RAM(AFR_ACCESS1)
AFR_ACCESS1 = 0
!
! Disconnect or destroy EMAS file.
!
%IF AFR_ROUTE = 0 %THEN %RETURN
%IF AFR_QTEMP = 1 %THEN  %C
      FLAG = ECTM FILE ROUTE(ROUTE, DELETE)
%IF AFR_QTEMP = 0 %THEN  %C
      FLAG = ECTM FILE ROUTE(ROUTE, DEASSIGN)
FILE = ECTM PPS(AFR_DESC DR0, AFR_DESC DR1, TEMP ROUTE)
%IF FILE # "" %THEN %START
      SETUSE(FILE,0,0)
      DESTROY(FILE,FLAG)
      ADD PARAM(TEMP ROUTE, AFR_DESC DR0, AFR_DESC DR1,  %C
         -1, -1, AFR_AREA DESC)
      %FINISH
FILE = ECTM PPS(AFR_DESC DR0, AFR_DESC DR1, TEMP RAM)
%IF FILE # "" %THEN %START
      SETUSE(FILE,0,0)
      DESTROY(FILE,FLAG)
      ADD PARAM(TEMP RAM, AFR_DESC DR0, AFR_DESC DR1,  %C
         -1, -1, AFR_AREA DESC)
      %FINISH
AFR_QAVAILABLE = 0
AFR_ASSIGN ID = 0
%END
!
%EXTERNALINTEGERFN CTM DEASSIGN FILE(%LONGINTEGER ROUTE)
DEASSIGN FILE(ROUTE)
%RESULT = 0
%END
!
%INTEGERFN INDEX ADDR(%STRING(63) NAME)
!
! Returns the address of a real or 'imaginary' index entry - the latter
! is constructed from defaults in the case of a non-catalogued file
! regardless of whether the underlying EMAS file exists (has been
! placed) or not.
!
%SYSTEMROUTINESPEC CONNECT(%STRING(31) FILE, %INTEGER A, B, C,  %C
      %RECORDNAME R, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC DISCONNECT(%STRING(31) FILE, %INTEGERNAME FLAG)
!
%RECORD R(CONREC)
%INTEGER TYPE, MAXREC, MINREC, FLAG, QSTD
%STRING(63) FILE, ENAME
!
! Should now look up CTM catalogue.  If not found, then . . .
!
QSTD = 0
%IF NAME -> (":STD.STDAD").FILE %THEN QSTD = 1
%IF QSTD = 0 %THEN %START
      FILE = EMAS NAME(NAME, 0)
      %IF EXIST(FILE) = 0 %THEN %RESULT = 0
!
! Corresponding EMAS file does exist - invent a file description
! for it.
!
      CONNECT(FILE,0,0,0,R,FLAG)
      %IF FLAG > 0 %THEN %RESULT = 0
      TYPE = 1
      MAXREC = 1024
      MINREC = 0
      %IF R_FILETYPE = 4 %THEN %START
         MAXREC = INTEGER(R_CONAD+24)
         %IF MAXREC & X'FF' = 1 %THEN TYPE = 3
         %IF MAXREC & X'FF' = 2 %THEN TYPE = 2
         MAXREC = MAXREC >> 16
         %IF TYPE = 3 %THEN MINREC = MAXREC
         %FINISH
      DISCONNECT(FILE,FLAG)
      %FINISH
DUMMY INDEX_NAME = NAME
DUMMY INDEX_LINK = 0
DUMMY INDEX_DESC DR0 = WORD DESC ! STDM PP LENGTH
DUMMY INDEX_DESC DR1 = ADDR(DUMMY INDEX_DESC AREA(0))
MOVE(4*STDM PP LENGTH,ADDR(STDM PP(0)),DUMMY INDEX_DESC DR1)
INTEGER(ADDR(DUMMY INDEX_AREA DESC)) = STRING DESC ! 512
INTEGER(ADDR(DUMMY INDEX_AREA DESC)+4) =  %C
      ADDR(DUMMY INDEX_DESC AREA(511))
%IF QSTD = 0 %THEN %START
!
! Add the PLACEMENT to the description, and set file type etc.
!
      ITOE(ADDR(FILE)+1, LENGTH(FILE))
      %IF TYPE = 3 %THEN ADD PARAM(FILE ORGANISATION,  %C
         DUMMY INDEX_DESC DR0, DUMMY INDEX_DESC DR1,  %C
         2, 0, DUMMY INDEX_AREA DESC)
      ADD PARAM(PLACEMENT,  %C
         DUMMY INDEX_DESC DR0, DUMMY INDEX_DESC DR1,  %C
         STRING DESC ! LENGTH(FILE), ADDR(FILE) + 1,  %C
         DUMMY INDEX_AREA DESC)
      ADD PARAM(MAXIMUM RECORD SIZE,  %C
         DUMMY INDEX_DESC DR0, DUMMY INDEX_DESC DR1,  %C
         MAXREC, 0, DUMMY INDEX_AREA DESC)
      ADD PARAM(MINIMUM RECORD SIZE,  %C
         DUMMY INDEX_DESC DR0, DUMMY INDEX_DESC DR1,  %C
         MINREC, 0, DUMMY INDEX_AREA DESC)
      ADD PARAM(CURRENT LENGTH,  %C
         DUMMY INDEX_DESC DR0, DUMMY INDEX_DESC DR1,  %C
         R_DATAEND - R_DATASTART, 0, DUMMY INDEX_AREA DESC)
      ADD PARAM(ACTUAL FILE SIZE,  %C
         DUMMY INDEX_DESC DR0, DUMMY INDEX_DESC DR1,  %C
         (R_DATAEND-R_DATASTART+992)//1024, 0, DUMMY INDEX_AREA DESC)
      %FINISH  %C
%ELSE TYPE = 4
ENAME = STD ROUTE(TYPE)
ITOE(ADDR(ENAME)+1,LENGTH(ENAME))
ADD PARAM(ROUTE NAME, DUMMY INDEX_DESC DR0,  %C
      DUMMY INDEX_DESC DR1, STRING DESC ! LENGTH(ENAME),  %C
      ADDR(ENAME)+1, DUMMY INDEX_AREA DESC)
%RESULT = ADDR(DUMMY INDEX)
%END
!
%INTEGERFN EMAS DEFINE(%INTEGER CHAN, IJS)
!
! Does an EMAS define or clear on assigning a value to a JS
! variable 'ICL9CEn' - if the value is a legitimate file
! route, the channel is assigned and the AFR updated,  otherwise
! the channel is cleared.
!
%INTEGER AFR AD
%INTEGER STATUS
%STRING(31) FILE
%RECORDNAME AFR(AFRFMT)
!
DEFINFO(CHAN,FILE,STATUS)
%IF STATUS&2 # 0 %THEN CLOSEF(CHAN)
%IF STATUS & 1 # 0 %THEN CLEAR(ITOS(CHAN))
!
! Check for IJS = 0 - clear only.
!
%IF IJS = 0 %THEN %RESULT = 0
!
AFR AD = ECTM GET ROUTE(JS DESC(IJS))
%IF AFR AD = 0 %THEN %RESULT = 0
AFR == RECORD(AFR AD)
!
! OK - define file and update AFR.
!
FILE = ECTM PPS(AFR_DESC DR0,AFR_DESC DR1, PLACEMENT)
%IF FILE # "" %THEN %START
      DEFINE(ITOS(CHAN).",".FILE)
      ADD PARAM(EMAS CHANNEL, AFR_DESC DR0, AFR_DESC DR1,  %C
         CHAN, 0, AFR_AREA DESC)
      %FINISH
%RESULT = 0
!
%END
!
!-----------------------------------------------------------------------
!
! Diagnostic and checking routines.
!
%ROUTINE DUMP VAR(%INTEGER I)
!
%RECORDNAME AFR(AFRFMT)
%INTEGER AD
%SWITCH CASE(0:4)
%OWNSTRING(3)%ARRAY SAVAIL(0:1) = "NO", "YES"
%OWNSTRING(11)%ARRAY STATUS(0:1) = "PERMANENT", "TEMPORARY"
%OWNSTRING(7)%ARRAY STYPE(0:4) = "BEGIN", "INT",  %C
      "STR", "NONSTD", "FILE"
!
SELECT OUTPUT(0)
NEW LINE
PRINT STRING("JS-VAR:  ");  WRITE(I,0);  NEW LINE
PRINT STRING("  Name:   ".JS NAME(I));  NEW LINE
PRINT STRING("  Type:   ".STYPE(JS TYPE(I)));  NEW LINE
PRINT STRING(" Value:   ".HEX(INTEGER(ADDR(JS DESC(I)))).  %C
            "   ".HEX(INTEGER(ADDR(JS DESC(I))+4)))
NEW LINE
-> CASE(JS TYPE(I))
!
CASE(4):
      AFR == RECORD(ADDRESS MASK & JS DESC(I))
      PRINT STRING("    Filename:     ".AFR_NAME);  NEW LINE
      PRINT STRING("    Assign ID:    ".HEX(AFR_ASSIGN ID))
                                        NEW LINE
      PRINT STRING("    Available:    ".SAVAIL(AFR_QAVAILABLE))
                                        NEW LINE
      PRINT STRING("    Status:       ".STATUS(AFR_QTEMP))
                                        NEW LINE
      PRINT STRING(" File description:")
                                        NEW LINE
      ECTM DUMP PPAIRS(AFR_DESC DR0, AFR_DESC DR1)
      %RETURN
!
CASE(1):
      AD = ECTM GET ROUTE(JS DESC(I))
      %IF AD # 0 %THEN %START
         AFR == RECORD(AD)
         PRINT STRING("            Local name of '".AFR_NAME."'")
                                        NEW LINE
         %FINISH  %C
      %ELSE %START
         PRINT STRING("    Value:  ".ITOS(JS DESC(I)));  NEW LINE
         %FINISH
      %RETURN
!
CASE(2):
      PRINT STRING("    Value:  ".  %C
         ETOS(INTEGER(ADDR(JS DESC(I))),INTEGER(ADDR(JS DESC(I))+4)))
                                        NEW LINE
      %RETURN
!
CASE(0):
      %RETURN
!
%END
!
%EXTERNALROUTINE CTM DUMP
!
%INTEGER I, SAVE TRACE
!
ECTM ENTER("DUMP")
SAVE TRACE = ECTM TRACE
ECTM TRACE = 1
!
SELECT OUTPUT(0)
%IF JS STACK TOP <= 0 %THEN %START
      NEW LINE
      PRINT STRING("Job space empty.");  NEW LINE
      %RETURN
      %FINISH
I = JS STACK TOP
%CYCLE
      %IF I <= 0 %THEN %EXIT
      DUMP VAR(I)
      I = I - 1
      %REPEAT
ECTM TRACE = SAVE TRACE
%END
!
%INTEGERFN PARAM ERR(%INTEGER AD, TYPE, IPAR)
!
SELECT OUTPUT(0)
PRINT STRING("CTM parameter error - parameter");  WRITE(IPAR,0)
PRINT STRING(" of routine ".CTM ROUTINE NAME);  NEW LINE
PRINT STRING("Value is ".HEX(INTEGER(AD)))
%IF TYPE = 3 %THEN PRINT STRING("   ".HEX(INTEGER(AD+4)))
NEW LINES(2)
%RESULT = 9001
%END
!
%INTEGERFN CHECK DESCRIPTOR(%INTEGER DR0, DR1, TYPE, ACC, IPAR)
!
! CHECKS A GIVEN DESCRIPTOR FOR VALIDITY (ACCORDING TO TYPE) AND
! ACCESSABILITY (READ OR WRITE).  RETURNS 0 IF OK, > 0 FOR ERROR,
! -1 FOR NIL DESCRIPTOR.
!
%INTEGER DESC, IERR
%OWNINTEGERARRAY TDESC(1:5) =  %C
                  X'58000000',
                  X'28000000',
                  X'30000000',
                  X'38000000',
                  X'00000000'
%OWNSTRING(15)%ARRAY TSTRING(0:5) =  %C
                  "nil",
                  "string",
                  "word",
                  "long word",
                  "long long word",
                  "code"
%OWNSTRING(31)%ARRAY SERR(0:4) =  %C
                  "Must be nil descriptor",
                  "Invalid descriptor format",
                  "No write access",
                  "No read access",
                  "Invalid address"
!
%IF DR0 = -1 %AND DR1 = -1 %THEN %RESULT = -1
%IF TYPE = 0 %THEN IERR = 0 %AND -> ERR
%IF TYPE = 5 %THEN %RESULT = 0;  ! Pro tem
!
DESC = DR0 & X'FF000000'
%IF DESC # TDESC(TYPE) %THEN %START
      %UNLESS TYPE = 1 %THEN IERR = 1 %AND -> ERR
      %UNLESS DESC = X'18000000' %THEN IERR = 1 %AND -> ERR
      %FINISH
!
*LDTB_   DR0
*LDA_    DR1
*VAL_    (%LNB+1)
*JCC_    8,<OK>
*JCC_    4,<NO WRITE>
*JCC_    2,<NO READ>
*JCC_    1,<INVALID>
!
OK:      %RESULT = 0
!
NO WRITE:
         %IF ACC > 1 %THEN IERR = 2 %AND -> ERR
         %RESULT = 0
!
NO READ:
         %IF ACC # 2 %THEN IERR = 3 %AND -> ERR
         %RESULT = 0
!
INVALID:
         IERR = 4
         -> ERR
!
ERR:
SELECT OUTPUT(0)
PRINT STRING("CTM descriptor error - ".SERR(IERR))
NEW LINE
PRINT STRING("Parameter");  WRITE(IPAR,0)
PRINT STRING(" of routine ".CTM ROUTINE NAME)
PRINT STRING(" should be a ".TSTRING(TYPE))
PRINT STRING(" descriptor");  NEW LINE
PRINT STRING("Descriptor value is ".HEX(DR0)."  ".HEX(DR1))
NEW LINES(2)
%RESULT = 9001
%END
!
%INTEGERFN CHECK ROUTE(%LONGINTEGER ROUTE, %INTEGER IPAR)
!
! Checks a given file route for validity, using ASSIGN ID to
! check that the file is still assigned.
!
%RECORDNAME AFR(AFRFMT)
%INTEGER R0, R1
!
R0 = INTEGER(ADDR(ROUTE))
R1 = INTEGER(ADDR(ROUTE)+4)
!
! Warning result for zero file route.
!
%IF R0 = 0 %AND R1 = 0 %THEN %RESULT = -1
!
! Check second half of route value - JS stack index of assigned
! file 'variable'.
!
%UNLESS 0 < R1 <= JS STACK TOP %THEN -> ERR1
%UNLESS JS TYPE(R1) = 4 %THEN -> ERR1
!
! Pick up AFR record - pointed at by 'descriptor' field of JS stack
! entry.
!
R1 = ADDRESS MASK & JS DESC(R1)
%UNLESS ADDR(JS(1)) <= R1 < ADDR(JS(JS FREE)) %THEN -> ERR1
AFR == RECORD(R1)
!
! Check the 'assign ID' - ensures that the file has not been de-
! assigned and the stack entry reused.
!
%UNLESS AFR_ASSIGN ID = R0 %THEN -> ERR2
%RESULT = 0
!
ERR1:
SELECT OUTPUT(0)
PRINT STRING("CTM file route error - invalid address")
-> ERR
!
ERR2:
SELECT OUTPUT(0)
PRINT STRING("CTM file route error - file de-assigned")
-> ERR
!
ERR:
NEW LINE
PRINT STRING("Parameter ")
WRITE(IPAR,0);  PRINT STRING(" of routine ".CTM ROUTINE NAME)
NEW LINE
PRINT STRING("Value is ".HEX(R0)."  ".HEX(R1));  NEW LINES(2)
%RESULT = 9001
%END
!
%INTEGERFN MAX(%INTEGER I, J)
%IF I > J %THEN %RESULT = I %ELSE %RESULT = J
%END
!
!-----------------------------------------------------------------------
!
! Top-level CTM interface routines.  Generally, each routine first
! checks and, if necessary, initialises the CTM.  If checking is
! called for, validates all supplied parameters as far as possible,
! converts parameters to EMAS/Imp forms (e.g. strings rather than
! string descriptors), calls corresponding second-level routine.
!
%EXTERNALINTEGERFN CTM JS WRITE(%INTEGER NAME DR0, NAME DR1,  %C
      INT DR0, INT DR1, STR DR0, STR DR1, NOT RANGE DR0, NOT RANGE DR1)
%INTEGER RC
!
! DECLARES NAMED JS VAR, IF NECESSARY, SAVES VALUE.  IF NAME IS OF
! THE FORM 'ICL9CE<N>', WHERE 'N' IS A CHANNEL NUMBER, ALSO DOES AN
! EMAS DEFINE OR CLEAR, AS APPROPRIATE.
!
%STRING(31) NAME
%LONGINTEGER DESC
%INTEGER AD, I, CHAN, FLAG, IRESP
!
ECTM ENTER("JS WRITE")
!
%IF ECTM CHECK = 1 %THEN %START
      I = MAX(0,CHECK DESCRIPTOR(NAME DR0,NAME DR1,1,1,1))
      I = MAX(I,CHECK DESCRIPTOR(INT DR0,INT DR1,3,1,2))
      I = MAX(I,CHECK DESCRIPTOR(STR DR0,STR DR1,1,1,3))
      I = MAX(I,CHECK DESCRIPTOR(NOT RANGE DR0,NOT RANGE DR1,0,1,4))
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
! Convert name to an Imp string, for convenience, and look up in stack.
!
NAME = ETON(NAME DR0,NAME DR1)
I = JS STACK TOP
IRESP = 0;  ! Stays zero if JS var found
%CYCLE
      %IF JS TYPE(I) # 4 %AND NAME = JS NAME(I) %THEN -> FOUND
      I = I - 1;  %IF I = 0 %THEN %EXIT
      %REPEAT
IRESP = -9110
!
! Not there - declare a new variable, if there's enough room.
!
I = JS STACK TOP + 1
%IF I > MAXIMUM JS VARS %THEN RC = 9001 %AND -> RETURN
JS STACK TOP = I
JS NAME(I) = NAME
JS TYPE(I) = 0
!
FOUND:
!
%IF INT DR0 = NIL %THEN -> NOT INT
%IF STR DR0 # NIL %THEN -> DESC ERR
%IF JS TYPE(I) = 0 %THEN JS TYPE(I) = 1
%IF JS TYPE(I) # 1 %THEN -> TYPE ERR
JS DESC(I) = LONGINTEGER(INT DR1)
CHAN = CE CHAN(NAME)
FLAG = 0
%IF CHAN # 0 %THEN FLAG = EMAS DEFINE(CHAN,I)
%IF FLAG > 0 %THEN IRESP = FLAG
RC = IRESP %AND -> RETURN
!
NOT INT:
%IF STR DR0 = NIL %THEN -> DESC ERR
!
! Construct 'destination' descriptor to JS area.
!
STR DR0 = STR DR0 & LENGTH MASK
%IF JS TYPE(I) = 0 %THEN %START
      JS TYPE(I) = 2
      AD = ADDR(JS(JS FREE))
      *LDTB_   STRING DESC
      *LDB_    STR DR0
      *LDA_    AD
      *STD_    DESC
      JS DESC(I) = DESC
      JS FREE = JS FREE + 256
      %IF JS FREE > SIZE OF JS AREA %THEN EXTEND
      %FINISH %ELSE DESC = JS DESC(I)
!
%IF JS TYPE(I) # 2 %THEN -> TYPE ERR
*LSS_    STR DR1
*LUH_    DESC
*LD_     DESC
*MV_     %L=%DR
RC = IRESP %AND -> RETURN
!
DESC ERR:
RC = 9000 %AND -> RETURN;  ! DESCRIPTOR ERROR
!
TYPE ERR:
RC = 9002 %AND -> RETURN;  ! WRONG JS-VAR TYPE
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%EXTERNALINTEGERFN CTM JS DECLARE(%INTEGER NAME DR0, NAME DR1,  %C
      INT DR0, INT DR1, STR DR0, STR DR1, NOT RANGE DR0, NOT RANGE DR1)
%INTEGER RC
!
! Scans down stack for named variable - if a JS BEGIN flag is
! found first, then a new variable is declared.  If the variable is
! found first, then the value is reset.
!
%STRING(31) NAME
%LONGINTEGER DESC
%INTEGER AD, I, CHAN, FLAG, IRESP
!
ECTM ENTER("JS DECLARE")
!
%IF ECTM CHECK = 1 %THEN %START
      I = MAX(0,CHECK DESCRIPTOR(NAME DR0,NAME DR1,1,1,1))
      I = MAX(I,CHECK DESCRIPTOR(INT DR0,INT DR1,3,1,2))
      I = MAX(I,CHECK DESCRIPTOR(STR DR0,STR DR1,1,1,3))
      I = MAX(I,CHECK DESCRIPTOR(NOT RANGE DR0,NOT RANGE DR1,0,1,4))
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
! Convert name to an Imp string, for convenience, and look up in stack.
! For JS DECLARE, we only search down the stack as far as the most
! recent JS BEGIN flag.
!
NAME = ETON(NAME DR0,NAME DR1)
I = JS STACK TOP
IRESP = -9111;  ! Stays set if JS var already exists
%CYCLE
      %IF JS TYPE(I) = 0 %THEN %EXIT
      %IF JS TYPE(I) # 4 %AND NAME = JS NAME(I) %THEN -> FOUND
      I = I - 1;  %IF I = 0 %THEN %EXIT
      %REPEAT
IRESP = 0
!
! Not there - declare a new variable, if there's enough room.
!
I = JS STACK TOP + 1
%IF I > MAXIMUM JS VARS %THEN RC = 9001 %AND -> RETURN
JS STACK TOP = I
JS NAME(I) = NAME
JS TYPE(I) = 0
!
FOUND:
!
%IF INT DR0 = NIL %THEN -> NOT INT
%IF STR DR0 # NIL %THEN -> DESC ERR
%IF JS TYPE(I) = 0 %THEN JS TYPE(I) = 1
%IF JS TYPE(I) # 1 %THEN -> TYPE ERR
JS DESC(I) = LONGINTEGER(INT DR1)
CHAN = CE CHAN(NAME)
FLAG = 0
%IF CHAN # 0 %THEN FLAG = EMAS DEFINE(CHAN,I)
%IF FLAG > 0 %THEN IRESP = FLAG
RC = IRESP %AND -> RETURN
!
NOT INT:
%IF STR DR0 = NIL %THEN -> DESC ERR
!
! Construct 'destination' descriptor to JS area.
!
STR DR0 = STR DR0 & LENGTH MASK
%IF JS TYPE(I) = 0 %THEN %START
      JS TYPE(I) = 2
      AD = ADDR(JS(JS FREE))
      *LDTB_   STRING DESC
      *LDB_    STR DR0
      *LDA_    AD
      *STD_    DESC
      JS DESC(I) = DESC
      JS FREE = JS FREE + 256
      %IF JS FREE > SIZE OF JS AREA %THEN EXTEND
      %FINISH %ELSE DESC = JS DESC(I)
%IF JS TYPE(I) # 2 %THEN -> TYPE ERR
*LSS_    STR DR1
*LUH_    DESC
*LD_     DESC
*MV_     %L=%DR
RC = IRESP %AND -> RETURN
!
DESC ERR:
RC = 9000 %AND -> RETURN;  ! DESCRIPTOR ERROR
!
TYPE ERR:
RC = 9002 %AND -> RETURN;  ! WRONG JS-VAR TYPE
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%EXTERNALINTEGERFN CTM JS READ(%INTEGER NAME DR0, NAME DR1,  %C
      INT DR0, INT DR1, STR DR0, STR DR1, NOT RANGE DR0, NOT RANGE DR1)
%INTEGER RC
!
! READS JS-VAR SET UP BY 'CTM JS WRITE'
!
%EXTERNALINTEGERFNSPEC CTM ASSIGN FILE(  %C
      %INTEGER ROUTE DR0, ROUTE DR1,  %C
      LOCAL DR0, LOCAL DR1,  FULL DR0, FULL DR1,  %C
      ACCESS TYPE, LOCK, NOT RANGE A,  %C
      NOTB DR0, NOTB DR1,  %C
      START SECT, END SECT,  %LONGINTEGER EXISTING ROUTE,  %C
      NOT RANGE C,  %INTEGER NOT D DR0, NOT D DR1, NOT E DR0, NOT E DR1)
%EXTERNALINTEGERFNSPEC CTM MAKE FILE(%INTEGER ROUTE DR0, ROUTE DR1,  %C
      LOCAL DR0, LOCAL DR1, FULL DR0, FULL DR1,  %C
      %LONGINTEGER DESC ROUTE, %INTEGER LOC DESC DR0, LOC DESC DR1,  %C
      FULL DESC DR0, FULL DESC DR1, INIT SIZE, MAX SIZE)
!
%STRING(31) NAME, FILE
%LONGINTEGER DESC
%INTEGER I, CHAN, STATUS, FLAG
!
ECTM ENTER("JS READ")
ECTM REPORT STRING("JS variable:", NAME DR0, NAME DR1)
!
%IF ECTM CHECK = 1 %THEN %START
      I = MAX(0,CHECK DESCRIPTOR(NAME DR0,NAME DR1,1,1,1))
      I = MAX(I,CHECK DESCRIPTOR(INT DR0,INT DR1,3,2,2))
      I = MAX(I,CHECK DESCRIPTOR(STR DR0,STR DR1,1,2,3))
      I = MAX(I,CHECK DESCRIPTOR(NOT RANGE DR0,NOT RANGE DR1,0,2,4))
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
! Look up name in JS stack.
!
NAME = ETON(NAME DR0,NAME DR1)
I = JS STACK TOP
%CYCLE
      %IF JS TYPE(I) # 4 %AND NAME = JS NAME(I) %THEN -> FOUND
      I = I - 1;  %IF I = 0 %THEN %EXIT
      %REPEAT
CHAN = CE CHAN(NAME)
%IF CHAN > 0 %THEN %START
!
! The JS variable name is of the form 'ICL9CEn', the variable is not
! defined, but the corresponding EMAS channel may be - if so, assign
! the file
!
      DEFINFO(CHAN,FILE,STATUS)
      %IF STATUS > 0 %THEN %START
         ITOE(ADDR(FILE)+1,LENGTH(FILE))
         FLAG = CTM ASSIGN FILE(NIL, NIL, NAME DR0, NAME DR1,  %C
            STRING DESC ! LENGTH(FILE), ADDR(FILE) + 1,  %C
            2,0,0,NIL,NIL,0,0,0,0,NIL,NIL,NIL,NIL)
         %IF FLAG = 9114 %THEN  %C
            FLAG = CTM MAKE FILE(NIL, NIL, NAME DR0, NAME DR1,  %C
               STRING DESC ! LENGTH(FILE), ADDR(FILE) + 1,  %C
               0,NIL,NIL,NIL,NIL,0,0)
         %IF FLAG > 0 %THEN -> FOUND
         FLAG = CTM JS READ(NAME DR0, NAME DR1, INT DR0, INT DR1,  %C
            NIL, NIL, NIL, NIL)
         %FINISH
      %FINISH
!
FOUND:
!
%IF INT DR0 = NIL %THEN -> NOT INT
%IF STR DR0 # NIL %THEN -> DESC ERR
%IF I # 0 %THEN %START
      %IF JS TYPE(I) # 1 %THEN -> TYPE ERR
      LONGINTEGER(INT DR1) = JS DESC(I)
      %FINISH  %C
%ELSE LONGINTEGER(INT DR1) = 0
ECTM REPORT LONG("Integer value:", INT DR0, INT DR1)
RC = 0
%IF I = 0 %THEN RC = 9087
-> RETURN
!
NOT INT:
%IF STR DR0 = NIL %THEN -> DESC ERR
STR DR0 = STR DR0 & LENGTH MASK
%IF I # 0 %THEN %START
      %IF JS TYPE(I) # 2 %THEN -> TYPE ERR
      DESC = JS DESC(I)
      %FINISH  %C
%ELSE %START
      *LDTB_   STRING DESC
      *LDA_    0
      *STD_    DESC
      %FINISH
*LSD_    DESC
*LDTB_   STRING DESC
*LDB_    STR DR0
*LDA_    STR DR1
*MV_     %L=%DR,0,64
ECTM REPORT STRING("String value:", STR DR0, STR DR1)
RC = 0
%IF I = 0 %THEN RC = -9087
-> RETURN
!
DESC ERR:
RC = 9000 %AND -> RETURN;  ! DESCRIPTOR ERROR
!
TYPE ERR:
RC = 9002 %AND -> RETURN;  ! WRONG JS-VAR TYPE
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%EXTERNALINTEGERFN CTM JS BEGIN(%LONGINTEGER DUMMY)
%INTEGER RC
!
! Creates JS 'variable' with name '***BEGIN***' and address
! pointing at the current top of the user GLA (for use by the
! loader, to unload code loaded within the JS block).
!
ECTM ENTER("JS BEGIN")
!
JS STACK TOP = JS STACK TOP + 1
%IF JS STACK TOP > MAXIMUM JS VARS %THEN RC = 9001 %AND -> RETURN
JS NAME(JS STACK TOP) = "***BEGIN***"
JS DESC(JS STACK TOP) = COMREG(44)
JS TYPE(JS STACK TOP) = 0
RC = 0 %AND -> RETURN
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%EXTERNALINTEGERFN CTM JS END(%LONGINTEGER DUMMY)
%INTEGER RC
!
%EXTERNALSTRINGFNSPEC ETOS(%LONGINTEGER DESC)
!
%INTEGER I, J, FLAG
%LONGINTEGER ROUTE
%STRING(31) FILE
%RECORDNAME AFR(AFRFMT)
!
ECTM ENTER("JS END")
!
! First have a quick look for a corresponding 'BEGIN'.
!
I = JS STACK TOP
%CYCLE
      %IF JS TYPE(I) = 0 %AND JS NAME(I) = "***BEGIN***" %THEN %EXIT
      I = I - 1
      %IF I = 0 %THEN RC = 9005 %AND -> RETURN
      %REPEAT
!
J = JS STACK TOP
%CYCLE
      %IF I = J %THEN %EXIT
      %IF JS TYPE(J) = 4 %THEN %START
!
! ASSIGNED FILE POINTER - DE-ASSIGN THE FILE
!
         AFR == RECORD(JS DESC(J))
         INTEGER(ADDR(ROUTE)) = AFR_ASSIGN ID
         INTEGER(ADDR(ROUTE)+4) = J
         DEASSIGN FILE(ROUTE)
         %FINISH
      %IF JS TYPE(J) = 6 %THEN %START
!
! Temporary work area - destroy it.
!
         FILE = ETOS(JS DESC(J))
         %IF FILE # "" %THEN %START
            SETUSE(FILE,0,0)
            DESTROY(FILE,FLAG)
            %FINISH
         %FINISH
      J = J - 1
      %REPEAT
!
UNLOAD(JS DESC(I))
JS STACK TOP = I - 1
%CYCLE
      I = I - 1
      %IF I <= 0 %THEN %EXIT
      %IF JS TYPE(I) = 4 %THEN %START
         AFR == RECORD(JS DESC(I))
         AFR_QAVAILABLE = 1
         %FINISH
      %REPEAT
RC = 0 %AND -> RETURN
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%INTEGERFN READ DESCRIPTION(%LONGINTEGER ROUTE,  %C
      %INTEGER LOC DR0, LOC DR1, FULL DR0, FULL DR1,  %C
      %INTEGERNAME PP DR0, PP DR1)
!
%EXTERNALINTEGERFNSPEC CTM ASSIGN FILE(  %C
      %INTEGER ROUTE DR0, ROUTE DR1,  %C
      LOCAL DR0, LOCAL DR1,  FULL DR0, FULL DR1,  %C
      ACCESS TYPE, LOCK, NOT RANGE A,  %C
      NOTB DR0, NOTB DR1,  %C
      START SECT, END SECT,  %LONGINTEGER EXISTING ROUTE,  %C
      NOT RANGE C,  %INTEGER NOT D DR0, NOT D DR1, NOT E DR0, NOT E DR1)
!
%INTEGER FLAG, AFR AD
%RECORDNAME AFR(AFRFMT)
!
%IF ROUTE = 0 %THEN %START
      %IF LOC DR0 = NIL %THEN %START
         FLAG = CTM ASSIGN FILE(LONG DESC ! 1, ADDR(ROUTE),  %C
            NIL, NIL, FULL DR0, FULL DR1, 1, 0, 0, NIL, NIL,  %C
            0, 0, 0, 0, NIL, NIL, NIL, NIL)
         %IF FLAG > 0 %THEN %RESULT = FLAG
         %FINISH  %C
      %ELSE %START
         FLAG = CTM JS READ(LOC DR0, LOC DR1,  %C
            LONG DESC ! 1, ADDR(ROUTE), NIL, NIL, NIL, NIL)
         %IF FLAG > 0 %THEN %RESULT = FLAG
         %IF ROUTE = 0 %THEN %RESULT = 9114
         %FINISH
      %FINISH
!
AFR AD = ECTM GET ROUTE(ROUTE)
%IF AFR AD = 0 %THEN %RESULT = 9114
AFR == RECORD(AFR AD)
!
MOVE(4*(AFR_DESC DR0 & LENGTH MASK),AFR_DESC DR1,PP DR1)
PP DR0 = AFR_DESC DR0
%RESULT = 0
%END
!
%INTEGERFN STACK DESCRIPTION(%INTEGER ROUTE DR1,  %C
      PP DR0, PP DR1, %INTEGERNAME AFRAD)
!
%INTEGER DESC LENGTH, AREA LENGTH, LEN, AREA ADDR
%INTEGER NPP, I
%INTEGERARRAYFORMAT PP FORM(1:3,1:100)
%INTEGERARRAYNAME PP
%RECORDNAME AFR(AFRFMT)
!
JS STACK TOP = JS STACK TOP + 1
%IF JS STACK TOP > MAXIMUM JS VARS %THEN %RESULT = 9001
JS NAME(JS STACK TOP) = ".FILE"
JS TYPE(JS STACK TOP) = 4
AFRAD = ADDR(JS(JS FREE))
JS DESC(JS STACK TOP) = AFRAD
JS FREE = JS FREE + 1024 + 128
%IF JS FREE > SIZE OF JS AREA %THEN EXTEND
!
AFR == RECORD(AFRAD)
AFR_QAVAILABLE = 0
AFR_QTEMP = 1
AFR_ROUTE = 0
AFR_ACCESS1 = 0
DESC LENGTH = PP DR0 & LENGTH MASK
AFR_DESC DR0 = WORD DESC ! DESC LENGTH
AFR_DESC DR1 = ADDR(AFR_DESC AREA(0))
MOVE(DESC LENGTH*4,PP DR1,AFR_DESC DR1)
AREA ADDR = ADDR(AFR_DESC AREA(511))
AREA LENGTH = 512
NPP = DESC LENGTH//3
PP == ARRAY(ADDR(AFR_DESC AREA(0)),PP FORM)
%IF NPP > 0 %THEN %START
   %CYCLE I = 1, 1, NPP
         %IF PP(2,I) >> 24 = X'58' %THEN %START
            LEN = PP(2,I) & LENGTH MASK
            MOVE(LEN,PP(3,I),AREA ADDR)
            PP(3,I) = AREA ADDR
            AREA ADDR = AREA ADDR + LEN
            AREA LENGTH = AREA LENGTH - LEN
            %FINISH
         %REPEAT
      %FINISH
INTEGER(ADDR(AFR_AREA DESC)) = STRING DESC ! AREA LENGTH
INTEGER(ADDR(AFR_AREA DESC)+4) = AREA ADDR
ASSIGN ID = ASSIGN ID + 1
AFR_ASSIGN ID = ASSIGN ID
!
INTEGER(ROUTE DR1) = ASSIGN ID
INTEGER(ROUTE DR1 + 4) = JS STACK TOP
!
%RESULT = 0
%END
!
%EXTERNALINTEGERFN CTM ASSIGN FILE(%INTEGER ROUTE DR0, ROUTE DR1,  %C
      LOCAL DR0, LOCAL DR1,  FULL DR0, FULL DR1,  %C
      ACCESS, LOCK, NOT RANGE A,  %C
      NOTB DR0, NOTB DR1,  %C
      START SECT, END SECT,  %LONGINTEGER EXISTING ROUTE,  %C
      NOT RANGE C,  %INTEGER NOT D DR0, NOT D DR1, NOT E DR0, NOT E DR1)
%INTEGER RC
!
%LONGINTEGER ROUTE
%STRING(31) ROUTE FILE, TEMP
%INTEGER I, ACC, AD, QLOCAL, FLAG, AFRAD
%STRING(63) NAME
%RECORDNAME INDEX(INDEXFMT)
%RECORDNAME AFR(AFRFMT)
!
ECTM ENTER("ASSIGN FILE")
!
%IF ECTM CHECK = 1 %THEN %START
      I = MAX(0,CHECK DESCRIPTOR(ROUTE DR0,ROUTE DR1,3,2,1))
      I = MAX(I,CHECK DESCRIPTOR(LOCAL DR0,LOCAL DR1,1,1,2))
      I = MAX(I,CHECK DESCRIPTOR(FULL DR0,FULL DR1,1,1,3))
      %IF NOT RANGE A # 0 %THEN  %C
         I = MAX(I,PARAM ERR(ADDR(NOT RANGE A),1,6))
      I = MAX(I,CHECK DESCRIPTOR(NOTB DR0,NOTB DR1,0,1,7))
      %IF START SECT # 0 %THEN  %C
         I = MAX(I,PARAM ERR(ADDR(START SECT),1,8))
      %IF END SECT # START SECT %THEN  %C
         I = MAX(I,PARAM ERR(ADDR(END SECT),1,9))
      I = MAX(I,CHECK ROUTE(EXISTING ROUTE,10))
      %IF NOT RANGE C # 0 %THEN  %C
         I = MAX(I,PARAM ERR(ADDR(NOT RANGE C),2,11))
      I = MAX(I,CHECK DESCRIPTOR(NOTD DR0,NOTD DR1,0,1,12))
      I = MAX(I,CHECK DESCRIPTOR(NOTE DR0,NOTE DR1,0,1,13))
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
%IF ROUTE DR0 = NIL %THEN %START
      %IF LOCAL DR0 = NIL %THEN -> PARAM ERR
      QLOCAL = 1
      ROUTE DR0 = LONG DESC ! 1
      ROUTE DR1 = ADDR(ROUTE)
      ROUTE = 0
      %FINISH  %C
%ELSE QLOCAL = 0
!
%IF FULL DR0 = NIL %THEN -> PARAM ERR
!
ACCESS = ACCESS & 7
LOCK = LOCK & 3
ACC = 1
NAME = FULL NAME(FULL DR0, FULL DR1)
%IF ECTMTRACE # 0 %THEN %START
      SELECT OUTPUT(0)
      PRINT STRING("FULL EMAS FILE NAME: ")
      PRINT STRING(NAME)
      NEW LINE
      %FINISH
!
! See if the file has already been assigned.
!
I = JS STACK TOP
%CYCLE
      %IF I = 0 %THEN %EXIT
      %IF JS TYPE(I) = 4 %THEN %START
         AFRAD = JS DESC(I) & ADDRESS MASK
         %IF AFRAD > 0 %THEN %START
            AFR == RECORD(AFRAD)
            %IF AFR_NAME = NAME %THEN %START
               INTEGER(ROUTE DR1) = AFR_ASSIGN ID
               INTEGER(ROUTE DR1+4) = I
               -> FOUND
               %FINISH
            %FINISH
         %FINISH
      I = I - 1
      %REPEAT
!
! No - stack file description
!
AD = INDEX ADDR(NAME)
%IF AD = 0 %THEN RC = 9114 %AND -> RETURN
INDEX == RECORD(AD)
FLAG = STACK DESCRIPTION(ROUTE DR1,  %C
      INDEX_DESC DR0, INDEX_DESC DR1, AFRAD)
%IF FLAG > 0 %THEN RC = FLAG %AND -> RETURN
AFR == RECORD(AFRAD)
AFR_NAME = NAME
!
! Check whether the description includes a 'route' filename, else
! choose an appropriate one.
!
ROUTE FILE = ECTM PPS(AFR_DESC DR0, AFR_DESC DR1, ROUTE NAME)
%IF ROUTE FILE = "" %THEN ROUTE FILE = DEFAULT ROUTE
!
! Load the 'route' file, if necessary, pick up the entry descriptor,
! call the route entry to assign this file.
!
AFR_ROUTE = ROUTE DESCRIPTOR(ROUTE FILE, TEMP)
%IF AFR_ROUTE = 0 %THEN RC = 9200 %AND -> RETURN
ITOE(ADDR(TEMP)+1,LENGTH(TEMP))
ADD PARAM(TEMP ROUTE, AFR_DESC DR0, AFR_DESC DR1,  %C
      STRING DESC ! LENGTH(TEMP), ADDR(TEMP)+1, AFR_AREA DESC)
!
FOUND:
ADD PARAM(ACCESS TYPE, AFR_DESC DR0, AFR_DESC DR1,  %C
      ACCESS, 0, DUMMY)
ADD PARAM(ACCESS LOCK, AFR_DESC DR0, AFR_DESC DR1,  %C
      LOCK, 0, DUMMY)
FLAG = ECTM FILE ROUTE(LONGINTEGER(ROUTE DR1), ASSIGN)
%IF FLAG > 0 %THEN RC = FLAG %AND -> RETURN
AFR_QAVAILABLE = 1
AFR_QTEMP = 0
!
FLAG = 0
%IF QLOCAL = 1  %THEN FLAG = CTM JS DECLARE(  %C
      LOCAL DR0, LOCAL DR1, ROUTE DR0, ROUTE DR1,  %C
      NIL, NIL, NIL, NIL)
%IF FLAG < 0 %THEN FLAG = 0
RC = FLAG %AND -> RETURN
!
PARAM ERR:
RC = 9005 %AND -> RETURN
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%INTEGERFN NEW FILE(%INTEGER ROUTE DR0, ROUTE DR1,  %C
      LOCAL DR0, LOCAL DR1, FULL DR0, FULL DR1,  %C
      %LONGINTEGER DESC ROUTE, %INTEGER LOC DESC DR0, LOC DESC DR1,  %C
      FULL DESC DR0, FULL DESC DR1, NEW DR0, NEW DR1, QTEMP, QPLACE)
!
! DOES ALL THE HARD WORK FOR FORM FILE, MAKE FILE, WORK FILE ETC.
!
%INTEGERARRAY PP(1:3,1:100)
%INTEGER I, QLOCAL, PP DR0, PP DR1, AFRAD
%STRING(63) NAME, FILE, EFILE, ROUTE FILE, TEMP
%LONGINTEGER ROUTE
%RECORDNAME AFR(AFRFMT)
!
%IF ROUTE DR0 = NIL %THEN %START
      %IF LOCAL DR0 = NIL %THEN -> PARAM ERR
      QLOCAL = 1
      ROUTE DR0 = LONG DESC ! 1
      ROUTE DR1 = ADDR(ROUTE)
      %FINISH  %C
%ELSE QLOCAL = 0
!
! Invent an appropriate EMAS filename, derived from the given
! 'terminal name' if possible, otherwise a CTM# name.
!
NAME = ""
%IF FULL DR0 # NIL %THEN %START
      NAME = FULL NAME(FULL DR0, FULL DR1)
      %IF INDEX ADDR(NAME) # 0 %THEN NAME = NEXT NAME(NAME)
      FILE = EMAS NAME(NAME,1)
      EFILE = FILE
      ITOE(ADDR(EFILE)+1,LENGTH(EFILE))
      %FINISH
!
! Read the given 'old' description from the stack or catalogue.
!
PP DR0 = WORD DESC
PP DR1 = ADDR(PP(1,1))
I = READ DESCRIPTION(DESC ROUTE, LOC DESC DR0, LOC DESC DR1,  %C
      FULL DESC DR0, FULL DESC DR1, PP DR0, PP DR1)
%IF I > 0 %THEN %RESULT = I
!
! Plug in the EMAS filename.
!
%IF NAME # "" %THEN  %C
      ADD PARAM(PLACEMENT, PP DR0, PP DR1,  %C
      STRING DESC ! LENGTH(EFILE), ADDR(EFILE) + 1, DUMMY)
!
%UNLESS NEW DR0 = NIL %THEN %START
!
! Add any 'new' description parameters to the 'old' description.
!
      I = MERGE PP(NEW DR0, NEW DR1, PP DR0, PP DR1)
      %IF I > 0 %THEN %RESULT = I
      %FINISH
!
I = STACK DESCRIPTION(ROUTE DR1, PP DR0, PP DR1, AFRAD)
%IF I > 0 %THEN %RESULT = I
!
! Update the stack entry.
!
AFR == RECORD(AFRAD)
AFR_NAME = NAME
AFR_QTEMP = QTEMP
!
! Check whether the description includes a 'route' filename, else
! choose an appropriate one.
!
%IF QPLACE = 1 %THEN %START
      ROUTE FILE = ECTM PPS(AFR_DESC DR0, AFR_DESC DR1, ROUTE NAME)
      %IF ROUTE FILE = "" %THEN ROUTE FILE = DEFAULT ROUTE
!
! Load the 'route' file, if necessary, pick up the entry descriptor,
! call the route entry to create this file.
!
      AFR_ROUTE = ROUTE DESCRIPTOR(ROUTE FILE, TEMP)
      %IF AFR_ROUTE = 0 %THEN %RESULT = 9200
      ITOE(ADDR(TEMP)+1,LENGTH(TEMP))
      ADD PARAM(TEMP ROUTE, AFR_DESC DR0, AFR_DESC DR1,  %C
         STRING DESC ! LENGTH(TEMP), ADDR(TEMP)+1, AFR_AREA DESC)
      I = ECTM FILE ROUTE(LONGINTEGER(ROUTE DR1), CREATE)
      %IF I > 0 %THEN %RESULT = I
      %FINISH
!
%IF QLOCAL = 0 %THEN %RESULT = 0
%RESULT = CTM JS DECLARE(LOCAL DR0,LOCAL DR1,  %C
      ROUTE DR0,ROUTE DR1,NIL,NIL,NIL,NIL)
!
PARAM ERR:
%RESULT = 9005
!
%END
!
%EXTERNALINTEGERFN CTM MAKE FILE(%INTEGER ROUTE DR0, ROUTE DR1,  %C
      LOCAL DR0, LOCAL DR1, FULL DR0, FULL DR1,  %C
      %LONGINTEGER DESC ROUTE, %INTEGER LOC DESC DR0, LOC DESC DR1,  %C
      FULL DESC DR0, FULL DESC DR1, INIT SIZE, MAX SIZE)
%INTEGER RC
!
%INTEGERARRAY PP(1:3,1:3)
%INTEGER NEW DR0, NEW DR1
%INTEGER I
!
ECTM ENTER("MAKE FILE")
!
%IF ECTM CHECK = 1 %THEN %START
      I = MAX(0,CHECK DESCRIPTOR(ROUTE DR0,ROUTE DR1,3,2,1))
      I = MAX(I,CHECK DESCRIPTOR(LOCAL DR0,LOCAL DR1,1,1,2))
      I = MAX(I,CHECK DESCRIPTOR(FULL DR0,FULL DR1,1,1,3))
      I = MAX(I,CHECK ROUTE(DESC ROUTE,4))
      I = MAX(I,CHECK DESCRIPTOR(LOC DESC DR0,LOC DESC DR1,1,1,5))
      I = MAX(I,CHECK DESCRIPTOR(FULL DESC DR0,FULL DESC DR1,1,1,6))
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
NEW DR0 = WORD DESC
NEW DR1 = ADDR(PP(1,1))
%UNLESS MAX SIZE = -1 %THEN  %C
   ADD PARAM(MAXIMUM FILE SIZE, NEW DR0, NEW DR1, MAX SIZE, 0, DUMMY)
%UNLESS INIT SIZE = -1 %THEN  %C
   ADD PARAM(INITIAL FILE SIZE, NEW DR0, NEW DR1, INIT SIZE, 0, DUMMY)
ADD PARAM(ACCESS TYPE,       NEW DR0, NEW DR1, 7, 0, DUMMY)
!
RC = NEW FILE(ROUTE DR0, ROUTE DR1, LOCAL DR0, LOCAL DR1,  %C
      FULL DR0, FULL DR1, DESC ROUTE, LOC DESC DR0, LOC DESC DR1,  %C
      FULL DESC DR0, FULL DESC DR1, NEW DR0, NEW DR1, 0, 1)
RETURN:
ECTM RESULT(RC)
%RESULT = RC
!
%END
!
%EXTERNALINTEGERFN CTM FORM FILE(%INTEGER ROUTE DR0, ROUTE DR1,  %C
      LOCAL DR0, LOCAL DR1, FULL DR0, FULL DR1,  %C
      %LONGINTEGER DESC ROUTE, %INTEGER LOC DESC DR0, LOC DESC DR1,  %C
      FULL DESC DR0, FULL DESC DR1, INIT SIZE, MAX SIZE)
%INTEGER RC
!
%INTEGERARRAY PP(1:3,1:3)
%INTEGER NEW DR0, NEW DR1
%INTEGER I
!
ECTM ENTER("FORM FILE")
!
%IF ECTM CHECK = 1 %THEN %START
      I = MAX(0,CHECK DESCRIPTOR(ROUTE DR0,ROUTE DR1,3,2,1))
      I = MAX(I,CHECK DESCRIPTOR(LOCAL DR0,LOCAL DR1,1,1,2))
      I = MAX(I,CHECK DESCRIPTOR(FULL DR0,FULL DR1,1,1,3))
      I = MAX(I,CHECK ROUTE(DESC ROUTE,4))
      I = MAX(I,CHECK DESCRIPTOR(LOC DESC DR0,LOC DESC DR1,1,1,5))
      I = MAX(I,CHECK DESCRIPTOR(FULL DESC DR0,FULL DESC DR1,1,1,6))
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
NEW DR0 = WORD DESC
NEW DR1 = ADDR(PP(1,1))
ADD PARAM(MAXIMUM FILE SIZE, NEW DR0, NEW DR1, MAX SIZE, 0, DUMMY)
ADD PARAM(INITIAL FILE SIZE, NEW DR0, NEW DR1, INIT SIZE, 0, DUMMY)
ADD PARAM(ACCESS TYPE,       NEW DR0, NEW DR1, 7, 0, DUMMY)
!
RC = NEW FILE(ROUTE DR0, ROUTE DR1, LOCAL DR0, LOCAL DR1,  %C
      FULL DR0, FULL DR1, DESC ROUTE, LOC DESC DR0, LOC DESC DR1,  %C
      FULL DESC DR0, FULL DESC DR1, NEW DR0, NEW DR1, 1, 1)
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%EXTERNALINTEGERFN CTM WRITE DESC(%INTEGER ROUTE DR0, ROUTE DR1,  %C
      LOCAL DR0, LOCAL DR1, FULL DR0, FULL DR1,  %C
      %LONGINTEGER DESC ROUTE, %INTEGER LOC DESC DR0, LOC DESC DR1,  %C
      FULL DESC DR0, FULL DESC DR1, PP DR0, PP DR1)
%INTEGER RC
!
%INTEGER I
!
ECTM ENTER("WRITE DESC")
!
%IF ECTM CHECK = 1 %THEN %START
      I = MAX(0,CHECK DESCRIPTOR(ROUTE DR0,ROUTE DR1,3,2,1))
      I = MAX(I,CHECK DESCRIPTOR(LOCAL DR0,LOCAL DR1,1,1,2))
      I = MAX(I,CHECK DESCRIPTOR(FULL DR0,FULL DR1,1,1,3))
      I = MAX(I,CHECK ROUTE(DESC ROUTE,4))
      I = MAX(I,CHECK DESCRIPTOR(LOC DESC DR0,LOC DESC DR1,1,1,5))
      I = MAX(I,CHECK DESCRIPTOR(FULL DESC DR0,FULL DESC DR1,1,1,6))
      I = MAX(I,CHECK DESCRIPTOR(PP DR0,PP DR1,2,1,7))
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
RC = NEW FILE(ROUTE DR0, ROUTE DR1, LOCAL DR0, LOCAL DR1,  %C
      FULL DR0, FULL DR1, DESC ROUTE, LOC DESC DR0, LOC DESC DR1,  %C
      FULL DESC DR0, FULL DESC DR1, PP DR0, PP DR1, 1, 0)
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%EXTERNALINTEGERFN CTM DELETE FILE(%LONGINTEGER ROUTE,  %C
      %INTEGER LOCAL DR0, LOCAL DR1, FULL DR0, FULL DR1,  %C
      NOTA DR0, NOTA DR1, NOTB)
%INTEGER RC
!
%RECORDNAME AFR(AFRFMT)
%INTEGER AFRAD, I
!
ECTM ENTER("DELETE FILE")
!
%IF ECTM CHECK = 1 %THEN %START
      I = MAX(0,CHECK ROUTE(ROUTE,1))
      I = MAX(I,CHECK DESCRIPTOR(LOCAL DR0,LOCAL DR1,1,1,2))
      I = MAX(I,CHECK DESCRIPTOR(FULL DR0,FULL DR1,1,1,3))
      I = MAX(I,CHECK DESCRIPTOR(NOTA DR0,NOTA DR1,0,1,4))
      %IF NOTB # 0 %THEN I = MAX(I,PARAM ERR(ADDR(NOTB),1,5))
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
%IF ROUTE = 0 %THEN %START
      %IF LOCAL DR0 = NIL %THEN %START
         %IF FULL DR0 = NIL %THEN -> DESC ERR
!
! Must assign the file (to obtain a route)
!
         I = CTM ASSIGN FILE(LONG DESC ! 1, ADDR(ROUTE), NIL, NIL,  %C
            FULL DR0, FULL DR1, 6, 0, 0, NIL, NIL,  %C
            0, 0, 0, 0, NIL, NIL, NIL, NIL)
         %IF I > 0 %THEN RC = I %AND -> RETURN
         %FINISH  %C
      %ELSE %START
         I = CTM JS READ(LOCAL DR0, LOCAL DR1,  %C
            LONG DESC ! 1, ADDR(ROUTE), NIL, NIL, NIL, NIL)
         %IF I # 0 %THEN RC = I %AND -> RETURN
         %FINISH
      %FINISH
AFR AD = ECTM GET ROUTE(ROUTE)
%IF AFR AD = 0 %THEN -> DESC ERR
AFR == RECORD(AFR AD)
AFR_QTEMP = 1
RC = 0 %AND -> RETURN
!
DESC ERR:
RC = 9000 %AND -> RETURN
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%EXTERNALINTEGERFN CTM SELECT RAM(%LONGINTEGER ROUTE,  %C
      %INTEGER LOCAL DR0, LOCAL DR1, PP DR0, PP DR1)
%INTEGER RC
!
! Capability bit settings by access type, from PSD 2.18.19.1 sheet 196
!
%CONSTINTEGER CAP1 = X'7FC027C3'
%CONSTINTEGER CAP2 = X'000C0060'
%CONSTINTEGER CAP3 = X'20301E60'
%CONSTINTEGER CAP4 = X'58038040'
%CONSTINTEGER CAP5 = X'00004000'
%CONSTINTEGER CAP6 = X'0000000C'
!
%LONGINTEGER CAPABILITIES
%INTEGER ACC, FLAG, AFRAD, REQUESTED, AVAILABLE
%INTEGER I, RAM DR0, RAM DR1, ACC1 DR0, ACC1 DR1, ACC2 DR0, ACC2 DR1
%STRING(31) FILE, TEMP
%RECORDNAME AFR(AFRFMT)
%LONGINTEGER DESC
%INTEGERNAME DR0, DR1
DR0 == INTEGER(ADDR(DESC))
DR1 == INTEGER(ADDR(DESC)+4)
!
! First select a suitable RAM, on the basis of the file
! description (found from the ROUTE parameter) and the
! 'capabilities' parameter pair.  This gives the name of
! an object file containing the routines RAM, ACCESS1, ACCESS2.
! This file is explicitly loaded and the RAM routine called
! to initialise the ram.
!
ECTM ENTER("SELECT RAM")
!
%IF ECTM CHECK = 1 %THEN %START
      I = MAX(0,CHECK ROUTE(ROUTE,1))
      I = MAX(I,CHECK DESCRIPTOR(LOCAL DR0,LOCAL DR1,1,1,2))
      I = MAX(I,CHECK DESCRIPTOR(PP DR0, PPDR1,2,1,3))
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
%IF ROUTE = 0 %THEN %START
      FLAG = CTM JS READ(LOCAL DR0, LOCAL DR1,  %C
         LONG DESC ! 1, ADDR(ROUTE), NIL, NIL, NIL, NIL)
      %IF FLAG # 0 %THEN RC = IMOD(FLAG) %AND -> RETURN
      %FINISH
!
AFR AD = ECTM GET ROUTE(ROUTE)
%IF AFR AD = 0 %THEN RC = 9735 %AND -> RETURN
AFR == RECORD(AFR AD)
%IF AFR_QAVAILABLE = 0 %THEN RC = 9087 %AND -> RETURN
!
! Check requested capabilities against those available with the
! current 'access type' as set by ASSIGN FILE etc.
!
CAPABILITIES = ECTM PPL(PP DR0, PP DR1, 16)
REQUESTED = INTEGER(ADDR(CAPABILITIES))
ACC = ECTM PPI(AFR_DESC DR0, AFR_DESC DR1, ACCESS TYPE)
AVAILABLE = 0
%IF ACC & 1 = 1 %THEN AVAILABLE = AVAILABLE ! CAP1
%IF ACC & 2 = 2 %THEN AVAILABLE = AVAILABLE ! CAP2
%IF ACC & 4 = 4 %THEN AVAILABLE = AVAILABLE ! CAP3
%IF ACC & 8 = 8 %THEN AVAILABLE = AVAILABLE ! CAP4
%IF ACC & 5 = 5 %THEN AVAILABLE = AVAILABLE ! CAP5
%IF ACC & 6 = 6 %THEN AVAILABLE = AVAILABLE ! CAP6
!
%IF REQUESTED & (~AVAILABLE) # 0 %THEN RC = 9095 %AND -> RETURN
%IF REQUESTED = 0 %THEN REQUESTED = AVAILABLE
INTEGER(ADDR(CAPABILITIES)) = REQUESTED
!
! Get RAM name from file description, if there, else add requested
! capabilities to the description and call the 'choose RAM' entry
! to the file route.
!
FILE = ECTM PPS(AFR_DESC DR0, AFR_DESC DR1, RAM NAME)
%IF FILE = "" %THEN %START
      ADD PARAM(RAM CAPABILITIES, AFR_DESC DR0, AFR_DESC DR1,  %C
         INTEGER(ADDR(CAPABILITIES)), INTEGER(ADDR(CAPABILITIES)+4),  %C
         AFR_AREA DESC)
      RC = ECTM FILE ROUTE(ROUTE, CHOOSE RAM)
      %IF RC > 0 %THEN -> RETURN
      FILE = ECTM PPS(AFR_DESC DR0, AFR_DESC DR1, TEMP RAM)
      %FINISH
%IF FILE = "" %THEN FILE = DEFAULT RAM
!
FLAG = RAM DESCRIPTORS(FILE, TEMP, RAM DR0, RAM DR1,  %C
      ACC1 DR0, ACC1 DR1, ACC2 DR0, ACC2 DR1)
%IF FLAG > 0 %THEN RC = FLAG %AND -> RETURN
!
INTEGER(ADDR(AFR_ACCESS1)) = ACC1 DR0
INTEGER(ADDR(AFR_ACCESS1)+4) = ACC1 DR1
ITOE(ADDR(TEMP)+1,LENGTH(TEMP))
ADD PARAM(TEMP RAM, AFR_DESC DR0, AFR_DESC DR1,  %C
      STRING DESC ! LENGTH(TEMP), ADDR(TEMP) + 1, AFR_AREA DESC)
!
! Set the access routine entry points in the caller's
! workspace, iff the appropriate parameter pairs are given.
! Note that the ppair value points to a longword to hold the call
! descriptor (i.e. the call descriptor does not go in the ppair
! list itself).  DESC is equivalenced to (DR0, DR1).
!
DESC = ECTM PPL(PP DR0, PP DR1, 24)
%IF DESC # 0 %AND DESC # NIL %THEN  %C
      INTEGER(DR1) = ACC1 DR0 %AND INTEGER(DR1+4) = ACC1 DR1
DESC = ECTM PPL(PP DR0, PP DR1, 19)
%IF DESC # 0 %AND DESC # NIL %THEN  %C
      INTEGER(DR1) = ACC2 DR0 %AND INTEGER(DR1+4) = ACC2 DR1
!
RC = CALL RAM(RAM DR0, RAM DR1, ROUTE, PP DR0, PP DR1)
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%EXTERNALINTEGERFN CTM GIVE ENVIRON(%INTEGER SYS DR0, SYS DR1,  %C
      MODE DR0, MODE DR1, JOB DR0, JOB DR1)
%INTEGER RC
!
! Returns: system name (EMAS), mode of use (batch, interactive),
! job name (batch only).
!
%STRING(31) SYSTEM
!
ECTM ENTER("GIVE ENVIRON")
!
SYSTEM = E"EMAS"
RC = 0 %AND -> RETURN
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%EXTERNALINTEGERFN CTM JS CALL(%INTEGER NR DR0, NR DR1,  %C
      TARGET DR0, TARGET DR1, PARAM DR0, PARAM DR1,  %C
      RESULT DR0, RESULT DR1)
%INTEGER RC
!
! Enters a 'target' procedure through the given descriptor with the
! given parameters on the stack.  Sets up a trap for CTM STOP to
! return here.  Leaves either the normal return code or the CTM STOP
! code in the 'result' area supplied by the caller.
!
%INTEGER I, LNB
!
ECTM ENTER("JS CALL")
!
%IF ECTM CHECK = 1 %THEN %START
      I = MAX(0,CHECK DESCRIPTOR(NR DR0, NR DR1, 0, 0, 1))
      I = MAX(I,CHECK DESCRIPTOR(TARGET DR0, TARGET DR1, 6, 1, 2))
      I = MAX(I,CHECK DESCRIPTOR(PARAM DR0, PARAM DR1, 3, 1, 3))
      I = MAX(I,CHECK DESCRIPTOR(RESULT DR0, RESULT DR1, 5, 2, 4))
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
! Set up a new 'JS var' with a recognisable type (5 = return point),
! containing the LNB of this routine and the address of the caller's
! result area.
!
JS STACK TOP = JS STACK TOP + 1
I = JS STACK TOP
%IF I > MAXIMUM JS VARS %THEN RC = 9001 %AND -> RETURN
JS NAME(I) = "***RETURN***"
JS TYPE(I) = 5
!
*STLN_   LNB
INTEGER(ADDR(JS DESC(I))) = LNB
INTEGER(ADDR(JS DESC(I))+4) = RESULT DR1
!
! Note the LNB in the subsystem COMREG(36), in case of accidents.
COMREG(36) = LNB
!
! Put the parameters on the stack and call the target
!
I = 5 + (PARAM DR0 & LENGTH MASK)
*PRCL_   4
*LDTB_   PARAM DR0
*LDA_    PARAM DR1
*LSS_    (%DR)
LOOP:
*MODD_   1
*JCC_    7,<DONE>
*SL_     (%DR)
-> LOOP
DONE:
*SL_     0
*LDTB_   TARGET DR0
*LDA_    TARGET DR1
*RALN_   I
*CALL_   (%DR)
*ST_     RC
!
! Normal return from the 'target' - put the result code in the
! caller's result area, cancel the saved return point.
! Note that we can't simply unstack the return point, since
! God only knows what has been stacked since the 'target' was entered.
!
LONGINTEGER(RESULT DR1) = 0
LONGINTEGER(RESULT DR1 + 8) = RC
JS DESC(I) = 0
RC = 0 %AND -> RETURN
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%EXTERNALINTEGERFN CTM STOP(%INTEGER R1, R2, R3, R4, R5)
!
! Returns to the last 'stop' point registered by CTM JS CALL, if any..
! Otherwise, returns to SCL level.
!
%INTEGER LNB, RESULT ADDR, I, RC
%LONGLONGREAL RESULT
!
ECTM ENTER("STOP")
!
%IF ECTM CHECK = 1 %THEN %START
      %FINISH
!
! Look down the JS stack for a saved return point.
!
I = JS STACK TOP
%CYCLE
      %IF JS TYPE(I) = 5 %AND JS DESC(I) # 0 %THEN %EXIT
      I =  I - 1
      %IF I = 0 %THEN %STOP
      %REPEAT
!
LNB = INTEGER(ADDR(JS DESC(I)))
RESULT ADDR = INTEGER(ADDR(JS DESC(I))+4)
JS DESC(I) = 0
!
! Put the CTM STOP parameter in the area specified by the result
! descriptor given to the original CTM JS CALL.
!
MOVE(16,ADDR(RESULT),RESULT ADDR)
!
! And return to the routine which called CTM JS CALL.
!
MOVE(4,ADDR(RESULT)+12,ADDR(RC))
*LSS_    RC
*LLN_    LNB
*EXIT_   0
%END
!
%EXTERNALINTEGERFN CTM READ DESC(%LONGINTEGER ROUTE,  %C
      %INTEGER LOCAL DR0, LOCAL DR1, FULL DR0, FULL DR1,  %C
      PP DR0, PP DR1)
%INTEGER RC
!
%INTEGER I, AFR AD, NPP, ID
%RECORDNAME AFR(AFRFMT)
%INTEGERNAME L0, L1
%LONGINTEGER L
%INTEGERARRAYFORMAT PP FORM(1:3,1:100)
%INTEGERARRAYNAME PP
!
ECTM ENTER("READ DESC")
!
%IF ECTM CHECK = 1 %THEN %START
      I = MAX(0,CHECK ROUTE(ROUTE, 1))
      I = MAX(I,CHECK DESCRIPTOR(LOCAL DR0, LOCAL DR1, 1, 1, 2))
      I = MAX(I,CHECK DESCRIPTOR(FULL DR0, FULL DR1, 1, 1, 3))
      I = MAX(I,CHECK DESCRIPTOR(PP DR0, PP DR1, 2, 2, 4))
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
%IF ROUTE = 0 %THEN %START
      I = CTM ASSIGN FILE(LONG DESC ! 1, ADDR(ROUTE),  %C
         LOCAL DR0, LOCAL DR1, FULL DR0, FULL DR1,  %C
         1, 0, 0, NIL, NIL,  %C
         0, 0, 0, 0, NIL, NIL, NIL, NIL)
      %IF I > 0 %THEN RC = I %AND -> RETURN
      %FINISH
!
AFR AD = ECTM GET ROUTE(ROUTE)
%IF AFR AD = 0 %THEN RC = 9114 %AND -> RETURN
AFR == RECORD(AFR AD)
!
NPP = (PP DR0 & LENGTH MASK)//3
%IF NPP > 0 %THEN %START
      PP == ARRAY(PP DR1, PP FORM)
      L0 == INTEGER(ADDR(L))
      L1 == INTEGER(ADDR(L)+4)
      %CYCLE I = 1, 1, NPP
         ID = PP(1,I)
         L = ECTM PPL(AFR_DESC DR0, AFR_DESC DR1, ID)
         ADD PARAM(ID, PP DR0, PP DR1, L0, L1, DUMMY)
         %REPEAT
      %FINISH
RC = 0 %AND -> RETURN
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%EXTERNALLONGINTEGERFN CTM PROCTIME
!
%EXTERNALLONGREALFNSPEC CPUTIME
!
%RESULT = INT(CPUTIME*1000)
%END
!
%EXTERNALINTEGERFN CTM DATE TIME(%LONGINTEGER INPUT TIME,  %C
      %INTEGER DATE DR0, DATE DR1, TIME DR0, TIME DR1, NOT RANGE)
%STRING(10) D1, D2, T1
%INTEGER RC
!
ECTM ENTER("DATE TIME")
%UNLESS DATE DR0 = NIL %OR DATE DR1 = 0 %THEN %START
      D1 = DATE
      D2 = "19".FROMSTRING(D1,7,8)."/"
      D2 = D2.FROMSTRING(D1,4,5)."/"
      D2 = D2.FROMSTRING(D1,1,2)
      ITOE(ADDR(D2)+1,10)
      MOVE(10,ADDR(D2)+1,DATE DR1)
      %FINISH
!
%UNLESS TIME DR0 = NIL %OR TIME DR1 = 0 %THEN %START
      T1 = TIME
      ITOE(ADDR(T1)+1,8)
      MOVE(8,ADDR(T1)+1,TIME DR1)
      %FINISH
RC = 0 %AND -> RETURN
!
RETURN:
ECTM RESULT(RC)
%RESULT = RC
%END
!
%ENDOFFILE