!**************************
!*    LINK6S/LINK         *
!* DATE: 10.APR.80        *
!* 4TH PASS FOR IMP COMP. *
!**************************


%CONTROL K'101011';    ! 11/45 & TRUSTED
%RECORDFORMAT DFGH(%INTEGER G)
%CONSTRECORD (DFGH) %NAME NULL = 0


%BEGIN

     !! STK = 27200

     %CONSTBYTEINTEGERNAME ID = K'160030'
     %CONSTBYTEINTEGERNAME FSYS = K'160055'

     %CONSTINTEGER EXAMINE = 0

     %CONSTINTEGER OUT = 2;            ! 'MAP' OUTPUT STREAM

     %INTEGER CKSM, BC, LOADPT, STK, STR, I, J
     %INTEGER LOAD, N, STK STRT, CODEL, GLAL, LDL
     %INTEGER STK GAP, TSTK, CODE STRT

     %OWNINTEGER GLA STRT = K'20';     ! LEAVES 20 BYTES FOR ME
     %OWNINTEGER CODE BASE = K'40000'
     %CONSTINTEGER SUPER CODE BASE = K'1400'
     %OWNINTEGER U REF = 0
     %OWNINTEGER PROG FILE = 0
     %OWNINTEGER F BLOCK =- 1

     %RECORDFORMAT SEGDF(%INTEGER TYPE, LEN)
     %RECORDFORMAT FBF(%INTEGER S, BC, LD, %BYTEINTEGERARRAY %C
       NAME(0:3), %INTEGER SP, %RECORD (SEGDF) %ARRAY SEGDEF(0:7))

     %OWNRECORD (FBF)FB

     %CONSTINTEGER NO ACCESS = 4
     %CONSTINTEGER READ ONLY = 5
     %CONSTINTEGER READ WRITE = 6
     %CONSTINTEGER SHARED = 7


     %CONSTINTEGER GLA MAX = 11000, GLA MAXI = 5500

     %RECORDFORMAT GF(%INTEGERARRAY C(0:GLA MAXI))
     %RECORDFORMAT GBF(%BYTEINTEGERARRAY C(0:GLA MAX))

     %RECORD (GF) %NAME GLAI
     %RECORD (GBF)GLA


     %RECORDFORMAT LFMF(%STRING (8)NAME, %BYTEINTEGER FLAG, %INTEGER %C
       REF)
     %RECORDFORMAT R1F(%RECORD (LFMF) %NAME LFM)
     %RECORDFORMAT R2F(%BYTEINTEGERNAME N)
     %RECORDFORMAT R3F(%INTEGER X)

     %RECORD (R1F)R1
     %RECORD (R2F) %NAME R2
     %RECORD (R3F) %NAME R3

     %RECORDFORMAT GLA HEADF(%INTEGERARRAY A(0:4), %INTEGER CODES, %C
       STK LM, GLA END)

     %RECORD (GLA HEADF) %NAME GLA HEAD

     %RECORDFORMAT REFF(%INTEGER PT, %INTEGER CODE, GLA)
     %RECORD (REFF) %NAME REF

     %RECORDFORMAT STRDF(%INTEGER R, N, G, %BYTEINTEGER S, RP, UNIT, %C
       FSYS, %BYTEINTEGERARRAY NAME(0:5), %INTEGER BLOCK)

     %RECORDFORMAT STRPF(%RECORD (STRDF) %NAME STRD)

     %RECORD (STRDF) %NAME STRD
     %CONSTRECORD (STRPF) %NAME STRP1 = K'160034'
     %CONSTRECORD (STRPF) %NAME STRP5 = K'160044'
     %CONSTINTEGERNAME STRP2 = K'160036'
     %RECORDFORMAT UNDEFF(%STRING (8)NAME, %BYTEINTEGER FLAG, %C
       %INTEGER REF)

     %CONSTINTEGER LIB END = 2
     %CONSTINTEGER LIB FILE = 1

     %RECORDFORMAT P2F(%BYTEINTEGER SERVICE, REPLY, %INTEGER A1, %C
       %BYTEINTEGERNAME A2, %INTEGER A3)

     %OWNRECORD (UNDEFF) %ARRAY UNDEFA(0:100)
     %OWNINTEGER UND PT = 0

     %CONSTINTEGER LIB ENTRIES = 41
     %RECORD (LFMF) %ARRAY LIBA(0:LIB ENTRIES+1)

     %ROUTINESPEC FIX GLA HEADER
     %ROUTINESPEC DO REFS(%INTEGER PT)
     %ROUTINESPEC CHECK REFS
     %ROUTINESPEC GET LIB(%BYTEINTEGER FSYS)
     %ROUTINESPEC LOAD FILE
     %ROUTINESPEC FIX EXTERNALS(%BYTEINTEGER FSYS)
     %ROUTINESPEC STUFF SEGS
     %ROUTINESPEC PUT BLOCK(%RECORD (GBF) %NAME C, %INTEGER INIT, %C
       MAX)
     %ROUTINESPEC START BLOCK
     %ROUTINESPEC DIGEST(%RECORD (GBF) %NAME C)
     %ROUTINESPEC PUT DUMMY HEADER
     %ROUTINESPEC COPY HEADER(%RECORD (FBF) %NAME FB)


     %ROUTINE OCTAL(%INTEGER N)
        %INTEGER I
        SPACE
        %CYCLE I = 15, -3, 0
           PRINTSYMBOL((N >> I)&7+'0')
        %REPEAT
     %END


     %INTEGERFN SYM
        %INTEGER N
        READSYMBOL(N)
        %RESULT = N
     %END


     %INTEGERFN WORD
        %INTEGER N
        N = SYM
        %RESULT = SYM << 8!(N&X'FF')
     %END


     %ROUTINE PUT(%INTEGER I)
        PRINTSYMBOL(I)
        CKSM = CKSM+I
     %END


     %ROUTINE PUT WORD(%INTEGER I)
        PUT(I&X'FF');  PUT(I >> 8)
     %END


     %ROUTINE PLANT(%INTEGER QUANT, ACCESS, %INTEGERNAME SEGS)
        %INTEGER LEN, N
        N = 0
        %UNTIL QUANT <= 0 %CYCLE
           N = N+1;  LEN = QUANT
           %IF LEN > K'17777' %THEN LEN = K'17777'
           FB_SEGDEF(SEGS)_TYPE = ACCESS
           FB_SEGDEF(SEGS)_LEN = LEN
           QUANT = QUANT-LEN-1;  SEGS = SEGS+1
        %REPEAT
     %END


     %INTEGERFN ROCTAL
        %INTEGER SUM, N, I
        SUM = 0
        SKIPSYMBOL %WHILE NEXTSYMBOL = ' ' %OR NEXTSYMBOL = NL
        %CYCLE
           N = NEXTSYMBOL-'0'
           %RESULT = SUM %IF N < 0 %OR N > 7
           SUM = SUM << 3+N
           SKIPSYMBOL
        %REPEAT
     %END


     GLAI == GLA
     R2 == R1;  R3 == R2
     FB_NAME(I) = ' ' %FOR I = 0, 1, 3

     %IF STRP2 = 0 %START
        STRD == STRP5_STRD
        %UNLESS STRD == NULL %START
           FB_NAME(I) = STRD_NAME(I) %FOR I = 0, 1, 3
        %FINISH
        STK = K'14000'
        STR = K'5000'
     %ELSE
        PROMPT('NAME?')
        %CYCLE I = 0, 1, 3
           READSYMBOL(J)
           %EXITIF J = NL
           FB_NAME(I) = J
        %REPEAT

        PROMPT('STACK:')
        STK = ROCTAL
        %IF STK = 0 %THEN CODE BASE = SUPER CODE BASE

        PROMPT('STREAMS:');  STR = ROCTAL
        STR = STR*K'1030'+K'500'

       NEWLINE
     %FINISH
     CODE STRT = 0
     SELECT OUTPUT(1)
     PUT DUMMY HEADER
     STRD == STRP5_STRD
     F BLOCK = STRD_BLOCK %UNLESS STRD == NULL
     SELECTOUTPUT(OUT)
     PRINTSTRING('PROG:');  PRINTSYMBOL(FB_NAME(I)) %FOR I = 0, 1, 3
     NEWLINE
     LOAD FILE
     DO REFS(GLAL)
     FIX EXTERNALS(FSYS)
     FIX EXTERNALS(0)
     STUFF SEGS

     GLAI_C(0) = GLA HEAD_GLA END;     ! ACTUAL TOP-OF-STACK WORD

     %IF STK = 0 %THEN STK STRT = K'140000'; ! SPECIAL FOR SUPERVISOR
     PUT BLOCK(GLA, STK STRT, GLAL)
     START BLOCK
     CHECK REFS
     %STOP


     %ROUTINE FIX GLA HEADER

        R2_N == GLA_C(GLA STRT)
        GLA HEAD == R1_LFM;            ! POINT GLA RECORD AT GLA
        GLA HEAD_CODES = CODE BASE+CODE STRT
        GLA HEAD_STK LM = STK STRT
        GLA HEAD_GLA END = STK STRT+GLAL
     %END


     %ROUTINE QUIT(%STRING (20)S)
        SELECT OUTPUT(0)
        PRINTSTRING(S);  NEWLINE
        %STOP
     %END

     %RECORD (UNDEFF) %MAP GET LINK(%RECORD (LFMF) %NAME LFM)
        %INTEGER N
        N = 0
        %IF UND PT # 0 %START
           %CYCLE N = 0, 1, UND PT
              %RESULT == UNDEFA(N) %IF UNDEFA(N)_NAME = LFM_NAME
           %REPEAT
        %FINISH
        UNDEFA(N)_NAME = LFM_NAME;  UND PT = UND PT+1
        %RESULT == UNDEFA(N)
     %END


     %ROUTINE FILL CHAIN(%RECORD (LFMF) %NAME LFM, %INTEGER RADD)
        %INTEGERNAME LINK
        %RECORD (UNDEFF) %NAME UNDEF

        UNDEF == GET LINK(LFM);  ! GET EXISTING, OR A NEW, CHAIN
        %IF UNDEF_FLAG = 1 %START
           PRINTSTRING(LFM_NAME); WRITE(UNDEF_FLAG, 2)
           WRITE(LFM_FLAG, 2); SPACE
           QUIT('*DOUBLE DEF?')
        %FINISH
        %WHILE UNDEF_REF # 0 %CYCLE;  ! SEARCH THE ENTRIES
           LINK == GLAI_C(UNDEF_REF >> 1)
           UNDEF_REF = LINK;         ! REMEMBER NEXT LINK
           LINK = RADD;        ! AND FILL IN THIS ONE
        %REPEAT
        UNDEF_FLAG = 1
        UNDEF_REF = RADD;          ! REMEMBER ADDRESS FOR FUTURE USE
        %IF UNDEF_NAME = '#GO' %THEN GLAI_C(1) = RADD
     %END

     %ROUTINE DO REFS(%INTEGER PT)

        %CONSTSTRING (5) %ARRAY TYPE(0:3) = %C
          'XDEF:', 'XREF:', 'DDEF:', 'DREF:'

        %RECORD (R2F) %NAME R2
        %RECORD (R1F)R1

        %RECORD (LFMF) %NAME LFM
        %RECORD (UNDEFF) %NAME UNDEF

        %INTEGER I, N, P, Q, C, CTY, TYP, SHSF, PR
        %INTEGERNAME LINK
        R2 == R1
        C = 0;  CTY = 0;                ! FORMATTING VARIABLE FOR 'REFS'
        SHSF = 0;                      ! SHARED CODE FLAG
        %CYCLE
           R2_N == GLA_C(PT)
           LFM == R1_LFM
           %EXITIF LENGTH(LFM_NAME) = 0
           TYP = LFM_FLAG
           %IF TYP&1 # 0 %START
              !! REFERENCE
              U REF = U REF+1
              LFM_REF = LFM_REF+GLA STRT
                                       ! ADD IN BASE OF LOCAL GLA
              UNDEF == GET LINK(LFM)
              GLAI_C(LFM_REF >> 1) = UNDEF_REF
              UNDEF_REF = LFM_REF %IF UNDEF_FLAG = 0
                                       ! IE, NOT ALREDY DEFINED
              !! IF IT EAS DEFINED, THEN FILL IN THE REFERENCE
              !! OTHERWISE: CONSTRUCT LINKS THROUGH THE REFERENCES
              %IF C = 0 %OR CTY # TYP %START
                 C = 0;  CTY = TYP
                 SPACES(2);  PRINTSTRING(TYPE(TYP))
              %FINISH
              PRINTSTRING(LFM_NAME);  SPACES(10-LENGTH(LFM_NAME))
              %IF C = 4 %THEN C = 0 %AND NEWLINE %ELSE C = C+1
           %ELSE
              !! DEFINITION
              NEWLINE %IF C # 0;  C = 0
              P = LFM_REF+GLA STRT;       ! P IS THE ARRAY INDEX OF ITEM
              Q = P+STK STRT+(2-TYP&127);  ! Q IS THE REAL ADDRESS OF ITEM
              PR = Q
              R2_N == GLA_C(P)
              REF == R1_LFM;           ! REF POINTS TO BEGINNING OF
                                       ! THE 3 WORDS
              %IF TYP&127 = 0 %START;       ! FOR ROUTINE REFS ONLY
                 REF_PT = Q
                 %IF TYP = 0 %START
                    REF_CODE = REF_CODE+CODE BASE+CODE STRT
                    PR = REF_CODE
                 %ELSE
                    SHSF = 1
                 %FINISH
                 REF_GLA = GLA STRT+STK STRT
              %FINISH
              FILL CHAIN(LFM, Q);      ! DEAL WITH UNDEFINEDS
              SPACES(2)
              PRINTSTRING(TYPE(TYP&127));  OCTAL(PR);  SPACES(2)
              PRINTSTRING(LFM_NAME);  NEWLINE
           %FINISH
           PT = PT+12
        %REPEAT
        NEWLINE %IF C # 0
        FIX GLA HEADER %IF SHSF = 0;           ! NOT IN CASE OF SHARED FILE
     %END


     %ROUTINE CHECK REFS
        %INTEGER N
        %RECORD (UNDEFF) %NAME UNDEF
        SELECT OUTPUT(0)
        N = 0
        %WHILE N <= UNDPT-1 %CYCLE
           UNDEF == UNDEFA(N)
           %IF UNDEF_FLAG = 0 %START
              PRINTSTRING(UNDEF_NAME);  PRINTSTRING(' UNDEFINED!
')
           %FINISH
           N = N+1
        %REPEAT
     %END


     %ROUTINE GET LIB(%BYTEINTEGER FSYS)

        %CONSTBYTEINTEGERARRAY LIB(0:5) = 
        'L', 'I', 'B', '0', '0', '0'


        %RECORD (P2F)P2, P3

        %RECORDFORMAT FILEF(%BYTEINTEGER UNIT, FSYS, %C
          %BYTEINTEGERARRAY NAME(0:5))

        %RECORD (FILEF)FILE


        %RECORDFORMAT F1F(%BYTEINTEGER X)
        %RECORD (F1F) %NAME F1

        F1 == LIBA(0)
        FILE_NAME(I) = LIB(I) %FOR I = 0, 1, 5
        FILE_FSYS = FSYS;  FILE_UNIT = 0
        LIBA(0)_FLAG = LIB END;    ! PROTECTION AGAINST NO LIB
        P2_SERVICE = 4;  P2_REPLY = ID
        P2_A1 = EXAMINE;  P2_A2 == FILE_UNIT
        PONOFF(P2)
        %IF P2_A1 = 0 %THENRETURN
        P3_SERVICE = 3;  P3_REPLY = ID
        P3_A1 = 0;                     ! READ BLOOCK
        P3_A2 == F1_X
        P3_A3 = P2_A1
        PONOFF(P3)
     %END


     %ROUTINE LOAD FILE
        %INTEGER PHY ADD, LINO
        SELECT INPUT(1)
        READSYMBOL(I) %UNTIL I = 1;  SKIPSYMBOL
        BC = WORD;  LOAD PT = WORD
        CODEL = WORD+CODE STRT;  GLAL = WORD+GLA STRT;  LDL = WORD

        %IF PROG FILE = 0 %START
           TSTK = STK+GLAL+K'100';   ! WITH EXTRA FOR EXT GLAS
           STK GAP = K'160000'-TSTK
           STK STRT = STK GAP&K'160000'
           %IF STK STRT = K'40000' %START
              SELECT OUTPUT(0); PRINTSTRING('STACK OVERFLOW?
')
               SELECT OUTPUT(OUT)
              STK STRT = K'60000'
          %FINISH
           %IF STK = 0 %THEN STK STRT = (CODE BASE+CODEL+K'77')&K'177700'
           !! SUPERVISOR GLA ON END OF CODE
        %FINISH
        PROG FILE = PROG FILE+1
        PHY ADD = CODE STRT+CODE BASE

        PRINTSTRING('  CODE:');  OCTAL(PHY ADD)
        PRINTSTRING('  GLA:');  OCTAL(GLA STRT+STK STRT)
        NEWLINE
        %IF GLAL > GLA MAX %THEN QUIT('GLA BUFFER OVERFLOW')

        SKIPSYMBOL %AND BC = BC-1 %UNTIL BC = 11
                                       ! INCLUDE CKSM
        %CYCLE
           READSYMBOL(I) %UNTIL I = 1;  SKIPSYMBOL
           BC = WORD
           %EXITIF BC = 6
           LOAD = WORD
           %IF BC < 6 %THEN QUIT('FILE FORMAT ERROR')
           %IF LOAD >= 0 %START
              SELECT OUTPUT(1)
              CKSM = 0
              PUT WORD(1);  PUT WORD(BC)
              PUT WORD(LOAD+PHY ADD)
              DIGEST(NULL)
              PRINTSYMBOL(-CKSM)
              LINO = WORD;  PUT WORD(LINO)
              PRINTSYMBOL(0);  PRINTSYMBOL(0)
              SELECT OUTPUT(OUT)
           %ELSE
              LOAD = LOAD&K'77777'+GLA STRT
              DIGEST(GLA)
           %FINISH
        %REPEAT
     %END


     %ROUTINE ARRANGE FOR LOAD(%RECORD (LFMF) %NAME LIB)
        %RECORD (STRDF) %NAME STRD
        SELECT INPUT(1)
        CLOSE INPUT
        STRD == STRP1_STRD
        STRD_FSYS = LIB_REF;     ! COPY FILE SYSTEM NUMBER
        STRD_NAME(I) = CHARNO(LIB_NAME, I+1) %FOR I = 0, 1, 5
     %END


     %ROUTINE FIX EXTERNALS(%BYTEINTEGER FSYS)
        %INTEGER FLAG, I
        %RECORD (LFMF) %NAME LIB, LIBN
        %RECORD (UNDEFF) %NAME UNDEF
        %RETURNIF UREF = 0
        GET LIB(FSYS)
        FLAG = 1;  N = 0
        %WHILE N <= UND PT-1 %CYCLE
           UNDEF == UNDEFA(N)
           %IF UNDEF_FLAG = 0 %START
              %CYCLE I = 0, 1, LIB ENTRIES
                 LIB == LIBA(I)
                 %EXITIF LIB_FLAG = LIB END
                 %IF LIB_FLAG = LIB FILE %START
                    LIBN == LIB
                    %CONTINUE
                 %FINISH
                 %IF UNDEF_NAME = LIB_NAME %START
                    %IF LIB_FLAG&128#0 %START; ! SHARED ENTRY
                       FILL CHAIN(LIB, LIB_REF); ! DEAL WITH IT NOW
                       %CONTINUE
                    %FINISH
                    PRINTSTRING('FILE:');  PRINTSTRING(LIBN_NAME)
                    NEWLINE
                    ARRANGE FOR LOAD(LIBN)
                                       ! SET THE STREAM UP
                    CODE STRT = CODEL
                    %IF STK=0 %AND PROG FILE=1 %THEN %C
                    CODE STRT=K'61000'-SUPER CODE BASE
                    GLA STRT = GLAL
                    LOAD FILE
                    DO REFS(GLAL)
                    %EXIT
                 %FINISH
              %REPEAT
           %FINISH
           N = N+1
        %REPEAT
     %END


     %ROUTINE STUFF SEGS
        %INTEGER SS, SEGPT, TSTK, SEG, DIFF, SS2

        TSTK = STK+GLAL;               ! WORK IT OUT AGAIN
        %IF TSTK+STK STRT > K'160000' %THEN TSTK = K'160000'-STK STRT
        SS = (K'160000'-TSTK)>>13;  SS2 = STK STRT>>13
        PRINTSTRING('
TOTALS: CODE =')
        OCTAL(CODEL)
        PRINTSTRING('  GLA/STACK =');  OCTAL(TSTK);  NEWLINE
        SEGPT = 1
        FB_SEGDEF(0)_TYPE = 4
        FB_SEGDEF(1)_TYPE = SHARED;  FB_SEGDEF(1)_LEN = 0
        SEG = 2
        PLANT(CODEL+4, READ ONLY, SEG)
        %IF SEG > SS2 %AND STK # 0  %THEN QUIT("VIRTUAL MEMORY TOO SMALL")
        %WHILE SEG < SS2 %CYCLE
           FB_SEGDEF(SEG)_TYPE = NO ACCESS
           SEG = SEG+1
        %REPEAT
        PLANT(TSTK, READ WRITE, SEG)
        %IF SS # SS2 %START
           FB_SEGDEF(SEG)_TYPE = NO ACCESS;  SEG = SEG+1
        %FINISH
        PLANT(STR, READ WRITE, SEG)
        FB_S = 1
        FB_BC = 8*4+6+4+2
        FB_LD = 0
        FB_SP = STK STRT+TSTK-2
        COPY HEADER(FB)
     %END


     %ROUTINE PUT BLOCK(%RECORD (GBF) %NAME C, %INTEGER INIT, MAX)
        %INTEGER I
        SELECT OUTPUT(1)
        CKSM = 0
        PUT(1);  PUT(0);  PUT WORD(MAX+6)
        PUT WORD(INIT)
        %CYCLE I = 0, 1, MAX-1
           PUT(C_C(I))
        %REPEAT
        PUT(-CKSM)
        PUT WORD(0)
        SELECT OUTPUT(OUT)
     %END


     %ROUTINE START BLOCK
        SELECT OUTPUT(1)
        CKSM = 0
        PUT WORD(1);  PUT WORD(6);  PUT WORD(-1)
        PUT(-CKSM)
        SELECT OUTPUT(OUT)
     %END


     %ROUTINE DIGEST(%RECORD (GBF) %NAME C)
        %INTEGER N
        %CYCLE BC = BC-7, -1, 0
           READSYMBOL(N)
           %IF C == NULL %START
              PRINTSYMBOL(N);  CKSM = CKSM+N
           %ELSE
              C_C(LOAD) = N;  LOAD = LOAD+1
           %FINISH
        %REPEAT
        SKIPSYMBOL;                   ! THE CHECKSUM
     %END


     %ROUTINE PUT DUMMY HEADER
        %INTEGER I
        PRINTSYMBOL(0) %FOR I = 1, 1, 47
     %END


     %ROUTINE COPY HEADER(%RECORD (FBF) %NAME FB)

        %RECORDFORMAT RX2F(%BYTEINTEGER X)
        %RECORD (RX2F) %NAME RX2

        %RECORD (FBF) %NAME RX
        %RECORD (P2F)P3

        RX == LIBA(0)
        RX2 == RX
        QUIT('NO OUTPUT FILE') %IF FBLOCK = -1
        SELECT OUTPUT(1)
        PRINTSYMBOL(0) %FOR I = 1, 1, 512-60
        SELECT OUTPUT(OUT)

        P3_SERVICE = 3;  P3_REPLY = ID
        P3_A1 = 0
        P3_A2 == RX2_X
        P3_A3 = F BLOCK
        PONOFF(P3);                    ! READ THE FIRST BLOCK AGAIN
        QUIT('READ DISC FAILS') %IF P3_A1 # 0

        RX = FB;                    ! COPY NEW HEADER

        P3_SERVICE = 3;  P3_REPLY = ID
        P3_A1 = 1;                     ! WRITE
        P3_A2 == RX2_X
        P3_A3 = FBLOCK
        PONOFF(P3);                    ! AND WRITE THE BLOCK OUT
        QUIT('WRITE DISC FAILS') %IF P3_A1 # 0
     %END
%ENDOFPROGRAM