CONSTSTRING (63) LOADVSN=" ** Loader 44B 02/11/83 **
"
CONSTINTEGER TRUE=1,FALSE=0
!
!***********************************************************************
!* *
!* Conditional compilation constants *
!* *
!***********************************************************************
!
CONSTINTEGER NEWCONNECT = 0; ! Set this non-zero to work with the
! new CONNECT mechanism.
CONSTINTEGER STUDENTSS=0; ! Zero for standard ss, non zero for student ss.
!
!*********************************************************************************************
!* *
!* EEEEEEE MM MM AAA SSSS 22222 9999 00000 00000 *
!* E M M M M A A S 2 9 9 0 0 0 0 0 0 *
!* EEEE M M M AAAAAAA SSS 22222 999 9 0 0 0 0 0 0 *
!* E M M A A S 2 9 0 0 0 0 0 0 *
!* EEEEEEE M M A A SSSS 22222 9 00000 00000 *
!* L OOOOOOO AAA DDDDD EEEEEEE RRRRRR *
!* L O O A A D D E R R *
!* L O O AAAAAAA D D EEEE RRRRRR *
!* L O O A A D D E R R *
!* LLLLLLL OOOOOOO A A DDDDD EEEEEEE R R *
!* *
!*********************************************************************************************
!
!
! IMPORTANT NOTE. Throughout this code LOADLEVEL refers to the global
! load level of the process. LOCLL (occasionally LL) refers to the local
! load level relevant to the code currently being executed. The two can
! sometimes differ since if an item has to be 'permanently loaded' the
! local load level will switch temporarily to 0.
! Almost all conditions in the loader are tested against 0 (FALSE)
! if possible for efficiency even at the expense of a certain unnaturalness
! in readability. Please do the necessary mental processing!
! C.McC.
!
INCLUDE "SS0302S_SSOWNF"
!
!***********************************************************************
!* *
!* Record formats *
!* *
!***********************************************************************
!
RECORDFORMAT ADDF(STRING (31) FILE, C
(INTEGER MAINEP,DUM1 OR INTEGER GLAFROM,GLATO))
RECORDFORMAT ATMODEF(HALFINTEGER FLAGS, BYTEINTEGER PADS,SPARE,LINELIM,PAGE, C
BYTEINTEGERARRAY TABS(1:8), BYTEINTEGER CR,ESC,DEL,CAN, C
PROMPT,END, HALFINTEGER FLAGS2,SPARE2,SPARE3, C
BYTEINTEGER SCREED1,SCREED2,SCREED3,SCREED4,SCREED5,SCREED6)
RECORDFORMAT BREFF(INTEGER FIRST,LAST,LINK) {Basic rec}
RECORDFORMAT CONTF(INTEGER DATAEND,DATASTART,PSIZE,FILETYPE, C
SUM,DATETIME,SPARE1,SPARE2,MARK,NULL1,UGLA,ASTK,USTK, C
NULL2,ITWIDTH,LDELIM,RDELIM,JOURNAL,SEARCHDIRCOUNT, C
ARRAYDIAG,INITWORKSIZE,SPARE,ITINSIZE,ITOUTSIZE, C
NOBL,ISTK, LONGINTEGER INITPARMS, INTEGER DATAECHO, C
TERMINAL,I23,I24,I25,I26,I27,I28,I29,I30,I31,I32, C
STRING (31) FSTARTFILE,BSTARTFILE,PRELOADFILE,MODDIR, C
CFAULTS,S6,S7,S8,S9,S10,S11,S12,S13,S14,S15, C
S16,S17,S18,S19,S20,S21,S22,S23,S24,S25,S26,S27, C
S28,S29,S30,S31,S32, STRING (31)ARRAY SEARCHDIR(1:16))
RECORDFORMAT DHF(INTEGER DATAEND, DATASTART, SIZE, FILETYPE, C
DATE, TIME, PSTART, SPARE)
RECORDFORMAT DIRINFF(STRING (6) USER, STRING (31) BATCHFILE, C
INTEGER MARK,FSYS,PROCNO,ISUFF,REASON,BATCHID,SESSICLIM, C
SCIDENSAD,SCIDENS,OPERNO,AIOSTAT,SCDATE, C
SYNC1DEST,SYNC2DEST,ASYNCDEST,AACCTREC,AICREVS, C
STRING (15) BATCHIDEN, STRING (31) BASEFILE, INTEGER PREVIC, C
INTEGER ITADDR0,ITADDR1,ITADDR2,ITADDR3,ITADDR4, C
STREAMID,DIDENT,SCARCITY,PREEMPTAT, STRING (11) SPOOLRFILE, C
INTEGER RESUNITS,SESSLEN,PRIORITY,DECKS,DRIVES,PARTCLOSE, C
RECORD (ATMODEF) TMODES, INTEGER PSLOT, STRING (63) ITADDR, C
INTEGERARRAY FCLOSING(0:3), INTEGER CLO FES,UEND)
! FCLOSING is a bit-array (0:99). Bit N is set if the operators had
! done D/CLOSE FSYS N <time> at the moment when the process was started.
! CLO FES is used in the same way to indicate 'FE closing' if the
! operators had done D/CLOSE FE N <time>. PART CLOSE is non-zero
! only if the process was started in the last seven minutes before
! a partial close-down.
! %RECORDFORMAT DUFFGLAF(%INTEGER FROM,TO)
RECORDFORMAT ENTF(INTEGER TYPE, (INTEGER DR0,DR1 OR INTEGER MAINEP, C
DUM1 OR INTEGER GLAFROM,GLATO OR INTEGER USECOUNT,ACCESSMODE), C
INTEGER LINK){Entry point or filename records}
RECORDFORMAT ESCF(INTEGER PC,RECAD, (INTEGER DR0,DR1 OR INTEGER DESCAD,ENTAD))
RECORDFORMAT FINDF(STRING (31) FILE, INTEGER DIRNO,TYPE,STATUS)
RECORDFORMAT FINDGLAF(STRING (31) FILE, INTEGER FROM,TO,GLASTART)
RECORDFORMAT IREFF(INTEGER DR0,DR1, (INTEGER OFFSET OR INTEGER ADYNR), C
INTEGER LINK) {Info rec}
RECORDFORMAT LD1F(INTEGER LINK,LOC, STRING (31) IDEN)
RECORDFORMAT LD4F(INTEGER LINK,DISP,L,A, STRING (31) IDEN)
RECORDFORMAT LD7F(INTEGER LINK,REFLOC, STRING (31) IDEN) { Also 8,11}
RECORDFORMAT LD9F(INTEGER LINK,REFARRAY,L, STRING (31) IDEN)
RECORDFORMAT LD13F(INTEGER LINK,A,DISP,LEN,REP,ADDR)
RECORDFORMAT LD14F(INTEGER LINK,N)
! %RECORDFORMAT LD14F(%INTEGER LINK,N, %RECORD(RELOCF)%ARRAY R(1:N))
! %RECORDFORMAT LLINFOF(%INTEGER TAB,GLA,ISTK)
RECORDFORMAT LNF(BYTEINTEGER TYPE, STRING (6) NAME, C
INTEGER REST,POINT,DR1)
RECORDFORMAT NAMEF(BYTEINTEGER TYPE, C
(STRING (10) NAME OR STRING (6) LNAME, INTEGER REST), C
INTEGER POINT)
RECORDFORMAT OFMF(INTEGER START,L,PROP)
! %RECORDFORMAT RELOCF(%INTEGER AREALOC,BASELOC)
RECORDFORMAT RF(INTEGER CONAD,FILETYPE,DATASTART,DATAEND)
! %RECORDFORMAT SCTABF(%STRING(31) NAME, %INTEGER I,J)
! %RECORDFORMAT SDIRF(%STRING(31) NAME, %INTEGER CONAD,TYPE) {While old/new}
! %RECORDFORMAT SDIRF(%STRING(31)NAME, %INTEGER CONAD)
! %RECORDFORMAT SSLF(%INTEGER START,LEN)
!
!***********************************************************************
!* *
!* Constants *
!* *
!***********************************************************************
!
CONSTBYTEINTEGERARRAY UNSHAREDAREA(1:5)=3,2,5,6,7
!
CONSTINTEGER ABASEOBJ=X'00800020'
CONSTINTEGER CMN=X'80000000',DYN=X'40000000',UNSAT=X'20000000',UNRES=X'10000000'
CONSTINTEGER DYNAMIC=0,UNRESOLVED=1,UNSATISFIED=2
CONSTINTEGER FNAMETYPE=0,DATA=1,CODE=2,MACRO=4,ALIAS=8
CONSTINTEGER FORTE=2
CONSTINTEGER K64=X'10000'
CONSTINTEGER LHOFFSET=1008 {251<<2 bytes of listheads}
CONSTINTEGER MAXFINDREC=128
CONSTINTEGER MAXLOADTABSIZE=X'00100000'; ! 1Mb
CONSTINTEGER MAXUGLASIZE=X'00400000'; ! Max size of user gla
CONSTINTEGER PRIME=251
CONSTINTEGER SEGSIZE=X'40000'
CONSTINTEGER SEGSHIFT=18
CONSTINTEGER SSBSTACKSEG=4; ! Segment no of base stack
CONSTINTEGER SSCHARFILETYPE=3
CONSTINTEGER SSDATAFILETYPE=4
CONSTINTEGER SSDIRFILETYPE=7
CONSTINTEGER SSOLDDIRFILETYPE=2
CONSTINTEGER SSOBJFILETYPE=1
CONSTINTEGER USTACKCONAD=X'02F80000'; ! Fixed address for user stack
!
CONSTINTEGERARRAYFORMAT LHF(0:PRIME)
!
CONSTLONGINTEGER CODEDR=X'E100000000000000'
CONSTLONGINTEGER DESCDR=X'B100000000000000'
CONSTLONGINTEGER ESCDR=X'E500000000000000'
CONSTLONGINTEGER NOTUSED=X'8282828282828282'
!
CONSTRECORD (SCTABF)ARRAYFORMAT SCTABAF(1:200)
!
CONSTSTRING (7) ASTACKNAME="T#ASTK"
CONSTSTRING (23) BASEDIR="SUBSYS.SYSTEM_BASEDIR"
CONSTSTRING (4) LASTFN="}{|~"; ! This can be used instead of a file name
! as a parameter to CONNECT, etc., to mean "the last file I nominated".
CONSTSTRING (11) LOADTABLES="T#LOAD"
CONSTSTRING (7) UGLANAME="T#UGLA"
CONSTSTRING (15) USEROOT="USEFOR fails - "
CONSTSTRING (7) USTACKNAME="T#USTK"
!
CONSTSTRING (7)ARRAY AREANAME(1:7)= C
"CODE","GLA ","PLT ","SST ","UST ","ICMN","ISTK"
CONSTSTRING (11)ARRAY MODLANG(0:10)= C
"unknown","IMP/IMP80","FORTE","IOPT","NASS","ALGOL","Opt code","PASCAL","SIMULA",
"BCPL","FORTRAN 77"
!
!***********************************************************************
!* *
!* %SYSTEM Routine/fn/map spec *
!* *
!***********************************************************************
!
SYSTEMINTEGERFNSPEC CHECKCOMMAND(STRING (255) COM)
SYSTEMINTEGERFNSPEC PARMAP
SYSTEMINTEGERFNSPEC PSTOI(STRING (63) S)
!
SYSTEMLONGREALFNSPEC CPUTIME
!
SYSTEMROUTINESPEC ALLOWINTERRUPTS
SYSTEMROUTINESPEC CHANGEACCESS(STRING (31) FILE, C
INTEGER MODE, INTEGERNAME FLAG)
SYSTEMROUTINESPEC CHANGEFILESIZE(STRING (31) FILE, C
INTEGER NEWSIZE, INTEGERNAME FLAG)
SYSTEMROUTINESPEC CONNECT(STRING (31) S, C
INTEGER MODE, HOLE, PROT, RECORD (RF)NAME R, INTEGERNAME FLAG)
SYSTEMROUTINESPEC DESTROY(STRING (31) FILE, INTEGERNAME FLAG)
SYSTEMROUTINESPEC DISCONNECT(STRING (31) FILE, INTEGERNAME FLAG)
SYSTEMROUTINESPEC DUMP(INTEGER FROM,TO)
SYSTEMROUTINESPEC FILL(INTEGER LEN,FROM,FILLER)
SYSTEMROUTINESPEC FILPS(STRINGNAME DPF,S)
SYSTEMROUTINESPEC MOVE(INTEGER L, FROM, TO)
SYSTEMROUTINESPEC NDIAG(INTEGER PC,LNB,FAULT,INF)
SYSTEMROUTINESPEC OUTFILE(STRING (31) S, C
INTEGER L, MAXB, USE, INTEGERNAME CONAD, FLAG)
SYSTEMROUTINESPEC PSYSMES(INTEGER ROOT,FLAG)
SYSTEMROUTINESPEC SETPAR(STRING (255) S)
SYSTEMROUTINESPEC SETUSE(STRING (31) FILE, INTEGER MODE,VALUE)
SYSTEMROUTINESPEC SIGNAL(INTEGER EP,P1,P2, INTEGERNAME FLAG)
SYSTEMROUTINESPEC SSTRACE(NAME FNRESULT, STRING (63) TMPL)
SYSTEMROUTINESPEC UCTRANSLATE(INTEGER AD,LEN)
!
SYSTEMSTRINGFNSPEC CONFILE(INTEGER AD)
SYSTEMSTRINGFNSPEC FAILUREMESSAGE(INTEGER I)
SYSTEMSTRING (8)FNSPEC HTOS(INTEGER VALUE,PLACES)
SYSTEMSTRINGFNSPEC ITOS(INTEGER I)
SYSTEMSTRINGFNSPEC NEXTTEMP
SYSTEMSTRINGFNSPEC SEGSINUSE(INTEGERNAME FIRSTSEG,LASTSEG, INTEGER SEGSTART)
SYSTEMSTRINGFNSPEC SPAR(INTEGER I)
!
!***********************************************************************
!* *
!* External/internal routine/fn/map specs *
!* *
!***********************************************************************
!
EXTERNALINTEGERFNSPEC DNEWOUTWARDCALL(INTEGER NEWACR,EMAS, C
NEWSTACKSEG,DR0,DR1, INTEGERNAME I,J)
EXTERNALINTEGERFNSPEC OUTPOS
EXTERNALINTEGERFNSPEC OUTSTREAM
EXTERNALINTEGERFNSPEC UINFI(INTEGER I)
!
EXTERNALROUTINESPEC CHANGECONTEXT
! %EXTERNALROUTINESPEC DPRINTSTRING(%STRING(255) S)
EXTERNALROUTINESPEC DSTOP(INTEGER REASON)
!
!***********************************************************************
!* *
!* Own variables *
!* *
!***********************************************************************
!
! %OWNINTEGER DYNDATAPC
! %OWNINTEGER DYNPC
! %OWNINTEGER EUDR0,EUDR1
! %OWNINTEGER LANG
! %OWNINTEGER LOADERGLA
! %OWNINTEGER MACRODR0=0,MACRODR1=0
! %OWNINTEGER MAINDR1=0
! %OWNINTEGER MAXUGLA
! %OWNINTEGER MONCONAD
! %OWNINTEGER SSDYNREFAD
! %OWNINTEGER SSTOPADIR
! %OWNINTEGER SSUGLASIZE=X'00010000'
! %OWNINTEGER TEMPISTK
! %OWNINTEGER TOPSCT
! %OWNINTEGER UNSATPC
! %OWNINTEGER USEFORDESCAD=0; ! Descriptor ad used by USEFOR
! %OWNINTEGER USERSTACKLNB=0
!
! %OWNINTEGERARRAY AREASTART(1:7) {Starting addresses of obj file areas}
! %OWNINTEGERARRAY NEXTAD(1:3)
! %OWNINTEGERARRAY SSLIBERR(1:4)
!
! %OWNINTEGERARRAYNAME RLH,PLH,TLH,SLH
!
! %OWNINTEGERNAME PERMOFFSET {Nextfree in perm entry table - mapped on to SSOWN_NEXTAD(2)}
! %OWNINTEGERNAME RCODE; ! Return code - maps on to SSCOMREG(24)
! %OWNINTEGERNAME TEMPOFFSET { Nextfree in temp entry tables - mapped on to SSOWN_NEXTAD(3)}
!
! %OWNLONGINTEGER DYNDR {S#DYNAMICREF entry desc}
! %OWNLONGINTEGER UNSATDR {S#UNSATREF entry desc}
!
! %OWNLONGREAL MONTIMEBASE=0
!
! %OWNRECORD(DUFFGLAF)%ARRAY DUFFGLA(0:63)=0(512)
! %OWNRECORD(SDIRF)%ARRAY SSADIR(-1:16) {Search dir list}
! %OWNRECORD(SSLF)%ARRAY SSLOADTAB(0:3)
!
! %OWNRECORD(SCTABF)%ARRAYNAME SCT
!
! %OWNSTRING(31) USEFORLASTNAME=""
!
! %OWNSTRING(31)%ARRAY PARTLOADED(0:2)=""(3)
!
!***********************************************************************
!* *
!* Extrinsic variables *
!* *
!***********************************************************************
!
! %EXTRINSICINTEGER DIRDISCON
! %EXTRINSICINTEGER INITSTACKSIZE
! %EXTRINSICINTEGER LOADMONITOR
! %EXTRINSICINTEGER SSADEFOPT
! %EXTRINSICINTEGER SSASTACKSIZE
! %EXTRINSICINTEGER SSAUXDR0
! %EXTRINSICINTEGER SSAUXDR1
! %EXTRINSICINTEGER SSCURAUX
! %EXTRINSICINTEGER SSCURBGLA
! %EXTRINSICINTEGER SSDIRAD
! %EXTRINSICINTEGER SSINHIBIT,SSINTCOUNT; ! These two must stay together
! %EXTRINSICINTEGER SSMAXAUX
! %EXTRINSICINTEGER SSMAXFSIZE
! %EXTRINSICINTEGER SSMAXBGLA
! %EXTRINSICINTEGER SSOPENUSED
! %EXTRINSICINTEGER SSUSTACKSIZE
! %EXTRINSICINTEGER TEMPAVDSET; ! Used by PLU packages
!
! %EXTRINSICINTEGERARRAY SSCOMREG(0:60)
!
! %EXTRINSICSTRING(31) AVD{ACTIVEDIR}
! %EXTRINSICSTRING(40) SSFNAME
! %EXTRINSICSTRING(6) SSOWNER
!
!***********************************************************************
!* *
!* External variables *
!* *
!***********************************************************************
!
! %EXTERNALINTEGER LOADINPROGRESS=0
! %EXTERNALINTEGER LOADLEVEL=1
! %EXTERNALINTEGER MONFILEAD=0
! %EXTERNALINTEGER MONFILETOP
! %EXTERNALINTEGER NOWARNINGS=FALSE; ! Print warning messages by default
! %EXTERNALINTEGER PERMISTK
! %EXTERNALINTEGER USTB=0
!
! %EXTERNALRECORD(LLINFOF)%ARRAY LLINFO(-1:31)=0(396)
!
! %EXTERNALSTRING(31) MONFILE=""
!
!
!***********************************************************************
!* *
!* End of declarations *
!* *
!***********************************************************************
!
!
ROUTINESPEC UNLOAD2(INTEGER LOCLL,FAIL)
!
!
ROUTINE TERMINALPRINT(STRING (255) S1,S2)
! Outputs to stream 0 then selects original output stream.
! Used to ensure that load monitoring and messages during the loading
! liable to be done for a dynamic call are written to the console and not
! the current output file.
INTEGER CUROUT
CUROUT=OUTSTREAM
SELECTOUTPUT(0)
IF OUTPOS#0 THEN NEWLINE
PRINTSTRING(S1)
PRINTSTRING(S2)
NEWLINE
SELECTOUTPUT(CUROUT)
RETURN
END ; ! OF TERMINALPRINT
!
!
SYSTEMROUTINE STOP
! Routine to reset the auxstack and return tidyly in the event
! of a failure
INTEGER I
IF SSOWN_LOADINPROGRESS#FALSE THEN UNLOAD2(1,1); ! UNLOAD2 resets LOADINPROGRESS
IF SSOWN_FULLDUMP#0 THEN SSOWN_FULLDUMP=0
IF SSOWN_SSAUXDR1#0 THEN START
INTEGER(SSOWN_SSAUXDR1)=SSOWN_SSCURAUX
INTEGER(SSOWN_SSAUXDR1+8)=SSOWN_SSMAXAUX
FINISH
IF SSOWN_SSCOMREG(36)#0 THEN START
I=SSOWN_SSCOMREG(36)
*LLN_I
*EXIT_0
FINISH
DSTOP(105); ! In case comreg(36) not set - hardly likely but still...
END ; ! OF STOP
!
!
SYSTEMROUTINE RETURN TO COMMAND LEVEL
! Routine to reset the auxstack and return to command level
INTEGER I
IF SSOWN_USERSTACKLNB=0 THEN STOP
IF SSOWN_LOADINPROGRESS#FALSE THEN UNLOAD2(1,1); ! UNLOAD2 resets LOADINPROGRESS
IF SSOWN_FULLDUMP#0 THEN SSOWN_FULLDUMP=0
IF SSOWN_SSAUXDR1#0 THEN START
INTEGER(SSOWN_SSAUXDR1)=SSOWN_SSCURAUX
INTEGER(SSOWN_SSAUXDR1+8)=SSOWN_SSMAXAUX
FINISH
! Now get the LNB for command level, reset SSOWN_SSCOMREG(36), load the LNB
! and exit
SSOWN_SSCOMREG(36)=SSOWN_USERSTACKLNB
I=SSOWN_USERSTACKLNB
*LLN_I
*EXIT_0
END ; ! OF RETURN TO COMMAND LEVEL
!
!
LONGINTEGERFNSPEC CHECKLOADED(STRING (31) ENTRY, C
INTEGERNAME TYPE,LISTHEAD)
!
SYSTEMROUTINE INITLOADER(INTEGERNAME FLAG)
! Routine is called once from SSINIT at startup time.
! This routine creates the loader tables and adds the system call table
! to the perm loaded table. File is 3 pages initially: 1 for refs, 1 for
! permloaded entries and 1 for temploaded entries.
! LLINFO fields are initialised where possible.
INTEGERARRAYNAME RLH,PLH,TLH,SLH
RECORD (SCTABF)ARRAYNAME SCT
RECORD (DIRINFF)NAME DIRINF
LONGINTEGER DESC
INTEGER TYPE,LHD,ADIRINF,I
! Map subsystem entry listheads
SLH==ARRAY(SSOWN_SSDIRAD+32,LHF)
SSOWN_SLH==SLH
OUTFILE(LOADTABLES,X'3000',MAXLOADTABSIZE,0,SSOWN_SSLOADTAB(0)_START,FLAG)
IF FLAG#0 THEN DSTOP(123); ! Unable to create T#LOAD
! Note that T#LOAD will always be connected at this address.
IF NEWCONNECT=0 THEN SETUSE(LOADTABLES,1,0); ! Increment use count
INTEGER(SSOWN_SSLOADTAB(0)_START)=X'3000'
INTEGER(SSOWN_SSLOADTAB(0)_START+4)=32
SSOWN_SSLOADTAB(0)_LEN=32
SSOWN_SSLOADTAB(1)_START=SSOWN_SSLOADTAB(0)_START+32
SSOWN_SSLOADTAB(1)_LEN=X'1000'-32
SSOWN_SSLOADTAB(2)_START=SSOWN_SSLOADTAB(0)_START+X'1000'
SSOWN_SSLOADTAB(2)_LEN=X'1000'
SSOWN_SSLOADTAB(3)_START=SSOWN_SSLOADTAB(0)_START+X'2000'
SSOWN_SSLOADTAB(3)_LEN=X'1000'
SSOWN_PERMOFFSET==SSOWN_NEXTAD(2)
SSOWN_TEMPOFFSET==SSOWN_NEXTAD(3)
SSOWN_NEXTAD(I)=LHOFFSET FOR I=3,-1,1
! Fill ref table with X'82'
FILL(SSOWN_SSLOADTAB(1)_LEN-LHOFFSET,SSOWN_SSLOADTAB(1)_START+LHOFFSET,X'82')
! Initialise LLINFO
! LLINFO(-1) holds the starting values of the perm items.
SSOWN_LLINFO(0)_TAB=SSOWN_PERMOFFSET
SSOWN_LLINFO(-1)_TAB=SSOWN_PERMOFFSET
SSOWN_LLINFO(1)_TAB=SSOWN_TEMPOFFSET
! LLINFO(0)_GLA initialised by INITDYNAMICREFS
! LLINFO(0)_ISTK and LLINFO(1)_ISTK initialised by INITUSTK
! LLINFO(1)_GLA initialised by GETGLA
RLH==ARRAY(SSOWN_SSLOADTAB(1)_START,LHF)
PLH==ARRAY(SSOWN_SSLOADTAB(2)_START,LHF)
TLH==ARRAY(SSOWN_SSLOADTAB(3)_START,LHF)
SSOWN_RLH==RLH
SSOWN_PLH==PLH
SSOWN_TLH==TLH
! Map on to system call list
ADIRINF=UINFI(10)
DIRINF==RECORD(ADIRINF)
SCT==ARRAY(DIRINF_SCIDENSAD,SCTABAF)
SSOWN_SCT==SCT
SSOWN_TOPSCT=DIRINF_SCIDENS
!
TYPE=CODE
LHD=-1
DESC=CHECKLOADED("S#ENTERONUSERSTACK",TYPE,LHD)
LONGINTEGER(ADDR(SSOWN_EUDR0))=DESC
LHD=-1
DESC=CHECKLOADED("S#ICLMATHSERRORROUTINE",TYPE,LHD)
LONGINTEGER(ADDR(SSOWN_SSLIBERR(1)))=DESC
SSOWN_SSCOMREG(13)=ADDR(SSOWN_SSLIBERR(1)); ! Needed by BASIC
SSOWN_SSCOMREG(58)=ADDR(SSOWN_MAINDR1); ! Needed by COBOL run
RETURN
END ; ! OF INITLOADER
!
!
ROUTINE INITUSTK
! SYSTEM Routine eventually
! Initialises the user stack and sets up pointers to the initialised
! stack reserved areas
INTEGER FLAG,I
SSOWN_USTB=USTACKCONAD
OUTFILE(USTACKNAME,SSOWN_SSUSTACKSIZE,0,X'40',SSOWN_USTB,FLAG)
IF FLAG#0 THEN START
SSOWN_USTB=0
TERMINALPRINT("Unable to create USERSTACK - ",FAILUREMESSAGE(FLAG))
RETURN TO COMMAND LEVEL
FINISH
IF NEWCONNECT=0 THEN SETUSE(USTACKNAME,1,0); ! Inc use count
SSOWN_TEMPISTK=SSOWN_USTB+32
SSOWN_PERMISTK=SSOWN_USTB+SSOWN_INITSTACKSIZE
INTEGER(SSOWN_USTB)=SSOWN_INITSTACKSIZE!4; ! To make sure new stack starts on odd word
SSOWN_LLINFO(-1)_ISTK=SSOWN_PERMISTK; ! Base value if loader tabs reset
SSOWN_LLINFO(0)_ISTK=SSOWN_PERMISTK
SSOWN_LLINFO(I)_ISTK=SSOWN_TEMPISTK FOR I=SSOWN_LOADLEVEL,-1,1; ! In case LOADLEVEL>1
! **Comment** The trouble with this approach is that there may be a lot
! of paging between initialised and normal user stack but its the only way
! of easily implementing 'permanently loaded' ISTK. Perhaps worth thinking
! about though.
RETURN
END ; ! OF INITUSTK
!
!
ROUTINE INITAUXSTACK
! Initialises the auxiliary stack.
INTEGER FLAG
OUTFILE(ASTACKNAME,SSOWN_SSASTACKSIZE,SSOWN_SSASTACKSIZE,0,SSOWN_SSAUXDR1,FLAG)
IF FLAG#0 THEN TERMINALPRINT("Create AUXSTACK fails - ", C
FAILUREMESSAGE(FLAG)) AND RETURN TO COMMAND LEVEL
IF NEWCONNECT=0 THEN SETUSE(ASTACKNAME,1,0)
SSOWN_SSMAXAUX=SSOWN_SSAUXDR1+SSOWN_SSASTACKSIZE
SSOWN_SSCURAUX=SSOWN_SSAUXDR1+32
INTEGER(SSOWN_SSAUXDR1)=SSOWN_SSCURAUX
INTEGER(SSOWN_SSAUXDR1+8)=SSOWN_SSMAXAUX
SSOWN_SSAUXDR0=X'28000000'!(SSOWN_SSASTACKSIZE>>2); ! Word vector descriptor
SSOWN_SSCOMREG(41)=ADDR(SSOWN_SSAUXDR0)
RETURN
END ; ! OF INITAUXSTACK
!
!
INTEGERFNSPEC HASH(STRING (31) ENTRY, INTEGER HASHCONST)
ROUTINESPEC ADDREF(STRING (31) ENTRY, INTEGERNAME FLAG, C
INTEGER DR0,AD,TYPE,STATUS,LOCLL,POS,NREFS)
!
SYSTEMROUTINE INITDYNAMICREFS
! Called by SSINIT at startup time.
! This routine has two functions -
! 1. Sets up code and branches to handle dynamic and unresolved refs
! from user programs
! 2. Deal with dynamic refs within the subsystem itself.
INTEGERARRAYFORMAT LDATAAF(0:15)
INTEGERARRAYNAME LDATA
RECORD (LD7F)NAME LD8
INTEGER I,PC,LSTART,ABGLA,AD,LHD,FLAG,TYPE,REFLOC
! Get DYNPC and SSOWN_UNSATPC. Need these before can call ADDREF
*JLK_3
*J_<DYNREF>
*LSS_TOS ; ! TOS now contains addr of jump to DYNREF
*ST_PC
SSOWN_DYNPC=PC; ! To ensure accessing %OWN does not have unexpected effect
*JLK_3
*J_<DYNDATAREF>
*LSS_TOS
*ST_PC
SSOWN_DYNDATAPC=PC
*JLK_3
*J_<UNSATREF>
*LSS_TOS
*ST_PC
SSOWN_UNSATPC=PC
!
! Now get entry descriptors of S#DYNAMIC and S#UNSATREF
TYPE=CODE
LHD=-1
SSOWN_DYNDR=CHECKLOADED("S#DYNAMICREF",TYPE,LHD)
LHD=-1
SSOWN_UNSATDR=CHECKLOADED("S#UNSATREF",TYPE,LHD)
! Deal with subsystem dynamic refs
SSOWN_DYNREFSTART=SSOWN_SSCURBGLA
LSTART=ABASEOBJ+INTEGER(ABASEOBJ+24); ! Load data
LDATA==ARRAY(LSTART,LDATAAF)
I=LDATA(8); ! Dynamic refs listhead
! ABGLA=ABASEFILE+((INTEGER(ABASEFILE)+X'0003FFFF')&X'FFFC0000')
! ABGLA=SSOWN_SSCURBGLA&X'FFFC0000'; ! Start of BGLA
ABGLA=ABASEOBJ+INTEGER(ABASEOBJ+INTEGER(ABASEOBJ+28)+16)
SSOWN_AREASTART(1)=ABGLA; ! Dummy to fool ADDREF
AD=ADDR(REFLOC); ! Ditto
WHILE I#0 CYCLE
LD8==RECORD(ABASEOBJ+I)
REFLOC=(LD8_REFLOC&X'00FFFFFF')!X'01000000'; ! Dummy REFLOC
LHD=HASH(LD8_IDEN,PRIME)
ADDREF(LD8_IDEN,FLAG,0,AD,CODE,DYNAMIC,0,LHD,1)
IF FLAG>0 THEN DSTOP(125); ! Failure adding subsystem dynamic refs to T#LOAD
I=LD8_LINK
REPEAT
SSOWN_LLINFO(0)_GLA=SSOWN_SSCURBGLA
SSOWN_LLINFO(-1)_GLA=SSOWN_SSCURBGLA
SSOWN_DYNREFEND=SSOWN_SSCURBGLA; ! So that a call of RESETLOADER can restore
! the subsys dynamic refs. Only ss dynamic refs will have
! SSOWN_DYNREFSTART<=R2_ADYNR<OWN_SSDYNREFEND
! Note that SSOWN_DYNREFEND and SSOWN_LLINFO(-1)_GLA are not necessarily
! always the same. Student subsystems tinker with LLINFO(-1) later.
RETURN ; ! End of initialisation sequence
!
! Come here on escape jump from user prog for dynamic code refs
DYNREF:
! Preserve environment for eventual call. For an external call then
! the only registers that have to be saved are LNB and PSR (also
! sprach PDS). The DR register contains the address of the escape table.
! At DR+8 we have
! the address of the location in the gla where the code descriptor has
! to go. In certain situations, unusual but not that unusual, the location
! in the gla may already be fixed up while there is an escape descriptor
! to the same item on the stack. When this happens it is likely that the
! reference will already have been removed from the reference tables so
! that the call to DYNAMICREF will produce gibberish at best. What must be
! done here is to compare the escape descriptor and the descriptor at
! the intended fix up location. If these are not the same then load the
! descriptor at the fix up location into ACC and jump to the post call
! code for the normal situation.
! If the descriptors are both escape then proceed thus:
! We must get DYNDR or UNSATDR into the DR register. These have known
! addresses by virtue of their positions in the SSOWN record, so after stacking
! the params to S#DYNAMICREF or S#UNSATREF we construct a descriptor to
! DYNDR or UNSATDR and haul it out of SSOWN on to the stack from whence
! we load it into %DR then call the routine.
! So begin by saving what has to be saved
*STLN_TOS ; ! Store LNB
*CPSR_TOS ; ! Copy PM,CC,ACS to TOS
! Compare address fields of escape descriptor and descriptor at ref address
*LCT_(DR +8); ! Load address of fix up location
*CYD_0; ! Copy escape descriptor to ACC
*STUH_B ; ! Throw away descriptor, decrement ACS
*UCP_(CTB +1); ! Logical compare with address field at fix up locn
*JCC_8,<EQUAL>
! If here then ref already fixed up
*LSD_(CTB ); ! Load ACC with code descriptor from fixed up loc
*J_<POSTCALL>
! Normal sequence
EQUAL:
*PRCL_4; ! Prepare for call
*STD_TOS ; ! Use escape desc as params to S#DYNAMICREF
*LD_X'3000000100100000'; ! Descriptor to SSOWN_DYNDR
*LSD_(DR ); ! Get DYNDR into the ACC
*ST_TOS ; ! Stack it
*LD_TOS ; ! Load DR with desc to S#DYNAMICREF
*RALN_7; ! Raise LNB to SF-7
*CALL_(DR ); ! Call S#DYNAMICREF
! Now if we couldn't find the ref then we won't return here from
! S#DYNAMICREF. The fact that we have means the descriptor is in the
! ACC as the %RESULT of S#DYNAMICREF
POSTCALL:
*ST_TOS
*LD_TOS ; ! DR now contains entry desc, now restore environment
*MPSR_TOS ; ! This resets ACS
*LLN_TOS
*ESEX_0; ! Resume processing
!
DYNDATAREF:
! Come here on encountering a dynamic data ref
! Must preserve whole environment when handling dynamic data refs
! WARNING. Certain types of data ref are accessed via XNB so the
! escape sequence would never be encountered - e.g. %extrinsic record fields.
! However for most simple data refs this sequence will be executed.
*STLN_TOS ; ! Store LNB
*ST_TOS ; ! Store ACC - length depends on ACS
*STB_TOS ; ! Store B
*CPSR_B ; ! Copy PM,CC,ACS to B
*ADB_16; ! Set bit 27(ICL) for MPSR to restore ACS
*STB_TOS ; ! And stack it
*STXN_TOS ; ! Store XNB
*STCT_TOS ; ! Store CTB
*PRCL_4; ! Prepare for call
*STD_TOS ; ! Use escape desc as params to S#DYNAMICREF
*LD_X'3000000100100000'; ! Descriptor to DYNDR
*LSD_(DR ); ! Get DYNDR into ACC
*ST_TOS ; ! Stack it
*LD_TOS ; ! Load DR with descriptor to S#DYNAMICREF
*RALN_7; ! Raise LNB to SF-7
*CALL_(DR ); ! Call S#DYNAMICREF
! Descriptor req is in ACC after call
*ST_TOS
*LD_TOS ; ! DR now contains data descriptor required
! Restore environment
*LCT_TOS
*LXN_TOS
*MPSR_TOS ; ! This resets ACS
*LB_TOS
*L_TOS
*LLN_TOS
*ESEX_0; ! Resume processing
!
UNSATREF:
! Get PC of unresolved ref then call S#UNSATREF
! No return from S#UNSATREF
! Get UNSATDR
*LSS_TOS ; ! PC of failing routine
*PRCL_4
*STD_TOS ; ! DR0,DR1 params for S#UNSATREF
*ST_TOS ; ! PC param for S#UNSATREF
*LD_X'3000000100100008'; ! Descriptor to UNSATDR
*LSD_(DR ); ! Get UNSATDR into ACC
*ST_TOS ; ! Stack it
*LD_TOS ; ! Load DR with desc for S#UNSATREF
*RALN_8
*CALL_(DR ); ! Call S#UNSATREF
END ; ! OF INITDYNAMICREF
!
!
INTEGERFN DYNLOAD
! Result is TRUE if LOADPARM MIN set
RESULT =SSOWN_SSCOMREG(39)&1
END ; ! OF DYNLOAD
!
!
INTEGERFN LET
! Result#0 if LOADPARM LET is set
RESULT =SSOWN_SSCOMREG(39)&2
END ; ! OF LET
!
!
SYSTEMINTEGERFN CURRENTLL
! Result is the current value of the overall LOADLEVEL
RESULT =SSOWN_LOADLEVEL
END ; ! OF CURRENTLL
!
!
SYSTEMINTEGERFN CURSTACK
! Result is 0 if running on base stack, else 1
INTEGER LNB
*STLN_LNB
IF LNB>>SEGSHIFT=SSBSTACKSEG THEN RESULT =0 ELSE RESULT =1
END ; ! OF CURSTACK
!
!
ROUTINE MONFAIL(INTEGER FLAG)
! Called if load monitoring to a file fails.
TERMINALPRINT("Load monitoring to file ".SSOWN_MONFILE." fails - ", C
FAILUREMESSAGE(FLAG)."
Monitor switched to terminal.")
SSOWN_MONFILE=""
SSOWN_MONFILEAD=0
SSOWN_MONFILETOP=0
RETURN
END ; ! OF MONFAIL
!
!
ROUTINE MONOUT(STRING (255) S)
LONGREAL TIM
RECORD (RF) RR
STRING (11) STIM
INTEGER L1,L2,AD,I,J,VMHOLEOK,FLAG
IF SSOWN_MONTIMEBASE=0 THEN SSOWN_MONTIMEBASE=CPUTIME
TIM=CPUTIME-SSOWN_MONTIMEBASE
! Turn TIM into suitable string for output.
STIM=ITOS(INTPT(FRACPT(TIM)*1000))
STIM="0".STIM WHILE LENGTH(STIM)<3
STIM=ITOS(INTPT(TIM)).".".STIM." "
TERMINAL OUTPUT:
IF SSOWN_MONFILE="" THEN TERMINALPRINT(STIM,S) AND RETURN
! If here then ouputting direct to file
L1=LENGTH(STIM)
L2=LENGTH(S)
! Is there room in MONFILE for STIM+S+newline?
IF SSOWN_MONFILEAD+L1+L2+1>=SSOWN_MONFILETOP THEN START
IF SSOWN_MONFILEAD=0 THEN START
! Create it.
OUTFILE(SSOWN_MONFILE,X'1000',0,0,SSOWN_MONCONAD,FLAG)
IF FLAG#0 THEN START
MONFAIL(FLAG)
->TERMINAL OUTPUT
FINISH
IF NEWCONNECT=0 THEN SETUSE(SSOWN_MONFILE,1,0)
SSOWN_MONFILEAD=X'20'
SSOWN_MONFILETOP=X'1000'
FINISH ELSE START
IF SSOWN_MONFILETOP&X'3FFFF'=0 THEN VMHOLEOK=FALSE ELSE VMHOLEOK=TRUE
! Try to extend the file
! If MONFILETOP is segment aligned then DISCONNECT
! MONFILE since we may need a bigger VM hole.
IF VMHOLEOK=FALSE THEN START
IF NEWCONNECT=0 THEN SETUSE(SSOWN_MONFILE,-1,0)
DISCONNECT(SSOWN_MONFILE,FLAG)
IF FLAG#0 THEN START
MONFAIL(FLAG)
->TERMINAL OUTPUT
FINISH
FINISH
SSOWN_MONFILETOP=SSOWN_MONFILETOP+X'1000'
CHANGEFILESIZE(SSOWN_MONFILE,SSOWN_MONFILETOP,FLAG)
IF FLAG#0 THEN START
MONFAIL(FLAG)
->TERMINAL OUTPUT
FINISH
IF NEWCONNECT=0 THEN SETUSE(SSOWN_MONFILE,1,0)
IF VMHOLEOK=FALSE THEN START
CONNECT(SSOWN_MONFILE,3,0,0,RR,FLAG)
IF FLAG#0 THEN START
MONFAIL(FLAG)
->TERMINAL OUTPUT
FINISH
SSOWN_MONCONAD=RR_CONAD
FINISH
INTEGER(SSOWN_MONCONAD+8)=SSOWN_MONFILETOP; ! Update header file size
FINISH
FINISH
! Put the new entry into MONFILE
J=SSOWN_MONCONAD+SSOWN_MONFILEAD
AD=ADDR(STIM)
FOR I=1,1,L1 CYCLE
BYTEINTEGER(J)=BYTEINTEGER(AD+I)
J=J+1
REPEAT
AD=ADDR(S)
FOR I=1,1,L2 CYCLE
BYTEINTEGER(J)=BYTEINTEGER(AD+I)
J=J+1
REPEAT
BYTEINTEGER(J)=X'0A'
SSOWN_MONFILEAD=SSOWN_MONFILEAD+L1+L2+1
INTEGER(SSOWN_MONCONAD)=SSOWN_MONFILEAD; ! Update file header DATAEND field
RETURN
END ; ! OF MONOUT
!
!
INTEGERFN INITHASH(STRING (31) NAME)
INTEGER A,J,L,A1,A2
A=ADDR(NAME)
L=BYTEINTEGER(A)
IF L>8 THEN START
! Close up last 4 to first 4
A1=A+5
A2=A+L-3
BYTEINTEGER(A1+J)=BYTEINTEGER(A2+J) FOR J=3,-1,0
FINISH ELSE NAME=NAME."<>#@!+&"
RESULT =BYTEINTEGER(A+1)*71+BYTEINTEGER(A+2)*47+BYTEINTEGER(A+3)*97+ C
BYTEINTEGER(A+4)*79+BYTEINTEGER(A+5)*29+BYTEINTEGER(A+6)*37+ C
BYTEINTEGER(A+7)*53+BYTEINTEGER(A+8)*59
END ; ! OF INITHASH
!
!
INTEGERFN HASH(STRING (31) NAME, INTEGER HASHCONST)
INTEGER A,J,W,L,A1,A2
A=ADDR(NAME)
L=BYTEINTEGER(A)
IF L>8 THEN START
! Close up last 4 to first 4
A1=A+5
A2=A+L-3
BYTEINTEGER(A1+J)=BYTEINTEGER(A2+J) FOR J=3,-1,0
FINISH ELSE NAME=NAME."<>#@!+&"
W=BYTEINTEGER(A+1)*71+BYTEINTEGER(A+2)*47+BYTEINTEGER(A+3)*97+ C
BYTEINTEGER(A+4)*79+BYTEINTEGER(A+5)*29+BYTEINTEGER(A+6)*37+ C
BYTEINTEGER(A+7)*53+BYTEINTEGER(A+8)*59
RESULT =W-(W//HASHCONST)*HASHCONST
END ; ! OF HASH
!
!
INTEGERFN OLDHASH(STRING (31) NAME, INTEGER HASHCONST)
! TEMPORARY while old directories still valid
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 OLDHASH
!
!
ROUTINE CONNDIRS
! Routine rebuilds loader search list. Activated when DIRDISCON#0
!
ROUTINE CONDIR(STRING (31) FILE)
INTEGER FLAG
RECORD (RF) RR
! Connect a file. Check it's a directory.
! Add it to list of directories in SSADIR.
! Increment count in SSOWN_SSTOPADIR.
! TEMPORARILY accepts old and new style directories
CONNECT(FILE,1,0,0,RR,FLAG)
IF FLAG=218 AND FILE=SSOWN_AVD{ACTIVEDIR} THEN START
! There is no ACTIVE DIR so leave hole
SSOWN_SSADIR(SSOWN_SSTOPADIR)=0
SSOWN_SSTOPADIR=SSOWN_SSTOPADIR+1
RETURN
FINISH
IF FLAG=0 AND SSOLDDIRFILETYPE#RR_FILETYPE#SSDIRFILETYPE THEN START
IF NEWCONNECT#0 THEN DISCONNECT (LASTFN, FLAG)
FLAG=267
SSOWN_SSFNAME=FILE; ! Not a directory
FINISH
IF FLAG#0=SSOWN_NOWARNINGS THEN TERMINALPRINT("*Warning - Connect directory fails - ", C
FAILUREMESSAGE(FLAG)) AND NEWLINE AND RETURN
IF SSOWN_SSTOPADIR>0 AND RR_CONAD=SSOWN_SSADIR(-1)_CONAD THEN START
IF NEWCONNECT#0 THEN SETUSE (LASTFN, -1, 0)
RETURN
FINISH
! SEARCHDIR=ACTIVEDIR so ignore SEARCHDIR
IF NEWCONNECT=0 THEN SETUSE(FILE,1,0)
SSOWN_SSTOPADIR = SSOWN_SSTOPADIR+1
SSOWN_SSADIR(SSOWN_SSTOPADIR)_NAME=FILE
SSOWN_SSADIR(SSOWN_SSTOPADIR)_CONAD=RR_CONAD
SSOWN_SSADIR(SSOWN_SSTOPADIR)_TYPE=RR_FILETYPE
RETURN
END ; ! OF CONDIR
!
INTEGER I,FLAG
RECORD (CONTF)NAME C
RECORD (RF) RR
SETUSE(SSOWN_SSADIR(I)_NAME,-1,0) FOR I=SSOWN_SSTOPADIR,-1,-1
! Reduce use counts on old directory list
SSOWN_SSTOPADIR=-2; ! Forget all previously known directories.
CONNECT(SSOWN_OPTIONSFILE,1,0,0,RR,FLAG)
! %IF FLAG#0 %THEN RR_CONAD=SSOWN_SSADEFOPT %ELSE SETUSE(SSOWN_OPTIONSFILE,1,0)
IF FLAG#0 THEN RR_CONAD=SSOWN_SSADEFOPT; ! Meantime
C==RECORD(RR_CONAD)
IF SSOWN_TEMPAVDSET=0 THEN SSOWN_AVD=C_MODDIR; ! In case updated by other than OPTION
CONDIR(SSOWN_AVD{ACTIVEDIR}); ! Yes it's that CONDIR moment.......sorry!
CONDIR(BASEDIR); ! Subsystem base directory
! Don't search searchdirs if temp active dir in use
IF SSOWN_TEMPAVDSET=0 START
I=0
WHILE I<C_SEARCHDIRCOUNT CYCLE
I=I+1
CONDIR(C_SEARCHDIR(I))
REPEAT
FINISH
SSOWN_DIRDISCON = 0; ! Search list rebuilt
RETURN
END ; ! OF CONNDIRS
!
!
SYSTEMROUTINE BDIRLIST
CONNDIRS; ! Rebuild searchlist
SSOWN_DIRDISCON=0
RETURN
END ; ! OF BDIRLIST
!
!
SYSTEMROUTINE TEMPDIR(STRING (31) FILE, INTEGERNAME FLAG)
! Copies FILE into T#DIR then nominates T#DIR as active dir till return
! to command level
RECORD (RF) RR
INTEGER CONAD
CONNECT(FILE,1,0,0,RR,FLAG)
RETURN IF FLAG#0
IF SSOLDDIRFILETYPE#RR_FILETYPE#SSDIRFILETYPE THEN START
DISCONNECT (LASTFN, FLAG)
SSOWN_SSFNAME=FILE
FLAG=267
RETURN
FINISH
OUTFILE("T#DIR",RR_DATAEND,0,0,CONAD,FLAG)
RETURN IF FLAG#0
! Now make copy
MOVE(RR_DATAEND,RR_CONAD,CONAD)
IF NEWCONNECT#0 THEN START
SETUSE (LASTFN, -1, 0)
SETUSE (FILE, -1, 0)
FINISH
SSOWN_AVD{ACTIVEDIR}="T#DIR"
SSOWN_TEMPAVDSET=1
SSOWN_SSOPENUSED=1; ! To ensure TIDYFILES called
CONNDIRS; ! Rebuild search list
RETURN
END ; ! OF TEMPDIR
!
!
!***********************************************************************
!* *
!* LOADER SEARCH MODULE *
!* *
!***********************************************************************
!
!
LONGINTEGERFN SEARCHSUBSYS(STRING (31) ENTRY, INTEGERNAME TYPE, C
INTEGER LISTHEAD)
INTEGER POINT,LEN,LENE
LONGINTEGER RES
IF SSOWN_SLH(LISTHEAD)=0 THEN START ; ! Nothing on chain
RES=0
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"SNIR")
RESULT =0
FINISH
POINT=SSOWN_SLH(LISTHEAD)+SSOWN_SSDIRAD; ! Address of first item off listhead
WHILE STRING(POINT)#"" CYCLE
LEN=BYTEINTEGER(POINT)
LENE=(LEN+9)&X'FFFFFFF8'; ! Bytes of name
IF STRING(POINT)=ENTRY AND BYTEINTEGER(POINT+LEN+1)&TYPE#0 THEN START
TYPE=BYTEINTEGER(POINT+LEN+1)
RES=LONGINTEGER(POINT+LENE)
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"SNIr")
RESULT =RES
FINISH
POINT=POINT+LENE+8
REPEAT
RES=0
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"SNIR")
RESULT =0; ! Not there
END ; ! OF SEARCHSUBSYS
!
!
LONGINTEGERFN SEARCHSCL(STRING (31) ENTRY, INTEGERNAME TYPE)
! Search Director's system call list. This list is ordered alphabetically
! so use binary chop. Note that all entries are of type CODE so return
! unless definitely looking for CODE type entries.
LONGINTEGER SCDR
INTEGER LO,HI,I
IF TYPE&CODE=0 THEN START
SCDR=0
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(SCDR,"SNR")
RESULT =0
FINISH
LO=1
HI=SSOWN_TOPSCT
WHILE LO<=HI CYCLE
I=(LO+HI)>>1
IF SSOWN_SCT(I)_NAME=ENTRY THEN START
TYPE=CODE
SCDR=X'E3000000'!SSOWN_SCT(I)_I
SCDR=(SCDR<<32)!SSOWN_SCT(I)_J
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(SCDR,"SNr")
RESULT =SCDR
FINISH
IF SSOWN_SCT(I)_NAME>ENTRY THEN HI=I-1 ELSE LO=I+1
REPEAT
SCDR=0
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(SCDR,"SNR")
RESULT =0; ! Not found
END ; ! OF SEARCHSCL
!
!
LONGINTEGERFN SEARCHLOADED(STRING (31) ENTRY, INTEGERNAME TYPE, C
INTEGER LISTHEAD)
RECORD (ENTF)NAME ENT
LONGINTEGER DESC
INTEGER I,START,J,RECAD,LENE,XTYPE
FOR I=2,1,3 CYCLE
START=SSOWN_SSLOADTAB(I)_START
IF I=2 THEN J=SSOWN_PLH(LISTHEAD) ELSE J=SSOWN_TLH(LISTHEAD)
WHILE J>0 CYCLE
RECAD=START+J
LENE=(BYTEINTEGER(RECAD)+4)&X'FFFFFFFC'
ENT==RECORD(RECAD+LENE)
XTYPE=ENT_TYPE&X'1FFFFFFF'; ! Off special entry bits
IF STRING(RECAD)=ENTRY AND (XTYPE&TYPE#0 OR TYPE=0) THEN START
IF TYPE=0 THEN START
! Filename search
IF SSOWN_MAINDR1=0 AND ENT_MAINEP#0 THEN SSOWN_MAINDR1=ENT_MAINEP
DESC=1
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(DESC,"SNIR")
RESULT =1; ! i.e. TRUE - the file is loaded
FINISH ELSE START
TYPE=XTYPE
DESC=ENT_DR0
DESC=(DESC<<32)!ENT_DR1
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(DESC,"SNIr")
RESULT =DESC
FINISH
FINISH
J=ENT_LINK
REPEAT
REPEAT
DESC=0
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(DESC,"SNIR")
RESULT =0; ! Not there
END ; ! OF SEARCHLOADED
!
!
LONGINTEGERFN CHECKLOADED(STRING (31) ENTRY, INTEGERNAME TYPE,LISTHEAD)
! Search currently loaded material for ENTRY. LISTHEAD will be <0 if it
! is not already known.
LONGINTEGER DESC
IF LISTHEAD<0 THEN LISTHEAD=HASH(ENTRY,PRIME)
DESC=SEARCHSUBSYS(ENTRY,TYPE,LISTHEAD)
IF DESC=0 THEN DESC=SEARCHSCL(ENTRY,TYPE)
IF DESC=0 THEN DESC=SEARCHLOADED(ENTRY,TYPE,LISTHEAD)
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(DESC,"SNNr")
RESULT =DESC
END ; ! OF CHECKLOADED
!
!
SYSTEMLONGINTEGERFN LOOKLOADED(STRING (31) ENTRY, INTEGERNAME TYPE)
! Checks all currently loaded material for ENTRY
INTEGER LHD
LHD=-1
RESULT =CHECKLOADED(ENTRY,TYPE,LHD)
END ; ! OF LOOKLOADED
!
!
STRINGFN SEARCHDIR(STRING (31) ENTRY, INTEGER CONAD,IHASH, C
INTEGERNAME TYPE)
! This function searches a directory connected at CONAD for entry
! ENTRY. Result is the name of a file containing the entry if TYPE
! is any of CODE, DATA or MACRO, the name of an alias for ENTRY
! if found and null if ENTRY is not found.
! TYPE found (if any) is returned to the calling routine.
INTEGER P,HASHCONST,PSTART,HSTART,LEN,INITPOS
RECORD (DHF)NAME DH
RECORD (NAMEF)ARRAYFORMAT HAF(0:99999)
RECORD (NAMEF)ARRAYNAME H
STRING (31) PART1,PART2,RES
DH==RECORD(CONAD)
HASHCONST=INTEGER(CONAD+DH_DATASTART)
PSTART=CONAD+DH_PSTART
HSTART=CONAD+DH_DATASTART+4
H==ARRAY(HSTART,HAF)
INITPOS=IHASH-(IHASH//HASHCONST)*HASHCONST; ! Start looking here.
LEN=LENGTH(ENTRY)
IF LEN>10 THEN START
PART1=SUBSTRING(ENTRY,1,6)
PART2=SUBSTRING(ENTRY,7,LEN)
FINISH ELSE START
PART1=ENTRY
PART2=""
FINISH
P=INITPOS
RES=""
CYCLE
IF H(P)_NAME="" THEN EXIT ; ! Not there
IF H(P)_NAME=PART1 AND (H(P)_TYPE&ALIAS#0 OR C
H(P)_TYPE&TYPE#0 ) THEN START ; ! It's looking good
! So it's either an alias or an item of the type
! looked for. Check for long name as well.
IF (H(P)_TYPE&X'80'=0 AND PART2="") OR C
((H(P)_TYPE&X'80'#0 AND PART2#"") AND C
PART2=STRING(PSTART+H(P)_REST)) THEN START
! Found it
TYPE=H(P)_TYPE&X'7F'
RES=STRING(PSTART+H(P)_POINT)
EXIT
FINISH
FINISH
P=P+1
P=0 IF P=HASHCONST
EXIT IF P=INITPOS; ! Hash table full and gone right round
REPEAT
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"SIINR")
RESULT =RES
END ; ! OF SEARCHDIR
!
!
STRINGFN SEARCHOLDDIR(STRING (31) ENTRY, INTEGERNAME TYPE, C
INTEGER CONAD)
! This is a TEMPORARY function to search old-style directories. Remove
! when new-style directories become the standard.
! This function searches a directory connected at CONAD for entry
! ENTRY. Result is the name of a file containing the entry if TYPE
! is any of CODE, DATA or MACRO, the name of an alias for ENTRY
! if found and null if ENTRY is not found.
! N.B. Macros and code entries are indistinguishable in old directories.
! TYPE found (if any) is returned to the calling routine.
INTEGER P,HASHCONST,PSTART,HSTART,LEN,INITPOS,OLDTYPE,BOTH
RECORD (DHF)NAME DH
RECORD (LNF)ARRAYFORMAT HAF(0:99999)
RECORD (LNF)ARRAYNAME H
STRING (31) PART1,PART2,RES
OLDTYPE=TYPE&1; ! CODE,MACRO,ALIAS all 0, DATA=1
! However this won't cope with a multiple TYPE such as CODE!DATA
! so need to indicate that either is acceptable
IF TYPE&1#0#TYPE&X'0000000E' THEN BOTH=TRUE ELSE BOTH=FALSE
DH==RECORD(CONAD)
HASHCONST=INTEGER(CONAD+DH_DATASTART)
PSTART=CONAD+DH_PSTART
HSTART=CONAD+DH_DATASTART+4
H==ARRAY(HSTART,HAF)
INITPOS=OLDHASH(ENTRY,HASHCONST); ! Start looking here
LEN=LENGTH(ENTRY)
IF LEN>10 THEN START
PART1=SUBSTRING(ENTRY,1,6)
PART2=SUBSTRING(ENTRY,7,LEN)
FINISH ELSE START
PART1=ENTRY
PART2=""
FINISH
P=INITPOS
RES=""
CYCLE
IF H(P)_NAME="" THEN EXIT ; ! Not there
IF H(P)_NAME=PART1 AND (H(P)_TYPE&X'7F'=OLDTYPE OR BOTH#FALSE) THEN START
! It's looking good
IF (H(P)_TYPE&X'80'=0 AND PART2="") OR C
((H(P)_TYPE&X'80'#0 AND PART2#"") AND C
PART2=STRING(PSTART+H(P)_REST)) THEN START
! Found it - make sure type found is o.k.
RES=STRING(PSTART+H(P)_POINT)
IF H(P)_TYPE&X'7F'=DATA THEN TYPE=DATA ELSE C
IF CHARNO(RES,1)='=' THEN TYPE=ALIAS ELSE C
IF TYPE&MACRO#0 THEN TYPE=CODE!MACRO ELSE TYPE=CODE
EXIT
FINISH
FINISH
P=P+1
P=0 IF P=HASHCONST
EXIT IF P=INITPOS; ! Hash table full and gone right round
REPEAT
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"SNiR")
RESULT =RES
END ; ! OF SEARCHOLDDIR
!
!
SYSTEMINTEGERFN SEARCH(STRING (31) ENTRY, LONGINTEGERNAME DESC, C
STRINGNAME FILE,ACTUALEPNAME, INTEGERNAME TYPE,LOCLL)
! This the loader's main searching routine for the EMAS subsystem.
! Searching is done in the order:
! 1. Subsystem entries
! 2. Privately loaded entries
! 3. Active directory
! 4. Subsystem base directory
! 5. Privately nominated directories
RECORDFORMAT DIRF(STRING (31) NAME, INTEGER DIRNO)
CONSTINTEGER TOPAHIST=9
RECORD (DIRF)ARRAY AHIST(0:TOPAHIST)
STRING (31) RES,LOOKFOR
INTEGER FLAG,I,IHASH,K,J,LISTHEAD,XTYPE,NEXTAHIST
LONGINTEGER DSC
!
ROUTINE PCHAIN(STRING (63) S, INTEGER TOP,DIRNO)
INTEGER I
SELECTOUTPUT(0)
PRINTSTRING(S)
PRINTSTRING("
History (reverse order of calling):
")
PRINTSTRING(LOOKFOR)
SPACES(32-LENGTH(LOOKFOR))
PRINTSTRING(" in ".CONFILE(SSOWN_SSADIR(DIRNO)_CONAD))
NEWLINE
FOR I=TOP,-1,0 CYCLE
PRINTSTRING(AHIST(I)_NAME)
SPACES(32-LENGTH(AHIST(I)_NAME))
PRINTSTRING(" in ".CONFILE(SSOWN_SSADIR(AHIST(I)_DIRNO)_CONAD))
NEWLINE
REPEAT
RETURN
END ; ! OF PCHAIN
!
FILE=""
NEXTAHIST=0
AHIST(I)=0 FOR I=TOPAHIST,-1,0
LOOKFOR=ENTRY
IF SSOWN_LOADMONITOR&8#0 THEN MONOUT( C
"Loader search initiated for ".LOOKFOR)
CYCLE
IF SSOWN_LOADMONITOR&8#0 THEN MONOUT("Looking for ".LOOKFOR)
IHASH=INITHASH(LOOKFOR)
LISTHEAD=IHASH-(IHASH//PRIME)*PRIME
XTYPE=TYPE
! First search system then privately loaded material for the entry
DSC=SEARCHSUBSYS(LOOKFOR,XTYPE,LISTHEAD)
IF DSC=0 THEN DSC=SEARCHSCL(LOOKFOR,XTYPE)
IF DSC=0 THEN DSC=SEARCHLOADED(LOOKFOR,XTYPE,LISTHEAD)
IF DSC#0 THEN START
! Found it
IF SSOWN_LOADMONITOR&8#0 THEN MONOUT(LOOKFOR." already loaded")
ACTUALEPNAME=LOOKFOR
DESC=DSC
TYPE=XTYPE
FLAG=-1
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"Sn2SNNR")
RESULT =-1
FINISH
!If here then didn't find it already loaded so enter sequence to
! search the directories for the entry. Will a) find it, b) find
! an alias to it, or c) not find it.
IF SSOWN_LOADMONITOR&8#0 THEN MONOUT(LOOKFOR." not currently loaded")
I=-1; ! 1st directory in search list - i.e. active dir (if present)
IF SSOWN_DIRDISCON#0 THEN CONNDIRS; ! Check if rebuild of search list required
CYCLE
I=I+1 AND CONTINUE IF SSOWN_SSADIR(I)_NAME=""
IF SSOWN_LOADMONITOR&8#0 THEN MONOUT("Searching directory ".SSOWN_SSADIR(I)_NAME)
IF SSOWN_SSADIR(I)_TYPE=SSDIRFILETYPE THEN C
RES=SEARCHDIR(LOOKFOR,SSOWN_SSADIR(I)_CONAD,IHASH,XTYPE) ELSE C
RES=SEARCHOLDDIR(LOOKFOR,XTYPE,SSOWN_SSADIR(I)_CONAD); ! TEMP
! RES=SEARCHDIR(LOOKFOR,SSOWN_SSADIR(I)_CONAD,IHASH,XTYPE)
IF RES#"" THEN START
! Found it - although it might be an alias
IF XTYPE&TYPE#0 THEN START
! Got a file. Set LOCLL to 0 if I=0 i.e.
! if it's in SUBSYS.SYSTEM_BASEDIR so that it's loaded
! on the BASEGLA
IF SSOWN_LOADMONITOR&1#0 THEN MONOUT( C
LOOKFOR." found in file ".RES)
TYPE=XTYPE
LOCLL=0 IF I=0
ACTUALEPNAME=LOOKFOR
FILE=RES
FLAG=0
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"S2SSNNR")
RESULT =0
FINISH
! So if here then found an alias
RES=SUBSTRING(RES,2,LENGTH(RES)); ! Remove preceding '='.
! Now it is conceivable that this alias could lead to a dead
! end and the item we are actually looking for is in the
! next directory down for example, so to recover from
! this occurrence stack the currently sought for item
! in the next free AHIST record (provided it's not already
! in which case we have a closed loop, or it's a reoccurrence
! of the same lhs of the alias in which case overwrite.).
! Initially always follow the aliases and if dead ends occur
! restore the previous environment one directory down and
! continue similarly until ultimate success or failure.
IF NEXTAHIST>TOPAHIST THEN START
PCHAIN("Alias chain too long",TOPAHIST,I)
FLAG=352
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"S222NNQ")
RESULT =352
FINISH
! Check if potential entry is already present
K=-1
! PCHAIN("*DUMP*",NEXTAHIST-1,I)
FOR J=0,1,NEXTAHIST CYCLE
K=J AND EXIT IF AHIST(J)_NAME=LOOKFOR AND AHIST(J)_DIRNO=I
REPEAT
IF K>=0 THEN START
PCHAIN("Alias loop detected",NEXTAHIST-1,I)
FLAG=285
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"S222NNQ")
RESULT =285
FINISH
! Add to history chain unless NAME and LOOKFOR are the same
! in which case overwrite
NEXTAHIST=NEXTAHIST-1 IF NEXTAHIST>0 AND C
LOOKFOR=AHIST(NEXTAHIST-1)_NAME
AHIST(NEXTAHIST)_NAME=LOOKFOR
AHIST(NEXTAHIST)_DIRNO=I
NEXTAHIST=NEXTAHIST+1
IF SSOWN_LOADMONITOR&8#0 THEN MONOUT( C
"Alias ".LOOKFOR." = ".RES." found in directory ".SSOWN_SSADIR(I)_NAME)
LOOKFOR=RES
EXIT ; ! Back to the outer cycle
FINISH ELSE START
! Entry not found. Increment I by 1
! If run out of directories to search then check if any alias
! branches to search.
I=I+1
IF I>SSOWN_SSTOPADIR THEN START
IF NEXTAHIST=0 OR (NEXTAHIST=1 AND C
AHIST(0)_DIRNO=SSOWN_SSTOPADIR) THEN START
SSOWN_SSFNAME=LOOKFOR
FLAG=289
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"S222NNQ")
RESULT =289
! Not found after complete search.
FINISH
! If here then must have branched off at least once to
! follow an alias chain. Restore the item which spawned
! the alias and carry on looking for it in the next dir.
NEXTAHIST=NEXTAHIST-1
LOOKFOR=AHIST(NEXTAHIST)_NAME
IHASH=INITHASH(LOOKFOR)
I=AHIST(NEXTAHIST)_DIRNO+1
IF SSOWN_LOADMONITOR&8#0 THEN MONOUT( C
"Alias chain exhausted - restoring ".LOOKFOR."
Starting search at ".SSOWN_SSADIR(I)_NAME)
FINISH
FINISH
REPEAT
REPEAT
END ; ! OF SEARCH
!
!
INTEGERFN GETGLA(INTEGER LL,LEN)
INTEGER INC,CUR,HOLE,FLAG,I
LEN = (LEN+15)&X'FFFFFFF0'; ! Quad word align
IF LL=0 THEN START
! Get space off basegla. Ensure quad alignment
SSOWN_SSCURBGLA = (SSOWN_SSCURBGLA+15)&X'FFFFFFF0'
IF SSOWN_SSCURBGLA+LEN > SSOWN_SSMAXBGLA THEN START
TERMINALPRINT("** Base gla full
** Try call of RESET LOADER","")
RETURN TO COMMAND LEVEL
FINISH
CUR = SSOWN_SSCURBGLA
SSOWN_SSCURBGLA = SSOWN_SSCURBGLA+LEN
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(CUR,"IIr")
RESULT = CUR
FINISH
! If here then require space off the user gla. May have to create it
! if it does not exist or attempt to extend it if it's not big enough
IF SSOWN_SSCOMREG(44)=0 THEN START
! Set hole to be the smaller of max file size allowed - SSMAXFSIZE -
! and max ugla size allowed - MAXUGLASIZE
IF SSOWN_SSMAXFSIZE>MAXUGLASIZE THEN HOLE=MAXUGLASIZE ELSE HOLE=SSOWN_SSMAXFSIZE
OUTFILE(UGLANAME,SSOWN_SSUGLASIZE,HOLE,0,SSOWN_SSCOMREG(38),FLAG)
IF FLAG # 0 THEN TERMINALPRINT("Create USERGLA fails - ", C
FAILUREMESSAGE(FLAG)) AND RETURN TO COMMAND LEVEL
IF NEWCONNECT=0 THEN SETUSE(UGLANAME,1,0)
SSOWN_MAXUGLA = SSOWN_SSCOMREG(38)+SSOWN_SSUGLASIZE
SSOWN_SSCOMREG(44)=SSOWN_SSCOMREG(38)
SSOWN_LLINFO(I)_GLA=SSOWN_SSCOMREG(38) FOR I=LL,-1,1; ! In case LL>1
FINISH
WHILE SSOWN_SSCOMREG(44)+LEN>SSOWN_MAXUGLA CYCLE
IF SSOWN_SSUGLASIZE>=SEGSIZE THEN INC=SEGSIZE ELSE INC=K64
CHANGEFILESIZE(UGLANAME,SSOWN_SSUGLASIZE+INC,FLAG)
IF FLAG#0 THEN START
TERMINALPRINT("Extend USERGLA fails - ",FAILUREMESSAGE(FLAG))
RETURN TO COMMAND LEVEL
FINISH
SSOWN_SSUGLASIZE = SSOWN_SSUGLASIZE+INC
SSOWN_MAXUGLA = SSOWN_SSCOMREG(38)+SSOWN_SSUGLASIZE
REPEAT
CUR = SSOWN_SSCOMREG(44)
SSOWN_SSCOMREG(44) = SSOWN_SSCOMREG(44)+LEN
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(CUR,"IIr")
RESULT = CUR
END ; ! OF GETGLA
!
!
INTEGERFN GETSPACE(INTEGERNAME FLAG, INTEGER AREA,OFFSET,LEN)
! Obtains LEN bytes of free space from area AREA of the loader
! tables. If it can't then it tries to extend T#LOAD by a page
! at a time and adjusts the tables so that the extra page is
! available to the requesting AREA then it tries again.
INTEGERARRAYNAME RLH,PLH,TLH
INTEGER SPACEAD,FSIZE,I,FILLAD,MLEN,MINHOLEAD,DUFF,LO,HI,AD,L
BYTEINTEGER FILLER
FLAG=0
FSIZE=INTEGER(SSOWN_SSLOADTAB(0)_START+8)
WHILE FLAG=0 CYCLE
IF AREA#1 THEN START
IF SSOWN_SSLOADTAB(AREA)_LEN-SSOWN_NEXTAD(AREA)-LEN>=0 THEN C
SPACEAD=SSOWN_SSLOADTAB(AREA)_START+SSOWN_NEXTAD(AREA) AND SSOWN_NEXTAD(AREA)= C
SSOWN_NEXTAD(AREA)+LEN ELSE SPACEAD=0
FINISH ELSE START
! Getting space in the reference tables is not quite so straightforward.
! Refs come and go during loading and running and the ref tables cannot
! be run in a stack-like manner. Instead space must be taken where it is
! found. The minimum size of hole of interest is 16 bytes, so start off
! by finding one of these. In subsequent searches for space then start
! looking there rather than at the start of the table.
HI=SSOWN_SSLOADTAB(1)_START+SSOWN_SSLOADTAB(1)_LEN-16
LO=SSOWN_SSLOADTAB(1)_START+SSOWN_NEXTAD(1)
! Look for 16 byte hole
MINHOLEAD=0
WHILE LO<=HI CYCLE
IF LONGINTEGER(LO)=LONGINTEGER(LO+8)=NOTUSED THEN START
MINHOLEAD=LO
SSOWN_NEXTAD(1)=LO-SSOWN_SSLOADTAB(1)_START
EXIT
FINISH
LO=LO+8
REPEAT
! If MINHOLEAD=0 then no option but to attempt to extend the table
IF MINHOLEAD=0 THEN START
SSOWN_NEXTAD(1)=HI+8-SSOWN_SSLOADTAB(1)_START
SPACEAD=0
FINISH ELSE START
IF LEN=16 THEN START
SPACEAD=MINHOLEAD
SSOWN_NEXTAD(1)=SSOWN_NEXTAD(1)+16
FINISH ELSE START
! If here then looking for a hole > 16
HI=HI+16-LEN; ! New upper limit
SPACEAD=0
WHILE LO<=HI CYCLE
IF LONGINTEGER(LO)=NOTUSED=LONGINTEGER(LO+8) THEN START
AD=LO+16
L=LEN-24
DUFF=FALSE
WHILE L>=0 CYCLE
DUFF=TRUE AND EXIT IF LONGINTEGER(AD+L)#NOTUSED
L=L-8
REPEAT
IF DUFF#FALSE THEN LO=AD+L+8 ELSE SPACEAD=LO AND EXIT
FINISH ELSE LO=LO+8
REPEAT
FINISH
FINISH
FINISH
! If successful then FILL the space with X'FF' which, incidentally,
! initialises the LINK fields to -1 which is the chain terminator anyway.
IF SPACEAD#0 THEN START
FILL(LEN,SPACEAD,X'FF')
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(SPACEAD,"NIiir")
RESULT =SPACEAD
FINISH
! If here then couldn't get the space. Try to extend T#LOAD.
IF FSIZE=MAXLOADTABSIZE OR FSIZE=SSOWN_SSMAXFSIZE THEN START
! Either condition means that we can't extend any further
TERMINALPRINT("** Loader tables full, tell ERCC Advisory","")
RETURN TO COMMAND LEVEL; ! No messing about
FINISH
FSIZE=FSIZE+X'1000'
CHANGEFILESIZE(LOADTABLES,FSIZE,FLAG)
IF FLAG#0 THEN START
SPACEAD=0
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(SPACEAD,"FIiiR")
RESULT =0
FINISH
INTEGER(SSOWN_SSLOADTAB(0)_START+8)=FSIZE
INTEGER(SSOWN_SSLOADTAB(0)_START)=FSIZE
! Reconstruct SSLOADTAB addresses
FOR I=1,1,3 CYCLE
SSOWN_SSLOADTAB(I)_START=SSOWN_SSLOADTAB(I-1)_START+SSOWN_SSLOADTAB(I-1)_LEN
REPEAT
! If area 3 needs extension, update SSLOADTAB(3)_LEN only
! If area#3 then must update SSLOADTAB(AREA)_LEN and all the
! succeeding SSLOADTAB(AREAS)_START for AREAS=AREA+1,1,3
! The hole must then be filled with X'00' for entry tables, X'82' for refs.
IF AREA=3 THEN START
SSOWN_SSLOADTAB(3)_LEN=SSOWN_SSLOADTAB(3)_LEN+X'1000'
FINISH ELSE START
SSOWN_SSLOADTAB(AREA)_LEN=SSOWN_SSLOADTAB(AREA)_LEN+X'1000'
FILLAD=SSOWN_SSLOADTAB(AREA+1)_START
MLEN=0
MLEN=MLEN+SSOWN_SSLOADTAB(I)_LEN FOR I=AREA+1,1,3
MOVE(MLEN,SSOWN_SSLOADTAB(AREA+1)_START,SSOWN_SSLOADTAB(AREA+1)_START+X'1000')
SSOWN_SSLOADTAB(I)_START=SSOWN_SSLOADTAB(I)_START+X'1000' FOR I=AREA+1,1,3
IF AREA=1 THEN FILLER=X'82' ELSE FILLER=X'00'
FILL(X'1000',FILLAD,FILLER)
FINISH
! Map listheads
RLH==ARRAY(SSOWN_SSLOADTAB(1)_START,LHF)
PLH==ARRAY(SSOWN_SSLOADTAB(2)_START,LHF)
TLH==ARRAY(SSOWN_SSLOADTAB(3)_START,LHF)
SSOWN_RLH==RLH
SSOWN_PLH==PLH
SSOWN_TLH==TLH
! So try again to get the space
REPEAT
END ; ! OF GETSPACE
!
!
INTEGERFN ESCAPEREC(INTEGER TYPE,RECAD,DESCAD,LOCLL)
! Creates an escape table on the base or user gla as appropriate for
! dynamic or (PARM LET) unsatisfied refs.
RECORD (ESCF)NAME ESCTAB
INTEGER ADYNR
ADYNR=GETGLA(LOCLL,16)
ESCTAB==RECORD(ADYNR)
ESCTAB_RECAD=RECAD
IF TYPE&X'1FFFFFFF'=CODE THEN START
IF TYPE&DYN#0 THEN ESCTAB_PC=SSOWN_DYNPC ELSE ESCTAB_PC=SSOWN_UNSATPC
ESCTAB_DESCAD=DESCAD
ESCTAB_ENTAD=0; ! Used by ss dyn refs
FINISH ELSE START
! If here it's data
IF TYPE&DYN#0 THEN ESCTAB_PC=SSOWN_DYNDATAPC ELSE ESCTAB_PC=SSOWN_UNSATPC
! Store data descriptor from gla before overwriting with escape desc
ESCTAB_DR0=INTEGER(DESCAD-4)
ESCTAB_DR1=INTEGER(DESCAD)
FINISH
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(ADYNR,"IiiIr")
RESULT =ADYNR
END ; ! OF ESCAPEREC
!
!
ROUTINE DATAREFWARNING(STRING (31) FILE,ENTRY, INTEGER TOOBIG,TOOSMALL)
STRING (11) S
INTEGER I
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(TOOBIG,"SSII")
IF TOOSMALL#0 THEN I=TOOSMALL AND S=" shorter" ELSE I=TOOBIG AND S=" LONGER"
TERMINALPRINT("**Warning - ".ITOS(I)." data ref(s) to ".ENTRY." in ".FILE, C
S." than current entry")
RETURN
END ; ! OF DATAREFWARNING
!
!
RECORD (FINDGLAF)FN FINDGLA(INTEGER REFAD)
! Function returns the name of the file and the range of gla associated
! with it which contains the data ref at REFAD.
! Note that 'gla' in this respect could mean ISTK.
RECORD (FINDGLAF) RES
RECORD (ENTF)NAME ENT
INTEGER I,J,RECAD,LENE,START,OFFSET
RES=0
FOR I=2,1,3 CYCLE
START=SSOWN_SSLOADTAB(I)_START
J=INTEGER(START+1004); ! The filenames listhead
CONTINUE IF J=0
WHILE J>0 CYCLE
RECAD=START+J
LENE=(BYTEINTEGER(RECAD)+4)&X'FFFFFFFC'
ENT==RECORD(RECAD+LENE)
IF ENT_TYPE=32 AND ENT_GLAFROM<REFAD<ENT_GLATO THEN START
! Found the gla or istk record required
RES_FROM=ENT_GLAFROM
RES_TO=ENT_GLATO
! Istk records come before gla records. There is always a gla
! record but not necessarily an istk one. These records are 20 bytes
! long so an istk record is 40 in front of the filename and a gla 20.
! Pointer to gla is 28 bytes beyond istk record.
IF STRING(RECAD)="+IS" THEN START
RES_GLASTART=INTEGER(RECAD+28)
RES_FILE=STRING(RECAD+40)
FINISH ELSE START
RES_GLASTART=RES_FROM
RES_FILE=STRING(RECAD+20)
FINISH
->OUT
FINISH
J=ENT_LINK
REPEAT
REPEAT
OUT:
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"iU")
RESULT =RES
END ; ! OF FINDGLA
!
!
ROUTINE SATISFYREF(STRING (31) ENTRY, LONGINTEGER DESC, C
INTEGERNAME FLAG, INTEGER TYPE,LOCLL,POS)
! Satisfies any references outstanding to ENTRY in the loaders
! tables of type(s) consistent with TYPE.
! This requires that the basic record chain must be searched right
! to the end.
! Equally any dynamic data ref must have its original data descriptor
! restored.
! Note on SATISFYREF and LOAD LEVEL
! ==== == ========== === ==== =====
! We distinguish between the loadlevel that a reference was generated at
! and the loadlevel of the entry at which it is satisfied. There is no
! problem when an entry at a given loadlevel satisfies a reference at
! the same or a higher loadlevel since the file containing the reference
! will be unloaded before or at the same time as the entry. The problem
! arises when a ref at one loadlevel is satisfied by an entry at a higher
! loadlevel since the file containing the entry is likely to be unloaded
! first. e.g. preloaded files, subsystem library files, etc.
! The two cases are handled differently.
! 1. loadlevel ref>= loadlevel entry
! Satisfy ref and destroy information record.
! 2. loadlevel ref<loadlevel entry.
! In these cases we OUGHT to be dealing with dynamic refs in which case
! the information record with its pointer to the escape table is not destroyed
! but the dyn/unsat bits in the basic record are unset to mark a satisfied
! ref. The reason for this is that if the file containing the entry is
! unloaded first then we have to recreate the original dynamic ref from
! the escape table in order to continue safely. All the refs that fall
! into this category will be marked as satisfied refs in the loader
! refs table, which saves the alternative and awful strategy of inspecting
! all the refs of all the files which remain loaded after the unload.
! However what if the ref is not dynamic? I can't envisage the circumstances
! at present but it could happen. If it does then change the information
! record to type dynamic and create a new escape record (and print a warning).
! Must create escape table before satisfying the ref since data refs have
! offsets in the DR1 field in the gla which must be stored.
! The problem is of course that the escape table is stored in gla at a
! higher loadlevel than the file which generated it (if it's not in
! the basegla). The unload will work o.k. but the next load will probably
! overwrite the escape table. This can be avoided by always taking the
! space for the escape table off the basegla
! This strategy should ensure that at unloading time, there should always
! be an escape table to restore from. (code or data - single word handled diff)
! *************************************************************************
RECORD (BREFF)NAME R1
RECORD (IREFF)NAME R2
RECORD (ESCF)NAME DREC
INTEGER I,J,RECAD,IRECAD,START,RTYPE,FOUND,REFLEN,LEN
INTEGER LASTBLINKAD,GOTUNSAT,LASTILINKAD
! %INTEGER NREFS {Temp}
INTEGERNAME ENTLEN,ENTAD
RECORD (FINDGLAF) REFINF
INTEGER TOOBIG,TOOSMALL,REFLANG
ENTLEN==INTEGER(ADDR(DESC))
ENTAD==INTEGER(ADDR(DESC)+4)
FLAG=0
REFINF=0
TOOBIG=0
TOOSMALL=0
TYPE=TYPE&X'1FFFFFFF'; ! Off cmn/dyn/unsat bits
START=SSOWN_SSLOADTAB(1)_START; ! Start of unsat ref area
FOUND=FALSE
I=SSOWN_RLH(POS)
LASTBLINKAD=START+POS<<2; ! Listhead address
! Search basic records for ENTRY
! NREFS=0 {Temp}
WHILE I>0 CYCLE
RECAD=START+I
LEN=(BYTEINTEGER(RECAD)+8)&X'FFFFFFF8'
RTYPE=INTEGER(RECAD+LEN)
R1==RECORD(RECAD+LEN+4)
I=R1_LINK; ! Maybe going to destroy R1 if its ref required so get link
IF STRING(RECAD)=ENTRY AND TYPE&RTYPE#0 THEN START
! Found it
! Now chain through information records for each ref
! Check ref loadlevel against entry loadlevel. Create escape tab
! if necessary. If ref>=entry then proceed as in rest of comment,
! if not then refer to note at routine head.
! If it's code then put in descriptor without further ado
! If data then must check the length of the ref against
! the length of the entry and warn or fail if appropriate.
! If no failures then release the space.
! After the information record chain has been destroyed
! then the basic record also has to be destroyed and the
! remaining records on the chain relinked.
! Of course I don't want to be interrupted while doing
! this!!!
SSOWN_SSINHIBIT=TRUE
FOUND=TRUE IF FOUND=FALSE
GOTUNSAT=FALSE
IF RTYPE&UNSAT#0 THEN GOTUNSAT=TRUE
RTYPE=RTYPE&X'0FFFFFFF'; ! Off cmn/dyn/unsat/unres bits
! Remove dyn/unsat/unres bits from basic record to show it's been satisfied
INTEGER(RECAD+LEN)=INTEGER(RECAD+LEN)&X'8FFFFFFF'
LASTILINKAD=RECAD+LEN+4; ! Address of 1st info rec link
J=R1_FIRST; ! There must be at least one
WHILE J>0 CYCLE ; ! Round the info records
! NREFS=NREFS+1 {Temp}
IRECAD=START+J
R2==RECORD(IRECAD)
J=R2_LINK
! Check if new escape table required
IF (R2_DR0>>24)&X'1F'<LOCLL AND R2_DR0&DYN=0 THEN START
IF SSOWN_NOWARNINGS=FALSE THEN C
TERMINALPRINT("Warning - satisfying non dynamic ref to ", C
ENTRY." by entry at higher loadlevel.
Ref made dynamic")
R2_DR0=(R2_DR0!DYN)&X'DFFFFFFF'; ! Off unsat/on dyn
! If its code or data then construct an escape table on basegla.
! Do nothing for single word refs.
IF RTYPE=CODE THEN R2_ADYNR=ESCAPEREC(RTYPE!DYN,RECAD,R2_DR1,0) ELSE C
IF RTYPE=DATA THEN R2_ADYNR=ESCAPEREC(RTYPE!DYN,RECAD,R2_DR1,0)
FINISH
! Fix up refs
IF RTYPE=CODE!DATA THEN START
! Single word ref. Restore offset, add ENTAD
INTEGER(R2_DR1)=R2_OFFSET+ENTAD
! Destroy ref unless it's at lower loadlevel than entry
IF (R2_DR0>>24)&X'1FF'>=LOCLL THEN START
FILL(16,IRECAD,X'82'); ! Destroy record
IF IRECAD-START<SSOWN_NEXTAD(1) THEN SSOWN_NEXTAD(1)=IRECAD-START
INTEGER(LASTILINKAD)=R2_LINK; ! Update last link
FINISH ELSE LASTILINKAD=IRECAD+12
FINISH ELSE START
IF TYPE=CODE THEN START
! If the ref is a subsystem dynamic ref then can't fill
! it in since the basegla is shareable.
! (Even an unshared basegla is treated as 'read only' after
! the ss dynamic refs escape descriptors have been planted.)
! Note the assumption that the subsystem only has dynamic
! CODE refs.
! Not fixing up the gla means that the escape sequence will
! be called each time the reference is called but no more than
! that.
! Because we actually need to know when a subsystem dyn ref
! has been satisfied when we get round to unloading then store
! ENTAD in word 4 of the escape table. This is what should be
! fed to DEADREF to find out whether the file containing the
! entry which satisfies the ss dyn ref is being unloaded.
UNLESS SSOWN_DYNREFSTART<=R2_ADYNR<SSOWN_DYNREFEND THEN C
LONGINTEGER(R2_DR1)=DESC ELSE INTEGER(R2_ADYNR+12)=ENTAD
FINISH ELSE START
! {Temp}
! %IF TYPE=CODE %THEN %START
! LONGINTEGER(R2_DR1)=DESC
! MONOUT(ENTRY." fixed up at ".HTOS(R2_DR1,8)." Esc tab at ".HTOS(R2_ADYNR,8))
! MONOUT("DESC ".HTOS(ENTLEN,8)." ".HTOS(ENTAD,8))
! MONOUT("Confirm ".HTOS(INTEGER(R2_DR1),8)." ".HTOS(INTEGER(R2_DR1+4),8))
! %FINISH
! %FINISH %ELSE %START
! {Temp}
! If we are dealing with a data ref then there could be a
! catastrophic fail if REFLEN>ENTLEN and LET is not set.
REFLEN=R2_DR0&X'00FFFFFF'; ! Off cmn/dyn/unsat bits and llev
IF REFLEN#ENTLEN THEN START
IF REFINF_FILE="" OR NOT (REFINF_FROM<R2_DR1<REFINF_TO) THEN START
UNLESS TOOSMALL=0=TOOBIG OR SSOWN_NOWARNINGS#FALSE THEN C
DATAREFWARNING(REFINF_FILE,ENTRY,TOOBIG,TOOSMALL)
TOOBIG=0
TOOSMALL=0
REFINF=FINDGLA(R2_DR1)
FINISH
REFLANG=BYTEINTEGER(REFINF_GLASTART+16)
IF REFLEN<ENTLEN THEN START
TOOSMALL=TOOSMALL+1 UNLESS ENTRY="F#BLCM" OR REFLANG=FORTE
FINISH ELSE START
IF LET=0 THEN START
! LET not set
FLAG=296
SSOWN_SSFNAME=ENTRY
TERMINALPRINT("**Error - Data ref ".ENTRY." in ". C
REFINF_FILE," longer than entry and LOADPARM LET not set")
->OUT
FINISH ELSE TOOBIG=TOOBIG+1
FINISH
FINISH
! If there's an esc descriptor at R2_DR1-4 then must restore
! original descriptor
IF INTEGER(R2_DR1-4)=X'E5000000' THEN START
DREC==RECORD(INTEGER(R2_DR1))
INTEGER(R2_DR1-4)=DREC_DR0
INTEGER(R2_DR1)=DREC_DR1
FINISH
INTEGER(R2_DR1)=INTEGER(R2_DR1)+ENTAD
FINISH
! Ref has been satisfied if here. If the ref loadlevel<LOCLL
! then leave the info record for possible unfixing later else
! destroy it
! The other restriction is that ss dyn ref info recs must
! never be destroyed.
IF (R2_DR0>>24)&X'1F'>=LOCLL AND C
NOT (SSOWN_DYNREFSTART<=R2_ADYNR<SSOWN_DYNREFEND) THEN START
FILL(16,IRECAD,X'82'); ! Destroy record.
IF IRECAD-START<SSOWN_NEXTAD(1) THEN SSOWN_NEXTAD(1)=IRECAD-START
INTEGER(LASTILINKAD)=R2_LINK; ! Update last link
FINISH ELSE LASTILINKAD=IRECAD+12
FINISH
REPEAT
UNLESS TOOBIG=0=TOOSMALL OR SSOWN_NOWARNINGS#FALSE THEN C
DATAREFWARNING(REFINF_FILE,ENTRY,TOOBIG,TOOSMALL)
! If last info record has been destroyed or there was only one
! then integer(LASTILINKAD) is going to be X'FFFFFFFF'.
! R1_LAST must therefore point to this record
IF INTEGER(LASTILINKAD)<0 THEN R1_LAST=LASTILINKAD-12-START
! If there are no info records left then destroy the basic record
! and update the last link pointer.
IF R1_FIRST<=0 THEN START
INTEGER(LASTBLINKAD)=R1_LINK
FILL(LEN+16,RECAD,X'82')
IF RECAD-START<SSOWN_NEXTAD(1) THEN SSOWN_NEXTAD(1)=RECAD-START
FINISH ELSE LASTBLINKAD=RECAD+LEN+12; ! Step past
SSOWN_SSCOMREG(7)=SSOWN_SSCOMREG(7)-1 IF GOTUNSAT#FALSE
ALLOWINTERRUPTS; ! Allow interrupts again
FINISH ELSE LASTBLINKAD=RECAD+LEN+12; ! Step past - never looked
REPEAT
! %IF NREFS#0 %AND SSOWN_LOADMONITOR&1#0 %THEN {Temp} MONOUT(HTOS(NREFS,8). %C
! " outstanding refs to ".ENTRY." satisfied") {Temp}
IF FOUND=FALSE THEN START
SSOWN_SSFNAME=ENTRY
FLAG=289; ! Not found
FINISH
OUT:
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"SlFIII")
RETURN
END ; ! OF SATISFYREF
!
!
ROUTINE ADDENTRY(STRING (31) ENTRY, INTEGERARRAYNAME LH, C
INTEGERNAME FLAG,OFFSET, INTEGER TYPE,I0,I1,AREA,POS)
! Adds filenames, code or data entries to the appropriate area of T#LOAD.
RECORD (ENTF)NAME R1,R2
LONGINTEGER XDESC
INTEGER I,RECAD,NRECAD,LEN,LENE,START,XTYPE
XTYPE=TYPE&X'1FFFFFFF'; ! Off special entry bits
FLAG=0
! Check that ENTRY isn't already loaded.
! ENTRY is a filename if XTYPE=0
IF XTYPE=0 THEN XDESC=SEARCHLOADED(ENTRY,XTYPE,POS) ELSE C
IF XTYPE<32 THEN XDESC=CHECKLOADED(ENTRY,XTYPE,POS) ELSE XDESC=0
IF XDESC#0 THEN START
! ENTRY already loaded somewhere.
SSOWN_SSFNAME=ENTRY
FLAG=354; ! already loaded
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"S4FniiiII")
RETURN
FINISH
! Not in tables if here so add it.
! If there is already a chain off POS then get the last LINK
START=SSOWN_SSLOADTAB(AREA)_START
RECAD=0
I=LH(POS)
WHILE I>0 CYCLE
RECAD=START+I
LEN=(BYTEINTEGER(RECAD)+4)&X'FFFFFFFC'; ! Name string
R1==RECORD(RECAD+LEN)
I=R1_LINK
REPEAT
LENE=(LENGTH(ENTRY)+4)&X'FFFFFFFC'; ! Bytes for ENTRY (word aligned)
! Get space for new record
NRECAD=GETSPACE(FLAG,AREA,OFFSET,LENE+16)
IF FLAG#0 THEN START
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"S4FniiiII")
RETURN
FINISH
SSOWN_SSINHIBIT=TRUE; ! Inhibit interrupts
OFFSET=NRECAD+LENE+16-START
STRING(NRECAD)=ENTRY
R2==RECORD(NRECAD+LENE)
R2_TYPE=TYPE
R2_DR0=I0; ! DR0 or MAINEP or GLAFROM or DUM2 or USECOUNT
R2_DR1=I1; ! DR1 or DUM1 or GLATO or DUM3 or ACCESSMODE
! Link already set by GETSPACE
! Update previous LINK field if pre existing chain
! otherwise listhead
NRECAD=NRECAD-START
IF RECAD=0 THEN LH(POS)=NRECAD ELSE R1_LINK=NRECAD
ALLOWINTERRUPTS
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"S4FniiiII")
RETURN
END ; ! OF ADDENTRY
!
!
!
ROUTINE ADDREF(STRING (31) ENTRY, INTEGERNAME FLAG, C
INTEGER DR0,AD,TYPE,STATUS,LOCLL,POS,NREFS)
! Adds dynamic and unsatisfied refs to T#LOAD. If the unresolved bit is set in the
! basic record and the incoming reference is unsatisfied then the ref
! will be made unresolved immediately.
! Creates an escape record on the gla (if required) for dynamic/unresolved refs
RECORD (BREFF)NAME R1
RECORD (IREFF)NAME R2,R3
INTEGER I,J,ADYNR,RECAD,NRECAD,IRECAD,START,FOUND,LENE,LEN
INTEGER RTYPE,AREA,K,REFLOC,REFAD,UNRESOLVEDREF
STRING (255) DUM
! %CONSTSTRING(11)%ARRAY SREF(1:3)="Data ","Code ","Single wd " {Temp}
IF STATUS=DYNAMIC THEN TYPE=TYPE!DYN AND DR0=DR0!DYN ELSE C
TYPE=TYPE!UNSAT AND DR0=DR0!UNSAT
DR0=DR0!(LOCLL<<24)
FLAG=0
AREA=1
START=SSOWN_SSLOADTAB(1)_START
LENE=(LENGTH(ENTRY)+8)&X'FFFFFFF8'; ! Bytes req by ENTRY (D-word aligned)
UNRESOLVEDREF=FALSE
FOUND=FALSE
RECAD=0
I=SSOWN_RLH(POS); ! Offset from START of first basic record
! Search chain for occurrence of ENTRY and TYPE
WHILE I>0 CYCLE
RECAD=START+I
LEN=(BYTEINTEGER(RECAD)+8)&X'FFFFFFF8'; ! Len of string d word aligned
RTYPE=INTEGER(RECAD+LEN); ! Record type
R1==RECORD(RECAD+LEN+4)
IF STRING(RECAD)=ENTRY AND TYPE&X'1FFFFFFF'=RTYPE&X'0FFFFFFF' THEN START
FOUND=TRUE
IF RTYPE&UNRES#0 THEN UNRESOLVEDREF=TRUE
EXIT
FINISH
I=R1_LINK
REPEAT
! If FOUND=FALSE then must create a new basic record for ENTRY.
! If there was already something on the chain then must also
! update the link field of the last basic record.
SSOWN_SSINHIBIT=TRUE; ! Disallow interrupts
IF FOUND=FALSE THEN START
! Create new basic record. Can't be unresolved if here.
NRECAD=GETSPACE(FLAG,AREA,LHOFFSET,LENE+16)
IF FLAG#0 THEN START
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"SFiiiIIII")
ALLOWINTERRUPTS
RETURN
FINISH
! If 1st member of a chain then update listhead else
! last link field
IF RECAD=0 THEN SSOWN_RLH(POS)=NRECAD-START ELSE R1_LINK=NRECAD-START
STRING(NRECAD)=ENTRY
INTEGER(NRECAD+LENE)=TYPE
! Now map R1 on to the last 3 integers of the basic record
R1==RECORD(NRECAD+LENE+4)
RECAD=NRECAD
FINISH ELSE IF UNRESOLVEDREF=FALSE OR TYPE&UNSAT=0 THEN C
INTEGER(RECAD+LEN)=INTEGER(RECAD+LEN)!TYPE
! Note on above line: What we are doing here is %or ing in dynamic
! or unsatisfied bits into the basic record TYPE field. If TYPE has the
! unresolved bit set and the new ref is unsatisfied then don't want to do this.
FOR K=NREFS-1,-1,0 CYCLE
REFLOC=INTEGER(AD+K<<2)
REFAD=SSOWN_AREASTART((REFLOC>>24)&X'0F')+REFLOC&X'00FFFFFF'
! Now create a new info record
IRECAD=GETSPACE(FLAG,AREA,LHOFFSET,16)
IF FLAG#0 THEN START
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"SFiiiIIII")
ALLOWINTERRUPTS
RETURN
FINISH
! {Temp}
! %IF SSOWN_LOADMONITOR&1#0 %THEN %START
! MONOUT(SREF(TYPE&X'1FFFFFFF')." ref to ".ENTRY." at ".HTOS(REFAD,8))
! %IF DR0&X'00FFFFFF'#0 %THEN MONOUT(" of length ".HTOS(DR0&X'00FFFFFF',8))
! MONOUT(" added to active ref tables")
! %FINISH
! {Temp}
J=IRECAD-START; ! Offset from start of AREA
R2==RECORD(IRECAD)
R2_DR0=DR0
R2_DR1=REFAD
! If this is a single word reference then hold INTEGER(REFAD) in R2_OFFSET.
! This is in case the reference is eventually made pseudo dynamic. We must
! be able to restore the offset if the reference is eventually satisfied
! indirectly through something else being loaded. The reference could become
! pseudo dynamic through LOADPARM MIN being set or by unloading if the ref
! gets satisfied by an entry at a higher loadlevel which is subsequently
! unloaded.
IF TYPE&X'1FFFFFFF'=CODE!DATA THEN R2_OFFSET=INTEGER(REFAD) ELSE R2_ADYNR=0
! If this is not the only member of this chain of info records then
! must update the link field from the now penultimate info record
! else the FIRST field of the basic record should point at this
! record.
! The LAST field must be updated regardless.
IF R1_LAST>0 THEN START
R3==RECORD(START+R1_LAST)
R3_LINK=J
FINISH ELSE R1_FIRST=J
R1_LAST=J
! If this is a dynamic or a new unresolved ref then require escape record
IF TYPE&DYN#0 OR UNRESOLVEDREF#FALSE THEN START
! Data refs - Escape record must store the descriptor before
! overwriting with escape desc for eventual restoration when called.
! List 11 refs - Not relevant. Can only be made 'dynamic' by CHANGEREFTYPE
! Create new escape record
! It doesn't matter that TYPE may have the unsat bit set since
! ESCAPEREC only looks for the presence or absence of the dyn bit.
IF TYPE&X'1FFFFFFF'=CODE THEN C
ADYNR=ESCAPEREC(TYPE,RECAD-START,REFAD,(DR0>>24)&X'1F') ELSE C
ADYNR=ESCAPEREC(TYPE,RECAD-START,REFAD,(DR0>>24)&X'1F') AND C
REFAD=REFAD-4; ! Data ref points at address field of descriptor
LONGINTEGER(REFAD)=ESCDR!ADYNR UNLESS SSOWN_DYNREFEND=0=SSOWN_UNSHAREDBGLA
! i.e. not with ss dynrefs in a shared bgla
R2_ADYNR=ADYNR
! %IF SSOWN_LOADMONITOR&1#0 %THEN %C
! MONOUT("Dynamic escape table for ".ENTRY." at ".HTOS(ADYNR,8)) {Temp}
IF SSOWN_LOADMONITOR&16#0 AND UNRESOLVEDREF#FALSE THEN START
IF TYPE&X'1FFFFFFF'=CODE THEN C
DUM="Code ref ".ENTRY." at ".HTOS(REFAD,8) ELSE C
DUM="Data ref ".ENTRY." at ".HTOS(REFAD+4,8)
TERMINALPRINT(DUM," made type UNRESOLVED")
FINISH
FINISH
REPEAT
! Increment SSOWN_SSCOMREG(7) if it's new unsatisfied ref.
! The condition for this is that this reference is an unsatisfied one
! and (it's the first occurrence of the ref or (it's already there and neither
! the unsatisfied bit nor the unresolved bit is set)).
FLAG=-1 IF TYPE&DYN=0 AND (FOUND=FALSE OR (FOUND#FALSE AND RTYPE&X'30000000'=0))
ALLOWINTERRUPTS
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"SFiiiIIII")
RETURN
END ; ! OF ADDREF
!
!
SYSTEMROUTINE FILLPATTN(INTEGER NCOPIES,N,FROM,TO)
! Moves NCOPIES of N bytes from address FROM to address TO
INTEGER J,Q,S
J=1; ! J groups at a time
Q=N; ! J groups are Q bytes long i.e. Q=J*N
S=FROM
WHILE NCOPIES>0 CYCLE
MOVE(Q,S,TO)
TO=TO+Q
NCOPIES=NCOPIES-J
IF Q<=2048 AND S#FROM THEN J=J<<1
! The test Q<=2048 ensures that we never get MOVEs of >4Kbytes,
! so that the source & destination fields together cover no more
! than 2 consecutive pages. This allows store accesses to be
! recognised as "sequential".
! The test S#TO simply avoids doubling J after the first MOVE,
! because at that point there is only one copy of the pattern
! in the area to be initialised
IF J>NCOPIES THEN J=NCOPIES
Q=J*N
S=TO-Q
REPEAT
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(J,"Iiii")
RETURN
END ; ! OF FILLPATTN
!
!
INTEGERFN CHECKBOUNDSITE(INTEGER AD,LEN)
IF NEWCONNECT=0 THEN START
! This function checks whether there are sufficient contiguous free
! segments from the segment containing AD to connect a file of LEN
! bytes. A result of 1 means that there are not sufficient free segs,
! 0 means that there are.
INTEGER NSEG,FLAG,SEGSTART,FIRST,LAST,RES,DIFF
STRING (31) FNAME
! Get no of segs required.
NSEG=((LEN+X'0003FFFF')&X'FFFC0000')>>18
SEGSTART=(AD&X'FFFC0000')>>18
WHILE NSEG>0 CYCLE
FNAME=SEGSINUSE(FIRST,LAST,SEGSTART)
IF FNAME#"" THEN START
! Try to disconnect it
DISCONNECT(FNAME,FLAG)
IF FLAG#0 THEN START
RES=1
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"iiR")
RESULT =1
FINISH
FINISH ELSE LAST=SEGSTART; ! i.e. unused
DIFF=LAST-SEGSTART+1
SEGSTART=SEGSTART+DIFF
NSEG=NSEG-DIFF
REPEAT
RES=0
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"iiR")
RESULT =0
FINISH
END ; ! OF CHECKBOUNDSITE
!
!
SYSTEMROUTINE LOADFILE2(STRING (31) FILE, INTEGERNAME FLAG, C
INTEGER LOCLL)
RECORD (OFMF)ARRAYFORMAT OFMAF(1:7)
RECORD (OFMF)ARRAYNAME OFM
INTEGERARRAYFORMAT LDATAAF(0:15)
INTEGERARRAYNAME LDATA
RECORD (LD1F)NAME LD1{Procedure entries}
RECORD (LD4F)NAME LD4{Data entries}
RECORD (LD7F)NAME LD7{Static refs},
LD8{Dynamic refs},LD11{Single word refs}
RECORD (LD9F)NAME LD9{Data refs}
RECORD (LD13F)NAME LD13{Multiple initialisation requests}
RECORD (LD14F)NAME LD14{Relocation block requests}
RECORD (RF) RR
RECORD (ADDF)ARRAY FENT(0:3)
CONSTINTEGERARRAY FENTTYPE(0:3)=0,32,32,64
CONSTSTRING (7) STEMPCODE="T#CODE",STEMPGLA="T#GLA"
INTEGER I,J,K,KK,FFLAG,PDMEM,LBASE,BOUND,XSEG,GLAREQ,LANG
INTEGER BISTKAD,CODEBLOCKED,CODEOK,CODEAD,GLABLOCKED,GLAOK,GLAAD
INTEGER AD,AREA,ISTKSIZE,ISTKOK,NRELOCNS,AREA1,AREA2,START,FROM
INTEGER MAINBIT,LCMN,N,REFARRAY,DUMMY,AFILE,LHD,REFAD,REFLOC,REFVAL
INTEGERARRAY PREFAREASTART(1:7) { For bound files if we have to unbind}
LONGINTEGER DESC
INTEGERNAME DR0,DR1
STRING (255) S1,S2
STRING (31) TEMPCODE,TEMPGLA
IF SSOWN_LOADINPROGRESS=FALSE THEN SSOWN_LOADINPROGRESS=TRUE
DR0==INTEGER(ADDR(DESC))
DR1==INTEGER(ADDR(DESC)+4)
!
!***
!*** START OF LOAD PHASE
!***
!
UNLESS FILE->S1.(".").S2 THEN FILE=SSOWN_SSOWNER.".".FILE
! Check if already loaded
DUMMY=FNAMETYPE
DESC=SEARCHLOADED(FILE,DUMMY,PRIME)
IF DESC#FALSE THEN START
IF NEWCONNECT#0 THEN SETUSE (LASTFN, -1, 0)
FLAG=350; ! Already loaded
SSOWN_SSFNAME=FILE
IF SSOWN_LOADMONITOR&2#0 THEN MONOUT("**** ".FILE." already loaded ****")
->OUT
FINISH
IF SSOWN_LOADMONITOR&2#0 THEN MONOUT("**** Starting to load ".FILE." ****")
SSOWN_SSCOMREG(8)=ADDR(SSOWN_AREASTART(1)); ! For simulator
CONNECT(FILE,1,0,0,RR,FLAG); ! Execute & read
->OUT UNLESS FLAG=0
IF NEWCONNECT#0 THEN SETUSE(LASTFN,-1,0)
AFILE=RR_CONAD; ! AFILE will always be conad of file with the code
! Now check that FILE is an object file. If not it may be a macro
IF RR_FILETYPE#SSOBJFILETYPE THEN START
SETUSE (LASTFN, -1, 0)
IF RR_FILETYPE=SSCHARFILETYPE THEN START
! Macro or at least assume it to be
SSOWN_MACRODR0=RR_DATAEND-RR_DATASTART
SSOWN_MACRODR1=RR_CONAD+RR_DATASTART
! LHD=PRIME
! ADDENTRY(FILE,FFLAG,FNAMETYPE,0,AFILE,0,LOCLL,LHD)
! FLAG=FFLAG %AND ->OUT %IF FFLAG#0
! EXAMINEMACRO somewhere here for MACRONAME????
! LHD=HASH(MACRONAME,PRIME)
! ADDENTRY(MACRONAME,FFLAG,LHD,MACRO,SSOWN_MACRODR0,SSOWN_MACRODR1,LOCLL)
! FLAG=FFLAG %AND ->OUT %IF FFLAG#0
FLAG=316; ! Attempt to call macro
IF SSOWN_LOADMONITOR&2#0 THEN C
MONOUT("**** Character file ".FILE." - macro assumed ****")
->OUT
FINISH ELSE START
SSOWN_SSFNAME=FILE
FLAG=267; ! Invalid filetype
->OUT
FINISH
FINISH
FENT(I)=0 FOR I=3,-1,0
FENT(0)_FILE=FILE
! We are now committed to loading the file. The problem is that it is
! not possible to tidy up an unload with UNLOAD2 until we have the
! filename record(s) in the loader tables and this doesn't happen until
! all the relocations have been done and all the entries are added -
! quite a long way down the code. If we get INT:Aed in the interim
! then we could be in trouble because use counts will have been set
! and possibly T#CODE and T#GLA created but it is still invisible
! to UNLOAD2.
! Solve this by storing the names in array PARTLOADED which is cleared
! after the filename records are in place. UNLOAD2 inspects PARTLOADED.
SSOWN_PARTLOADED(0)=FILE
SETUSE(LASTFN,1,0); ! Increment use count
! Now want to find out if FILE is a) a pdfile mem, b) a bound file
! or c) has code crossing a segment boundary
IF FILE->S1.("_").S2 THEN PDMEM=TRUE ELSE PDMEM=FALSE
LBASE=RR_CONAD+INTEGER(RR_CONAD+24); ! Start of load data
IF 14#INTEGER(LBASE)#15 THEN FLAG=226 AND ->OUT; ! Corrupt obj
LDATA==ARRAY(LBASE,LDATAAF)
IF LDATA(5)#0 THEN BOUND=TRUE ELSE BOUND=FALSE
OFM==ARRAY(RR_CONAD+INTEGER(RR_CONAD+28)+4,OFMAF)
!<<<<<<<<< ENHANCED OFM STRUCT >>>>>>>>>>>>
SSOWN_AREASTART(1)=RR_CONAD+OFM(1)_START; ! Code
SSOWN_AREASTART(4)=RR_CONAD+OFM(4)_START; ! SST
IF BOUND#FALSE THEN START
! Get preferred areastarts in case we have to unbind later.
! **** Note that there is an implicit assumption in handling bound
! **** files that the CODE and the SST are contiguous areas. Relocating
! **** into T#CODE files wouldn't work otherwise.
PREFAREASTART(1)=LDATA(5)+OFM(1)_START; ! Code
PREFAREASTART(4)=LDATA(5)+OFM(4)_START; ! SST
FINISH
! Relocate the code+sst if the file is a pdfile member and its code
! crosses a segment boundary. A linked file may have a total code length that
! suggests it may cross a segment boundary but the linker should have
! ensured that no one code area does.
IF PDMEM#FALSE AND SSOWN_AREASTART(1)>>SEGSHIFT#(SSOWN_AREASTART(1)+OFM(1)_L)>>SEGSHIFT C
THEN XSEG=TRUE ELSE XSEG=FALSE
IF XSEG#FALSE AND SSOWN_LOADMONITOR&1#0 THEN C
MONOUT("** Warning: Code relocated - crosses segment boundary")
! And while we're here lets find out how much GLA is going to be
! needed
GLAREQ=0
FOR I=4,-1,1 CYCLE
GLAREQ=GLAREQ+OFM(UNSHAREDAREA(I))_L
REPEAT
! And what language it is - top byte of 4th word of GLA (or PLT
! if it exists
IF OFM(3)_L=0 THEN I=2 ELSE I=3
LANG=BYTEINTEGER(RR_CONAD+OFM(I)_START+16)
UNLESS 1<=LANG<=10 THEN LANG=0
IF SSOWN_LOADMONITOR&2#0 THEN MONOUT("Module source language ".MODLANG(LANG))
! *** Bound files ***
! Bound files have to be treated somewhat differently. If the code
! and gla can be connected at their preferred sites then all the
! relocations are already satisfied, but if either or both cannot
! be connected at preferred sites then the preset relocations must
! be unscrambled before the relocations are fixed up with the actual
! addresses.
! Bound files which are members of pdfiles: Although in theory the
! code could be copied to a T#CODE file to the preferred site
! (assuming it's available), doing this superficially attractive
! trick could in fact cause havoc with, for example, large packages
! held as bound files in a single pdfile. Imagine 8 private copies
! of SPSS all running simultaneously.! Bound files which are themselves
! members of pdfiles will be treated as having the preferred code
! site unavailable and relocated in situ.
! T#CODE files will only be employed for code crossing segment
! boundaries. ( Incidentally this overrides pdfile mem considerations).
! Linking is common to both bound and unbound files
! *********************************************************************
UNLESS BOUND=FALSE THEN START
!** BOUNDFILE START
IF SSOWN_LOADMONITOR&1#0 THEN MONOUT(FILE." is a bound file")
BISTKAD=LDATA(10); ! Initstack seg is invariant
! Deal with code first. If it doesn't cross a segment boundary
! then we want to connect the whole file at LDATA(5) else want to
! connect a T#CODE file with CODE+SST at that address.
IF XSEG#FALSE THEN START
! Must move the code (and sst)
TEMPCODE=STEMPCODE.NEXTTEMP
SSOWN_PARTLOADED(2)=TEMPCODE
! Check if preferred site is free
IF NEWCONNECT#0 THEN START
CODEAD = LDATA(5)
OUTFILE (TEMPCODE,OFM(1)_L+OFM(4)_L+32,0,X'40',CODEAD,FLAG)
IF FLAG=0 THEN START
CODEBLOCKED = FALSE
CODEOK = TRUE
FINISH ELSE START
CODEBLOCKED = TRUE
CODEOK = FALSE
OUTFILE (TEMPCODE,OFM(1)_L+OFM(4)_L+32,0,0,CODEAD,FLAG)
FINISH
FINISH ELSE START
CODEBLOCKED=CHECKBOUNDSITE(LDATA(5),OFM(1)_L+OFM(4)_L+32)
IF CODEBLOCKED=FALSE THEN START
CODEOK=TRUE
CODEAD=LDATA(5)
OUTFILE(TEMPCODE,OFM(1)_L+OFM(4)_L+32,0,X'40',CODEAD,FLAG)
FINISH ELSE START
CODEOK=FALSE
OUTFILE(TEMPCODE,OFM(1)_L+OFM(4)_L+32,0,0,CODEAD,FLAG)
FINISH
FINISH
->OUT UNLESS FLAG=0
AFILE=CODEAD
IF NEWCONNECT=0 THEN SETUSE(TEMPCODE,1,0)
FENT(3)_FILE=TEMPCODE
! Store originating SSOWN_AREASTART(1) as word 8 of T#CODE so that
! originating address can be passed back to NDIAGS
INTEGER(CODEAD+28)=SSOWN_AREASTART(1)
! Move the code and sst
SSOWN_AREASTART(1)=32+CODEAD
SSOWN_AREASTART(4)=SSOWN_AREASTART(1)+OFM(1)_L
MOVE(OFM(1)_L,RR_CONAD+OFM(1)_START,SSOWN_AREASTART(1))
MOVE(OFM(4)_L,RR_CONAD+OFM(4)_START,SSOWN_AREASTART(4))
FINISH ELSE START
! Doesn't cross seg boundary
! If preferred code location is free then reconnect FILE at that
! location.
! There are two special conditions. a) code may already be
! connected at preferred site and b) pdfile members require
! code relocations regardless.
! Check if preferred site is free
IF NEWCONNECT=0 THEN START
CODEBLOCKED=CHECKBOUNDSITE(LDATA(5),INTEGER(RR_CONAD+8))
IF PDMEM=FALSE AND CODEBLOCKED=FALSE THEN START
! Relocate at preferred site
SETUSE(FILE,-1,0); ! Decrement use count
RR_CONAD=LDATA(5)
DISCONNECT(FILE,FFLAG)
IF FFLAG=0 THEN START
! Disconnected O.K.
CONNECT(FILE,1,0,X'40',RR,FLAG)
! Connect at fixed site
->OUT UNLESS FLAG=0
AFILE=RR_CONAD
SETUSE(FILE,1,0); ! Inc use count
LBASE=RR_CONAD+INTEGER(RR_CONAD+24)
LDATA==ARRAY(LBASE,LDATAAF)
OFM==ARRAY(RR_CONAD+INTEGER(RR_CONAD+28)+4,OFMAF)
SSOWN_AREASTART(1)=RR_CONAD+OFM(1)_START
SSOWN_AREASTART(4)=RR_CONAD+OFM(4)_START
CODEOK=TRUE
FINISH ELSE CODEOK=FALSE
FINISH ELSE START
IF PDMEM=FALSE AND LDATA(5)=AFILE THEN C
CODEOK=TRUE ELSE CODEOK=FALSE
FINISH
FINISH ELSE START
IF PDMEM=TRUE THEN CODEOK = FALSE C
ELSE IF LDATA(5)=AFILE THEN CODEOK = TRUE ELSE START
! Relocate at preferred site
RR_CONAD=LDATA(5)
DISCONNECT(FILE,FFLAG)
IF FFLAG=0 THEN START
! Disconnected O.K.
CONNECT(FILE,1,0,X'40',RR,FLAG)
IF FLAG=0 THEN CODEOK = TRUE ELSE START
CONNECT(FILE,1,0,0,RR,FLAG)
CODEOK = FALSE
->OUT UNLESS FLAG=0
FINISH
! Connect at fixed site
AFILE=RR_CONAD
LBASE=RR_CONAD+INTEGER(RR_CONAD+24)
LDATA==ARRAY(LBASE,LDATAAF)
OFM==ARRAY(RR_CONAD+INTEGER(RR_CONAD+28)+4,OFMAF)
SSOWN_AREASTART(1)=RR_CONAD+OFM(1)_START
SSOWN_AREASTART(4)=RR_CONAD+OFM(4)_START
FINISH ELSE CODEOK=FALSE
FINISH
FINISH
FINISH
! Now the gla
! GLAAD is always the ad of the first byte of gla used by this file
TEMPGLA=STEMPGLA.NEXTTEMP
SSOWN_PARTLOADED(1)=TEMPGLA
IF NEWCONNECT=0 THEN START
GLABLOCKED=CHECKBOUNDSITE(LDATA(6),GLAREQ)
IF GLABLOCKED=FALSE THEN GLAOK=TRUE ELSE GLAOK=FALSE
IF GLAOK=FALSE THEN C
OUTFILE(TEMPGLA,GLAREQ,0,0,GLAAD,FLAG) C
ELSE START
GLAAD=LDATA(6)
OUTFILE(TEMPGLA,GLAREQ,0,X'40',GLAAD,FLAG)
FINISH
FINISH ELSE START
GLAAD = LDATA(6)
OUTFILE(TEMPGLA,GLAREQ,0,X'40',GLAAD,FLAG)
IF FLAG=0 THEN START
GLABLOCKED = FALSE
GLAOK = TRUE
FINISH ELSE START
GLABLOCKED = TRUE
GLAOK = FALSE
OUTFILE(TEMPGLA,GLAREQ,0,0,GLAAD,FLAG)
FINISH
FINISH
->OUT UNLESS FLAG=0
IF NEWCONNECT=0 THEN SETUSE(TEMPGLA,1,0)
FENT(1)_FILE=TEMPGLA
FENT(1)_GLAFROM=GLAAD
FENT(1)_GLATO=GLAAD+GLAREQ
! Now assign the various SSOWN_AREASTARTs
! If GLAOK is false then going to have to unbind relocation list later
! so calculate PREFAREASTARTs as well.
AD=GLAAD
IF GLAOK=FALSE THEN DUMMY=LDATA(6)-AD
FOR I=1,1,4 CYCLE
AREA=UNSHAREDAREA(I)
SSOWN_AREASTART(AREA)=AD
IF GLAOK=FALSE THEN PREFAREASTART(AREA)=AD+DUMMY
MOVE(OFM(AREA)_L,RR_CONAD+OFM(AREA)_START,AD)
AD=AD+OFM(AREA)_L
REPEAT
! Initialised stack
! If loading on basegla then take the initstack off the top end
! of the initialised area else off the bottom end.
ISTKSIZE=OFM(7)_L
IF ISTKSIZE#0 THEN START
IF SSOWN_USTB=0 THEN INITUSTK
IF LOCLL#0 AND SSOWN_TEMPISTK=BISTKAD THEN ISTKOK=TRUE ELSE C
ISTKOK=FALSE AND PREFAREASTART(7)=BISTKAD
IF LOCLL#0 THEN START
! User gla
IF SSOWN_TEMPISTK+ISTKSIZE<=SSOWN_PERMISTK THEN START
SSOWN_AREASTART(7)=SSOWN_TEMPISTK
MOVE(ISTKSIZE,RR_CONAD+OFM(7)_START,SSOWN_AREASTART(7))
SSOWN_TEMPISTK=SSOWN_TEMPISTK+ISTKSIZE
FINISH ELSE START
FLAG=312
->OUT
FINISH
FINISH ELSE START
IF SSOWN_PERMISTK-ISTKSIZE>=SSOWN_TEMPISTK THEN START
SSOWN_PERMISTK=SSOWN_PERMISTK-ISTKSIZE
SSOWN_AREASTART(7)=SSOWN_PERMISTK
MOVE(ISTKSIZE,RR_CONAD+OFM(7)_START,SSOWN_AREASTART(7))
FINISH ELSE START
FLAG=312
->OUT
FINISH
FINISH
FENT(2)_FILE="+IS"
FENT(2)_GLAFROM=SSOWN_AREASTART(7)
FENT(2)_GLATO=SSOWN_AREASTART(7)+ISTKSIZE
FINISH ELSE ISTKOK=TRUE; ! ie none to worry about
IF SSOWN_LOADMONITOR&1#0 THEN START
S1=" connected at preferred site"
IF CODEOK=FALSE THEN MONOUT("**Warning: CODE NOT".S1) ELSE C
MONOUT("CODE".S1)
IF GLAOK=FALSE THEN MONOUT("**Warning: GLA NOT".S1) ELSE C
MONOUT("GLA".S1)
IF ISTKSIZE#0 AND ISTKOK=FALSE THEN MONOUT("**Warning: ISTK NOT". C
S1) ELSE MONOUT("ISTK".S1)
FINISH
! Do as many of the relocations as required
! If CODEOK=TRUE then dont have to do CODE or SST relocations
! (where AREA2=CODE or SST)
! If GLAOK=TRUE then dont do PLT,GLA,ICMN,USTK relocations
! (AREA2=3,2,5,6)
! If ISTKOK=TRUE then dont do ISTK relocations (AREA2=7)
UNLESS CODEOK#FALSE AND (GLAOK#FALSE AND ISTKOK#FALSE) C
THEN START
! Some relocations necessary. Have to unbind those which have
! to be done again first
I=LDATA(14)
WHILE I#0 CYCLE
LD14==RECORD(RR_CONAD+I)
NRELOCNS=LD14_N; ! No of relocations for this record
K=RR_CONAD+I+8; ! Address of first AREALOC
KK=K+4; ! Address of first BASELOC
FOR J=NRELOCNS-1,-1,0 CYCLE
AREA2=INTEGER(KK)>>24
IF ((CODEOK=FALSE AND (AREA2=1 OR AREA2=4)) OR C
(GLAOK=FALSE AND (AREA2=2 OR AREA2=5 OR AREA2=6 OR C
AREA2=3)) OR (ISTKOK=FALSE AND AREA2=7)) THEN START
! Unbind first
AREA1=INTEGER(K)>>24
AD=SSOWN_AREASTART(AREA1)+INTEGER(K)&X'00FFFFFF'
! Relocating in this instance means replacing the old
! preferred areastart by the actual areastart.
INTEGER(AD)=INTEGER(AD)-PREFAREASTART(AREA2)+SSOWN_AREASTART(AREA2)
FINISH
K=K+8
KK=K+4
REPEAT
I=LD14_LINK
REPEAT
FINISH
!** BOUND FILE FINISH
FINISH ELSE START
GLAAD=GETGLA(LOCLL,GLAREQ); ! Assign area on BASE or USER gla
AD=GLAAD
FOR I=1,1,4 CYCLE
AREA=UNSHAREDAREA(I)
SSOWN_AREASTART(AREA)=AD
MOVE(OFM(AREA)_L,RR_CONAD+OFM(AREA)_START,AD)
AD=AD+OFM(AREA)_L
REPEAT
FENT(1)_FILE="+GL"
FENT(1)_GLAFROM=GLAAD
FENT(1)_GLATO=GLAAD+GLAREQ
! Check whether code needs relocation
UNLESS XSEG=FALSE AND OFM(1)_PROP&1=0 THEN START
SSOWN_PARTLOADED(2)=TEMPCODE
TEMPCODE=STEMPCODE.NEXTTEMP
OUTFILE(TEMPCODE,32+OFM(1)_L+OFM(4)_L,0,0,CODEAD,FLAG)
->OUT UNLESS FLAG=0
IF NEWCONNECT=0 THEN SETUSE(TEMPCODE,1,0)
FENT(3)_FILE=TEMPCODE
AFILE=CODEAD
INTEGER(CODEAD+28)=SSOWN_AREASTART(1); ! Store orig AREASTART(1)
SSOWN_AREASTART(1)=CODEAD+32
SSOWN_AREASTART(4)=SSOWN_AREASTART(1)+OFM(1)_L
MOVE(OFM(1)_L,RR_CONAD+OFM(1)_START,SSOWN_AREASTART(1)); ! CODE
MOVE(OFM(4)_L,RR_CONAD+OFM(4)_START,SSOWN_AREASTART(4)); ! SST
IF OFM(1)_PROP&1#0 AND SSOWN_LOADMONITOR&1#0 THEN C
MONOUT("** Warning - Code flagged as unshareable and relocated")
FINISH
! Initialised stack (if any)
! If loading on BASEGLA then take the ISTK off the top of the area
! else off the bottom
! MONOUT("Relocations")
ISTKSIZE=OFM(7)_L
IF ISTKSIZE#0 THEN START
IF SSOWN_USTB=0 THEN INITUSTK
IF LOCLL#0 THEN START
! Temp ISTK
IF SSOWN_TEMPISTK+ISTKSIZE<=SSOWN_PERMISTK THEN START
SSOWN_AREASTART(7)=SSOWN_TEMPISTK
MOVE(ISTKSIZE,RR_CONAD+OFM(7)_START,SSOWN_AREASTART(7))
SSOWN_TEMPISTK=SSOWN_TEMPISTK+ISTKSIZE
FINISH ELSE START
FLAG=312
->OUT
FINISH
FINISH ELSE START
IF SSOWN_PERMISTK-ISTKSIZE>=SSOWN_TEMPISTK THEN START
SSOWN_PERMISTK=SSOWN_PERMISTK-ISTKSIZE
SSOWN_AREASTART(7)=SSOWN_PERMISTK
MOVE(ISTKSIZE,RR_CONAD+OFM(7)_START,SSOWN_AREASTART(7))
FINISH ELSE START
FLAG=312
->OUT
FINISH
FINISH
FENT(2)_FILE="+IS"
FENT(2)_GLAFROM=SSOWN_AREASTART(7)
FENT(2)_GLATO=SSOWN_AREASTART(7)+ISTKSIZE
FINISH
!*
!* RELOCATIONS (listhead 14)
!*
I=LDATA(14)
WHILE I#0 CYCLE
LD14==RECORD(RR_CONAD+I)
NRELOCNS=LD14_N
K=RR_CONAD+I+8; ! Ad of first AREALOC
KK=K+4; ! Ad of first BASELOC
FOR J=NRELOCNS-1,-1,0 CYCLE
AREA1=INTEGER(K)>>24
AREA2=INTEGER(KK)>>24
AD=SSOWN_AREASTART(AREA1)+INTEGER(K)&X'00FFFFFF'
INTEGER(AD)=INTEGER(AD)+SSOWN_AREASTART(AREA2)+INTEGER(KK)&X'00FFFFFF'
K=K+8
KK=K+4
REPEAT
I=LD14_LINK
REPEAT
FINISH
! All code common to both bound and unbound files from here
!*
!* MULTIPLE INITIALISATIONS (listhead 13)
!*
I=LDATA(13)
WHILE I#0 CYCLE
LD13==RECORD(RR_CONAD+I)
START=SSOWN_AREASTART(LD13_A)+LD13_DISP
IF LD13_LEN=1 THEN FROM=ADDR(LD13_ADDR) ELSE C
FROM=RR_CONAD+LD13_ADDR
FILLPATTN(LD13_REP,LD13_LEN,FROM,AD)
I=LD13_LINK
REPEAT
! If a T#CODE was created then change access to ER. All relocations
! now completed.
IF XSEG#FALSE OR OFM(1)_PROP&1#0 THEN START
CHANGEACCESS(TEMPCODE,5,FLAG)
->OUT IF FLAG#0
FINISH
! Load monitor OFM output
IF SSOWN_LOADMONITOR&2#0 THEN START
FOR I=1,1,7 CYCLE
IF OFM(I)_L#0 THEN MONOUT(AREANAME(I)." ". C
HTOS(SSOWN_AREASTART(I),8)." ".HTOS(OFM(I)_L,8))
REPEAT
FINISH
!
!***
!*** END OF LOAD PHASE
!***
!
! Add code and data entries to loader tables
!*
!* CODE ENTRIES (listhead 1)
!*
! MONOUT("Entries")
I=LDATA(1)
WHILE I#0 CYCLE
LD1==RECORD(RR_CONAD+I)
I=LD1_LINK
! Special for the DAP
AD=SSOWN_AREASTART((LD1_LOC>>24)&X'0F')+LD1_LOC&X'00FFFFFF'; ! Ad of e.p.
! If the top bit of LD1_LOC is set then this is a main entry.
! If it's the first encountered in this load then assign AD
! to SSOWN_MAINDR1. Don't add entry points called S#GO to loader tables
IF LD1_LOC&X'80000000'#0 THEN START
! Found a main entry
MAINBIT=X'80000000'
IF SSOWN_MAINDR1=0 THEN SSOWN_MAINDR1=AD AND FENT(0)_MAINEP=AD
FINISH ELSE MAINBIT=0
UNLESS LD1_IDEN="S#GO" THEN START
! Establish descriptor type. If it's a code area descriptor then
! use E1000000 else B1000000.
IF (LD1_LOC>>24)&X'0000007F'=1 THEN DESC=CODEDR!AD ELSE C
DESC=DESCDR!AD
! Add to loader tables
LHD=HASH(LD1_IDEN,PRIME)
IF LOCLL=0 THEN C
ADDENTRY(LD1_IDEN,SSOWN_PLH,FFLAG,SSOWN_PERMOFFSET,MAINBIT!CODE,DR0,DR1,2,LHD) ELSE C
ADDENTRY(LD1_IDEN,SSOWN_TLH,FFLAG,SSOWN_TEMPOFFSET,MAINBIT!CODE,DR0,DR1,3,LHD)
IF FFLAG=354 THEN START
IF SSOWN_NOWARNINGS=FALSE THEN C
TERMINALPRINT("** WARNING - Code entry ".LD1_IDEN," already loaded")
FFLAG=0
FINISH
FLAG=FFLAG AND ->OUT IF FFLAG#0
! Satisfy any outstanding refs to this entry
SATISFYREF(LD1_IDEN,DESC,FFLAG,CODE,LOCLL,LHD)
FLAG=FFLAG AND ->OUT IF 289#FFLAG#0; ! Shouldn't happen for code
FINISH
IF SSOWN_LOADMONITOR&4#0 THEN MONOUT("Code Entry ". C
LD1_IDEN." at ".HTOS(INTEGER(AD+4),8))
REPEAT
!*
!* DATA ENTRIES (listhead 4)
!*
I=LDATA(4)
WHILE I#0 CYCLE
LD4==RECORD(RR_CONAD+I)
! Values of LD_A>=10 are treated as initialised common i.e. area 6
IF LD4_A>=10 THEN AD=SSOWN_AREASTART(6) ELSE AD=SSOWN_AREASTART(LD4_A)
AD=AD+LD4_DISP
DESC=LD4_L
DESC=(DESC<<32)!AD
LHD=HASH(LD4_IDEN,PRIME)
IF LOCLL=0 THEN C
ADDENTRY(LD4_IDEN,SSOWN_PLH,FFLAG,SSOWN_PERMOFFSET,DATA,DR0,DR1,2,LHD) ELSE C
ADDENTRY(LD4_IDEN,SSOWN_TLH,FFLAG,SSOWN_TEMPOFFSET,DATA,DR0,DR1,3,LHD)
FLAG=FFLAG AND ->OUT IF FFLAG#0
! Satisfy any outstanding refs to this entry
SATISFYREF(LD4_IDEN,DESC,FFLAG,DATA,LOCLL,LHD)
FLAG=FFLAG AND ->OUT IF 289#FFLAG#0
IF SSOWN_LOADMONITOR&4#0 THEN MONOUT("Data Entry ". C
LD4_IDEN." at ".HTOS(AD,8)." of length ".HTOS(LD4_L,8))
I=LD4_LINK
REPEAT
!*
!*
!*
! If here then have successfully added any code and data entries
! to loader tables and have satisfied any outstanding refs to them.
! Now add the filename records to listhead(PRIME)
FOR I=3,-1,0 CYCLE
IF FENT(I)_FILE#"" THEN START
IF LOCLL=0 THEN ADDENTRY(FENT(I)_FILE,SSOWN_PLH,FFLAG,SSOWN_PERMOFFSET,FENTTYPE(I), C
FENT(I)_MAINEP,FENT(I)_DUM1,2,PRIME) ELSE C
ADDENTRY(FENT(I)_FILE,SSOWN_TLH,FFLAG,SSOWN_TEMPOFFSET,FENTTYPE(I),FENT(I)_MAINEP, C
FENT(I)_DUM1,3,PRIME)
FLAG=FFLAG AND ->OUT IF FFLAG#0
FINISH
REPEAT
SSOWN_PARTLOADED(I)="" FOR I=2,-1,0; ! UNLOAD2 will pick it up now
!
!***
!*** LINK PHASE
!***
!
!*
!* STATIC PROCEDURE REFS (listhead 7)
!*
! MONOUT("Code Refs")
I=LDATA(7)
WHILE I#0 CYCLE
AD=RR_CONAD+I
LD7==RECORD(AD)
IF LD7_IDEN="S#DAPDATA" AND LOCLL=0 THEN FLAG=1011 AND ->OUT
! Now search currently loaded material for ref. If not found, add
! to list of unsat refs.
DUMMY=CODE
LHD=-1
DESC=CHECKLOADED(LD7_IDEN,DUMMY,LHD)
IF DESC#0 THEN START
REFAD=SSOWN_AREASTART(LD7_REFLOC>>24)+LD7_REFLOC&X'00FFFFFF'; ! Desc location
LONGINTEGER(REFAD)=DESC
! %IF SSOWN_LOADMONITOR&1#0 %THEN MONOUT("Static code ref to ".LD7_IDEN." at ".HTOS(REFAD,8). %C
! " satisfied by known entry") {Temp}
FINISH ELSE START
! Didn't find it
ADDREF(LD7_IDEN,FFLAG,0,AD+4,CODE,UNSATISFIED,LOCLL,LHD,1)
FLAG=FFLAG AND ->OUT IF FFLAG>0; ! Something nasty
SSOWN_SSCOMREG(7)=SSOWN_SSCOMREG(7)+1 IF FFLAG<0; ! A new unsat ref
FINISH
I=LD7_LINK
REPEAT
!
!*
!* DYNAMIC PROCEDURE REFS (listhead 8)
!*
I=LDATA(8)
WHILE I#0 CYCLE
AD=RR_CONAD+I
LD8==RECORD(AD)
IF LD8_IDEN="S#DAPDATA" AND LOCLL=0 THEN FLAG=1011 AND ->OUT
! Search loaded material. If not found add to dyn ref list.
DUMMY=CODE
LHD=-1
DESC=CHECKLOADED(LD8_IDEN,DUMMY,LHD)
IF DESC#0 THEN START
REFAD=SSOWN_AREASTART(LD8_REFLOC>>24)+LD8_REFLOC&X'00FFFFFF'
LONGINTEGER(REFAD)=DESC
! %IF SSOWN_LOADMONITOR&1#0 %THEN MONOUT("Dynamic code ref to ".LD8_IDEN." at ".HTOS(REFAD,8). %C
! " satisfied by known entry") {Temp}
FINISH ELSE START
ADDREF(LD8_IDEN,FFLAG,0,AD+4,CODE,DYNAMIC,LOCLL,LHD,1)
FLAG=FFLAG AND ->OUT IF FFLAG>0
FINISH
I=LD8_LINK
REPEAT
!
!*
!* DATA REFS (listhead 9)
!*
! MONOUT("Data Refs")
I=LDATA(9)
WHILE I#0 CYCLE
LD9==RECORD(RR_CONAD+I)
! MONOUT(LD9_IDEN)
LCMN=LD9_REFARRAY&X'80000000'; ! Common bit
REFARRAY=LD9_REFARRAY&X'7FFFFFFF'; ! Off common bit
I=LD9_LINK
AD=RR_CONAD+REFARRAY
N=INTEGER(AD); ! No of occurrences of this ref
AD=AD+4; ! Now points to first element of the REFLOCs
IF LD9_IDEN="ICL9CEAUXST" OR LD9_IDEN="ICL9LDLIBPROC" THEN START
! Deal with specials first
IF LD9_IDEN="ICL9CEAUXST" THEN START
! Create AUXSTACK if it doesn't already exist
IF SSOWN_SSAUXDR1=0 THEN INITAUXSTACK
REFVAL=SSOWN_SSCOMREG(41)
! COMREG(41)==Address of T#AUXST desc ( ADDR(SSOWN_SSAUXDR0) )
FINISH ELSE REFVAL=ADDR(SSOWN_SSLIBERR(1))
FOR J=N-1,-1,0 CYCLE
REFLOC=INTEGER(AD+J<<2)
REFAD=SSOWN_AREASTART((REFLOC>>24)&X'0F')+REFLOC&X'00FFFFFF'
INTEGER(REFAD)=REFVAL
! %IF SSOWN_LOADMONITOR&1#0 %THEN MONOUT("Data ref to ".LD9_IDEN." at ".HTOS(REFAD,8). %C
! " satisfied by known entry") {Temp}
REPEAT
CONTINUE
FINISH
DUMMY=DATA
LHD=-1
DESC=CHECKLOADED(LD9_IDEN,DUMMY,LHD)
IF DESC#0 THEN START
! It's loaded. Check the length of this ref against
! the entry. If lengths are the same then fill in
! and go on. If length ref<length loaded then
! print warning for all except FORTE and refs called F#BLCM. If > then print
! warning if PARM(LET) set, catastrophic fail
! otherwise.
DR0=DR0&X'7FFFFFFF'; ! Off any common bit
IF LD9_L<DR0 THEN START
DATAREFWARNING(FILE,LD9_IDEN,0,N) UNLESS LD9_IDEN="F#BLCM" OR C
LANG=FORTE OR SSOWN_NOWARNINGS#FALSE
FINISH ELSE IF LD9_L>DR0 THEN START
IF LET=0 THEN START
FLAG=296
SSOWN_SSFNAME=LD9_IDEN
TERMINALPRINT("**Error - Data ref ".LD9_IDEN." in ". C
FILE," longer than entry and LOADPARM LET not set")
->OUT
FINISH ELSE START
DATAREFWARNING(FILE,LD9_IDEN,N,0) IF SSOWN_NOWARNINGS=FALSE
FINISH
FINISH
FOR J=N-1,-1,0 CYCLE
REFLOC=INTEGER(AD+J<<2)
REFAD=SSOWN_AREASTART((REFLOC>>24)&X'0F')+REFLOC&X'00FFFFFF'
INTEGER(REFAD)=INTEGER(REFAD)+DR1; ! Satisfy ref
! %IF SSOWN_LOADMONITOR&1#0 %THEN MONOUT("Data ref to ".LD9_IDEN." at ".HTOS(REFAD,8). %C
! " of len ".HTOS(LD9_L,8)." satisfied by known entry") {Temp}
REPEAT
FINISH ELSE START
! Not currently loaded. Add to unsat ref table. It might
! already be there or it might be a new one. If it is there
! then it will have a length associated with it.
! For now just add the reference, deal with any inconsistencies
! at ref satisfying time.
ADDREF(LD9_IDEN,FFLAG,LD9_L!LCMN,AD,DATA!LCMN,UNSATISFIED,LOCLL,LHD,N)
FLAG=FFLAG AND ->OUT IF FFLAG>0
SSOWN_SSCOMREG(7)=SSOWN_SSCOMREG(7)+1 IF FFLAG<0
FINISH
REPEAT
!*
!* SINGLE WORD REFS (listhead 11)
!*
I=LDATA(11)
WHILE I#0 CYCLE
AD=RR_CONAD+I
LD11==RECORD(AD)
! Search currently loaded for either code or data ref
DUMMY=CODE!DATA
LHD=-1
DESC=CHECKLOADED(LD11_IDEN,DUMMY,LHD)
IF DESC#0 THEN START
REFAD=SSOWN_AREASTART(LD11_REFLOC>>24)+LD11_REFLOC&X'00FFFFFF'
INTEGER(REFAD)=INTEGER(REFAD)+DESC&X'00000000FFFFFFFF'
! %IF SSOWN_LOADMONITOR&1#0 %THEN MONOUT("Single wd ref to ".LD11_IDEN." at ".HTOS(REFAD,8). %C
! " satisfied by known entry") {Temp}
FINISH ELSE START
! Didn't find it
ADDREF(LD11_IDEN,FFLAG,0,AD+4,CODE!DATA,UNSATISFIED,LOCLL,LHD,1)
FLAG=FFLAG AND ->OUT IF FFLAG>0
SSOWN_SSCOMREG(7)=SSOWN_SSCOMREG(7)+1 IF FFLAG<0
FINISH
I=LD11_LINK
REPEAT
!
!***
!*** END OF LINK PHASE
!***
!
IF SSOWN_LOADMONITOR&2#0 THEN MONOUT("**** Finished loading ".FILE." ****")
OUT:
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"SFI")
RETURN
END ; ! OF LOADFILE2
!
!
SYSTEMROUTINE UNLOAD2(INTEGER LOCLL,FAIL)
! This routine unloads all files currently loaded with a load level
! greater than or equal to LOCLL.
! ***** Unloading strategy *****
! 1. Find out which files are to be unloaded by scanning the temporarily
! loaded entry tables (and the permanently loaded tables if the load
! failed). Since these tables operate like a stack then
! only require to look at records which are situated beyond the start
! of the area assciated with LOCLL. Also construct a table of
! gla ranges to go. (T#UGLA, maybe #BGLA, and any gla associated with
! bound files connected at their preferred gla sites.)
! 2. Reduce use counts and disconnect files with use counts of 0.
! Destroy any T#CODE or T#GLA files with use counts of 0.
! 3. Discard any ref in the unsat/dyn table which has a loadlevel
! >= LOCLL.
! Any ref with loadlevel<LOCLL which is currently satisfied (dyn/unsat
! bits in basic record NOT set) should be checked to see whether it now
! points into an area of gla about to be unloaded. If it does then unfix
! and replace with an escape descriptor derived from the associated escape
! table and warn the caller what has been done.
! *****************************************************************
! N.B. The only trappable failure of UNLOAD2 is when attempting to
! destroy T# files or disconnect files to be unloaded. Since these failures
! do not catastrophically affect the operation of the loader then they will
! merely be reported and UNLOAD2 won't return an error flag
!
INTEGERFN DEADREF(INTEGER AD,NDUFF)
INTEGER I,FLAG
FLAG=FALSE
FOR I=0,1,NDUFF CYCLE
FLAG=TRUE AND EXIT IF SSOWN_DUFFGLA(I)_FROM<=AD<=SSOWN_DUFFGLA(I)_TO
REPEAT
IF FLAG=FALSE AND SSOWN_DYNREFSTART<=AD<SSOWN_DYNREFEND THEN FLAG=TRUE
! A ss dynamic ref.
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"iIR")
RESULT =FLAG
END ; ! OF DEADREF
!
!
ROUTINE DISCARDFILES(INTEGERARRAYNAME LH, INTEGERNAME NDUFF, C
INTEGER START,DSTART,NEXTFREE)
RECORD (ENTF)NAME ENT
STRING (31) S1,S2,FNAME
INTEGER I,J,RECAD,LENE,FLAG
! All files from DSTART onwards have to be unloaded
! Chain down the filename listhead, pick up any new DUFFGLA ranges
! from T#GLA out of bound files, reduce use counts and destroy
! T#CODE and T#GLA as necessary.
! There are also DATASPACE entries on this listhead. These have
! ENT_TYPE=X'40000000'.
J=LH(PRIME)
WHILE J>0 CYCLE
RECAD=START+J
LENE=(BYTEINTEGER(RECAD)+4)&X'FFFFFFFC'
ENT==RECORD(RECAD+LENE)
IF J>=DSTART THEN START
FNAME=STRING(RECAD)
IF "+GL"#FNAME#"+IS" THEN START
IF ENT_TYPE&X'40000000'#0 THEN START
! DATASPACE file - may have multiple use counts
SETUSE(FNAME,-1,0) FOR I=ENT_USECOUNT,-1,0
FINISH ELSE START
SETUSE(FNAME,-1,0); ! Reduce use count
IF FNAME->S1.("T#CODE").S2 THEN DESTROY(FNAME,FLAG) ELSE C
IF FNAME->S1.("T#GLA").S2 THEN START
! More DUFFGLA
SSOWN_DUFFGLA(NDUFF)_FROM=ENT_GLAFROM
SSOWN_DUFFGLA(NDUFF)_TO=ENT_GLATO
NDUFF=NDUFF+1
DESTROY(FNAME,FLAG)
FINISH ELSE IF SSOWN_LOADMONITOR&2#0 THEN MONOUT(">>>> Unloading ".FNAME." <<<<")
FINISH
FINISH
FINISH
J=ENT_LINK
REPEAT
! Now update entry link fields
FOR I=PRIME,-1,0 CYCLE
IF LH(I)=0 THEN CONTINUE ; ! Nothing on listhead
IF LH(I)>=DSTART THEN LH(I)=0 AND CONTINUE ; ! Discard whole chain
! So if here then chain is wholly retained or straddles DSTART
J=LH(I)
WHILE J>0 CYCLE
RECAD=START+J
LENE=(BYTEINTEGER(RECAD)+4)&X'FFFFFFFC'
ENT==RECORD(RECAD+LENE)
IF ENT_LINK>=DSTART THEN ENT_LINK=-1 AND EXIT ; ! Terminate chain
J=ENT_LINK
REPEAT
REPEAT
! Zero the deleted areas
FILL(NEXTFREE-DSTART,START+DSTART,X'00')
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"4Niii")
RETURN
END ; ! OF DISCARDFILES
!
INTEGERFN TIDYIRECS(INTEGERNAME RTYPE,FIRST,LAST, C
INTEGER LOCLL,START,RECAD,PERMTOUNLOAD,NDUFF,PERMDUFF)
! Function destroys any info records off the current basic record which
! have loadlevels>=current loadlevel being unloaded.
! It also restores escape descriptors for previously satisfied refs which
! now point into an area of gla which has to be unloaded.
RECORD (IREFF)NAME R2
INTEGER IRECAD,J,LASTLINKAD,TYPE,DUFFREF,RETAINREF,AD,SSDYNREF
LASTLINKAD=ADDR(FIRST)
J=FIRST; ! Link to first info rec.
WHILE J>0 CYCLE
SSDYNREF=FALSE
IRECAD=START+J
R2==RECORD(IRECAD)
J=R2_LINK
! Check loadlevel - bottom 5 bits of top byte of DR0 field
! Destroy info rec if loadlevel>=locll or for a failed load
! check whether the ref is located in the area of gla being removed
! or an area of ISTK being unloaded
IF PERMTOUNLOAD#FALSE AND DEADREF(R2_DR1,PERMDUFF)#0 THEN C
RETAINREF=FALSE ELSE RETAINREF=TRUE; ! Check whether perm ref to stay
IF (R2_DR0>>24)&X'1F'>=LOCLL OR RETAINREF=FALSE THEN START
! Get rid of it. Update last link.
INTEGER(LASTLINKAD)=R2_LINK
FILL(16,IRECAD,X'82')
! If this hole has an offset less than SSOWN_NEXTAD(1) then reset SSOWN_NEXTAD(1)
IF IRECAD-START<SSOWN_NEXTAD(1) THEN SSOWN_NEXTAD(1)=IRECAD-START
FINISH ELSE START
! Ref at lower loadlevel than entry or possibly locll 0
LASTLINKAD=IRECAD+12; ! Update LASTLINKAD
IF RTYPE&X'70000000'=0 THEN START
! Satisfied ref. Check if it has to be unfixed (i.e. points
! into a DUFFGLA area)
TYPE=RTYPE&X'1FFFFFFF'; ! Off cmn/dyn/unsat bits
IF TYPE=CODE THEN START
AD=INTEGER(R2_DR1+4)
! If this is a ss dyn ref then AD points at the escape table
! otherwise it points into the gla of the file containing the
! entry which satisfied this ref. For a ss dyn ref then this info
! is at AD+12
IF SSOWN_DYNREFSTART<=AD<SSOWN_DYNREFEND THEN SSDYNREF=TRUE C
AND DUFFREF=DEADREF(INTEGER(AD+12),PERMDUFF) ELSE C
DUFFREF=DEADREF(AD,NDUFF)
FINISH ELSE DUFFREF=DEADREF(INTEGER(R2_DR1),NDUFF)
UNLESS DUFFREF=FALSE THEN START
! Ref has to be unfixed. SATISFYREF should have ensured that
! there is an escape table.
RTYPE=RTYPE!DYN; ! Recreate dynamic ref
IF TYPE=CODE THEN START
! Fill in escape descriptor EXCEPT for subsystem dynamic
! refs. These are invariant since the ss basegla is not connected
! in write mode.
IF SSDYNREF=FALSE THEN START
LONGINTEGER(R2_DR1)=ESCDR!R2_ADYNR
IF SSOWN_NOWARNINGS=FALSE THEN C
TERMINALPRINT("Warning - Code ref to ".STRING(RECAD)." at ", C
HTOS(R2_DR1,8)." made dynamic while unloading")
FINISH ELSE INTEGER(AD+12)=0
FINISH ELSE C
IF TYPE=DATA THEN START
LONGINTEGER(R2_DR1-4)=ESCDR!R2_ADYNR
IF SSOWN_NOWARNINGS=FALSE THEN C
TERMINALPRINT("Warning - Data ref to ".STRING(RECAD)." at ", C
HTOS(R2_DR1,8)." made dynamic while unloading")
FINISH ELSE START
INTEGER(R2_DR1)=X'FFFFFFFF'
IF SSOWN_NOWARNINGS=FALSE THEN C
TERMINALPRINT("Warning - Single word ref ".STRING(RECAD)." made pseudo dynamic while unloading","
Will fail catastrophically if called directly")
FINISH
FINISH
FINISH
FINISH
REPEAT
! Now if the last info rec has been destroyed or there was only one anyway
! then the integer at LASTLINKAD is not going to be synonymous with LAST.
! LAST should point at this record
IF INTEGER(LASTLINKAD)<0 THEN LAST=LASTLINKAD-12-START
! If FIRST<=0 no info chain remains.
IF FIRST<=0 THEN J=0 ELSE J=1
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(J,"nnnIiiIIIR")
RESULT =J
END ; ! OF TIDYIRECS
!
!
INTEGER I,J,NDUFF,TSTART,PSTART,PERMDUFF,FLAG
INTEGER LENE,RECAD,START,LASTLINKAD,AD,TEMPTOUNLOAD,PERMTOUNLOAD
RECORD (BREFF)NAME R1
INTEGERNAME RTYPE
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FAIL,"II"); ! N.B. Monitor on entry only
! Check for failed PRELOAD.
IF SSOWN_PRELOADFAILED#FALSE=FAIL THEN SSOWN_PRELOADFAILED=FALSE AND FAIL=TRUE
RETURN IF LOCLL<=0 AND FAIL=FALSE; ! Not allowed
! Find out what there is that is unloadable
IF SSOWN_LLINFO(0)_TAB=SSOWN_PERMOFFSET OR FAIL=FALSE THEN PERMTOUNLOAD=FALSE ELSE C
PERMTOUNLOAD=TRUE
IF (LOCLL=1 AND SSOWN_LLINFO(LOCLL)_TAB=SSOWN_TEMPOFFSET) OR SSOWN_LLINFO(LOCLL)_TAB=0 C
THEN TEMPTOUNLOAD=FALSE ELSE TEMPTOUNLOAD=TRUE
! Which leads to the following table :
! FAIL TEMPTOUNLOAD PERMTOUNLOAD Require UNLOAD?
! F F F NO
! F F T NO
! F T F YES
! F T T YES
! T F F NO
! T F T YES
! T T F YES
! T T T YES
! Check PARTLOADED array in case we got interrupted during
! the critical phase of LOADFILE.
FOR I=2,-1,0 CYCLE
IF SSOWN_PARTLOADED(I)#"" THEN START
SETUSE(SSOWN_PARTLOADED(I),-1,0)
IF I#0 THEN DESTROY(SSOWN_PARTLOADED(I),FLAG); ! i.e. a T#CODE or T#GLA
SSOWN_PARTLOADED(I)=""; ! Reset it
FINISH
REPEAT
IF FAIL=FALSE=TEMPTOUNLOAD OR (FAIL#FALSE AND C
TEMPTOUNLOAD=FALSE=PERMTOUNLOAD) THEN START
SSOWN_MAINDR1=0
IF LOCLL=1 THEN SSOWN_MONTIMEBASE=0
RETURN
FINISH
PSTART=SSOWN_SSLOADTAB(2)_START; ! Start of perm loaded entry table
TSTART=SSOWN_SSLOADTAB(3)_START; ! Start of temp loaded entry table
NDUFF=0
SSOWN_SSINHIBIT=TRUE; ! Turn off inhibits
IF FAIL#FALSE AND SSOWN_LLINFO(0)_TAB#SSOWN_PERMOFFSET THEN START
! Load failed - something loaded on basegla during it, so unload it
SSOWN_DUFFGLA(NDUFF)_FROM=SSOWN_LLINFO(0)_GLA
SSOWN_DUFFGLA(NDUFF)_TO=SSOWN_SSCURBGLA
NDUFF=NDUFF+1
! For perm loaded material we also have to check permistk range
! which may be removed. Add this to DUFFGLA as well although its not gla.
IF SSOWN_USTB#0 AND SSOWN_PERMISTK#SSOWN_LLINFO(0)_ISTK THEN START
SSOWN_DUFFGLA(NDUFF)_FROM=SSOWN_PERMISTK
SSOWN_DUFFGLA(NDUFF)_TO=SSOWN_LLINFO(0)_ISTK
NDUFF=NDUFF+1
FINISH
START=PSTART+LHOFFSET
DISCARDFILES(SSOWN_PLH,NDUFF,PSTART,SSOWN_LLINFO(0)_TAB,SSOWN_PERMOFFSET)
PERMDUFF=NDUFF-1
SSOWN_PERMOFFSET=SSOWN_LLINFO(0)_TAB
SSOWN_SSCURBGLA=SSOWN_LLINFO(0)_GLA
SSOWN_PERMISTK=SSOWN_LLINFO(0)_ISTK
FINISH
! UGLA area to be discarded
SSOWN_DUFFGLA(NDUFF)_FROM=SSOWN_LLINFO(LOCLL)_GLA
SSOWN_DUFFGLA(NDUFF)_TO=SSOWN_SSCOMREG(44)
NDUFF=NDUFF+1
! If there is any tempistk to unload then add to DUFFGLA as well
! in case anything refers to it. Only possibly relevant when LOADLEVEL>1.
IF SSOWN_USTB#0 AND SSOWN_LLINFO(LOCLL)_ISTK#SSOWN_TEMPISTK THEN START
SSOWN_DUFFGLA(NDUFF)_FROM=SSOWN_LLINFO(LOCLL)_ISTK
SSOWN_DUFFGLA(NDUFF)_TO=SSOWN_TEMPISTK
NDUFF=NDUFF+1
FINISH
! Scan the temp table entries still loaded, update the links and
! zero the released area.
START=TSTART+LHOFFSET
DISCARDFILES(SSOWN_TLH,NDUFF,TSTART,SSOWN_LLINFO(LOCLL)_TAB,SSOWN_TEMPOFFSET)
SSOWN_TEMPOFFSET=SSOWN_LLINFO(LOCLL)_TAB
SSOWN_SSCOMREG(44)=SSOWN_LLINFO(LOCLL)_GLA
SSOWN_TEMPISTK=SSOWN_LLINFO(LOCLL)_ISTK
NDUFF=NDUFF-1
! Tidy ref tables by discarding any ref with loadlevel>=LOCLL
! Any ref with loadlevel< LOCLL should be unfixed if it is satisfied
! and now points into a DUFFGLA area.
START=SSOWN_SSLOADTAB(1)_START
FOR I=PRIME-1,-1,0 CYCLE
IF SSOWN_RLH(I)>0 THEN START
! Something on this listhead
LASTLINKAD=START+I<<2; ! Ad of first link field
J=SSOWN_RLH(I)
! Search basic records
WHILE J>0 CYCLE
RECAD=START+J
LENE=(BYTEINTEGER(RECAD)+8)&X'FFFFFFF8'; ! Bytes of name
RTYPE==INTEGER(RECAD+LENE)
AD=RECAD+LENE+4
R1==RECORD(AD); ! The basic record
J=R1_LINK
! Now want to tidy the information records. Do this in a
! function for readability of the code.
IF TIDYIRECS(RTYPE,R1_FIRST,R1_LAST,LOCLL,START,RECAD, C
PERMTOUNLOAD,NDUFF,PERMDUFF)=0 THEN START
! No info records left - destroy basic record
INTEGER(LASTLINKAD)=R1_LINK; ! Relink basic chain
FILL(LENE+16,RECAD,X'82')
IF RECAD-START<SSOWN_NEXTAD(1) THEN SSOWN_NEXTAD(1)=RECAD-START
FINISH ELSE LASTLINKAD=RECAD+LENE+12
REPEAT
FINISH
REPEAT
! Check if USEFOR has been used and has been unloaded in this call of UNLOAD2.
IF SSOWN_USEFORDESCAD#0#DEADREF(SSOWN_USEFORDESCAD,NDUFF) THEN C
SSOWN_USEFORDESCAD=0 AND SSOWN_USEFORLASTNAME=""
! Now tidy LLINFO
IF LOCLL>1 THEN START
I=LOCLL
WHILE SSOWN_LLINFO(I)_TAB#0 CYCLE
SSOWN_LLINFO(I)_TAB=0
I=I+1
REPEAT
FINISH
! In the course of unloading we may have had to create new escape
! records on the base gla so update LLINFO(0)_GLA
SSOWN_LLINFO(0)_GLA=SSOWN_SSCURBGLA
SSOWN_MAINDR1=0; ! Reset
IF LOCLL=1 THEN SSOWN_MONTIMEBASE=0; ! Reset for next load if at command level
SSOWN_LOADINPROGRESS=FALSE; ! In case it isn't
SSOWN_SSCOMREG(7)=0
ALLOWINTERRUPTS
RETURN
END ; ! OF UNLOAD2
!
!
STRINGFN NEXTREF(INTEGERNAME TYPE,DR0,RECSTART,LHD)
! Gets the next unsatisfied reference from the loader tables
! by inspecting the basic records. Looking for unsatisfied code,
! data or single word refs.
! Preferentially searches for code refs before data refs on the
! assumption that since most data refs are to common areas to be
! created by the loader then the longer we wait the more likely
! the longest length for this area will turn up and avoid
! unnecessary failures.
! For a data ref then inspect the chain of information records. If
! any of them have the common bit set then return the maximum length
! of the records which have the common bit set through DR0 since
! the loader will create space if the directory search fails.
! Data refs are selected before single word refs since a common area
! created by the loader could satisfy a single word ref of the same
! name. Also return basic record address.
RECORD (BREFF)NAME R1
RECORD (IREFF)NAME R2
INTEGER I,START,RECAD,DRECAD,SRECAD,IRECAD,J,K,MAXLEN,LEN
INTEGER XTYPE,STYPE,DTYPE,SLHD,DLHD
STRING (31) RES
START=SSOWN_SSLOADTAB(1)_START
DRECAD=0
SRECAD=0
DR0=0
FOR J=PRIME-1,-1,0 CYCLE
IF SSOWN_RLH(J)>0 THEN START
! Found a chain
I=SSOWN_RLH(J)
WHILE I>0 CYCLE
RECAD=START+I
LEN=(BYTEINTEGER(RECAD)+8)&X'FFFFFFF8'; ! Bytes for name str
TYPE=INTEGER(RECAD+LEN)
R1==RECORD(RECAD+LEN+4)
! An unsatisfied code ref (note not dynamic) in this chain
! will mean that the UNSAT bit is set in TYPE. Return the name
! and the TYPE minus dyn and unsat bits. If it's not code
! and we haven't already found a data or single word ref
! then assign the record address to DRECAD and the type to
! DTYPE for possible later use if we don't find any unsat
! code refs.
IF TYPE&UNSAT#0 THEN START
XTYPE=TYPE&X'1FFFFFFF'
IF XTYPE=CODE THEN START
RECSTART=I
LHD=J
RES=STRING(RECAD)
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"nnnNR")
RESULT =RES
FINISH ELSE C
IF XTYPE=CODE!DATA AND SRECAD=0 THEN SRECAD=RECAD AND C
STYPE=TYPE AND SLHD=J ELSE C
IF XTYPE=DATA AND DRECAD=0 THEN START
DRECAD=RECAD
DTYPE=TYPE
DLHD=J
MAXLEN=0
! Now search the information chain for the maximum
! length common area (if any)
K=R1_FIRST
WHILE K>0 CYCLE
IRECAD=START+K
R2==RECORD(IRECAD)
IF R2_DR0&X'80000000'#0 AND C
R2_DR0&X'00FFFFFF'>MAXLEN THEN C
MAXLEN=R2_DR0&X'00FFFFFF'
K=R2_LINK
REPEAT
FINISH
FINISH
I=R1_LINK
REPEAT
FINISH
REPEAT
! If here then haven't found a code ref. There ought to be a data/single
! word ref or the table is all screwed up
IF DRECAD#0 THEN START
TYPE=DTYPE
DR0=MAXLEN
RECSTART=DRECAD-START
LHD=DLHD
RES=STRING(DRECAD)
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"nnnNR")
RESULT =RES
FINISH
IF SRECAD#0 THEN START
TYPE=STYPE
RECSTART=SRECAD-START
LHD=SLHD
RES=STRING(SRECAD)
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"nnnNR")
RESULT =RES
FINISH
! We should never get to here
TYPE=0
RES=""
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(RES,"nnnNR")
RESULT =""
END ; ! OF NEXTREF
!
!
ROUTINE CHANGEREFTYPE(INTEGER RECSTART,REFTYPE)
! Makes unsatisfied info records off the basic chain at RECAD
! into dynamic records if REFTYPE=DYNAMIC otherwise puts in escape
! descriptor to unsat ref code. Since the searching criterion
! for NEXTREF is the unsat bit set in the basic record then
! this bit is unset. Dyn bit is set in both basic and info recs
! if REFTYPE=DYNAMIC. Unsat bit unset in info recs if they are
! made dynamic otherwise it's left alone.
RECORD (BREFF)NAME R1
RECORD (IREFF)NAME R2
INTEGER J,LENE,RECAD,IRECAD,XTYPE,ESCTYPE
INTEGERNAME RTYPE
STRING (31) REF,ST
! Map on to basic record
RECAD=SSOWN_SSLOADTAB(1)_START+RECSTART
REF=STRING(RECAD)
LENE=(BYTEINTEGER(RECAD)+8)&X'FFFFFFF8'
RTYPE==INTEGER(RECAD+LENE)
SSOWN_SSINHIBIT=TRUE
RTYPE=RTYPE&X'DFFFFFFF'; ! Off unsat bit
IF REFTYPE=DYNAMIC THEN RTYPE=RTYPE!DYN ELSE RTYPE=RTYPE!UNRES
! Note. This is the only place where the unresolved bit can be set.
XTYPE=RTYPE&X'0FFFFFFF'; ! Off cmn/dyn/unsat/unres bits
R1==RECORD(RECAD+LENE+4)
! Now investigate the info recs
! Code and data refs require escape tables whereas single word
! refs can only be made pseudo dynamic
J=R1_FIRST
WHILE J>0 CYCLE
IRECAD=J+SSOWN_SSLOADTAB(1)_START
R2==RECORD(IRECAD)
IF R2_DR0&UNSAT#0 THEN START
! Interested in this one
IF REFTYPE=DYNAMIC THEN START
ESCTYPE=XTYPE!DYN
R2_DR0=(R2_DR0!DYN)&X'DFFFFFFF'; ! Set dyn / unset unsat
ST=" made type DYNAMIC.
"
FINISH ELSE ESCTYPE=XTYPE AND ST=" made type UNRESOLVED.
"
IF XTYPE=CODE THEN START
R2_ADYNR=ESCAPEREC(ESCTYPE,RECSTART,R2_DR1,(R2_DR0>>24)&X'1F')
LONGINTEGER(R2_DR1)=ESCDR!R2_ADYNR
IF SSOWN_LOADMONITOR&16#0 THEN C
PRINTSTRING("Code ref ".REF." at ".HTOS(R2_DR1,8).ST)
FINISH ELSE IF XTYPE=DATA THEN START
R2_ADYNR=ESCAPEREC(ESCTYPE,RECSTART,R2_DR1,(R2_DR0>>24)&X'1F')
LONGINTEGER(R2_DR1-4)=ESCDR!R2_ADYNR
IF SSOWN_LOADMONITOR&16#0 THEN C
PRINTSTRING("Data ref ".REF." at ".HTOS(R2_DR1,8).ST)
FINISH ELSE START
INTEGER(R2_DR1)=X'FFFFFFFF'; ! Imposs address
PRINTSTRING("Warning - Single word ref ".REF. C
" made pseudo dynamic.
Will fail catastrophically if called.")
FINISH
FINISH
J=R2_LINK
REPEAT
SSOWN_SSCOMREG(7)=SSOWN_SSCOMREG(7)-1; ! Decrement unsat ref count
ALLOWINTERRUPTS
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(J,"ii")
RETURN
END ; ! OF CHANGEREFTYPE
!
!
ROUTINE CREATECMN(STRING (31) LOOKFOR, INTEGER LL,DR0, INTEGERNAME FLAG, C
INTEGER LHD)
LONGINTEGER DESC
INTEGER START
BYTEINTEGER FILLER
IF SSOWN_SSCOMREG(39)&4=0 THEN FILLER=X'81' ELSE C
FILLER=X'00'
START=GETGLA(LL,DR0)
FILL(DR0,START,FILLER)
IF LL=0 THEN ADDENTRY(LOOKFOR,SSOWN_PLH,FLAG,SSOWN_PERMOFFSET,DATA,DR0,START,2,LHD) ELSE C
ADDENTRY(LOOKFOR,SSOWN_TLH,FLAG,SSOWN_TEMPOFFSET,DATA,DR0,START,3,LHD)
->OUT IF FLAG#0
IF SSOWN_LOADMONITOR&4#0 THEN MONOUT("Common area ". C
LOOKFOR." created at ".HTOS(START,8)." of length ". C
HTOS(DR0,8))
DESC=DR0
DESC=(DESC<<32)!START
SATISFYREF(LOOKFOR,DESC,FLAG,DATA,LL,LHD)
->OUT IF FLAG#0
OUT:
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(START,"SIiFI")
RETURN
END ; ! OF CREATECMN
!
!
SYSTEMROUTINE CASCADELOAD(INTEGERNAME FLAG, INTEGER LOCLL)
STRING (31) LOOKFOR,FILE,ACTUALEPNAME
LONGINTEGER DESC
INTEGER URECAD,FFLAG,LL,TYPE,DR0,XTYPE,LHD,LHDA
IF SSOWN_LOADINPROGRESS=FALSE THEN SSOWN_LOADINPROGRESS=TRUE
FLAG=0
LL=LOCLL
CYCLE
WHILE SSOWN_SSCOMREG(7)#0 CYCLE
LOOKFOR=NEXTREF(TYPE,DR0,URECAD,LHD); ! The next unsat ref
XTYPE=TYPE&X'1FFFFFFF'; ! 1FFFFFFF not 0FFFFFFF since if unsat not unres
FFLAG=SEARCH(LOOKFOR,DESC,FILE,ACTUALEPNAME,XTYPE,LL)
IF FFLAG<0 THEN START
! Already loaded - satisfy refs
SATISFYREF(LOOKFOR,DESC,FLAG,XTYPE,LL,LHD); ! Decrements SSOWN_SSCOMREG(7) if req.
->OUT IF FLAG#0; ! Something nasty happened
FINISH ELSE IF FFLAG=0 THEN EXIT ELSE START
! Didn't find it so ....
! 1. Check if data common and create if necessary else
! 2. If parm let set then change ref type to unresolved
! 3. Fail
IF TYPE&CMN#0 AND TYPE&X'1FFFFFFF'=DATA THEN START
! Create common area
CREATECMN(LOOKFOR,LL,DR0,FLAG,LHD)
->OUT IF FLAG#0
FINISH ELSE IF LET#0 THEN START
CHANGEREFTYPE(URECAD,UNRESOLVED)
IF SSOWN_NOWARNINGS=FALSE THEN C
TERMINALPRINT("Unresolved ref ",LOOKFOR)
NEWLINE
FINISH ELSE START
FLAG=289
SSOWN_SSFNAME=LOOKFOR
TERMINALPRINT("Unsatisfied ref ",LOOKFOR)
NEWLINE
->OUT
FINISH
FINISH
REPEAT
SSOWN_LOADINPROGRESS=FALSE AND ->OUT IF FILE=""; ! Happens if last ref is made unresolved
LOADFILE2(FILE,FLAG,LL)
->OUT IF 0#FLAG#350; ! 350 (already loaded) means an inconsistent directory.
! Now that the file is loaded there could have been 1 of 3 outcomes:
! 1. ACTUALEPNAME is not loaded, i.e. the directory is inconsistent.
! 2. ACTUALEPNAME is loaded and either LOOKFOR=ACTUALEPNAME in which case
! LOADFILE2 satisfied the reference or
! 3. LOOKFOR#ACTUALEPNAME, i.e. an alias, and we have still to satisfy LOOKFOR.
! So call SEARCHLOADED for the descriptor to ACTUALEPNAME and proceed from
! there.
IF LOOKFOR=ACTUALEPNAME THEN LHDA=LHD ELSE LHDA=HASH(ACTUALEPNAME,PRIME)
DESC=SEARCHLOADED(ACTUALEPNAME,XTYPE,LHDA)
IF DESC=0 THEN START
SSOWN_SSFNAME=ACTUALEPNAME
FLAG=293; ! Inconsistent directory entry for ACTUALEPNAME
->OUT
FINISH
IF LOOKFOR#ACTUALEPNAME THEN START
SATISFYREF(LOOKFOR,DESC,FLAG,XTYPE,LL,LHD)
->OUT IF FLAG#0
FINISH
LL=LOCLL IF LL#LOCLL
SSOWN_LOADINPROGRESS=FALSE AND ->OUT IF SSOWN_SSCOMREG(7)=0
REPEAT
OUT:
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(LL,"FI")
RETURN
END ; ! OF CASCADELOAD
!
!
SYSTEMROUTINE MINLOAD(INTEGER LOCLL,MAKEDYNAMIC, INTEGERNAME FLAG)
STRING (31) LOOKFOR
INTEGER URECAD,TYPE,DR0,NEWTYPE,LHD
IF SSOWN_LOADINPROGRESS=FALSE THEN SSOWN_LOADINPROGRESS=TRUE
FLAG=0
IF MAKEDYNAMIC#FALSE THEN NEWTYPE=DYNAMIC ELSE NEWTYPE=UNRESOLVED
WHILE SSOWN_SSCOMREG(7)#0 CYCLE
LOOKFOR=NEXTREF(TYPE,DR0,URECAD,LHD)
! Create any common areas
IF TYPE&CMN#0 AND TYPE&X'1FFFFFFF'=DATA THEN START
CREATECMN(LOOKFOR,LOCLL,DR0,FLAG,LHD)
->OUT IF FLAG#0
CONTINUE
FINISH
CHANGEREFTYPE(URECAD,NEWTYPE)
REPEAT
SSOWN_LOADINPROGRESS=FALSE
OUT:
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(LHD,"IIF")
RETURN
END ; ! OF MINLOAD
!
!
SYSTEMLONGINTEGERFN LOADEP(STRING (31) ENTRY, C
INTEGERNAME TYPE,FLAG, INTEGER LOCLL)
STRING (31) FILE,ACTUALEPNAME
INTEGER FFLAG,ETYPE
LONGINTEGER EDESC
IF SSOWN_LOADINPROGRESS=FALSE THEN SSOWN_LOADINPROGRESS=TRUE
EDESC=0
ETYPE=TYPE
FLAG=0
! See if it's already loaded
FFLAG=SEARCH(ENTRY,EDESC,FILE,ACTUALEPNAME,ETYPE,LOCLL)
IF FFLAG<0 THEN START
! Already loaded
SSOWN_LOADINPROGRESS=FALSE
->OUT
FINISH ELSE IF FFLAG>0 THEN START
FLAG=FFLAG
EDESC=0
->OUT
FINISH
! If here then found a file
LOADFILE2(FILE,FLAG,LOCLL)
IF 316#FLAG#0 THEN EDESC=0 AND ->OUT; ! 316 if a macro found
IF FLAG=316 THEN START
ETYPE=MACRO; ! Old style directories don't differentiate code¯o
FLAG=0
EDESC=LONGINTEGER(ADDR(SSOWN_MACRODR0))
->OUT
FINISH
! We know that we must have loaded the file we want, but it may have
! been loaded as the end result of an alias chain so must use
! ACTUALEPNAME with LOOKLOADED to get the descriptor.
EDESC=LOOKLOADED(ACTUALEPNAME,ETYPE)
IF EDESC=0 THEN START
! We have loaded the file that the directory said we should load but the
! entry point isn't there. We must have an inconsistent directory, i.e.
! an object file has been updated but the directory it is inserted into
! hasn't been.
SSOWN_SSFNAME=ACTUALEPNAME
FLAG=293; ! Inconsistent directory entry for &
EDESC=0
->OUT
FINISH
IF SSOWN_SSCOMREG(7)#0 THEN START
! If here then some unsatisfied refs. What we do depends on the load
! parms.
IF DYNLOAD=FALSE THEN CASCADELOAD(FLAG,LOCLL) ELSE C
MINLOAD(LOCLL,DYNLOAD,FLAG)
IF FLAG#0 THEN EDESC=0 AND ->OUT
FINISH ELSE SSOWN_LOADINPROGRESS=FALSE
! All O.K. if here - update LLINFO(0)
IF SSOWN_LLINFO(0)_TAB#SSOWN_PERMOFFSET THEN START
SSOWN_LLINFO(0)_TAB=SSOWN_PERMOFFSET
SSOWN_LLINFO(0)_GLA=SSOWN_SSCURBGLA
SSOWN_LLINFO(0)_ISTK=SSOWN_PERMISTK
FINISH
OUT:
IF FLAG=0 THEN TYPE=ETYPE
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(EDESC,"SNFIr")
RESULT =EDESC
END ; ! OF LOADEP
!
!
SYSTEMLONGINTEGERFN LOADENTITY(STRING (31) ENTRY, INTEGERNAME TYPE,FLAG, C
INTEGER LOCLL)
STRING (31) S1,S2
RECORD (LD1F)NAME LD1
LONGINTEGER EDESC
INTEGER ETYPE,I,START,FOUND
RECORD (RF) RR
IF SSOWN_LOADINPROGRESS=FALSE THEN SSOWN_LOADINPROGRESS=TRUE
! If ENTRY contains '_' or '.' then can avoid LOADEP call
UNLESS ENTRY->S1.(".").S2 OR ENTRY->S1.("_").S2 THEN START
! Try as a command
ETYPE=TYPE
EDESC=LOADEP(ENTRY,ETYPE,FLAG,LOCLL)
IF FLAG=0 THEN START
TYPE=ETYPE
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(EDESC,"SNFIr")
RESULT =EDESC
FINISH
! If FLAG#289 then error and give up. However if 'not found' (289)
! then this might have come from failed cascade and want to give up
! under these circumstances as well. Only proceed if we couldn't find ENTRY
IF FLAG#289 OR (FLAG=289 AND SSOWN_SSFNAME#ENTRY) THEN ->ERR
FINISH
! Not a command and no funny failure. Try to CONNECT
CONNECT(ENTRY,1,0,0,RR,FLAG)
IF 218#FLAG#0 AND 220#FLAG#167 {Invalid filename} THEN ->ERR
IF FLAG=218 OR (FLAG=0 AND SSCHARFILETYPE#RR_FILETYPE#SSOBJFILETYPE) C
OR FLAG=220 OR FLAG=167 THEN START
! Didn't find it
FLAG=289
->ERR
FINISH
IF NEWCONNECT#0 THEN SETUSE (LASTFN, -1, 0)
IF RR_FILETYPE=SSCHARFILETYPE THEN START
PRINTSTRING("Character file ".ENTRY." found - attempting OBEYJOB
")
SSOWN_LOADINPROGRESS=FALSE
FLAG=-1
->ERR
FINISH
SSOWN_MAINDR1=0
PRINTSTRING("Object file ".ENTRY." found - looking for main entry
")
! Check for main entry before calling LOADFILE2
START=RR_CONAD+INTEGER(RR_CONAD+24)+4; ! Listhead of code entries
I=INTEGER(START)
FOUND=FALSE
WHILE I#0 CYCLE
LD1==RECORD(RR_CONAD+I)
IF LD1_LOC&X'80000000'#0 THEN FOUND=TRUE AND EXIT
I=LD1_LINK
REPEAT
IF FOUND=FALSE THEN FLAG=298 AND ->ERR; ! No main entry
PRINTSTRING("Main entry found
")
LOADFILE2(ENTRY,FLAG,LOCLL)
IF 350#FLAG#0 THEN ->ERR
IF SSOWN_SSCOMREG(7)#0 THEN START
! Unsatisfied refs
IF DYNLOAD=FALSE THEN CASCADELOAD(FLAG,LOCLL) ELSE C
MINLOAD(LOCLL,DYNLOAD,FLAG)
IF FLAG#0 THEN ->ERR
FINISH ELSE SSOWN_LOADINPROGRESS=FALSE
! All O.K. if here - update LLINFO(0)
IF SSOWN_LLINFO(0)_TAB#SSOWN_PERMOFFSET THEN START
SSOWN_LLINFO(0)_TAB=SSOWN_PERMOFFSET
SSOWN_LLINFO(0)_GLA=SSOWN_SSCURBGLA
SSOWN_LLINFO(0)_ISTK=SSOWN_PERMISTK
FINISH
TYPE=X'80000000'; ! Set top bit to indicate ENTER mode is 0
EDESC=X'B100000000000000'!SSOWN_MAINDR1
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(EDESC,"SNFIr")
RESULT =EDESC
ERR:
EDESC=0
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(EDESC,"SNFIr")
RESULT =0
END ; ! OF LOADENTITY
!
!
SYSTEMLONGINTEGERFN DYNAMICREF(INTEGER DR0,DR1)
! Function to handle dynamic refs which require to be satisfied.
! Called from INITDYNAMICREF.
STRING (31) ENAME
LONGINTEGER EDESC,DESC
RECORD (ESCF)NAME DREC
INTEGER RECAD,LENE,TYPE,FLAG,LNB
! DR1 is the address of the escape table from which the basic record
! describing this ref can be obtained. From this we want the name and
! the type to call LOADEP.
! PRINTSTRING("+++ Call to DYNAMICREF ==> ".HTOS(DR1,8)." +++
! ")
DREC==RECORD(DR1)
RECAD=SSOWN_SSLOADTAB(1)_START+DREC_RECAD; ! Addr of basic record
ENAME=STRING(RECAD)
LENE=(BYTEINTEGER(RECAD)+8)&X'FFFFFFF8'; ! Bytes of name string
TYPE=INTEGER(RECAD+LENE)&X'1FFFFFFF'; ! Off cmn/dyn/unsat bits
IF SSOWN_LOADMONITOR&1#0 THEN MONOUT("Attempting to load ".ENAME." dynamically")
! Now a call on LOADEP should, if successful, satisfy all outstanding refs
! to ENAME in the course of loading the file in which it occurs.
! N.B. It can't already be loaded since it wouldn't still be in the ref
! tables
EDESC=LOADEP(ENAME,TYPE,FLAG,SSOWN_LOADLEVEL)
IF FLAG=0 THEN START
! If dealing with code entry then result is EDESC. However if dealing
! with a data entry we have to restore the data descriptor exactly
! as it would have been if it had been there from the start. LOADEP will
! return the length and the address of the entry so we must reconstruct
! the descriptor by taking the type and bound from DREC_DR0 and adding
! the offset in DREC_DR1 to the address field in EDESC
IF SSOWN_LOADMONITOR&1#0 THEN C
MONOUT("Load initiated by dynamic call to ".ENAME." successful")
IF TYPE&DATA#0 THEN START
EDESC=EDESC&X'00000000FFFFFFFF'
DESC=DREC_DR0
EDESC=DESC<<32+DREC_DR1+EDESC
FINISH
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(EDESC,"iir")
RESULT =EDESC
FINISH
! If here then LOADEP failed for one reason or another. This means abandoning
! the load.
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"SFI")
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(EDESC,"iir")
SELECTOUTPUT(0)
PRINTSTRING("
Load initiated by dynamic call to ".ENAME." failed
")
PSYSMES(47,FLAG)
*STLN_LNB; ! Store current LNB
SSOWN_SSCOMREG(10)=1; ! %MONITOR called flag for JCL interpreter
NDIAG(X'2000000',INTEGER(INTEGER(LNB)),0,0)
! ** Comment **
! The PC being handed to NDIAG is, to quote the old loader 'wrong value
! pro tem'. However it doesn't seem to matter judging by the effects.
! Handing over the appropriate value is slightly more difficult since
! it has to be done in conjunction with storing the environment before
! calling DYNAMICREF. In future it might be better to store the environment
! in a record rather than on the stack, in which case it would be possible to
! give a sensible PC. Another advantage would be preparing the way for
! storing multiple environments more tidily.
RETURN TO COMMAND LEVEL
END ; ! OF DYNAMICREF
!
!
SYSTEMROUTINE UNSATREF(INTEGER DR0,DR1,PC)
! Routine handles any direct calls on unresolved refs.
RECORD (ESCF)NAME DREC
INTEGER RECAD,LNB
! All we require to do here is extract the name of the ref from the
! basic record then call NDIAG and tidy up.
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(PC,"iii")
DREC==RECORD(DR1); ! The escape table
RECAD=SSOWN_SSLOADTAB(1)_START+DREC_RECAD
*STLN_LNB
SELECTOUTPUT(0)
PRINTSTRING("Attempt to call unsatisfied reference - ".STRING(RECAD))
NEWLINE
SSOWN_SSCOMREG(10)=1; ! %MONITOR called flag for JCL interpreter
NDIAG(PC,INTEGER(INTEGER(LNB)),0,0)
RETURN TO COMMAND LEVEL
END ; ! OF UNSATREF
!
!
SYSTEMROUTINE ENTERONUSERSTACK(INTEGER USEPARAM,DR0,DR1, STRING (255) PARAM)
!THIS IS CALLED BY ENTER WHEN WE ARE CALLING AN EXTERNAL ROUTINE
!OR A MAIN PROGRAM.FOR EXTERNAL ROUTINES (USEPARAM#0) IT ENABLES US
!TO CALL SIGNAL ON THE USER STACK AND HENCE MAKE "ON EVENT" WORK.
INTEGER FLAG,LNB,FAILPC,NEWLNB,FAILDR0,FAILDR1
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"IiiS")
*STLN_LNB; !LNB FOR THIS ROUTINE
*JLK_3; !TO OBTAIN ADDRESS OF NEXT INSTRUCTION
*J_<FAIL>
*LSS_TOS
*ST_FAILPC; !THE PC TO BE USED FOR THE RETURN
SIGNAL(0,FAILPC,LNB,FLAG)
*STSF_NEWLNB; !LNB FOR THE CALLED ROUTINE
*MPSR_X'40C0' ; !SET PROGRAM STATUS REG - MASK REAL UNDERFLOW
SSOWN_SSCOMREG(36)=NEWLNB!4; !PRCL FORCES ODD ALIGNMENT - FOR %STOP
! If we have just executed a stack switch then remember the LNB in
! case we want to go back to command level directly later.
IF SSOWN_USERSTACKLNB=0 THEN SSOWN_USERSTACKLNB=SSOWN_SSCOMREG(36)
*PRCL_4
IF USEPARAM#0 START ; !CALL ROUTINE WITH PARAMETER
*LSD_PARAM; !DESCRIPTOR TO PARAM
*ST_TOS ; !TO STACK
*LD_DR0; !PLT DESCRIPTOR TO DR
*RALN_7
*CALL_(DR )
RETURN
FINISH
!MUST BE MAIN PROGRAM (OR COMPILER) CALL WITH NO PARAMETER
*LD_DR0
*RALN_5
*CALL_(DR )
RETURN
FAIL: !COMES HERE IF CONTINGENCY
*ST_FAILDR0
IF SSOWN_RCODE=0 THEN SSOWN_RCODE=103050709
SIGNAL(0,FAILPC,LNB,FLAG); !REPLACE SIGNAL FOR NEXT TIME
NDIAG(INTEGER(FAILDR1+16),INTEGER(FAILDR1+8),10,INTEGER(FAILDR1))
END ; ! OF ENTERONUSERSTACK
!
!
SYSTEMROUTINE ENTER(INTEGER MODE,DR0,DR1, STRING (255) PARAM)
INTEGER STACKSWITCH,SAVECURAUX,SAVECOMREG34,SAVECOMREG36,ACR,FLAG,SF
INTEGER USEPARAM,LNB,NEWLNB,PRIV
INTEGER EDR0,EDR1; ! Must stay together
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"IiiS")
IF SSOWN_LOADMONITOR&1#0 THEN MONOUT("ENTER called")
*STLN_LNB
PRIV=INTEGER(LNB+4)&X'00040000'; ! PRIV bit in PSR
STACKSWITCH=0
! Switch stacks if a) you are presently on the base stack
! b) you are not privileged
! c) you are calling something outside the basefile
! or
! c') you explicitly request a stack switch
IF CURSTACK=0=PRIV AND (DR1>SSOWN_LLINFO(-1)_GLA OR MODE&1#0) THEN STACKSWITCH = 1
USEPARAM=MODE&2; !MUST PUT DESCRIPTOR TO PARAM ON STACK
SAVECOMREG36=SSOWN_SSCOMREG(36); !USED BY %STOP - Saved LNB for contingency trapping
SAVECOMREG34=SSOWN_SSCOMREG(34); ! Signal level
IF SSOWN_SSAUXDR1#0 START ; !AUX STACK IN USE - SAVE CURRENT TOP
SAVECURAUX=SSOWN_SSCURAUX; ! Current base of AUXSTACK
SSOWN_SSCURAUX=INTEGER(SSOWN_SSAUXDR1); ! Current limit of AUXSTACK
FINISH ELSE SAVECURAUX=0
IF STACKSWITCH=1 START ; !NEED TO SELECT USER STACK
IF SSOWN_USTB=0 THEN INITUSTK
ACR=(INTEGER(LNB+4)>>20)&15; !CURRENT ACR LEVEL
! Call ENTERONUSERSTACK
FLAG=DNEWOUTWARDCALL(ACR,1,SSOWN_USTB>>SEGSHIFT,SSOWN_EUDR0,SSOWN_EUDR1,EDR0,EDR1)
IF FLAG#0 THEN DSTOP(122); ! DNEWOUTWARDCALL failed
EDR0=EDR0!X'E3000000'; !TYPE SYSTEM CALL
CHANGECONTEXT
*PRCL_4
*LSS_USEPARAM
*ST_TOS
*LSD_DR0
*ST_TOS
*LSD_PARAM
*ST_TOS
*LD_EDR0
*RALN_10
*CALL_(DR )
-> AFTERCALL
FINISH ELSE START ; !ENTER ON CURRENT STACK
EDR0=DR0
EDR1=DR1
*STSF_SF; !NEED TO ALIGN NEWLNB ON PAGE BOUNDARY
SF=((4095-(SF&X'FFF'))>>2)+2; !NO OF WORDS TO ALIGN
*ASF_SF
*STSF_NEWLNB
SSOWN_SSCOMREG(36)=NEWLNB; !PRCL ALIGNS LNB ON ODD WORD
!TEMP NEED TO OR WITH 4 ON LAST LINE
FINISH
IF USEPARAM=0 START ; !NO PARAMETER
*PRCL_4
*LD_EDR0; !ENTRY DESCRIPTOR
*RALN_5
*CALL_(DR )
FINISH ELSE START
*PRCL_4
*LSD_PARAM; !DESCRIPTOR TO PARAM
*ST_TOS ; !PUT AT TOS - IF SYSTEM CALL THEN PARAM IS COPIED TO NEW STACK
*LD_EDR0
*RALN_7
*CALL_(DR )
FINISH
AFTERCALL:
CHANGECONTEXT
SSOWN_SSCOMREG(34)=SAVECOMREG34
SSOWN_SSCOMREG(36)=SAVECOMREG36
IF SAVECURAUX#0 THEN SSOWN_SSCURAUX=SAVECURAUX
IF SSOWN_USERSTACKLNB#0 THEN SSOWN_USERSTACKLNB=0
END ; ! OF ENTER
!
!
EXTERNALROUTINE RUN(STRING (255) PROG)
INTEGER FLAG
RECORD (RF) RR
CONNECT(PROG,1,0,0,RR,FLAG)
IF FLAG#0 THEN ->ERR2
IF NEWCONNECT#0 THEN SETUSE (LASTFN, -1, 0)
IF RR_FILETYPE#SSOBJFILETYPE THEN START
SSOWN_SSFNAME=PROG
FLAG=267
->ERR2
FINISH
! Increment loadlevel
SSOWN_LOADLEVEL=SSOWN_LOADLEVEL+1
IF SSOWN_LOADLEVEL>31 THEN FLAG=351 AND ->ERR
SSOWN_LLINFO(SSOWN_LOADLEVEL)_TAB=SSOWN_TEMPOFFSET
SSOWN_LLINFO(SSOWN_LOADLEVEL)_GLA=SSOWN_SSCOMREG(44)
SSOWN_LLINFO(SSOWN_LOADLEVEL)_ISTK=SSOWN_TEMPISTK
SSOWN_MAINDR1=0
LOADFILE2(PROG,FLAG,SSOWN_LOADLEVEL)
IF 350#FLAG#0 THEN ->ERR
IF SSOWN_MAINDR1=0 THEN FLAG=298 AND -> ERR; ! No main entry
IF SSOWN_SSCOMREG(7)#0 THEN START
! Unsatisfied refs
IF DYNLOAD=FALSE THEN CASCADELOAD(FLAG,SSOWN_LOADLEVEL) ELSE C
MINLOAD(SSOWN_LOADLEVEL,DYNLOAD,FLAG)
IF FLAG#0 THEN ->ERR
FINISH ELSE SSOWN_LOADINPROGRESS=FALSE
SSOWN_RCODE=0
ENTER(0,X'B1000000',SSOWN_MAINDR1,"")
UNLOAD2(SSOWN_LOADLEVEL,0)
SSOWN_LOADLEVEL=SSOWN_LOADLEVEL-1
RETURN
ERR:
! If here then fail the load at this LOADLEVEL
UNLOAD2(SSOWN_LOADLEVEL,1)
SSOWN_LOADLEVEL=SSOWN_LOADLEVEL-1
ERR2:
PSYSMES(39,FLAG)
SSOWN_RCODE=FLAG
RETURN
END ; ! OF RUN
!
!
EXTERNALROUTINE EXECUTE(STRING (255) PROG)
! Unlike RUN this operates at the current loadlevel and does
! not unload if successful.
INTEGER FLAG
RECORD (RF) RR
CONNECT(PROG,1,0,0,RR,FLAG)
IF FLAG#0 THEN ->ERR
IF NEWCONNECT#0 THEN SETUSE (LASTFN, -1, 0)
IF RR_FILETYPE#SSOBJFILETYPE THEN START
SSOWN_SSFNAME=PROG
FLAG=267
->ERR
FINISH
SSOWN_MAINDR1=0
LOADFILE2(PROG,FLAG,SSOWN_LOADLEVEL)
IF 350#FLAG#0 THEN ->ERR
IF SSOWN_MAINDR1=0 THEN FLAG=298 AND -> ERR; ! No main entry
IF SSOWN_SSCOMREG(7)#0 THEN START
! Unsatisfied refs
IF DYNLOAD=FALSE THEN CASCADELOAD(FLAG,SSOWN_LOADLEVEL) ELSE C
MINLOAD(SSOWN_LOADLEVEL,DYNLOAD,FLAG)
IF FLAG#0 THEN ->ERR
FINISH ELSE SSOWN_LOADINPROGRESS=FALSE
SSOWN_RCODE=0
ENTER(0,X'B1000000',SSOWN_MAINDR1,"")
RETURN
ERR:
! Fail the whole load
UNLOAD2(SSOWN_LOADLEVEL,1)
PSYSMES(103,FLAG)
SSOWN_RCODE=FLAG
RETURN
END ; ! OF EXECUTE
!
!
EXTERNALROUTINE PRELOAD(STRING (255) S)
INTEGER LL,FLAG
RECORD (RF) RR
! Make sure it's not being called by user software.
! {Chance it meantime}%UNLESS CURSTACK=0 %THEN FLAG=358 %AND ->ERR
LL=0; ! All loading on the base gla
CONNECT(S,1,0,0,RR,FLAG)
IF FLAG#0 THEN ->ERR
IF NEWCONNECT#0 THEN SETUSE (LASTFN, -1, 0)
IF RR_FILETYPE#SSOBJFILETYPE THEN START
SSOWN_SSFNAME=S
FLAG=267
-> ERR
FINISH
! Any failure up to here does not require a call of UNLOAD2
LOADFILE2(S,FLAG,LL)
IF 350#FLAG#0 THEN ->ERR1
IF FLAG=350 THEN PRINTSTRING(S." already loaded
")
IF SSOWN_SSCOMREG(7)#0 THEN START
MINLOAD(LL,TRUE,FLAG); ! Make any unsat refs dynamic
IF FLAG#0 THEN -> ERR1
FINISH ELSE SSOWN_LOADINPROGRESS=FALSE
! All O.K. if here - update LLINFO(0)
SSOWN_LLINFO(0)_TAB=SSOWN_PERMOFFSET
SSOWN_LLINFO(0)_GLA=SSOWN_SSCURBGLA
SSOWN_LLINFO(0)_ISTK=SSOWN_PERMISTK
SSOWN_RCODE=0
RETURN
ERR1:
! If the PRELOAD failed at command level then call UNLOAD2(1,1)
! immediately but if the failure was within a program then an immediate
! call on UNLOAD2 would probably unload the calling program. To avoid this
! set the own PRELOADFAILED which is acted on at the next call of UNLOAD2.
IF CURSTACK#0 THEN SSOWN_PRELOADFAILED=TRUE ELSE C
UNLOAD2(1,1); ! Which will only unload the file which failed
ERR:
PSYSMES(52,FLAG)
SSOWN_RCODE=FLAG
RETURN
END ; ! OF PRELOAD
!
!
EXTERNALROUTINE CALL(STRING (31) COMMAND, STRING (255) PARAM)
INTEGER DR0,DR1,FLAG,ETYPE
LONGINTEGERNAME EDESC
EDESC==LONGINTEGER(ADDR(DR0))
! Check if illegal request by a student
IF STUDENTSS#0 THEN START
IF CHECKCOMMAND(COMMAND)#0 THEN START
PRINTSTRING(COMMAND." not valid
")
SSOWN_RCODE=307; ! Illegal call from within program
RETURN
FINISH
FINISH
! Increment loadlevel
SSOWN_LOADLEVEL=SSOWN_LOADLEVEL+1
IF SSOWN_LOADLEVEL>31 THEN FLAG=351 AND ->ERR
SSOWN_LLINFO(SSOWN_LOADLEVEL)_TAB=SSOWN_TEMPOFFSET
SSOWN_LLINFO(SSOWN_LOADLEVEL)_GLA=SSOWN_SSCOMREG(44)
SSOWN_LLINFO(SSOWN_LOADLEVEL)_ISTK=SSOWN_TEMPISTK
ETYPE=CODE
EDESC=LOADEP(COMMAND,ETYPE,FLAG,SSOWN_LOADLEVEL)
IF FLAG#0 THEN ->ERR
SSOWN_RCODE=0; ! Before we ENTER
ENTER(2,DR0,DR1,PARAM)
UNLOAD2(SSOWN_LOADLEVEL,0)
SSOWN_LOADLEVEL=SSOWN_LOADLEVEL-1
! Note that return code should be set by whatever ENTERed or by
! ENTERONUSERSTACK if a contingency occurred.
RETURN
ERR:
UNLOAD2(SSOWN_LOADLEVEL,1)
! Note that the old loader used -86 to ensure a call on %STOP
! if the CALL ran into trouble. This version allows failures to be
! trapped by the user.
PSYSMES(86,FLAG)
SSOWN_RCODE=FLAG
SSOWN_LOADLEVEL=SSOWN_LOADLEVEL-1
RETURN
END ; ! OF CALL
!
!
EXTERNALROUTINE EMASFC(INTEGERNAME AC,LC,AP,LP)
!***********************************************************************
!* *
!* This routine enables a FORTRAN program to call foreground commands *
!* or any IMP routines requiring one %STRING(255) parameter *
!* The call should be of the form: *
!* CALL EMASFC("DEFINE",6,"10,TEMP",7) *
!* wher the second and fourth parameters specify the length of the *
!* first and third. *
!* *
!***********************************************************************
STRING (31) COMMAND
STRING (255) PARAM
IF LC>31 THEN LC=31; ! Truncate command name
IF LP>255 THEN LP=255; ! Truncate parameter
MOVE(LC,ADDR(AC),ADDR(COMMAND)+1)
LENGTH(COMMAND)=LC
MOVE(LP,ADDR(AP),ADDR(PARAM)+1)
LENGTH(PARAM)=LP
CALL(COMMAND,PARAM)
END ; ! OF EMASFC
!
!
SYSTEMINTEGERFN USEFOR(ROUTINENAME MYNAME, STRING (31) EXTERNALNAME)
! This function is for use in place of CALL particularly in situations
! when constant loading and unloading is a problem, e.g.in a loop.
! MYNAME is the name of a dummy dynamic routine or function which
! must be declared in the calling program. The parameter list of this
! dummy routine or function is immaterial to USEFOR although it is only
! external routines with the same parameter spec that can be called at
! run-time by the program. EXTERNALNAME is the name of the external routine
! which the user actually wants to call at run-time. What this function
! does is to work its way back from its own stack to the location
! in the gla which contains the escape descriptor corresponding to
! the dummy routine, load EXTERNALNAME then if the load was successful
! overwrite the escape descriptor by the descriptor to EXTERNALNAME.
! A call on the dummy routine in the user program is then equivalent
! to a call on EXTERNALNAME. If we want to call EXTERNALNAME many times
! then we only have to load it once. If desired then we can give the
! program different EXTERNALNAMEs in the same run. Beware problems
! with serial re-entrancy though!
RECORD (ESCF)NAME ESCTAB
LONGINTEGER EDESC
INTEGER LNB,FLAG,TYPE
*STLN_LNB; ! Store LNB
IF SSOWN_USEFORDESCAD=0 THEN START
! First call of USEFOR. Must find the descriptor to the routine in the gla
! If USEFOR is being called correctly then there should be an escape
! descriptor at LNB+20. The escape descriptor will point us to the
! escape table whose 4th field points us at the location we want.
! However an unresolved reference will also have an escape descriptor
! in this location so must also check that the PC field in the escape
! table is DYNPC and not SSOWN_UNSATPC.
UNLESS BYTEINTEGER(LNB+20)=X'E5' AND INTEGER(INTEGER(LNB+24))=SSOWN_DYNPC THEN START
PRINTSTRING(USEROOT)
IF BYTEINTEGER(LNB+20)=X'E5' THEN PRINTSTRING("not %DYNAMICROUTINESPEC") C
ELSE PRINTSTRING("dummy %DYNAMICROUTINESPEC satisfied during loading")
FLAG=-1
->OUT
FINISH
! Map on to escape table
ESCTAB==RECORD(INTEGER(LNB+24))
SSOWN_USEFORDESCAD=ESCTAB_DESCAD
FINISH
! Check if USEFORLASTNAME and EXTERNALNAME are the same. If so then no more to do.
IF SSOWN_USEFORLASTNAME=EXTERNALNAME THEN FLAG=0 AND ->OUT
! Load EXTERNALNAME
TYPE=2; ! Code
EDESC=LOADEP(EXTERNALNAME,TYPE,FLAG,CURRENTLL)
IF FLAG#0 THEN PRINTSTRING(USEROOT.FAILUREMESSAGE(FLAG)) AND ->OUT
! Update USEFORLASTNAME and overwrite descriptor at SSOWN_USEFORDESCAD
SSOWN_USEFORLASTNAME=EXTERNALNAME
LONGINTEGER(SSOWN_USEFORDESCAD)=EDESC
FLAG=0
OUT:
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"4SR")
RESULT =FLAG
END ; ! OF USEFOR
!
!
EXTERNALROUTINE DATASPACE(STRING (255) S)
! This routine is used to make a pseudo data entry into the perm
! loaded entry table. The routine takes 3, optionally 5 params:
! ENTRY - name of new data entry
! FILE - name of the file which contains the area used by the data entry
! LENGTH - length of data area in bytes
! OFFSET(optional) - offset of start of data area from start of file
! i.e. CONAD+DATASTART, in bytes, defaults to 0
! ACCESS(optional) - type of access required to data area. Permitted values:
! R - read and read shared
! W - write unshared
! WS - write shared
! Defaults to W on file, R on pdfile
CONSTINTEGERARRAY CONMODE(0:3)=3,1,3,11
CONSTSTRING (3)ARRAY ACCMODE(1:3)="R","W","WS"
STRING (35) TEMPLATE
STRING (31) FILE,ENTRY,ACCESS,S1,S2
LONGINTEGER DESC
RECORD (ENTF)NAME ENT
INTEGER FLAG,LEN,AD,OFFSET,I,J,HOLDPRMOFF,LENE,LHD,MODE,PDMEM,K,RECAD,RMODE
INTEGER USECOUNTAD
RECORD (RF) RR
TEMPLATE="ENTRY,FILE,LENGTH,OFFSET=0,ACCESS="
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
IF PARMAP&X'FFFFFFE0'#0 THEN FLAG=263 AND ->ERR
ENTRY=SPAR(1)
FILE=SPAR(2)
IF FILE->S1.("_").S2 THEN PDMEM=TRUE ELSE PDMEM=FALSE
UNLESS FILE->S1.(".").S2 THEN FILE=SSOWN_SSOWNER.".".FILE
LEN=PSTOI(SPAR(3))
IF LEN<0 THEN START
SSOWN_SSFNAME=SPAR(3)
FLAG=357; ! Not a positive integer
->ERR
FINISH
OFFSET=PSTOI(SPAR(4))
IF OFFSET<0 THEN START
SSOWN_SSFNAME=SPAR(4)
FLAG=357; ! Not a positive integer
->ERR
FINISH
ACCESS=SPAR(5)
IF ACCESS#"" THEN START
MODE=-1
FOR I=1,1,3 CYCLE
MODE=I AND EXIT IF ACCESS=ACCMODE(I)
REPEAT
IF MODE<0 THEN START
SSOWN_SSFNAME=ACCESS
FLAG=202; ! Invalid parameter
->ERR
FINISH
FINISH ELSE IF PDMEM=FALSE THEN MODE=3 ELSE MODE=1
! Now check legal MODE if pdfile member
IF PDMEM#FALSE AND MODE#1 THEN START
PRINTSTRING("** Error - Pdfile members used by DATASPACE must have R access
")
FLAG=269; ! Illegal use of pdfile member
->ERR
FINISH
! Do we know about FILE already, i.e. is there another DATASPACE entry
! in it? Check filenames listhead.
RMODE=0
J=INTEGER(SSOWN_SSLOADTAB(2)_START+1004)
WHILE J>0 CYCLE
RECAD=SSOWN_SSLOADTAB(2)_START+J
LENE=(BYTEINTEGER(RECAD)+4)&X'FFFFFFFC'
ENT==RECORD(RECAD+LENE)
IF ENT_TYPE&X'40000000'#0 AND FILE=STRING(RECAD) THEN START
! Found another dataspace entry in the same file
! Check access modes
RMODE=ENT_ACCESSMODE
IF RMODE#MODE THEN START
*LSS_RMODE
*SHZ_I
PRINTSTRING("**Error - ".FILE." is already connected in ". C
ACCMODE(32-I)." mode for DATASPACE entries
")
FLAG=266; ! Inconsistent file use
->ERR
FINISH
USECOUNTAD=ADDR(ENT_USECOUNT)-SSOWN_SSLOADTAB(2)_START; ! Note it's an offset
FINISH
J=ENT_LINK
REPEAT
! Connect FILE
CONNECT(FILE,MODE,0,0,RR,FLAG)
IF FLAG#0 THEN ->ERR
IF RR_FILETYPE#SSDATAFILETYPE THEN START
IF RR_FILETYPE=SSCHARFILETYPE THEN PRINTSTRING( C
"**WARNING: ".FILE." is a character file
") ELSE START
IF NEWCONNECT#0 THEN SETUSE (LASTFN, -1, 0)
FLAG=267
->ERR
FINISH
FINISH
! Check data area is wholly within FILE
AD=RR_CONAD+RR_DATASTART+OFFSET; ! Start of data area
UNLESS AD+LEN-1<RR_CONAD+RR_DATAEND THEN FLAG=355 AND ->ERR
! If there is at least 1 other DATASPACE entry in this file
! i.e. RMODE#0 then must check for overlap
! Search the perm loaded entries to check for overlap
IF RMODE#0 THEN START
J=SSOWN_SSLOADTAB(2)_START+SSOWN_LLINFO(-1)_TAB; ! Start searching from here
WHILE BYTEINTEGER(J)#0 CYCLE
LENE=(BYTEINTEGER(J)+4)&X'FFFFFFFC'
ENT==RECORD(J+LENE)
K=ENT_TYPE&X'1FFFFFFF'; ! Remove special entry bits
*LSS_K
*SHZ_I
I=31-I
IF I=0 AND ENT_TYPE&X'40000000'#0 THEN START
! Found another dataspace entry
IF NOT (AD+LEN-1<ENT_DR1 OR AD>ENT_DR1+ENT_DR0-1) THEN START
SSOWN_SSFNAME=STRING(J)
FLAG=356; ! Overlaps previously defined data area
->ERR
FINISH
FINISH
J=J+LENE+16
REPEAT
FINISH
HOLDPRMOFF=SSOWN_PERMOFFSET; ! For possible failure if adding a file record
LHD=HASH(ENTRY,PRIME)
ADDENTRY(ENTRY,SSOWN_PLH,FLAG,SSOWN_PERMOFFSET,X'40000000'!DATA,LEN,AD,2,LHD); ! Perm load it
IF FLAG#0 THEN ->ERR; ! No need to unload
! Now add file record to listhead PRIME if required otherwise increment
! file record use count
IF RMODE=0 THEN START
ADDENTRY(FILE,SSOWN_PLH,FLAG,SSOWN_PERMOFFSET,X'40000000',1,MODE,2,PRIME)
IF FLAG#0 THEN START
FILL(SSOWN_PERMOFFSET-HOLDPRMOFF,SSOWN_SSLOADTAB(2)_START+HOLDPRMOFF,X'00')
SSOWN_PERMOFFSET=HOLDPRMOFF
-> ERR
FINISH
FINISH ELSE INTEGER(SSOWN_SSLOADTAB(2)_START+USECOUNTAD)= C
INTEGER(SSOWN_SSLOADTAB(2)_START+USECOUNTAD)+1
IF NEWCONNECT=0 THEN SETUSE(FILE,1,0)
*LSS_MODE
*SHZ_I
PRINTSTRING("Data entry ".ENTRY." defined - len ".HTOS(LEN,8)." at ". C
HTOS(AD,8)." access mode ".ACCMODE(32-I))
NEWLINE
! Since a new entry has been added to the perm entry tables we must
! satisfy any outstanding refs to it exactly as in LOADFILE2
DESC=LEN
DESC=(DESC<<32)!AD
! Find which listhead refs to ENTRY will be chained on.
SATISFYREF(ENTRY,DESC,FLAG,DATA,0,LHD)
IF 289#FLAG#0 THEN ->ERR
! Update LLINFO(0)_TAB and LLINFO(0)_GLA
SSOWN_LLINFO(0)_TAB=SSOWN_PERMOFFSET
SSOWN_LLINFO(0)_GLA=SSOWN_SSCURBGLA
SSOWN_RCODE=0
RETURN
ERR:
PSYSMES(107,FLAG)
SSOWN_RCODE=FLAG
RETURN
END ; ! OF DATASPACE
!
!
EXTERNALROUTINE ALIASENTRY(STRING (255) S)
! This is a PRELIMINARY version of the command which will add an alias
! to the temp loaded table only. cf DATASPACE
! Command is similar to DATASPACE in that it adds a pseudo entry to
! the loader tables. It is used to provide an alias to an entry name
! which is already loaded.
STRING (11) TEMPLATE
STRING (31) ENTRY,ALIAS
INTEGER DR0,DR1
LONGINTEGERNAME DESC
INTEGER FLAG,TYPE,LHD
DESC==LONGINTEGER(ADDR(DR0))
TEMPLATE="ENTRY,ALIAS"
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
IF PARMAP&X'FFFFFFFC'#0 THEN FLAG=263 AND ->ERR
ENTRY=SPAR(1)
ALIAS=SPAR(2)
!
TYPE=CODE!DATA; ! or MACRO perhaps? Think about it
! Check that ALIAS is not loaded
LHD=-1
DESC=CHECKLOADED(ALIAS,TYPE,LHD)
IF DESC#0 THEN START
SSOWN_SSFNAME=ALIAS
FLAG=354; ! Entry already loaded
->ERR
FINISH
! Now check that ENTRY is loaded
DESC=LOOKLOADED(ENTRY,TYPE)
IF DESC=0 THEN START
SSOWN_SSFNAME=ENTRY
FLAG=353; ! Entry not loaded
->ERR
FINISH
ADDENTRY(ALIAS,SSOWN_PLH,FLAG,SSOWN_PERMOFFSET,X'20000000'!TYPE,DR0,DR1,2,LHD); ! Perm load it
IF FLAG#0 THEN ->ERR; ! No need to unload
PRINTSTRING(ALIAS." aliased to entry name ".ENTRY)
NEWLINE
! Satisfy any outstanding refs
SATISFYREF(ALIAS,DESC,FLAG,TYPE,0,LHD)
IF 289#FLAG#0 THEN ->ERR
! Update LLINFO(0)_TAB
SSOWN_LLINFO(0)_TAB=SSOWN_PERMOFFSET
SSOWN_RCODE=0
RETURN
ERR:
PSYSMES(108,FLAG)
SSOWN_RCODE=FLAG
RETURN
END ; ! OF ALIASENTRY
!
EXTERNALROUTINE RESETLOADER(STRING (255) S)
! Causes ALL user loaded material to be unloaded.
! Fools UNLOAD2 into thinking there is a failed load incorporating
! all the user loaded material
! Note that LLINFO(-1) contains the initial perm values of TAB
! GLA and ISTK so we unload to these values at level 0.
! First make sure it has been called by the CLI.
UNLESS CURSTACK=0 THEN START
TERMINALPRINT("RESETLOADER fails - ",FAILUREMESSAGE(358))
SSOWN_RCODE=358
RETURN
FINISH
SSOWN_LLINFO(0)_TAB=SSOWN_LLINFO(-1)_TAB
SSOWN_LLINFO(0)_GLA=SSOWN_LLINFO(-1)_GLA
SSOWN_LLINFO(0)_ISTK=SSOWN_LLINFO(-1)_ISTK
SSOWN_LOADLEVEL=1
UNLOAD2(SSOWN_LOADLEVEL,1)
SSOWN_RCODE=0
RETURN
END ; ! OF RESETLOADER
!
!
EXTERNALROUTINE LOADPARM(STRING (255) S)
! This routine is the loader's equivalent of PARM which refers to compilers
! and allows loader options to be set. The default is FULL which means a
! full cascade load and fails if any unsatisfied refs remain. LOADPARM MIN
! loads only the file which contains the required entry point. Any common
! areas required are created and all unsatisfied refs are made dynamic.
! LOADPARM LET makes unsatisfied refs unresolved after a full cascade load
! so that execution can begin. LET is ignored when LOADPARM MIN is set.
STRING (255) PARMSOUT,PARM
INTEGER LPARMS,FLAG
IF S="?" THEN START
IF SSOWN_SSCOMREG(39)&1=0 THEN PARMSOUT="FULL" ELSE PARMSOUT="MIN"
IF SSOWN_SSCOMREG(39)&2#0 THEN PARMSOUT=PARMSOUT.",LET"
IF SSOWN_SSCOMREG(39)&4#0 THEN PARMSOUT=PARMSOUT.",ZERO"
PRINTSTRING(PARMSOUT."
")
SSOWN_RCODE=0
RETURN
FINISH
!
LPARMS=0
SETPAR(S)
FLAG=0
CYCLE
PARM=SPAR(0)
EXIT IF PARM=""
IF PARM="FULL" THEN LPARMS=LPARMS&X'FFFFFFFE' AND CONTINUE
IF PARM="MIN" THEN LPARMS=LPARMS!1 ELSE C
IF PARM="LET" THEN LPARMS=LPARMS!2 ELSE C
IF PARM="ZERO" THEN LPARMS=LPARMS!4 ELSE START
SSOWN_SSFNAME=PARM
FLAG=202
PSYSMES(109,FLAG)
FINISH
REPEAT
IF FLAG=0 THEN SSOWN_SSCOMREG(39)=LPARMS
SSOWN_RCODE=FLAG
RETURN
END ; ! OF LOADPARM
!
!
SYSTEMINTEGERFN FIND(STRING (31) ENTRY, INTEGERNAME NREC, INTEGER ADR,TYPE)
! This function will search through the entire loader search list looking
! for occurrences of ENTRY of type TYPE. Those found are returned in a record
! array supplied by the caller at ADR. Each element of the record
! array requires 40 bytes. NREC should be set by the caller to the maximum
! number of records he/she is prepared to accept. The function will reset N
! to the number actually returned.
! The function has an initial capacity of 128 records (MAXFINDREC).
! Possible error results :
! 326 - Illegal value of NREC, i.e. <1 or >MAXFINDREC(128 at present)
! 300 - NREC not big enough, i.e. more records to return than given NREC.
RECORD (FINDF)ARRAYFORMAT FINDFAF(1:MAXFINDREC)
RECORD (FINDF)ARRAYNAME E
LONGINTEGERNAME DSC
INTEGER DR0,DR1
INTEGER TOP,LHD,XTYPE,NTYPE,I,IHASH,FLAG
STRING (31) RES
STRING (31)ARRAY CACHE(1:3)
UNLESS 1<=NREC<=MAXFINDREC THEN START
IF NREC<1 THEN START
PRINTSTRING("Illegal value of NREC - ".ITOS(NREC)."
")
SSOWN_SSFNAME="NREC"
FLAG=326; ! Invalid value for & param
->OUT
FINISH ELSE PRINTSTRING("NREC value too large - reset to ". C
ITOS(MAXFINDREC)."
")
FINISH
DSC==LONGINTEGER(ADDR(DR0))
CACHE(I)="" FOR I=3,-1,1
TOP=NREC
NREC=0
E==ARRAY(ADR,FINDFAF)
LHD=HASH(ENTRY,PRIME); ! Listhead of ENTRY in loader tables
IHASH=INITHASH(ENTRY); ! For faster access to new style directories.
! Start by searching the loader tables for ENTRY
! Note that there are only CODE entries in the subsystem and system call
! list so these tables only need be searched if the CODE bit is set in TYPE.
IF TYPE&CODE#0 THEN START
XTYPE=CODE
DSC=SEARCHSUBSYS(ENTRY,XTYPE,LHD)
IF DSC#0 THEN START
! Found it
NREC=NREC+1
E(NREC)_FILE=""
E(NREC)_DIRNO=-2
E(NREC)_TYPE=CODE
E(NREC)_STATUS=1; ! Publically loaded
FINISH ELSE START
! Only one item of the same name and type can be loaded at the same time
! so only search system call list if not in subsystem.
DSC=SEARCHSCL(ENTRY,XTYPE)
IF DSC#0 THEN START
NREC=NREC+1
E(NREC)_FILE=""
E(NREC)_DIRNO=-2
E(NREC)_TYPE=CODE
E(NREC)_STATUS=1
FINISH
FINISH
FINISH
! Now things start to get complicated.
! ENTRY may be privately loaded and TYPE could be any selection of
! CODE!DATA!MACRO!ALIAS. Different things called ENTRY could be loaded at
! the same time but their TYPE would be different.
! CODE or DATA (or MACRO) entries loaded via the loader search list will be
! encountered again when searching the directories. Because of the way they
! are created, DATASPACE and ALIASENTRY entries will be encountered in the
! loader tables but not in the directories. Entries of type ALIAS are not
! loaded but will be encountered during the directory search.
!
! *Strategy*
! Use SEARCHLOADED to look up the loader tables and store the name of the
! file containing ENTRY in the array CACHE. If we encounter the same file
! later then can indicate that it's STATUS is 'privately loaded', if we don't
! then it must be an ALIASENTRY if CODE or DATASPACE if DATA.
!
! ** Note on MACROs
! At the time of writing, macros are not loadable so they will not
! be encountered by SEARCHLOADED. Equally macro entries and code entries are
! not distinguished in old style directories (they are all flagged 'code').
! SEARCHOLDDIR will return a TYPE of CODE!MACRO if the MACRO bit is set
! in the TYPE parameter for all code or macro entries.
! To keep things as simple as possible this code will adopt the convention
! meantime that CODE!MACRO should be treated as CODE.
! Therefore if new style directories are implemented or macros become loadable
! then the code will have to be expanded.
!
! Search privately loaded entries.
XTYPE=TYPE
WHILE XTYPE#0 CYCLE
NTYPE=XTYPE
DSC=SEARCHLOADED(ENTRY,NTYPE,LHD)
IF DSC#0 THEN START
! Found something
IF NTYPE=DATA THEN CACHE(NTYPE)=CONFILE(DR1) ELSE C
CACHE(NTYPE)=CONFILE(INTEGER(DR1+4))
FINISH
XTYPE=XTYPE!!NTYPE; ! Knock out the bit of the type found
REPEAT
! Now the loader search list
FOR I=-1,1,SSOWN_SSTOPADIR CYCLE
CONTINUE IF SSOWN_SSADIR(I)_NAME=""; ! In case there is no activedir
XTYPE=TYPE
WHILE XTYPE#0 CYCLE
NTYPE=XTYPE
IF SSOWN_SSADIR(I)_TYPE=SSDIRFILETYPE THEN C
RES=SEARCHDIR(ENTRY,SSOWN_SSADIR(I)_CONAD,IHASH,NTYPE) ELSE C
RES=SEARCHOLDDIR(ENTRY,NTYPE,SSOWN_SSADIR(I)_CONAD)
IF RES#"" THEN START
! Found something
NREC=NREC+1
IF NREC>TOP THEN START
NREC=NREC-1
FLAG=300; ! Table too small
->OUT
FINISH
NTYPE=CODE IF NTYPE=CODE!MACRO; ! Meantime
E(NREC)_FILE=RES
E(NREC)_DIRNO=I
E(NREC)_TYPE=NTYPE
E(NREC)_STATUS=0; ! Not currently loaded
! Now see if this record requires adjustment.
IF NTYPE=ALIAS THEN START
E(NREC)_FILE=" ".E(NREC)_FILE WHILE LENGTH(E(NREC)_FILE)<10
FINISH ELSE START
IF RES=CACHE(NTYPE) THEN E(NREC)_STATUS=-1 AND CACHE(NTYPE)=""
FINISH
FINISH
IF SSOWN_SSADIR(I)_TYPE#SSDIRFILETYPE AND NTYPE&X'0000000E'#0 THEN C
XTYPE=XTYPE&1 ELSE XTYPE=XTYPE!!NTYPE
REPEAT
REPEAT
! Check out CACHE to see if any DATASPACE or ALIASENTRY entries.
FOR I=1,1,2 CYCLE
IF CACHE(I)#"" THEN START
NREC=NREC+1
IF NREC>TOP THEN FLAG=291 AND ->OUT; ! Too many entries
E(NREC)_FILE=CACHE(I)
E(NREC)_DIRNO=-2-I; ! So DATASPACE=-3, ALIASENTRY=-4
E(NREC)_TYPE=I
E(NREC)_STATUS=-1
FINISH
REPEAT
FLAG=0
OUT:
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"SIiIQ")
RESULT =FLAG
END ; ! OF FIND
!
!
!***********************************************************************
!* *
!* Loader hash commands *
!* *
!***********************************************************************
!
EXTERNALROUTINE CURRENTREFS(STRING (255) S)
! Prints out a list of currently active refs
! An active reference is one which will trigger off a loader search i.e.
! dynamic or unsatisfied. NOT unresolved or satisfied by entry at higher loadlvl
CONSTSTRING (15)ARRAY ST(1:3)="- Data",
"- Code",
"- Single word"
RECORD (BREFF)NAME R1
RECORD (IREFF)NAME R2
INTEGER I,J,RECAD,IRECAD,START,LENE,FOUND,TYPE,XTYPE,K,N
FOUND=FALSE
START=SSOWN_SSLOADTAB(1)_START; ! Start of ref table.
PRINTSTRING("Current active refs are:
")
FOR I=PRIME-1,-1,0 CYCLE
IF SSOWN_RLH(I)>0 THEN START
! Something off this listhead
J=SSOWN_RLH(I)
WHILE J>0 CYCLE
RECAD=START+J; ! Basic record
LENE=(BYTEINTEGER(RECAD)+8)&X'FFFFFF8'; ! Bytes of name
TYPE=INTEGER(RECAD+LENE)
R1==RECORD(RECAD+LENE+4)
IF TYPE&X'60000000'#0 THEN START
FOUND=TRUE IF FOUND=FALSE
PRINTSTRING(STRING(RECAD))
SPACES(2)
XTYPE=TYPE&X'1FFFFFFF'
PRINTSTRING(ST(XTYPE))
N=0
K=R1_FIRST
WHILE K>0 CYCLE
N=N+1
IF N&7=0 THEN NEWLINE
SPACES(2)
IRECAD=START+K
R2==RECORD(IRECAD)
PRINTSTRING(HTOS(R2_DR1,8))
IF R2_DR0&CMN#0 THEN PRINTSTRING(" (Common)")
IF R2_DR0&DYN#0 THEN PRINTSTRING(" (Dynamic)") ELSE C
IF R2_DR0&UNSAT#0 THEN PRINTSTRING(" (Unsat)")
K=R2_LINK
REPEAT
NEWLINE
FINISH
J=R1_LINK
REPEAT
FINISH
REPEAT
IF FOUND=FALSE THEN PRINTSTRING("* None *
")
RETURN
END ; ! OF CURRENTREFS
!
!
EXTERNALROUTINE LOADEDFILES(STRING (255) S)
ROUTINE DOFILES(INTEGER START)
RECORD (ENTF)NAME ENT
STRING (31) FNAME
INTEGER J,RECAD,LENE
J=INTEGER(START+1004)
IF J=0 THEN PRINTSTRING("* None *
") AND RETURN
WHILE J>0 CYCLE
RECAD=START+J
LENE=(BYTEINTEGER(RECAD)+4)&X'FFFFFFFC'
ENT==RECORD(RECAD+LENE)
FNAME=STRING(RECAD)
UNLESS 32<=ENT_TYPE<=64 THEN START
PRINTSTRING(FNAME)
IF ENT_TYPE#0 THEN PRINTSTRING(" (DATASPACE entries)")
NEWLINE
FINISH
J=ENT_LINK
REPEAT
RETURN
END ; ! OF DOFILES
PRINTSTRING("Perm loaded files:
")
DOFILES(SSOWN_SSLOADTAB(2)_START)
PRINTSTRING("Temp loaded files:
")
DOFILES(SSOWN_SSLOADTAB(3)_START)
RETURN
END ; ! OF LOADEDFILES
!
!
EXTERNALROUTINE LOADEDENTRIES(STRING (255) S)
! Prints entries which have been loaded by the caller i.e. no subsys or
! system call table entries
! Does permanent then temporary entries
ROUTINE DOENT(INTEGER START,OFFSET)
CONSTSTRING (7)ARRAY ST(0:2)="Data ",
"Code ",
"Macro"
STRING (31) ENAME
RECORD (ENTF)NAME ENT
INTEGER I,J,LENE,K
! Note 1008 rather than 1004 as in LOADEDFILES. START+1004 is the address
! of the listhead of files. An ALIASENTRY record won't add a
! file record so to be sure of picking them up check the first integer
! after the listheads. If it has anything in it then there must be entries.
IF INTEGER(START+1008)=0 THEN PRINTSTRING("* None *
") AND RETURN
! Plod down the entry table
J=START+OFFSET
WHILE BYTEINTEGER(J)#0 CYCLE
ENAME=STRING(J)
LENE=(BYTEINTEGER(J)+4)&X'FFFFFFFC'
ENT==RECORD(J+LENE)
K=ENT_TYPE&X'1FFFFFFF'; ! i.e. remove special entry type bits
IF K=0 OR K>=32 THEN START
! Got a file record
IF K=0 THEN PRINTSTRING("=>=>=>=>=> found in file ".ENAME) AND NEWLINE
FINISH ELSE START
*LSS_K
*SHZ_I
I=31-I
PRINTSTRING(ENAME." ".ST(I)." at ")
IF I=0 THEN PRINTSTRING(HTOS(ENT_DR1,8)." length ".HTOS(ENT_DR0,8)) ELSE C
PRINTSTRING(HTOS(INTEGER(ENT_DR1+4),8))
IF ENT_TYPE&X'80000000'#0 THEN PRINTSTRING(" (Main entry)")
IF ENT_TYPE&X'40000000'#0 THEN PRINTSTRING(" (DATASPACE entry => ". C
CONFILE(ENT_DR1).")") AND NEWLINE
IF ENT_TYPE&X'20000000'#0 THEN PRINTSTRING(" (ALIASENTRY entry)") C
AND NEWLINE
FINISH
NEWLINE
J=J+LENE+16
REPEAT
RETURN
END ; ! OF DOENT
!
! Perm loaded first
PRINTSTRING("Perm loaded entries:
")
DOENT(SSOWN_SSLOADTAB(2)_START,SSOWN_LLINFO(-1)_TAB)
! Temp loaded
PRINTSTRING("Temp loaded entries:
")
DOENT(SSOWN_SSLOADTAB(3)_START,SSOWN_LLINFO(1)_TAB)
RETURN
END ; ! OF LOADEDENTRIES
!
!
EXTERNALROUTINE LOADDUMP(STRING (255) S)
! Dumps out loader tables and SSLOADTAB, DUFFGLA, LLINFO
CONSTSTRING (11)ARRAY LTAREA(1:3) = "REFS ","PERM ENT","TEMP ENT"
INTEGER I,L
PRINTSTRING("***** DUFFGLA *****
")
FOR I=0,1,63 CYCLE
CONTINUE IF SSOWN_DUFFGLA(I)_FROM=0
PRINTSTRING(HTOS(SSOWN_DUFFGLA(I)_FROM,8)." ".HTOS(SSOWN_DUFFGLA(I)_TO,8)."
")
REPEAT
NEWLINES(2)
PRINTSTRING("***** LLINFO *****
")
FOR I=-1,1,31 CYCLE
IF SSOWN_LLINFO(I)_TAB#0 THEN START
PRINTSTRING(HTOS(SSOWN_LLINFO(I)_TAB,8)." ".HTOS(SSOWN_LLINFO(I)_GLA,8)." ". C
HTOS(SSOWN_LLINFO(I)_ISTK,8)."
")
FINISH
REPEAT
NEWLINES(2)
IF S#"" THEN L=BYTEINTEGER(ADDR(S)+1)-X'30' ELSE L=-1
UNLESS -1<=L<=3 THEN L=-1
PRINTSTRING(" Dump of loader tables
AREA START LEN
")
FOR I=1,1,3 CYCLE
PRINTSTRING(LTAREA(I)." ".HTOS(SSOWN_SSLOADTAB(I)_START,8)." ". C
HTOS(SSOWN_SSLOADTAB(I)_LEN,8))
NEWLINE
REPEAT
NEWLINES(2)
IF L<0 THEN C
DUMP(SSOWN_SSLOADTAB(0)_START,SSOWN_SSLOADTAB(0)_START+INTEGER(SSOWN_SSLOADTAB(0)_START)-1) C
ELSE DUMP(SSOWN_SSLOADTAB(L)_START,SSOWN_SSLOADTAB(L)_START+SSOWN_SSLOADTAB(L)_LEN-1)
RETURN
END ; ! OF LOADDUMP
!
!
SYSTEMINTEGERFN DAPDATA(STRING (31) ENTRY,FILE, INTEGER LEN,CONAD)
! This is a special for the DAP. The function makes a pseudo data entry
! in the temporarily loaded entries table, a bit like DATASPACE, but we map
! on directly to a nominated virtual address. Checking is minimal.
! We do not add a filename record since the file for which this used is
! created by the Director and is invisible to the subsystem.
! Review again when Director and subsystem connected file tables merge.
! This function cannot be called by something which is permanently
! loaded. There is a line in LOADFILE2 to trap this.
LONGINTEGER DESC
INTEGER FLAG,LHD
UNLESS FILE="#DAP" AND LEN>0 AND CONAD>0 THEN FLAG=1010 AND ->OUT; ! Minimal check
LHD=HASH(ENTRY,PRIME)
ADDENTRY(ENTRY,SSOWN_TLH,FLAG,SSOWN_TEMPOFFSET,X'40000000'!DATA,LEN,CONAD,3,LHD)
IF FLAG#0 THEN ->OUT
! O.K. so satisfy outstanding refs
DESC=LEN
DESC=(DESC<<32)!CONAD
SATISFYREF(ENTRY,DESC,FLAG,DATA,SSOWN_LOADLEVEL,LHD)
FLAG=0 IF FLAG=289; ! There weren't any to satisfy
OUT:
IF SSOWN_DIAGMON&1#0 THEN SSTRACE(FLAG,"SSiiQ")
RESULT =FLAG
END ; ! OF DAPDATA
!
!
! * These routines are dummies and are only provided for ease of
! * conversion from the old to the new loader.
!
!
SYSTEMROUTINE FINDENTRY(STRING (31) ENTRY, C
INTEGER TYPE, DAD, STRINGNAME FILE, C
INTEGERNAME DR0, DR1, FLAG)
PRINTSTRING("FINDENTRY not available in new loader
")
FLAG=1001
RETURN
END ; ! OF FINDENTRY
!
!
SYSTEMROUTINE LOAD(STRING (31) NAME, INTEGER TYPE, C
INTEGERNAME FLAG)
PRINTSTRING("LOAD not available in new loader
")
FLAG=1001
RETURN
END ; ! OF LOAD
!
!
SYSTEMROUTINE LOADCOMMAND(STRING (31) COMMAND, C
STRINGNAME ALIASEDTO, INTEGERNAME MODE, DR0, DR1, FLAG)
PRINTSTRING("LOADCOMMAND not available in new loader
")
FLAG=1001
RETURN
END ; ! OF LOADCOMMAND
!
!
SYSTEMROUTINE LOADFILE(STRING (31) S, INTEGER MODE, C
INTEGERNAME FLAG)
PRINTSTRING("LOADFILE not available in new loader
")
FLAG=1001
RETURN
END ; ! OF LOADFILE
!
!
SYSTEMROUTINE UNLOAD(INTEGER CURGLA)
PRINTSTRING("UNLOAD not available in new loader
")
RETURN
RETURN TO COMMAND LEVEL
END ; ! OF UNLOAD
!
EXTERNALROUTINE LVSN(STRING (255) S)
PRINTSTRING(LOADVSN)
RETURN
END ; ! OF LVSN
!
!
EXTERNALROUTINE DOPROFILE
PPROFILE
RETURN
END ; ! OF DOPROFILE
!
!
ENDOFFILE