!* MODIFIED 28/02/78 21.00
!*
!*
!*NE %EXTRINSICINTEGER ICL9CEILT
!*NE %EXTRINSICINTEGER ICL9CEELT
!*
!*
SYSTEMINTEGERMAPSPEC COMREG(INTEGER I)
SYSTEMROUTINESPEC OUTFILE(STRING (15) S,INTEGER L,MAXB,USE, C
INTEGERNAME CONAD,FLAG)
SYSTEMROUTINESPEC CONNECT(STRING (31) S, C
INTEGER ACCESS, MAXBYTES, USE, RECORDNAME R, C
INTEGERNAME FLAG)
!*NE %SYSTEMROUTINESPEC CHANGEUSE(%STRING(31) S,%INTEGER NEW USE, %C
!*NE %INTEGERNAME FLAG)
!*NE %SYSTEMROUTINESPEC REMOVE AREA(%STRING(8) S)
SYSTEMROUTINESPEC PHEX(INTEGER I)
SYSTEMROUTINESPEC SSMESS(INTEGER N)
SYSTEMROUTINESPEC SSERR(INTEGER N)
!*
RECORDFORMAT RF(INTEGER CONAD, FILESIZE, INTEGERARRAY D(0 : 7))
!*
!*
!%RECORDFORMAT LF FMT(%STRING (31) NAME, %C
! %INTEGER AFILE, AGLA, LOADLEVEL)
!*
!%OWNRECORDARRAY LF(1 : 8)(LF FMT)
!*
OWNINTEGERARRAY COMPE(4:6)
OWNINTEGER CTYPE
OWNINTEGER LFCOUNT = 0
CONSTINTEGER LFMAX = 8
!*
RECORDFORMAT EFMT(STRING (31) NAME, INTEGER P1, P2, LINK)
!* CODE ENTRIES P1 = DR0 FOR ENTRY DESCRIPTOR
!* P2 = DR1
!* DATA ENTRIES P1 = ADDRESS
!* P2 = LENGTH
!* UNSAT. REF. P1 = ADDRESS OF REF. DESCRIPTOR
!* DYNAM. REF. P1 = ADDRESS OF REF. DESCRIPTOR
!* DATA REF. P1 = ADDRESS OF REFERENCE WORD
!* P2 = EXPECTED LENGTH
!*
CONSTINTEGER ERECSIZE = 44
OWNINTEGER EFREE
OWNINTEGER LISTBASE
!
!%RECORDFORMAT LOADRECFMT(%INTEGER GLABASE, %INTEGERARRAY SAVE(3 : 7))
!*
!%OWNRECORDARRAY LOADREC(0 : 4)(LOADRECFMT)
!*
OWNINTEGER LOADLEVEL = 0
CONSTINTEGER MAXLOADLEVEL = 4
OWNINTEGER UNASSPATTERN=X'81'
!*
OWNINTEGER GLABASE
OWNINTEGER BASELDATA
OWNINTEGER BASEEPHEAD
!*
CONSTINTEGER NUMEPS=225
!*
CONSTSTRING (15)ARRAY VALIDEPS(1:225)= C
'ICL9CEDATE',
'ICL9CETIME',
'S#CPUTIME',
'ICL9CECPUTIME',
'S#STOP',
'GAMMAFN',
'LOGGAMMA',
'CPUTIM',
'HDATE',
'CTIME',
'S#SIGNAL',
'S#FIO1',
'S#FAUX',
'S#IOCP',
'S#NDIAG',
'S#INTPT',
'S#INT',
'S#FRACPT',
'S#PRINT',
'S#PRINTFL',
'S#READ',
'ONCOND',
'CPUTIME',
'ERFN',
'ERFNC',
'S#IEXP',
'HYPTAN',
'S#ISIN',
'S#ICOS',
'S#ISQRT',
'COT',
'S#IRADIUS',
'S#ITAN',
'S#IARCCOS',
'S#IARCSIN',
'S#IARCTAN',
'S#AARCTAN',
'HYPSIN',
'HYPCOS',
'EXPTEN',
'S#ILOG',
'LOGTEN',
'LRANDOM',
'S#ININTEGER',
'S#INREAL',
'S#OUTINTEGER',
'S#OUTREAL',
'S#OUTTERMINATOR',
'S#WRITETEXT',
'S#ABS',
'S#IABS',
'S#SIGN',
'S#MAXREAL',
'S#MINREAL',
'S#MAXINT',
'S#EPSILON',
'S#AFAULT',
'S#ALREAD',
'S#ANXTSY',
'S#ARDSYM',
'S#APRSYM',
'S#ALGPTH',
'S#PRSTNG',
'S#ASELIN',
'S#ASELOU',
'S#ALGNWL',
'S#ALGSPC',
'S#ALGNLS',
'S#ALGSPS',
'S#LENGTH',
'S#INSYMBOL',
'S#OUTSYMBOL',
'S#AICODE',
'S#OUTSTRING',
'S#READ1900',
'S#PRINT1900',
'S#OUTPUT',
'S#READBOOLEAN',
'S#WRITEBOOLEAN',
'S#COPYTEXT',
'S#ALRDCH',
'S#ALNXCH',
'S#ALSKCH',
'S#ALPRCH',
'S#ALGMON',
'ICL9CEXIT',
'S#WRITE',
'TIME',
'DATE',
'CLOSESTREAM',
'S#CLOSESTREAM',
'SETMARGINS',
'READSTRING',
'FROMSTRING',
'SETRETURNCODE',
'BITS',
'PARITY',
'SHIFTC',
' ',
' ',
'ISOCARD',
'RFDISO',
'IFDISO',
'SOLVELNEQ',
'DIVMATRIX',
'UNIT',
'INVERT',
'DET',
'NULL',
'ADDMATRIX',
'SUBMATRIX',
'COPYMATRIX',
'MULTMATRIX',
'MULTTRMATRIX',
'TRANSMATRIX',
'RANDOM',
'ICL9CEDIAG',
'ICL9CELABELS',
'ICL9CEFTRACE',
'OPENSQ',
'CLOSESQ',
'READSQ',
'WRITESQ',
'OPENDA',
'CLOSEDA',
'READDA',
'WRITEDA',
'READLSQ',
'LENGTHSQ',
'S#GETSQ',
'S#PUTSQ',
'S#OPENSQ',
'S#CLOSESQ',
'S#OPENDA',
'S#CLOSEDA',
'S#GETDA',
'S#PUTDA',
'S#RWNDSQ',
'M#1LGAMMA',
'M#2LGAMMA',
'M#4LGAMMA',
'M#1GAMMA',
'M#2GAMMA',
'M#4GAMMA',
'M#1SQRT',
'M#2SQRT',
'M#4SQRT',
'M#1ASIN',
'M#2ASIN',
'M#4ASIN',
'M#1ACOS',
'M#2ACOS',
'M#4ACOS',
'M#1SIN',
'M#2SIN',
'M#4SIN',
'M#1COS',
'M#2COS',
'M#4COS',
'M#1TAN',
'M#2TAN',
'M#4TAN',
'M#1COT',
'M#2COT',
'M#4COT',
'M#1ATAN',
'M#2ATAN',
'M#4ATAN',
'M#1ATAN2',
'M#2ATAN2',
'M#4ATAN2',
'M#1EXP',
'M#2EXP',
'M#4EXP',
'M#1SINH',
'M#2SINH',
'M#4SINH',
'M#1COSH',
'M#2COSH',
'M#4COSH',
'M#1TANH',
'M#2TANH',
'M#4TANH',
'M#1LOG10',
'M#2LOG10',
'M#4LOG10',
'M#1LOG',
'M#2LOG',
'M#4LOG',
'M#1EXP10',
'M#2EXP10',
'M#4EXP10',
'M#1ERF',
'M#2ERF',
'M#4ERF',
'M#1CERF',
'M#2CERF',
'M#4CERF',
'M#1ABSC',
'M#2ABSC',
'M#4ABSC',
'M#1CCOS',
'M#2CCOS',
'M#4CCOS',
'M#1CSIN',
'M#2CSIN',
'M#4CSIN',
'M#1CSQRT',
'M#2CSQRT',
'M#4CSQRT',
'M#1CLOG',
'M#2CLOG',
'M#4CLOG',
'M#1CEXP',
'M#2CEXP',
'M#4CEXP',
'M#1C1XPR1',
'M#2C2XPR2',
'M#4C4XPR4',
'M#AL11XP1',
'M#AL22XP2',
'M#AL44XP4',
'ICL9CEIDATE',
'ICL9CEITIME',
'***END***'
!*
!*
SYSTEMINTEGERFN INITLOAD
INTEGER I, J
OUTFILE('SS#WRK',X'80000',X'80000',0,EFREE,J)
OUTFILE('SS#GLA',X'40000',0,0,GLABASE,I)
IF I#0 OR J # 0 THEN SSERR(225)
COMREG(38) = GLABASE; ! ADDRESS OF SS#GLA
COMREG(44) = GLABASE+16; ! CURRENT FREE GLA
I=ADDR(BASELDATA)&X'FFFC0000'
COMREG(35)=I ;! GLA BASE
!*E; BASELDATA=X'800000'+INTEGER(X'800018')
!*NE BASELDATA=X'800000'+INTEGER(X'80000C')
BASEEPHEAD=INTEGER(BASELDATA+4)
RESULT =0
END ; ! INITLOAD
!*
ROUTINE MOVE(INTEGER LENGTH, FROM, TO)
INTEGER I
RETURNIF LENGTH <= 0
I = X'18000000'!LENGTH
*LSS_FROM
*LUH_I
*LDTB_I
*LDA_TO
*MV_L =DR
END ; !OF MOVE
!*
ROUTINE FILL(INTEGER LENGTH, FROM,FILLER)
INTEGER I
RETURNIF LENGTH <= 0
I = X'18000000'!LENGTH
*LDTB_I
*LDA_FROM
*LB_FILLER
*MVL_L =DR
END
!*
!*
ROUTINE EPOP(INTEGERNAME LIST, AD)
!%RECORDNAME E(EFMT)
AD = LISTBASE
LISTBASE=LISTBASE+ERECSIZE
END ; ! EPOP
!*
ROUTINE EPUSH(INTEGERNAME LIST, INTEGER AD)
RECORDNAME E(EFMT)
E==RECORD(AD)
E_LINK = LIST
LIST = AD
END ; ! EPUSH
!*
!*
CONSTSTRING (21) SSBASEDIR = "SUBSYS.SYSTEM_BASEDIR"
RECORDFORMAT LNF(BYTEINTEGER TYPE, STRING (6) NAME, C
INTEGER REST, POINT, DR1)
!LONG NAME FORMAT
RECORDFORMAT SNF(BYTEINTEGER TYPE, STRING (10) NAME, C
INTEGER POINT, DR1)
!SHORT NAME FORMAT
RECORDFORMAT DHF(INTEGER DATAEND, DATASTART, SIZE, FILETYPE, C
DATE, TIME, PSTART, SPARE)
!DIRECTORY HEADER FORMAT
RECORDFORMAT XRF(INTEGER CONAD, FILETYPE, DATASTART, DATAEND)
STRINGFN FINDSYSTEMENTRY(STRING (31) ENTRY)
!***********************************************************************
!* *
!* This function is used to find the name of the object file which *
!* contains a given entry. It only searches the Edinburgh Subsystem *
!* standard base directory, which is assumed to have the name *
!* SUBSYS.SYSTEM_BASEDIR *
!* If the entry is not found or the directory cannot be connected *
!* then the result is null. *
!* *
!***********************************************************************
STRING (31) RES
RECORDNAME DH(DHF); !MAPS ONTO DIRECTORY HEADER
RECORD RR(XRF)
INTEGER LENE, INITP, HASHCONST, HASHBASE, P, PSTART, DAD, C
FLAG
INTEGERFN HASH(STRING (31) NAME, INTEGER HASHCONST)
INTEGER RES, A, B, C, D, E, F, G, H, I, J, K
!A-K ALL NEEDED
STRING(ADDR(A)) = NAME."<>12ABXY89*"
RES = A!!B>>4!!C
RESULT = (RES-RES//HASHCONST*HASHCONST)
END ; !OF HASH
RES = ""; !FAILURE BY DEFAULT
CONNECT(SSBASEDIR,0,0,0,RR,FLAG)
IF FLAG#0 THEN SSMESS(FLAG)
IF FLAG # 0 THEN -> ERR
DAD = RR_CONAD; !ADDRESS OF DIRECTORY
DH == RECORD(DAD); !MAP DH ONTO DIRECTORY HEADER
PSTART = DAD+DH_PSTART
HASHCONST = INTEGER(DAD+DH_DATASTART)
!NO OF ENTRIES IN HASHED TABLE
HASHBASE = DAD+DH_DATASTART+4
LENE = LENGTH(ENTRY)
INITP = HASH(ENTRY,HASHCONST); !START SEARCHING HERE
P = INITP; !START SEARCHING HERE
IF LENE <= 10 START ; !DEAL WITH SHORT ENTRY NAMES
BEGIN ; !NEED INNER BLOCK FOR
! DECLARATIONS
RECORDARRAYFORMAT HAF(0 : HASHCONST-1)(SNF)
RECORDARRAYNAME H(SNF)
H == ARRAY(HASHBASE,HAF); !MAP H ONTO HASHED TABLE
CYCLE
IF H(P)_NAME = ENTRY AND H(P)_TYPE = 0 START
RES = STRING(PSTART+H(P)_POINT)
!FILENAME - DIRECTORY OR OBJECT
EXIT ; !SUCCESS
FINISH
IF H(P)_NAME = "" THEN EXIT
!ENTRY NOT FOUND
P = P+1
IF P = HASHCONST THEN P = 0
!OVER THE TOP
IF P = INITP THEN EXIT
!GONE RIGHT ROUND
REPEAT
END
FINISH ELSE START
!NOW DEAL WITH LONG NAMES
BEGIN
RECORDARRAYFORMAT HAF(0 : HASHCONST)(LNF)
RECORDARRAYNAME H(LNF)
STRING (26) REST; !REST OF LONG NAME
H == ARRAY(HASHBASE,HAF)
REST = FROMSTRING(ENTRY,7,LENE)
LENGTH(ENTRY) = 6; !TRUNCATE IT
CYCLE
IF H(P)_NAME = ENTRY AND H(P)_TYPE = X'80' C
AND STRING(H(P)_REST+PSTART) = REST START
RES = STRING(PSTART+H(P)_POINT)
EXIT
FINISH
IF H(P)_NAME = "" THEN EXIT
!NOT FOUND
P = P+1
IF P = HASHCONST THEN P = 0
!OVER THE TOP
IF P = INITP THEN EXIT
!GONE RIGHT ROUND
REPEAT
END
FINISH
ERR:
RESULT = RES
END ; !OF FINDSYSTEMENTRY
! %EXTERNALROUTINE TESTFINDCS(%STRING(31) ENTRY)
! PRINTSTRING("
! ".FINDSYSTEMENTRY(ENTRY)."
! ")
!%END
ROUTINESPEC LOAD FILE(STRING (31) FILE,INTEGERNAME FLAG)
EXTERNALINTEGERFN LOAD COMPILER(INTEGER TYPE, STRING (31) CENTRY C
,INTEGERNAME ENTRY)
INTEGER COM44,FLAG,CGLABASE,OLDGLABASE
OWNINTEGER GCUR=0
! SAVE CURRENT GLA POINTER
COM44=COMREG(44)
OLDGLABASE=GLABASE
IF GCUR=0 START
OUTFILE("T#CGLA",X'40000',0,0,GCUR,FLAG)
IF FLAG#0 START
PRINTSTRING("
CANNOT CREATE T#CGLA, FLAG = ")
WRITE(FLAG,1)
NEWLINE
RESULT =206
FINISH
GLABASE=GCUR&X'FFFC0000'
INTEGER(GLABASE+8)=X'40000'
FINISH
GLABASE=GCUR&X'FFFC0000'
COMREG(44)=GCUR
CTYPE=TYPE
LOADFILE(FINDSYSTEMENTRY(CENTRY),FLAG)
IF FLAG#0 START
PRINTSTRING("
LOAD COMPILER FAILS, FLAG = ")
WRITE(FLAG,1)
RESULT =FLAG
FINISH
GCUR=COMREG(44)
GLABASE=OLDGLABASE
COMREG(44)=COM44
ENTRY=COMPE(CTYPE)
CTYPE=0
RESULT =0
END
!*NE %ROUTINE WHERE IS(%STRING (32) S, %INTEGERNAME DR0, DR1,%C
!*NE %INTEGER ADDRTAB)
!*NE %STRING (32) T
!*NE %INTEGER FIRSTCH, I, LINK
!*NE %INTEGERARRAYFORMAT LTFM(1:100000)
!*NE %INTEGERARRAYNAME ICL9
!*NE ICL9==ARRAY(ADDRTAB,LTFM)
!*NE DR0 = -1
!*NE FIRSTCH = BYTEINTEGER(ADDR(S)+1)
!*NE !! SEARCH EXTERNAL LINKAGE TABLE FOR NAME
!*NE !!
!*NE NEXTTABLE:
!*NE
!*NE %RETURN %IF ICL9(1)=-1 ;! ABANDON IF NO ELT
!*NE %IF FIRSTCH = '$' %THEN LINK = 1 %ELSE LINK = FIRSTCH-63
!*NE LINK = ICL9(LINK); ! INDEX BY FIRST LETTER
!*NE %WHILE LINK>0 %CYCLE
!*NE T = STRING(ADDR(ICL9(LINK+1)))
!*NE %IF S = T %THEN %START
!*NE I = LINK+1+(LENGTH(S)+4)>>2
!*NE DR0 = ICL9(I)
!*NE DR1 = ICL9(I+1)
!*NE %RETURN
!*NE %FINISH
!*NE %RETURN %IF T > S
!*NE %EXIT %UNLESS ICL9(LINK)>0
!*NE LINK = ICL9(LINK)+LINK
!*NE %REPEAT
!*NE %END
INTEGERFN FINDEP(STRING (31) S, C
INTEGER HEAD,TYPE, INTEGERNAME DR0,DR1)
!* TYPE = 0 PROC 1 DATA
STRING (32) REST
RECORDNAME E(EFMT)
RECORDFORMAT LDATA1FMT(INTEGERC
LINK,LOC,STRING (31) IDEN)
RECORDNAME L(LDATA1FMT)
INTEGER I,J
WHILE HEAD # 0 CYCLE
E == RECORD(HEAD)
IF E_NAME = S THENSTART
DR0=E_P1
DR1=E_P2
RESULT =0
FINISH
HEAD = E_LINK
REPEAT
!*
!* NOW SEARCH BASE FILE
!*
IF S="EXIT" THEN S="ICL9CEXIT"
IF S#'S#GO' AND TYPE=0 THENSTART
CYCLE J=1,1,NUMEPS
!*E; %IF S->("ICL9CEZ").S %THEN S="S#".S
IF VALIDEPS(J)=S OR CTYPE>0 START
I=BASEEPHEAD
WHILE I#0 CYCLE
!*E; L==RECORD(X'800000'+I)
!*NE L==RECORD(BASELDATA+I)
IF L_IDEN=S THENSTART
DR0=X'B1000000'
DR1=(L_LOC&X'FFFFFF')+COMREG(35)
RESULT =0
FINISH
I=L_LINK
REPEAT
FINISH
REPEAT
FINISH
!*NE %IF S->('S#').S %THEN S='ICL9CEZ'.S
!*NE WHERE IS(S,DR0,DR1,ADDR(ICL9CEILT))
!*NE %IF DR0=-1 %THENSTART
!*NE I=ADDR(ICL9CEELT)
!*NE *LDTB_X'18000010'
!*NE *LDA_I
!*NE *VAL_(%LNB+1)
!*NE *JCC_3,<NOGO>
!*NE WHERE IS(S,DR0,DR1,I)
!*NE %FINISH
!*NE %IF DR0#-1 %THEN %RESULT=0
!*NE NOGO:
RESULT =1
END ; ! FINDEP
!*
OWNINTEGER ISTACKBASE;! FOR INITIALISED STACK AREA
OWNINTEGER ISTACKSIZE
OWNINTEGER ISTACKPATTERN
OWNINTEGER MAINEPAD
!*
ROUTINESPEC PLIST(INTEGER HEAD)
!*
ROUTINE LOAD FILE (STRING (31) S ,INTEGERNAME FLAG)
!*
RECORDFORMAT LD13F(INTEGER LINK,A,DISP,LEN,REP,ADDR)
RECORDFORMAT DREFF(INTEGER LINK,REFARRAY,L,STRING (31) IDEN)
RECORDNAME DREF(DREFF)
INTEGERARRAYFORMAT REFLOCAF(1:10000)
INTEGERARRAYNAME REFLOC
RECORDNAME LD13(LD13F)
INTEGER START,REFARRAY,REFCOUNT,LINK
RECORDFORMAT R1FMT(INTEGER LINK, REFLOC, STRING (31) NAME)
RECORDFORMAT R2FMT(INTEGER LINK,DISP,L,A,STRING (31) NAME)
RECORDFORMAT R3FMT(INTEGER LINK,N)
RECORDNAME R1(R1FMT)
RECORDNAME R2(R2FMT)
RECORDNAME R3(R3FMT)
!*
RECORD R(RF)
!*
RECORDNAME E(EFMT)
!*
INTEGER COM3, COM4, COM5, COM6, COM7
INTEGER I, J, K, L, M, AFILE, AGLA, LBASE, UNSHDISP,AREADESC
INTEGER B
INTEGER GCUR,GEND
STRING (31) NAME
INTEGER DR0,DR1
INTEGERARRAY BASE(1 : 7)
!*
! I = 0
! %WHILE I < LFCOUNT %CYCLE; ! THROUGH LIST OF LOADED FILES
! I = I+1
! %IF S = LF(I)_NAME %THEN FLAG = -1 %ANDRETURN
! !ALREADY LOADED
! %REPEAT
!*
IF COMREG(27)&X'10010' #0 THEN UNASSPATTERN=0 ELSE UNASSPATTERN=X'81'
ISTACKPATTERN=COMREG(14)+X'10';! USE PART OF SS#WORK
CONNECT(S,0,0,0,R,FLAG)
IF FLAG # 0 THENSTART
PRINTSTRING('
UNABLE TO CONNECT '.S.' FLAG =')
WRITE(FLAG,1)
NEWLINE
RETURN
FINISH
!*
AFILE = R_CONAD
!*
AREADESC=INTEGER(AFILE+28)+AFILE
J=AREADESC+4
UNSHDISP=INTEGER(J+12)
AGLA=AFILE+UNSHDISP
LBASE=AFILE+INTEGER(AFILE+24)
IF INTEGER(LBASE)#14 THEN SSMESS(226) AND RETURN
I=INTEGER(J+16)+INTEGER(J+52)+INTEGER(J+64) ;! GLALENGTH
GEND = GLABASE+INTEGER(GLABASE+8); ! SS#GLA END
GCUR = COMREG(44); !CURRENT FREE GLA POINTER
IF GCUR+I>GEND THENSTART
SIZE ERR:
PRINTSTRING('
STATIC DATA AREA TOO LARGE
')
FLAG = 2
RETURN
FINISH
!*
MOVE(I,AGLA,GCUR)
AGLA = GCUR
GCUR=(GCUR+I+7)&X'FFFFFFF8'
COMREG(44) = GCUR
!*
INTEGER(GLABASE)=GCUR-GLABASE
AREADESC=INTEGER(AFILE+28)+AFILE
J = AREADESC+4
BASE(1) = AFILE+INTEGER(J); !CODE
BASE(2) = AGLA+INTEGER(J+12)-UNSHDISP; !GLA
BASE(3) = AGLA+INTEGER(J+24)-UNSHDISP; !PLT
BASE(4) = AFILE+INTEGER(J+36); !SHARED SYMBOL TABLES
BASE(5) = AGLA+INTEGER(J+48)-UNSHDISP; !UNSH SYMBOL TABLES
BASE(6) = AGLA+INTEGER(J+60)-UNSHDISP;! COMMON
BASE(7)=ISTACKPATTERN
ISTACKSIZE=INTEGER(J+76)
IF ISTACKSIZE#0 THENSTART
MOVE(ISTACKSIZE,AFILE+INTEGER(J+72),ISTACKPATTERN)
FINISH
LISTBASE=ISTACKPATTERN+ISTACKSIZE+16
! MOVE(20,ADDR(COMREG(3)),ADDR(COM3))
COM3=0
COM4=0
COM5=0
COM6=0
COM7=0
!*
!* PROCESS CODE ENTRIES
!*
I = INTEGER(LBASE+4)
WHILE I # 0 CYCLE
R1 == RECORD(AFILE+I)
EPOP(EFREE,J)
IF J = 0 THEN -> TOO MANY
E == RECORD(J)
E_P1 = X'B1000000'; !DR0
E_P2 = R1_REFLOC&X'FFFFFF'+BASE((R1_REFLOC>>24)&X'F'); !DR1
IF R1_REFLOC>>31#0 THEN MAINEPAD=E_P2
E_NAME = R1_NAME
IF CTYPE#0 THEN COMPE(CTYPE)=E_P2
EPUSH(COM3,J)
I = R1_LINK
REPEAT
!*
!*PROCESS DATA ENTRIES
!*
I = INTEGER(LBASE+16)
WHILE I # 0 CYCLE
R2 == RECORD(AFILE+I)
EPOP(EFREE,J)
IF J = 0 THEN -> TOO MANY
E == RECORD(J)
E_P1 = R2_DISP+BASE(R2_A); !ADDRESS
E_P2 = R2_L; !LENGTH
E_NAME = R2_NAME
EPUSH(COM4,J)
I = R2_LINK
REPEAT
!*
!* PROCESS PROCEDURE REFS
!*
M = 0
I = INTEGER(LBASE+28)
PROCREF: WHILE I # 0 CYCLE
R1 == RECORD(AFILE+I); ! REF. DESC.
K = (R1_REFLOC&X'FFFFFF')+BASE(R1_REFLOC>>24)
IF FINDEP(R1_NAME,COM3,0,DR0,DR1) # 0 THENSTART ; !NOT DEFINED
EPOP(EFREE,J)
IF J = 0 THEN -> TOO MANY
E == RECORD(J)
E_P1 = K
E_NAME = R1_NAME
EPUSH(COM5,J)
FINISHELSESTART ; ! LOCATED
E == RECORD(J)
INTEGER(K) = DR0
INTEGER(K+4) = DR1
FINISH
I = R1_LINK
REPEAT
!*
IF M = 0 THENSTART ; ! PROCESS DYNAMIC PROCEDURE REFS
I = INTEGER(LBASE+32)
M = 1
-> PROC REF; ! HANDLE AS STATIC MEANTIME
FINISH
!*
!* PROCESS DATA REFERENCES
!*
I = INTEGER(LBASE+36)
WHILE I # 0 CYCLE
DREF == RECORD(AFILE+I)
REFARRAY=DREF_REFARRAY&X'7FFFFFFF'
REFCOUNT=INTEGER(AFILE+REFARRAY)
REFLOC==ARRAY(AFILE+REFARRAY+4,REFLOCAF)
CYCLE REFCOUNT=1,1,REFCOUNT
K=REFLOC(REFCOUNT)&X'FFFFFF'+BASE(REFLOC(REFCOUNT)>>24)
IF DREF_IDEN='SS#AUXST' THEN START
INTEGER(K)=COMREG(37)
->NEXTDATAREF
FINISH
IF DREF_IDEN='SZAUXST' OR DREF_IDEN='ICL9CEAUXST' THENSTART
INTEGER(K)=COMREG(41);! ADDRESS OF SS#AUXST DESC.
->NEXTDATAREF
FINISH
IF FINDEP(DREF_IDEN,COM4,1,DR0,DR1) # 0 THENSTART ; !NOT DEFINED
EPOP(EFREE,J)
IF J = 0 THEN -> TOO MANY
E == RECORD(J)
E_P1 = K
E_P2 = DREF_L
E_NAME = DREF_IDEN
EPUSH(COM7,J)
FINISHELSESTART ; !LOCATED
E == RECORD(J)
INTEGER(K) = INTEGER(K)+DR0
FINISH
NEXTDATAREF: REPEAT
I = DREF_LINK
REPEAT
!*
!****** ALLOCATE UNITIALISED COMMON AREAS
!*
WHILE COM7#0 CYCLE
J=0;! FOR LIST OF REFS TO THIS AREA
K=0;! FOR REMAINING REFS
E==RECORD(COM7)
NAME=E_NAME
L=E_P2;! SIZE OF AREA
J=COM7
COM7=E_LINK
E_LINK=0
WHILE COM7#0 CYCLE
E==RECORD(COM7)
I=COM7
COM7=E_LINK
IF NAME=E_NAME THENSTART
IF E_P2>L THEN L=E_P2;! REQUIRE MAX OF ALL REFS
E_LINK=J
J=I
FINISHELSESTART
E_LINK=K
K=I
FINISH
REPEAT
IF GCUR+L>GEND THEN ->SIZE ERR
M=GCUR
GCUR=(GCUR+L+7)&X'FFFFFFF8'
COMREG(44)=GCUR
FILL(L,M,UNASSPATTERN)
WHILE J#0 CYCLE
E==RECORD(J)
I=J
INTEGER(E_P1)=INTEGER(E_P1)+M
J=E_LINK
REPEAT
E_P1=M
E_P2=L
E_LINK=COM4
COM4=I;! ADD TO INITIALISED LIST
COM7=K;! BALANCE OF REFS
REPEAT
! %IF COMREG(27)&X'8000'#0 %AND COM4#0 %THENSTART;! PARM(MAP)
! PRINTSTRING('
!COMMON AREAS ADDRESS LENGTH
!')
! I=COM4
! %WHILE I#0 %CYCLE
! NEWLINE
! E==RECORD(I)
! PRINTSTRING(E_NAME)
! SPACES(16-LENGTH(E_NAME))
! PHEX(E_P1)
! SPACES(4)
! PHEX(E_P2)
! I=E_LINK
! %REPEAT
! NEWLINES(2)
! %FINISH
!*
!* PROCESS INITIALISTION DATA
!*
I=INTEGER(LBASE+52)
WHILE I#0 CYCLE
LD13==RECORD(AFILE+LINK)
START=BASE(LD13_A)+LD13_DISP
IF LD13_LEN=1 START
FILL(LD13_REP,START,LD13_ADDR)
FINISHELSESTART
CYCLE I=1,1,LD13_REP
MOVE(LD13_LEN,LD13_ADDR,START)
START=START+LD13_LEN
REPEAT
FINISH
LINK=LD13_LINK
REPEAT
!*
!*PROCESS RELOCATION BLOCKS
!*
I = INTEGER(LBASE+56)
WHILE I#0 CYCLE
R3 == RECORD(AFILE+I)
J = R3_N
K = AFILE+I+8
CYCLE L = 1,1,J
B=INTEGER(K+4)>>24
IF B=7 THEN B=ISTACKBASE ELSE B=BASE(B)
M=BASE(INTEGER(K)>>24)+(INTEGER(K)&X'FFFFFF')
INTEGER(M)=INTEGER(M)+B+(INTEGER(K+4)&X'FFFFFF')
K=K+8
REPEAT
I = R3_LINK
REPEAT
MOVE(20,ADDR(COM3),ADDR(COMREG(3)))
RETURN
TOO MANY: SSMESS(227)
PRINTSTRING('
PROC ENTRIES:
')
PLIST(COM3)
PRINTSTRING('
DATA ENTRIES:
')
PLIST(COM4)
PRINTSTRING('
PROC REFS:
')
PLIST(COM5)
PRINTSTRING('
DATA REFS:
')
PLIST(COM7)
NEWLINE
FLAG=3
RETURN
END ; ! LOAD FILE
!*
!*
ROUTINE PLIST(INTEGER I)
RECORDNAME E(EFMT)
WHILE I#0 CYCLE
E==RECORD(I)
PRINTSTRING(E_NAME)
NEWLINE
I=E_LINK
REPEAT
END
!*
SYSTEMROUTINE SJRUN(STRING (63) S)
INTEGER I,J,F
IF COMREG(24)#0 THENSTART
SSMESS(222)
RETURN
FINISH
ISTACKSIZE=0
*PUT_X'5F98';! STSF (TOS)
*PUT_X'6398';! LSS (TOS)
**=I
ISTACKBASE=(I+7)&X'FFFFFFF8'
I=INITLOAD
MAINEPAD=0
LOADFILE('SS#TMPOB',F)
IF F#0 THENSTART
RETURN
FINISH
I=COMREG(5)
IF I#0 THENSTART
F=1
PRINTSTRING('
UNSATISFIED REFERENCES:
')
PLIST(I)
FINISH
I=COMREG(7)
IF I#0 THENSTART
PRINTSTRING('
UNSATISFIED DATA REFERENCES:
')
PLIST(I)
F=1
FINISH
IF F=0 THENSTART
IF ISTACKSIZE#0 THENSTART
I=(ISTACKSIZE+16)>>2
**I
*PUT_X'499C';! ST B
*PUT_X'6F9C';! ASF B
MOVE(ISTACKSIZE,ISTACKPATTERN,ISTACKBASE)
FINISH
IF MAINEPAD#0 THENSTART
I=X'B1000000'
J=MAINEPAD
->ENTER
FINISH
IF FINDEP('S#GO',COMREG(3),0,I,J)=0 THENSTART
ENTER:
!*NE CHANGE USE('SS#TMPOB',1,F)
IF COMREG(36)&4=0 THEN C
COMREG(36)=COMREG(36)+4
!*NE %IF F#0 %THEN %MONITOR
!*NE REMOVE AREA('SS#WRK')
**I
*PUT_X'4998';! ST (TOS)
**J
*PUT_X'4998';! ST (TOS)
*PUT_X'7998';! LD_(TOS)
*PUT_X'5D98';! STLN (TOS)
*PUT_X'6E04';! ASF 4
*PUT_X'6C05';! RALN 5
*PUT_X'1FDC';! CALL @(DR)
RETURN
FINISHELSESTART
PRINTSTRING('
***NO MAIN PROGRAM
')
FINISH
FINISH
END ;! RUN
ENDOFFILE