!
! Contact Alan Anderson ,ERCC before modifying this code
!
!
! Dec 6  Vsn 12 - Corrections for IMP on Perq
!
!Sept 8    Vsn 11  - Handles Imp data entries and references.!
!
!August 31 Vsn 10
!                  - Uses in store work file if big memory.
!                  - Ensures old object files taken care of.
!
!August 20 Vsn 9
!                  Lasttype becomes an own - P71
!                  Diagnostic records are moved out of qcodes into
!                  the unswopped area at the back of the file.
!                  For Fortran on Perq only, not IMP.
!                  Comment out decode sections. redtapelen->0.
!
!june 24 - Vsn 7   better error messages
!june 24           watch for adjacency and repitition in data statements
!june 18           work segment limit raised to 128kb.
!june 16           lmax  h -> I to avoid going negative in large compilations.
!
!JUNE 14 - Vsn 6   F77 1.4
!                  Avoid half(addr(x+1)) for IMP bug
!                  Extend work area by 8 blocks at a time.
!                  Patcher no longer needs size 80 strings.
!                  Increment LMAX in areafrag: for bug.
!MAY 26 - Vsn 5    F77 1.3
!                  MODULE NAMES ARE CONVERTED TO UPPER CASE
!MAY 25 -          COMMON NAMES TRUNCATED TO 8 FOR LOADER TABLE.
!                  VERSION STRING PADDED TO 80 FOR PATCHER



%CONSTINTEGER EMAS=0,PERQ=1,SYS=EMAS
%CONSTINTEGER NOTSYS=(SYS+1)&1


!********************************************
!*             PERQ LPUT                    *
!********************************************




        %ROUTINESPEC QPUT(%INTEGER A,B,C,D)  {ensure qput is routine number one}
{PERQ   %externalroutinespec MOVEBEE
{PERQ   %EXTERNALROUTINESPEC WRITE BLOCK(%HALFINTEGER FILEID,BLOCK, %INTEGER AD)
{PERQ   %EXTERNALROUTINESPEC READBLOCK(%HALFINTEGER FILEID,BLOCK,%INTEGER AD)
{PERQ   %EXTERNALROUTINESPEC NEWSEG(%INTEGER AD, %HALFINTEGER SIZE,INC,MAXSIZE)
{perq   %externalhalfintegerfnspec createfile(%integer adname)
{perq  %externalroutinespec destroyfile(%string(100) s)
{PERQ   %EXTERNALROUTINESPEC CLOSEFILE(%HALFINTEGER FILEID,BLOCKS,BITS)
!        %DYNAMICROUTINESPEC QCODE(%INTEGER I,J,K,L)
{EMAS}  %SYSTEMSTRINGFNSPEC FAILUREMESSAGE(%INTEGER MESS)
{EMAS}  %EXTERNALSTRINGFNSPEC UINFS(%INTEGER N)
{EMAS}  %SYSTEMSTRINGFNSPEC SPAR(%INTEGER N)
{EMAS}  %SYSTEMROUTINESPEC SETFNAME(%STRING(63) S)
{EMAS}  %EXTERNALROUTINESPEC CHANGECONTEXT
{EMAS}  %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER I)
{EMAS}  %SYSTEMROUTINESPEC OUTFILE(%STRING (15) S,  %C
{EMAS}         %INTEGER LENGTH, MAXBYTES, PROTECTION, %INTEGERNAME CONAD, FLAG)
{EMAS}  %SYSTEMROUTINESPEC MOVE(%INTEGER L,F,T)
{PERQ   %externalroutinespec EXTENDSEG(%halfinteger FILEID,INC)
        %SYSTEMROUTINESPEC SSERR(%INTEGER N)
        %SYSTEMROUTINESPEC PHEX(%INTEGER N)
{perq       %externalhalfintegerfnspec memorysize  {in blocks}
!*
!*



{EMAS}    !--------------------------------------
{EMAS}    !   ROUTINE TO CHANGE BYTE ORDER
{EMAS}    !--------------------------------------
{EMAS}
{EMAS}    %ROUTINE REVERSE(%INTEGER AD,LEN)
{EMAS}
{EMAS}    %INTEGER I,J
{EMAS}
{EMAS}    I=AD
{EMAS}      %UNTIL I=AD+(LEN*2) %CYCLE
{EMAS}       J=BYTEINTEGER(I)
{EMAS}       BYTEINTEGER(I)=BYTEINTEGER(I+1)
{EMAS}       BYTEINTEGER(I+1)=J
{EMAS}       I = I + 2
{EMAS}    %REPEAT
{EMAS}    %END

{PERQ    %ROUTINE COPY(%INTEGER LEN,SBASE, %HALFINTEGER SDISP, %INTEGER TBASE,                       %HALFINTEGER TDISP)
{PERQ
{PERQ       **@TBASE
{PERQ       *LDDW
{PERQ       **TDISP
{PERQ       **@SBASE
{PERQ       *LDDW
{PERQ       **SDISP
{PERQ       **LEN+1
{PERQ       *STLATE_X'63'
{PERQ       *MVBW
{PERQ    %END





!*
%EXTERNALROUTINE QPUT(%INTEGER TYPE,  P1, P2, P3)

%RECORDFORMAT RF0(%HALFINTEGER TYPE,RECLEN, %INTEGER LA, DATALEN, FILLER)
%RECORDFORMAT RF1(%HALFINTEGER TYPE,RECLEN, %INTEGER  LINK, N, RID, %STRING(32) NAME)
%RECORDFORMAT RF4(%HALFINTEGER TYPE,RECLEN, %INTEGER  LINK,  L,%HALFINTEGER PROPS, AREA, %STRING (31) NAME)
%RECORDFORMAT RF7(%HALFINTEGER TYPE,RECLEN, %INTEGER  LINK, %HALFINTEGER AREA,AREALOC, BASE,BASELOC)
%RECORDFORMAT RF8(%HALFINTEGER TYPE,RECLEN, %INTEGER  LINK, CODEADDR, ADDRFIELD)
%RECORDFORMAT RF9(%HALFINTEGER TYPE,RECLEN, %INTEGER LINK, %halfinteger sp1,iin, %integer LA,DATALEN,FILLER)
%RECORDFORMAT RF10(%HALFINTEGER TYPE,RECLEN, %INTEGER LINK,AREA,DISP,LEN)
%recordformat rf14(%halfinteger type,reclen,%integer link,%halfinteger disp,len ,%string(31) name)
%RECORDFORMAT RF27(%HALFINTEGER TYPE,RECLEN, %INTEGER LINK,LINE,INF,%STRING(32) NAME)
%RECORD(RF0) %NAME R0
%RECORD(RF1) %NAME R1
%RECORD(RF4) %NAME R4
%RECORD(RF7) %NAME R7
%RECORD(RF8) %NAME R8
%ownRECORD(RF9) %NAME R9
%RECORD(RF10) %NAME R10
%record(rf14) %name r14
%RECORD(RF27) %NAME R27


%INCLUDE "ercs04.QLFORMATS"
%RECORDFORMAT RF11(%HALFINTEGER TYPE,RECLEN, %INTEGER LINK,%HALFINTEGER PROPS,RTNO, %RECORD(DICTFM) D, %C
%HALFINTEGER DIAGDISP,PLEN, %STRING(31) NAME)
%RECORD(RF11) %NAME R11
%INCLUDE "perqimports"


!-----------------------------------------
!             CONSTANTS
!------------------------------------------

        %CONSTINTEGER MAXAREAS=6
        %CONSTINTEGER FORTRAN=1,IMP=2
{EMAS}  %CONSTINTEGER HDRLEN = 544   ;! BYTE DISP FROM EMAS FILE START TO CODE
{EMAS}  %CONSTINTEGER EHEAD=32
{EMAS}  %CONSTINTEGER MAXFSIZE=X'80000'
{PERQ   %CONSTINTEGER HDRLEN = 512
{PERQ   %CONSTINTEGER EHEAD = 0
{PERQ   %CONSTINTEGER MAXFSIZE=(64*1024)-1
        %CONSTINTEGER REDTAPELEN = 0   ;! DISP TO LDATA AND AREA MAP
{PERQ   %consthalfinteger WSEGINC=8    ;! extend work segment by eight blocks at a time
{perq   %consthalfinteger onemeg=2048  {blocks}


!-----------------------------------------
!             OWNS - (Globals)
!----------------------------------------

{perq   %ownhalfinteger memsize=onemeg
{EMAS}  %OWNINTEGER     WORKMAX
{PERQ   %ownhalfinteger WSEGSIZE=wseginc   {minimum work segment size}
        %ownhalfinteger unsatrefs=0
{PERQ   %ownhalfinteger WSEGMAX=wseginc    {Maximum work segment size}
        %OWNINTEGER     WORKAD
        %OWNINTEGER     LMAX=54
        %OWNINTEGER     TBASE, TON, TMAX,WPTR
       %ownhalfinteger dontcare=x'01ff'  {switch off param checking}
        %OWNINTEGER     FBASE
        %OWNHALFINTEGER NUMIMPS=0
        %OWNHALFINTEGER MAXRT=0
{PERQ   %OWNHALFINTEGER NUMWORKBLOCKS=0
{PERQ   %OWNHALFINTEGER NUMOBJBLOCKS=0      { Number of blocks in object file}
{PERQ   %ownhalfinteger Numdiagblocks=0     { Number of blocks in diags}
        %ownhalfinteger Diaglength=0        { Byte length of diagnostics}
        %owninteger     Dbase=0             { Address of Diagnostic work file}
        %ownstring(6)   rels="2.0"
        %OWNSTRING(110) ROOT
        %OWNHALFINTEGER TRACE=0,WORKID=0,OBJID=0
        %OWNHALFINTEGER TYPE19NUM=0,TYPE20NUM=0
        %OWNHALFINTEGER LANGUAGE
        %OWNINTEGER     LA
        %ownhalfinteger     Lasttype=0
        %OWNINTEGER     NULLFLAG=0
!        %OWNINTEGER     DECODEHEAD=0,DECODETAIL=0
        %OWNHALFINTEGER MAINEP=0
        %OWNSTRING (110) FILE
        %OWNINTEGERARRAY     HEAD(5 : 25)=0(*)
        %OWNINTEGERARRAY     AREALENGTH(1 : MAXAREAS)
        %OWNINTEGERARRAY     AREASTART(1 : MAXAREAS)
{PERQ   %OWNHALFINTEGERARRAY BUF(0:255)
        %OWNHALFINTEGERARRAY AREAPROP(1 : MAXAREAS)
        %OWNHALFINTEGERARRAY MODUSED(0:MODCOUNT)=-1(*)
        %ownbyteintegerarray rtused(0:rcount)=0(*)

!-----------------------------------
!          LOCALS
!----------------------------------

        %INTEGER LI,J,K,L,FLAG
{EMAS}  %INTEGER     I,list
{PERQ   %HALFINTEGER I,list
{perq   %halfinteger wblock
        %INTEGER     OBJLEN,AD
        %HALFINTEGER M,INC
        %string(110) rest
        %STRING(32)  XREF
        %INTEGER     LDSTART, LDDISP,CODEBASE
        %SWITCH      EP(0 : 40+MAXAREAS)
        %SWITCH      LSW(0 : 40+MAXAREAS)
        %string(255) %name DESC
{emas}  %BYTEINTEGERARRAYFORMAT MAXBYTEFM(0:MAXFSIZE)
{EMAS}  %BYTEINTEGERARRAYNAME OBJECT



!----------------------------------------------------
!   ROUTINE TO FIX KNOWN SYSTEM XREFS
!-----------------------------------------------------

{EMAS}%ROUTINE FIX(%INTEGER RID,%INTEGER DISP)
{EMAS}
{EMAS}
{EMAS}   %CONSTINTEGER CALLXB = 234
{EMAS}   %CONSTINTEGER CALLXW = 235
{EMAS}   %constinteger LVRD   =  98
{EMAS}   %HALFINTEGER OPCODE
{EMAS}
{EMAS}         DISP=DISP+512
{EMAS}         OPCODE = OBJECT(DISP)
{EMAS}          %IF OPCODE = CALLXW  %or OPCODE = LVRD %START
{EMAS}              OBJECT(DISP+1)=MODUSED(MODINDEX(RID))
{EMAS}               OBJECT(DISP+2)=0
{EMAS}               OBJECT(DISP+3) = RNO(RID)
{EMAS}               %IF OBJECT(DISP+4)=1 %THEN OBJECT(DISP+4)=2
{EMAS}         %FINISH %ELSESTART
{EMAS}                %IF OPCODE = CALLXB   %START
{EMAS}                   OBJECT(DISP+1)=MODUSED(MODINDEX(RID))
{EMAS}                   OBJECT(DISP+2) = RNO(RID)
{EMAS}             %FINISHELSESTART
{EMAS}                 NEWLINE
{EMAS} PRINTSTRING(" Compiler Error: BAD XREF ".RNAMES(RID)." pointing at")
{EMAS}               WRITE(DISP-(512+redtapelen),1)
{EMAS}              NEWLINE
{EMAS}         %FINISH
{EMAS}      %FINISH
{EMAS}    %END


{PERQ %ROUTINE FIX(%INTEGER RID,%INTEGER DISP)
{PERQ
{PERQ
{PERQ    %CONSThalfINTEGER CALLXB = 234
{PERQ    %CONSThalfINTEGER CALLXW = 235
{PERQ    %consthalfinteger LVRD   =  98

{PERQ    %RECORDFORMAT CALLFM(%BYTEINTEGER SEG,OP,RT,SR)
{PERQ    %RECORD(CALLFM) CALL
{PERQ   %halfinteger BIT
{PERQ %integer AT
{PERQ
{PERQ          DISP=DISP+512
{PERQ     INC=DISP&1
{PERQ     AT = FBASE + (DISP>>1)
{PERQ      COPY(4,at,inc,ADDR(CALL),0)
{PERQ          %IF CALL_OP = CALLXW  %or CALL_OP = LVRD %START
{PERQ              CALL_SEG=MODUSED(MODINDEX(RID))
{PERQ               CALL_SR=0
{PERQ               CALL_RT = RNO(RID)
!                    check LexLev for IMP lvrd
{PERQ         %FINISH %ELSESTART
{PERQ                %IF CALL_OP = CALLXB   %START
{PERQ                   CALL_SEG=MODUSED(MODINDEX(RID))
{PERQ                   CALL_SR = RNO(RID)
{PERQ             %FINISHELSESTART
{PERQ                 PRINTSTRING("
{PERQ BAD XREF ".RNAMES(RID)." pointing at")
{PERQ               WRITE(DISP-(512+redtapelen),1)
{PERQ              NEWLINE
{PERQ             %RETURN
{PERQ         %FINISH
{PERQ      %FINISH
{PERQ       COPY(4,ADDR(CALL),0,at,inc)
{PERQ    %END

    %routine spxhalf(%halfinteger n)
      %constbyteintegerarray hx(0:15)='0','1','2','3','4','5','6','7','8',
                                      '9','A','B','C','D','E','F'
      %halfinteger i,j

      space
      %cycle i=12,-4,0
         printsymbol(hx((n>>i)&15))
      %repeat
   %end

    %ROUTINE SPHEX(%INTEGER N)
       SPACE
       PHEX(N)
    %END

{perq    %routine patchspace
{perq       *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0
{perq       *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0
{perq       *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0
{perq       *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0 ; *LDC0
{perq   %end


   %ROUTINE ROUND TO BLOCK BOUNDARY
{EMAS}  L = ((L + 479)&X'FFFFFE00')+EHEAD
{PERQ   L = (L +255)&X'FFFFFF00'
   %END

   %ROUTINE PLACE8(%STRING(255)   S, %INTEGER AD)
     %STRING(255) T

        T=S
        T=T." " %WHILE LENGTH(T)<8
{EMAS}  MOVE(8,ADDR(T)+1,AD)
{PERQ   COPY(8,ADDR(T),1,AD,0)
   %END

   %INTEGERFN WSQWRITE(%INTEGER N)
{EMAS}    %RESULT = N
{perq     %if memsize>=onemeg %then %result=n
{PERQ    %RESULT=ADDR(BUF(((TON-TBASE)&X'FF')))
   %END




  %ROUTINE CONVUPPER(%STRINGNAME S)
    %BYTEINTEGERARRAYFORMAT BF(0:255)
    %BYTEINTEGERARRAYNAME B
    %HALFINTEGER I

    B == ARRAY(ADDR(S),BF)
    I=1
    %WHILE I<=B(0) %CYCLE
        %IF 'a'<=B(I)<='z' %THEN B(I)=B(I)-32
        I=I+1
    %REPEAT
   %END



   %ROUTINE FAIL(%STRING(255) S)
        SELECTOUTPUT(0)
{EMAS}  COMREG(24)=1   ; ! CAUSE COMPILATION TO FAIL
{EMAS}  COMREG(47) = 0;                      ! Overwrite 'no of statements' left by compiler
        PRINTSTRING(S)
        %STOP
   %END


%routine cerr(%string(255)s)
     Fail("Compiler Error: ".s)
%end

%routine serr(%string(255) s)
   Fail("Compiler size Limit exceeded: ".s)
%end



  %routine Put stringP3 into(%string(*) %name s)
    %halfinteger i
    %byteintegerarray b(1:32)

{perq     copy(32,P3,0,addr(b(2)),0)
{emas}     s = string(P3)
{perq     %if b(1)<32 %and b(2)>32 %then s=string(P3) %elsestart
{perq        %cycle i=1,1,b(2)
{perq         b(i) = b(i+1)
{perq       %repeat
{perq       s = string(addr(b(2)))
{perq      %finish
    %end

   %routine checkobjsize(%integer i)
      serr("Object file full") %if i>=Fbase+(64*(1024>>sys))
   %end


   %ROUTINE CHECKWORK(%INTEGER N)
{PERQ  %HALFINTEGER I
{PERQ  %if (N>512 %and memsize<onemeg) %then cerr("Work record maxsize exceeded")
       %IF TON+(N>>SYS) > TMAX %THEN %START
{EMAS}    %IF WORKMAX > X'40000' %THEN %START
{EMAS}       INTEGER(TON) = (WORKAD+X'40000'-TON)!X'19000000'
{EMAS}               ! TYPE/SIZE OF FILLER RECORD
{EMAS}               !THIS MAKES A PSEUDO RECORD TYPE 25 TO  BE SKIPPED
{EMAS}       TMAX = WORKAD+WORKMAX-64
{EMAS}       TON = WORKAD+X'40000'
{EMAS}       WORKMAX = 0
{EMAS}    %FINISH %ELSE FAIL("Work file too small")
{perq     %if memsize>=onemeg %start
{perq        memsize=1024
{perq       halfinteger(ton)=2  {Marker of transition to work file}
{perq     %finishelsestart
{PERQ     HALFINTEGER(WSQWRITE(TON))=1
{PERQ     WRITEBLOCK(WORKID,NUMWORKBLOCKS,ADDR(BUF(0))) { HERE IS WHERE SEQ. WRITES IN FIRST PASS ARE DONE}
{PERQ    NUMWORKBLOCKS=NUMWORKBLOCKS+1
{PERQ     %FINISH
{perq     ton = ((ton>>8)+1)<<8
{PERQ     BUF(I)=0 %FOR I=0,1,255
{PERQ     TMAX = TON+250
{perq     lasttype=0
       %FINISH
   %END;                                      ! CHECKWORK

!****************
!*   START HERE *
!****************


{PERQ    MOVEBEE %UNLESS memsize>=onemeg

{TRACEING}  %IF TRACE#0 %START
{TRACEING}     NEWLINE
{TRACEING}     PRINTSTRING("QPUT(")
{TRACEING}     WRITE(TYPE,1)
{TRACEING}     SPHEX(P1)
{TRACEING}     SPHEX(P2)
{TRACEING}     SPHEX(P3)
{TRACEING}     PRINTSTRING(")")
{TRACEING}     %IF 41<=TYPE<=TYPE+MAXAREAS %START
{TRACEING}        SPHEX(INTEGER(P3))
{TRACEING}     %FINISH
{TRACEING}     %IF TYPE=11 %OR TYPE=12  %or type = 16  %or type=5  %or type=14 %or type=15 %THEN PRINTSTRING("  - ".STRING(P3))
{TRACEING}     %IF TYPE=7 %START
{TRACEING}        NEWLINE
{TRACEING}        I=0
{TRACEING}        SPHEX(INTEGER(P3+I))  %AND I=I+(4>>SYS) %WHILE P1>(I<<SYS)
{TRACEING}     %FINISH
{traceing}     %if type=5 %start
{traceing}        spxhalf(halfinteger(p1+i)) %for i=0,(2>>sys),(byteinteger(p1)+1)>>sys
{traceing}     %finish
{TRACEING}     %IF TYPE=11 %THEN %START
{TRACEING}        spxhalf(HALFINTEGER(P2+I)) %FOR I=0,(2>>SYS),(22>>SYS)
{TRACEING}        NEWLINE
{TRACEING}        J=INTEGER(P2+(20>>SYS))
{TRACEING}        %IF J#0 %START
{TRACEING}           SPXHALF(HALFINTEGER(J+I)) %FOR I=0,(2>>SYS),(BYTEINTEGER(J)+1)>>SYS
{TRACEING}       NEWLINE
{TRACEING}       %FINISH
{TRACEING}     %FINISH
{traceing}   newline
{TRACEING}  %FINISH

            %RETURN %UNLESS NULLFLAG=0
            %IF TYPE>100 %THEN ->AREAFRAG
{perq        lasttype=type
{perq      desc==rels { just for valid diagnostics}
            -> EP(TYPE)
!!

EP(*):    PRINTSTRING("
Unsupported LPUT entry ")
     WRITE(TYPE,1)
     NEWLINE
     %RETURN

!!


!--------------------------------------
!     INITIALISING CALLS ON QPUT
!--------------------------------------

EP(0):                    ;! SECOND CALL FROM COMPILER

!                            P1 = language {0=pas,1=for,2=imp}
!                            P2 = release number   (addr string if >100)
!                            P3 = version number

        LANGUAGE = P1
       %if P2>100 %then rels=string(P2)
{EMAS}  LANGUAGE=2 %IF LANGUAGE=0   {EMAS IMP SETS ZERO NOT 2}
{EMAS}  TRACE=COMREG(26)
{EMAS}  ROOT = SPAR(1)
{EMAS} CONVUPPER(ROOT)
{EMAS}  FILE <- STRING(COMREG(52))
{EMAS}  %IF FILE = ".NULL" %THEN %START
{EMAS}     NULLFLAG = 1
{EMAS}     %RETURN
{EMAS}  %FINISH
{EMAS}  WORKAD = COMREG(14)
{perq    workad=0
{perq   memsize=memorysize
{perq   %if memsize>=onemeg %then   newseg(addr(workad)+1,255,1,255)
        TBASE = WORKAD+EHEAD
{EMAS}  WORKMAX = INTEGER(WORKAD+8);            !SIZE OF WORK FILE
{EMAS}  TMAX = WORKMAX
{EMAS}  %IF TMAX > X'40000' %THEN TMAX = X'40000'
{EMAS}  TMAX = WORKAD+TMAX-64
{PERQ   TMAX = TBASE+250
{perq   %if memsize>=onemeg %then tmax=tbase+64000
        TON = TBASE
        %RETURN
!*
{PERQ EP(1):                  ;! FIRST CALL FROM COMPILER
{PERQ
{PERQ                         ;! P1 = FILE ID OF WORKFILE
{PERQ                         ;! P2 = TRACEING CONTROL
{PERQ                         ;! P3 =  ADDR OF SOURCE FILE STRING
{PERQ
{PERQ   FILE = STRING(P3)
{PERQ  CONVUPPER(FILE)
{perq   root = file
{perq   i=0  %while root -> rest.(">").root
{perq   %if root -> root.(".").rest %then i=0
{PERQ   WORKID = P1
{PERQ   TRACE = P2
{PERQ   Nullflag=(trace>>8)&1
{PERQ   trace = trace&255
{PERQ   %RETURN





!--------------------------------------------------
!       REMEMBER AREA FRAGMENTS
!--------------------------------------------------

EP(40):
EP(41):
EP(42):
EP(43):
EP(44):
EP(45):
EP(46):
        CHECKWORK(P1&X'FFFF'+16)
        R0 == RECORD(WSQWRITE(TON))
        R0_LA = P2
        I = (P1&X'FFFF'+19)&X'FFFFFFFC'
        R0_TYPE = TYPE
        R0_RECLEN=I
        R0_DATALEN = P1&X'FFFF'
        R0_FILLER = P1>>16;                    ! NO. OF COPIES
{emas}  MOVE(P1&X'FFFF',P3,TON+16)
{perq   ad = addr(buf((TON+8-tbase)&x'ff'))
{perq  %if memsize>=onemeg %then ad=ton+8
{perq   inc = ad&1  ; ad = ad&(-2)
{perq   copy(p1&x'ffff',p3,0,ad,inc)
        TON = TON+(I>>SYS)
        %RETURN


!-----------------------------------
!         ENTRY POINT DEFINITION
!-----------------------------------

!                        P1 = (mainep<<31)!(props<<16)!rtno
!                        P2 = Address of data area containing:
!                              8 word routine dictionary entry
!                              1 word byte disp. codestart to diag entry
!                              1 word spare
!                              2 word virtual address of routine parameter desc.
!                        P3 = Address of string containing routine name.


EP(11):
        %IF P1< 0 %THEN  MAINEP = 1;      ! EXISTENCE OF MAIN EP IF TOP BIT SET
        J = INTEGER(P2+(20>>SYS))   ;! GET ADDRESS OF DESCRIPTOR
        %IF J=0 %THEN INC=0 %ELSE INC=(BYTEINTEGER(J)+4)>>2<<2
        CHECKWORK(64+INC) ; ! ADD LENGTH OF ROUTINE PARAMETER DESCRIPTOR
        R11 == RECORD(WSQWRITE(TON))
        R11_NAME=STRING(P3)
{EMAS}  %IF R11_NAME ->("S#").R11_NAME %THEN I=0   ;! FORTRAN DOES NOT GENERATE S#
        I = (LENGTH(R11_NAME)+36)&X'FC'
        LMAX = LMAX + (I-24)
        R11_TYPE=11
        R11_RECLEN=(I+INC)>>1<<1
{EMAS}  R11_PROPS = P1>>16
{perq    K = addr(p1)
{PERQ   R11_PROPS = HALFINTEGER(k+1)
{EMAS}  R11_RTNO = P1&X'FFFF'
{PERQ   R11_RTNO = HALFINTEGER(ADDR(P1))
        %if r11_rtno>maxrt %then maxrt=r11_rtno
        R11_D <- RECORD(P2)
        R11_DIAGDISP = HALFINTEGER(P2+(16>>SYS))
         TON = TON + (I>>SYS)
        %IF J=0 %THEN R11_PLEN=0 %ELSESTART   ;! IGNORE IF ADDRESS IS ZERO
{EMAS}     MOVE(INC,J,ADDR(R11)+I)
{PERQ      COPY(INC,J,0,ADDR(R11)+(I>>1),0)
          R11_PLEN=I
        %FINISH
        TON = TON +(INC>>SYS)
        %RETURN


!----------------------------
!    SYSTEM REFERENCES
!----------------------------

!                      P1 = Address of parameter descriptor *new*
!                      P2 = Byte offset codestart to call instruction opcode.
!                      P3 = Address of string containing routine name.


EP(12):
        CHECKWORK(44)
         put stringp3 into(xref)
        %IF XREF -> ("S#").XREF %THEN I=0
        %CYCLE I=0,1,RCOUNT
           %IF XREF=RNAMES(I) %START
             R1 == record(wsqwrite(TON))
             R1_TYPE = 12
             R1_RECLEN = 16
             R1_N = P2     {remember offset of call instr}
             LMAX = LMAX + 16
             TON = TON + (16>>sys)
              R1_RID=I
              MODUSED(MODINDEX(R1_RID))=1
              RTUSED(i) = 1
              %RETURN
           %FINISH
        %REPEAT
        printstring("
Warning - Unknown system reference '".xref."'")
        NEWLINE
        {%RETURN - fall through for IMP}



!-------------------------------
!   USER EXTERNAL REFERENCE
!-------------------------------

!                        P1 = Address of Parameter descriptor
!                        P2 = Byte offset codestart to call instruction opcode.
!                        P3 = Address of string containing routine name
EP(5):
         UNSATREFS=UNSATREFS+1
        %if p1=0 %then p1=addr(dontcare)
         INC = (byteinteger(P1)+5)>>2<<2   {length of descriptor in bytes}
         %if type=5 %then xref=string(p3)  {%else set in ep(12) above}
         I = (length(XREF)+21)>>2<<2 {length of rest of R1 in bytes}
         CHECKWORK(I+INC)
         R1 == record(WSQWRITE(TON))
         R1_TYPE = 5
         R1_RECLEN=(I+INC)>>1<<1           {Total length of entry}
         LMAX = LMAX + R1_RECLEN
         R1_N = P2                         {Offset to call instr from codestart}
         R1_NAME = string(P3)
         R1_RID = I                         {Offset to descriptor within R1}
         TON = TON + (I>>sys)               {TON = start point for descriptor}
{PERQ    COPY(INC,P1,0,addr(R1)+(i>>1),0)
{EMAS}   MOVE(INC,P1,TON)
         TON = TON + (INC>>sys)
         %return



!-----------------------------------------------
!      IMP DATA ENTRIES and DATA REFERENCES
!-----------------------------------------------

!                           P1 = (area<<24) ! length in bytes (assume area=gla)
!                           P2 = disp within area in bytes
!                           P3 = addr(string) - name of data item

EP(14):
EP(15):
       r14 == record(wsqwrite(ton))
       r14_type=type
       r14_len = p1&x'FFFFFF'
       r14_disp = P2
       r14_name = string(P3)
       i = (length(string(P3))+16)&x'FC'
       r14_reclen = i
       ton = ton + (i>>sys)
       %return
       
       


!----------------------
!     AREA FRAGMENT
!----------------------

!                           P1 = (repition <<16 ) ! length in bytes
!                           P2 = displacement in BYTES
!                           P3 = ADDRESS of data

AREAFRAG:
        M = P1&X'FFFF'

        {Do Peephole optimisation of data statement initialisations to save space
{perq
{perq       %if lasttype=type %start                    {if previous record was to the same area}
{perq          {R9 still points at last record
{perq          {Look for repitition
{perq          %if r9_datalen=4 %and m=4 %and r9_la+(r9_filler*4)=p2 %and integer(p3)=integer(Addr(r9)+12) %start
{perq             r9_filler=r9_filler+1
{perq             %Return
{perq          %finish
{perq          { Look for adjacency
{perq          %if r9_datalen+r9_la=p2  %and r9_datalen&3=0  %and 0<=p1>>16<=1 %Start   {only doing 4byte values
{perq             checkwork(m)
{perq             %unless lasttype=0 %Start    {check there is room in the buffer
{perq                copy(m,p3,0,addr(r9)+12+(r9_datalen>>1),0)
{perq                r9_datalen=r9_datalen+m
{perq               r9_reclen=r9_reclen+m
{perq                lmax=lmax+m
{perq                ton=ton+(m>>1)
{perq                %return
{perq             %finish
{perq          %finish
{perq        %finish
        lasttype=type
        {fall through to normal processing

        CHECKWORK(M+24)
        R9 == RECORD(WSQWRITE(TON))
        R9_LA=P2
        I = (M+27)&X'FFFC'
        R9_TYPE=6
       R9_iin = TYPE
        R9_RECLEN=I
        R9_DATALEN=M
        R9_FILLER=P1>>16
{emas}  MOVE(M,P3,TON+24)
{perq   %IF MEMSIZE>=ONEMEG %THEN ad = wsqwrite(ton+12) %ELSE AD=ADDR(BUF((TON+12-TBASE)&255))
{PERQ   INC = AD&1  ; AD = AD&(-2)
{PERQ   COPY(M,P3,0,AD,INC)
        LMAX = LMAX + i
        TON = TON + (I>>SYS)
        %RETURN




!--------------------------------
!     COMMON DEFINITIONS
!--------------------------------

EP(16):
        CHECKWORK(52)
        R4 == RECORD(WSQWRITE(TON))
        R4_NAME=STRING(P3)
        LENGTH(R4_NAME)=8 %IF LENGTH(R4_NAME)>8     ;! COMMON NAMES TO HAVE ONLY 8 CH SIGNIFICANCE
        R4_L=P2
        R4_PROPS=P1&X'FFFF'
        R4_AREA = P1>>16
        I = (LENGTH(R4_NAME)+20)&X'FC'
        LMAX = LMAX+I
        R4_TYPE = 16
        R4_RECLEN = I
        TON = TON + (I>>SYS)
        %RETURN



{EMAS} !---------------------------------
{EMAS} !     REVERSE BYTES
{EMAS} !---------------------------------
{EMAS}
{EMAS}    EP(9):
{EMAS}
{EMAS}                                       !P1 = AREA ID
{EMAS}                                       !P2 = DISP
{EMAS}                                       !P3 = LENGTH ( IN BYTES)
{EMAS}
{EMAS}    CHECKWORK(20)
{EMAS}    R10 == RECORD(WSQWRITE(TON))
{EMAS}    R10_TYPE=9
{EMAS}    R10_RECLEN=20
{EMAS}    R10_AREA=P1
{EMAS}    R10_DISP=P2
{EMAS}    R10_LEN=P3
{EMAS}    TON=TON+(20>>SYS)
{EMAS}    %RETURN



!------------------------------------------------
!   MODIFY 16 BIT ADDRESS FIELD IN AN INSTRUCTION
!------------------------------------------------

EP(18):
                                              ! P2  @ IN CODE AREA
                                              ! P3  unsigned 16 BIT VALUE TO BE ADDED TO ADDRESS FIELD
   CHECKWORK(16)
   R8 == RECORD(WSQWRITE(TON))
   R8_TYPE = 18
   R8_RECLEN=16
   R8_CODEADDR = P2
   R8_ADDRFIELD = p3&X'FFFF'
   TON = TON+(16>>SYS)
   %RETURN
!*

!----------------------------------------
!          RELOCATION
!----------------------------------------

 EP(20):                                 ! 16 BIT RELOCS OF WORD AT P2 BYTES IN GLA BY GLA BASE
 EP(19):                                 ! 32 BIT RELOCATION OF WORD AT P2 IN GLA BY BASE OF AREA P3
!
   CHECKWORK(16)
   R7 == RECORD(WSQWRITE(TON))
   R7_TYPE=TYPE
   R7_RECLEN=16
   R7_AREALOC = P2>>1
   %IF TYPE=20 %THEN R7_BASE=2 %ELSEC
   R7_BASE=P3
   TON = TON+(16>>SYS)
   %IF TYPE=19 %THEN TYPE19NUM=TYPE19NUM+1
   %IF TYPE=20 %THEN TYPE20NUM=TYPE20NUM+1
   LMAX=LMAX+16
   %RETURN
!*

!---------------------------------------
! NOTE CODE SECTION FOR DECODE
!---------------------------------------

! EP(27):
! !* P1   >0  line no
! !* 2 = len<<18 ! start
! !*
!       CHECKWORK(12)
!       R27==RECORD(WSQWRITE(TON))
!       %IF DECODEHEAD=0 %THEN DECODEHEAD=TON %ELSE INTEGER(WSQWRITE(DECODETAIL)+(4>>SYS))=TON
!       DECODETAIL=TON
!       R27_TYPE=27
!       R27_RECLEN=16
!       R27_LINK=0
!       R27_LINE=P1
!       R27_INF=P2
!       TON=TON+(12>>SYS)
!       %RETURN
!*

!-----------------------------------------------------------
!      EP(7 OR 8)   END OF FIRST PASS
!------------------------------------------------------------
                     { ACCESS TO WORKFILE HAS BEEN SEQUENTIAL WRITES UP TO THIS POINT }


EP(7):

   %BEGIN
      %INTEGERARRAYFORMAT BASEFM(1:MAXAREAS)
      %INTEGERARRAYNAME BASE

      BASE == ARRAY(P3,BASEFM)
      HALFINTEGER(WSQWRITE(TON)) = 7
{PERQ TON = TON + 1
      CHECKWORK(512)    ;! FLUSH FINAL WORK BUFFER
{PERQ %IF MEMSIZE<ONE MEG %THEN CLOSE FILE(WORKID,NUMWORKBLOCKS,4096)   { NOT ESSENTIAL }
      J = (P1-4)//4 ; %IF J>MAXAREAS %THEN J=MAXAREAS
      AREALENGTH(I) = (BASE(I)+3)&X'FFFFFFFC' %FOR I=1,1,J
   %END

{PERQ  %RETURN      { EMAS FALLS THROUGH TO ENTRY(8)


EP(8):                                        ! END OF FILE
!                                   P1 = ADDR MODULE CHAIN
!                                   P2 = first free import seg number
!                                   P3 = ADDR OUTPUT FILE NAME

!
!        --- Create object file -----
!

{perq  string(p3)->rest.(".SEG")
{PERQ   %IF UNSATREFS#0 %START
{perq     destroyfile(string(p3))   ;! destroy existing .SEG to avoid ambiguity
{PERQ     STRING(P3) = REST.".PSG"
{PERQ   %FINISH  %else destroyfile(rest.".PSG")   { destroy existing .PSG if a .SEG is being produced}
{perq   objid=createfile(p3)
{perq   fail("Compilation fails: Cannot create object file") %if objid=0
{EMAS}  %IF NULLFLAG < 0 %THEN SSERR(228);      !PROGRAM TOO LARGE
!
!         --- Create Object Segment ---
!
        OBJLEN = LMAX+16 + 6000
        OBJLEN = OBJLEN+AREALENGTH(I) %FOR I=1,1,MAXAREAS
{EMAS}  OUTFILE(FILE,OBJLEN,0,0,FBASE,FLAG)
{EMAS}  %IF FLAG#0 %THEN %start
{emas}    SETFNAME(FILE)
{emas}    Fail("Create object file fails - ".FAILUREMESSAGE(FLAG))
{emas}  %finish
{PERQ   NUMOBJBLOCKS = (OBJLEN+511)>>9
{PERQ   %if numobjblocks>256 %then numobjblocks=256
{PERQ   NEWSEG(ADDR(FBASE)+1,NUMOBJBLOCKS,1,NUMOBJBLOCKS)
!
!         --- Create Diagnostic Segment ---
!
        Diaglength=arealength(6)
        arealength(6)=0
{perq   Numdiagblocks=(diaglength+511)>>9
        %unless diaglength=0 %start
{emas}    Outfile("t#qdiag",diaglength,0,0,Dbase,flag)
{emas}    %if flag#0 %then Fail("Create work file fails - ".failuremessage(flag))
{perq     Newseg(addr(Dbase)+1,numdiagblocks,1,numdiagblocks)
        %finish
        
!
!        --- Zero object file ----    (Possible remove later)
!

{PERQ   HALFINTEGER(J)=0 %FOR J=FBASE,1,FBASE+(NUMOBJBLOCKS*256)-1

!
!       ---  Work out relative area starts ---
!

        CODEBASE = ((HDRLEN+REDTAPELEN)>>SYS)+FBASE
        AREASTART(1) = HDRLEN+REDTAPELEN;            ! 32 FOR EMAS}HEADER PLUS 256 WORDS FOR PERQ HEADER + ? FOR RED TAPE
        AREASTART(4) = AREASTART(1)+AREALENGTH(1);   ! CST AFTER CODE
        AREASTART(3) = AREASTART(4)+AREALENGTH(4)
        AREASTART(2) = AREASTART(3)+AREALENGTH(3);   ! GLA AFTER SST
        AREASTART(5) = AREASTART(2)+AREALENGTH(2);   ! GLAST AFTER GLA
        AREASTART(6) = AREASTART(5)+AREALENGTH(5)
        LDSTART      = (AREASTART(6)+ 3)&X'FFFFFFFC'
        
        
        checkobjsize(ldstart)
{EMAS}  OBJECT  == ARRAY(FBASE + EHEAD,MAXBYTEFM)
        LDSTART =  (LDSTART>>SYS) + FBASE
        LDATA   == ARRAY(LDSTART,LDATAFM)
        
!
!      ---  Fill in Emas file header  ---
!

{EMAS}  INTEGER(FBASE+4) = EHEAD;                  ! START OF CODE
{EMAS}  INTEGER(FBASE+12) = 1;                     ! OBJECT FILE CODE
{EMAS}  INTEGER(FBASE+24) = LDSTART-FBASE;         ! START OF LDATA


        LDATA(I) = 0 %FOR I=1,1,10
        TON = TBASE
{EMAS}  LDDISP = 60
{PERQ   LDDISP = 11


!      ---   CREATE WORK SEGMENT  ---

{PERQ   TBASE = 0
{perq   wsegmax=256    {enforce 128k segment size limit}
{PERQ   NEWSEG(addr(tbase)+1,WSEGSIZE,WSEGINC,WSEGMAX)
{PERQ   wptr = TBASE



  ! ASSIGN SEGMENT NUMBERS TO IMPORTED MODULES

        { 1 is always assigned to F77INIT}
        { 2 to n may be claimed by EXTHELP }
        { n onwards are used for the remainder of the system references}

      MODUSED(0)=1   ;! F77INIT
{perq     NUMIMPS=P2
{emas}    numimps=1
     %CYCLE I=1,1,MODCOUNT

{EMAS}  %IF MODUSED(I)#X'FFFF' %START
{PERQ   %IF MODUSED(I)>=0 %START
           MODUSED(I)=NUMIMPS+1
           NUMIMPS=NUMIMPS+1
        %FINISH
     %REPEAT



!-----------------------------------------------------
! The next section reads back through the work file
!-----------------------------------------------------


! Ton is the pointer to the work file which contains area frags and red tape
! {PERQ Wptr is a pointer to the work segment containing only red tape.


{perq    memsize=memorysize
{perq   wblock = -1
{perq   ->LSW(1)
{emas}  -> LSWITCH


LSW(40):         {Area Fragments}
LSW(41):
LSW(42):
LSW(43):
LSW(44):
LSW(45):
LSW(46):

     R0 == RECORD(TON)
     J = R0_FILLER;                             ! NO. OF COPIES
     L = R0_DATALEN
     LA = R0_LA
     %if i=46  %then k=r0_la %else K =  AREASTART(I-40)+R0_LA    ;! TARGET DISP
     %WHILE J >= 0 %CYCLE
{EMAS}  %if i=46 %then move(L,TON+16,DBase+K) %else MOVE(L,TON+16,FBASE+K)
{PERQ   %if i=46 %then copy(L,TON+8,0,Dbase+(k>>1),k&1) %elsestart
{Perq   COPY(L,TON+8,0,FBASE +(K>>1),K&1)
{Perq  %finish
        K = K+L
        J = J-1
     %REPEAT
     -> NEXT


LSW(*):  newline
{PERQ         printstring("Block = ")
{PERQ         write(wblock,1)
       cerr("CORRUPT WORKFILE ")


{perq   LSW(2):     ;! end of data segment - rest in work file
{perq           memsize=1024
                { Fall through to LSW(1) }

{PERQ   LSW(1):     ;! END OF BLOCK
{perq         %if memsize>=onemeg %then ton=workad %elsestart
{perq          TON = Addr(BUF(0))
{PERQ          WBLOCK=WBLOCK+1
{perq          READBLOCK(workid,wblock,TON)
{perq        %finish
{PERQ           ->LSWITCH


{PERQ
LSW(11):
{perq     MOVEBEE
LSW(5):        { Take Red tape here}
LSW(6):
LSW(12):
LSW(18):
LSW(14):
LSW(15):
LSW(9):
LSW(19):
LSW(20):
LSW(16):
        r1 == record(TON)
        r1_link = HEAD(i)
{perq   head(i) = wptr
{emas}  HEAD(i) = TON
{PERQ   %if WPTR+(R1_RECLEN>>sys)>TBASE+(WSEGSIZE*(512>>SYS)) %start ;! need to extend work segment
{PERQ      %if WSEGSIZE=WSEGMAX %then serr("Work segment full")
{PERq     WSEGSIZE = WSEGSIZE + WSEGINC
{perq     K = addr(tbase)
{PERQ      EXTENDSEG(halfinteger(k+1),WSEGSIZE)
{PERQ   %finish

{perq   COPY(r1_reclen,TON,0,WPTR,0)
        TON = TON + (r1_reclen>>sys)
{perq   WPTR = WPTR + (r1_reclen>>1)
        ->lswitch

NEXT:

        TON = TON + (HALFINTEGER(TON+(2>>SYS))>>SYS)
LSWITCH:

        I = HALFINTEGER(TON)
        -> LSW(I)

LSW(7):

{EMAS}  CHANGECONTEXT;    !FINISHED WITH COMPILER - LOSE FROM WORKING SET
        -> NEXT %UNLESS HALFINTEGER(TON) = 7

        L = LDSTART+LDDISP;                        ! SPACE FOR LISTHEADS+OBJDATA
        checkobjsize(L)

!-----------------------------------------------
!         FORM LIST 1 - PROCEDURE ENTRIES
!-----------------------------------------------

    J = HEAD(11)
    %WHILE J # 0 %CYCLE
       R11 == RECORD(J)
      checkobjsize(L+256)
       L1 == RECORD(L)
       L1_LINK = LDATA(1)
       LDATA(1) = (L-LDSTART)>>NOTSYS
       L1_PROPS = R11_PROPS
       L1_RTNO = R11_RTNO
       L1_DIAGDISP = R11_DIAGDISP
       L1_NAME = R11_NAME
{EMAS} REVERSE(ADDR(L1_NAME),(LENGTH(L1_NAME)+2)>>1)
       INC =(10+LENGTH(R11_NAME))&X'FFFFFFFE'
       L = L + (INC>>SYS)
       J = R11_LINK
    %REPEAT


!---------------------------------------
!   FORM LIST 2 - system REFERENCES
!---------------------------------------

      J = HEAD(12)
      %WHILE J # 0 %CYCLE
        checkobjsize(L)
         L2 == RECORD(L)
         R1 == RECORD(J)
         %if rtused(r1_rid)#0 %start
            L2_LINK=LDATA(2)
            LDATA(2)=(L-LDSTART)>>NOTSYS
            L2_rt =rno(r1_rid)
            L2_NAME = RNAMES(R1_RID)
            INC = (6+LENGTH(L2_NAME))&X'FFFFFFFE'
            L = L + (INC>>SYS)
{EMAS}      REVERSE(ADDR(L2_NAME),(LENGTH(L2_NAME)+2)>>1)
            rtused(r1_rid)=0
         %finish
         FIX(R1_RID,REDTAPELEN+R1_N)     ;! RELOCATE CALLS ON XREFS
       J = R1_LINK
      %REPEAT
!*



!-----------------------------------------------------------
!     Form List 4 & 5 - IMP Data entries and references 
!-----------------------------------------------------------


      %cycle list=14,1,15   {Handling TWO lists here}
        j = head(list)
        %while j#0 %cycle
          r14 == record(j)
          checkobjsize(L+256)
          l4 == record(L)
         l4_link=ldata(list-10)
         ldata(list-10)=(l-ldstart)>>notsys
          l4_disp = r14_disp>>1   {words}
          l4_len  = r14_len>>1   {words}
          l4_name = r14_name
{emas}     reverse(addr(l4_name),(length(l4_name)+2)>>1)
          inc = (8 + length(l4_name))&x'FFFFFFFE'
          L = L + (inc>>sys)
          j = r14_link
        %repeat
      %repeat
      
      


!----------------------------------------
!     MODIFY ADDRESSES IN CODE
!-----------------------------------------

     J = HEAD(18)
     %WHILE J # 0 %CYCLE
        R8 == RECORD(J)
        K=R8_CODEADDR
        j = areastart(1)+k
        LI=FBASE+(j>>SYS)
{EMAS}  HALFINTEGER(LI)=HALFINTEGER(LI)+R8_ADDRFIELD
{PERQ   COPY(2,LI,j&1,ADDR(M),0)
{PERQ   M = M + R8_ADDRFIELD
{PERQ   COPY(2,ADDR(M),0,LI,j&1)
        J = R8_LINK
     %REPEAT

     { FINISHED CONSTRUCTION OF AREAS NOW ON PERQ}


!-------------------------------------
!     PRODUCE DECODE LISTING
!-------------------------------------

!       %WHILE DECODEHEAD#0 %CYCLE
!          R27==RECORD(DECODEHEAD)
!          I=R27_LINE
!          J=R27_INF>>18;! length
!          K=(R27_INF<<14)>>14;! address
!          PRINTSTRING("
! LINE ")
!          WRITE(I,1)
!          NEWLINE
!          QCODE(FBASE+EHEAD+K,FBASE+EHEAD+K+J,K,X'F0000000')
!          DECODEHEAD=R27_LINK
!       %REPEAT

!--------------------------------------------
!      FORM LIST 6 - COMMON DEFINITIONS
!--------------------------------------------

{PERQ       MOVEBEE
     J=HEAD(16)
     %WHILE J#0 %CYCLE
        R4==RECORD(J)
       checkobjsize(L+256)
        L6==RECORD(L)
        L6_LINK = LDATA(6)
        LDATA(6)=(L-LDSTART)>>NOTSYS
        L6_AREA NO =R4_AREA
        L6_PROPS=R4_PROPS
{EMAS}  L6_LENGTH=((R4_L&X'FFFF')<<16)!(R4_L>>16)
{PERQ   L6_LENGTH=R4_L
        L6_NAME = R4_NAME
{EMAS}  REVERSE(ADDR(l6_NAME),(LENGTH(l6_NAME)+2)>>1)
        INC = ( 12 + LENGTH(R4_NAME) ) &X'FFFFFFFE'
        L = L + (INC>>SYS)
        J = R4_LINK
     %REPEAT

{EMAS} !---------------------------------------------
{EMAS} !       REVERSE BYTES SPECIFICALLY REQUESTED
{EMAS} !----------------------------------------------
{EMAS}
{EMAS} J = HEAD(9)
{EMAS} %WHILE J # 0 %CYCLE
{EMAS}    R10 == RECORD(J)
{EMAS}    LI = FBASE+AREASTART(R10_AREA)+R10_DISP
{emas}   %if r10_area=6 %then li=Dbase+ r10_disp
{EMAS}    REVERSE(LI,(R10_LEN+1)>>1)
{EMAS}    J = R10_LINK
{EMAS} %REPEAT

!*


!-------------------------------------------
!   FORM LIST 7 - AREA FRAGMENTS
!-------------------------------------------

         J=HEAD(6)
         %WHILE J#0 %CYCLE
            R9 == RECORD(J)
            checkobjsize(l+256)
            L7 == RECORD(L)
            L7_LINK=LDATA(7)
            LDATA(7)=(L-LDSTART)>>NOTSYS
            L7_AREA=r9_iin-100
{emas}      L7_disp = (R9_la>>16)!((r9_la&x'ffff')<<16)
{PERQ       L7_DISP=R9_LA
            L7_COPIES=R9_FILLER
            L7_copies=1 %if L7_copies=0
            L7_LEN=R9_DATALEN
{EMAS}      MOVE(R9_DATALEN,J+24,L+12)
{PERQ       COPY(R9_DATALEN,J,24,L,12)
            L = L + ((12+R9_DATALEN+1)>>1<<NOTSYS)
            J = R9_LINK
         %REPEAT




!-----------------------------------------
!   LIST 9 - 32 BIT RELOCATIONS
!-----------------------------------------

{PERQ  MOVEBEE
J = HEAD(19)
%IF J#0 %START
   LDATA(9) = (L-LDSTART)>>NOTSYS
   checkobjsize(l+256)
   L9 == RECORD(L)
   L9_LINK = 0
   L9_NUM = TYPE19NUM

   %CYCLE I=1,1,TYPE19NUM
      R7 == RECORD(J)
      L9_FIX(I)_DISP = R7_AREALOC
      L9_FIX(I)_AREA = R7_BASE
      J = R7_LINK
   %REPEAT
   L = L + ((4 + (TYPE19NUM*4))>>SYS)
%FINISH

!-------------------------------------------
!   LIST 8 - 16 BIT RELOCATIONS
!-------------------------------------------

J = HEAD(20)
%IF J # 0 %START
   LDATA(8) = (L-LDSTART)>>NOTSYS
    checkobjsize(L+256)
   L8 == RECORD(L)
   L8_LINK = 0
   L8_NUM = TYPE20NUM
   %CYCLE I=1,1,TYPE20NUM
      R7 == RECORD(J)
      L8_DISP(I)=R7_AREALOC
      J = R7_LINK
   %REPEAT
   L = L + ((4 + (TYPE20NUM*2))>>SYS)
%FINISH


!-------------------------------------
!   LIST 10 - POINTER TO ROOT FILENAME
!---------------------------------------

{EMAS}  L=(L+1)&X'FFFFFFFE'
        LDATA(10) = (L-LDSTART)>>NOTSYS
{PERQ   COPY(LENGTH(ROOT)+1,ADDR(ROOT),0,L,0)
{EMAS}  STRING(L) = root
{EMAS}  REVERSE(L,(LENGTH(ROOT)+2)>>1)
{PERQ   INC = (LENGTH(ROOT)+2)&X'FFFFFFFE'
{EMAS}  INC = ( LENGTH(ROOT)+3)&X'FFFFFFFC'
        L = L + (INC>>SYS)


!*
!--------------------------------------------------------
! FORM AREA SUMMARY ( OBJECT FILE MAP )
!---------------------------------------------------------


{EMAS}   L = (L+3)&(-4)
{EMAS}   INTEGER(FBASE+28) = L-FBASE
         AMAP == ARRAY(L,AMAPFM)
         %CYCLE M = 1,1,MAXAREAS
            AMAP(M)_START = (AREASTART(M)-HDRLEN)>>1
            AMAP(M)_PROPS = AREAPROP(M)
           %IF M=6 %THEN J=DIAGLENGTH %ELSE J=AREALENGTH(M)
           J=J>>1
{EMAS}      AMAP(M)_LEN = ((J&X'FFFF')<<16)!(J>>16)
{PERQ       AMAP(M)_LEN = J
            L = L+(8>>SYS)
         %REPEAT


!-------------------------------------------------------
!    FILL IN ROUTINE DICTIONARY
!----------------------------------------------------

        J = HEAD(11)
{EMAS}  L = (L+7)&X'FFFFFFF8'    { ROUND TO QUAD WORD BOUNDARY }
{PERQ   L = (L+3)&X'FFFFFFFC'
        DICTIONARY == ARRAY(L,DICTAFM)

        %WHILE J#0 %CYCLE
           R11 == RECORD(J)
           DICT == DICTIONARY(R11_RTNO)
           DICT = R11_D
           DICT_LL = DICT_LL+1
           DICT_ENTRY = DICT_ENTRY + REDTAPELEN
           DICT_EXIT = DICT_EXIT + REDTAPELEN
           J = R11_LINK
        %REPEAT
        L = L + ((16>>SYS)*(maxrt+1))

        checkobjsize(L)

!
!------------------------------------------
!    FILL IN CODESTART
!----------------------------------------
!

      AD = CODEBASE-(REDTAPELEN>>SYS)
      CH == RECORD(AD)
      I = (ADDR(DICTIONARY(0))-AD)
      CH_DICT = I>>NOTSYS
!    %if mainep#0 %then ch_rts=maxrt+1 %elsec
!     ch_rts=maxrt
    CH_RTS=MAXRT+1
      CH_LDATA = (LDSTART-AD)>>NOTSYS
      CH_MAP = (ADDR(AMAP(1))-AD)>>NOTSYS
      LDATA(0)=10
!-----------------------------------------------

{EMAS} REVERSE(AREASTART(1)+FBASE+8,((AREALENGTH(1)-8)>>1))   ;! RE-ORDER WORK SEGMENT BYTES



!---------------------------------------------------------------------------
!         FILL IN PERQ HEADER
!--------------------------------------------------------------------------

         ROUND TO BLOCK BOUNDARY

         H == RECORD(FBASE+EHEAD)
         H_FLAGS=MAINEP      ;! 1 IF PROGRAM , 0 IF MODULE
         H_QVERSION = 3
!{EMAS}  REVERSE(ADDR(H_FLAGS),1)

{EMAS}   PLACE8(FILE,ADDR(H_MODULE(0)))    ;! TAKE FIRST EIGHT CHARS OF OBJECT FILE NAME
!{PERQ   PLACE8("FRED    ",FBASE+1)
{PERQ    PLACE8(ROOT,FBASE+1)
!                                          AS PERQ MODULE NAME
{EMAS}   H_SOURCEFILE="EMAS:".UINFS(1).">".ROOT
{EMAS}  %IF COMREG(27)&X'00010000'#0 %THEN H_SOURCEFILE=H_SOURCEFILE.".OPT"
{PERQ    H_SOURCEFILE=FILE
{EMAS}   REVERSE(ADDR(H)+(2>>SYS),54)
         H_NUMIMPS = NUMIMPS
         H_IMPBLOCK = ((L-FBASE)>>(9-SYS))    ;! BLOCK NUMBER OF IMPORT BLOCK
         H_GDSIZE = (AREALENGTH(2)+AREALENGTH(5)+1)//2
        %if language=1 %then h_version="Fortran77 compiler - Release " %elsec
         h_version = "Imp compiler - Release "
         h_version = h_version.rels  {should get itos in here and use ep(0 P2,P3}
{EMAS}        H_copyright="COPYRIGHT - University of Edinburgh"
{perq   H_copyright=""
         H_COPYRIGHT=H_COPYRIGHT." " %WHILE LENGTH(H_COPYRIGHT)<80  ;! TEMP
{EMAS}   REVERSE(ADDR(H_VERSION),80)
         H_LANGUAGE=language



!-----------------------------
!   FILL IN IMPORT TABLE
!-----------------------------

  %BEGIN
     %INTEGER J,AD
     %STRING(8) S
     %STRING(100) PATH
     %INTEGERARRAY E(0:255)
{PERQ  %recordformat XMODFM(%string(100) Path,%string(14) Modname,%integer Link)
{PERQ  %record(XMODFM) %name XMOD

     AD = L

!   F77INIT is always the seg 1 import.

     Path = "F77INIT"
     Place8(Path,L)
     Path = "F77INIT.PAS"
{EMAS}  Move(length(Path)+1,addr(Path),L+8)
{pERQ  Copy(length(Path)+1,addr(Path),0,L+4,0)
     L = L + (110>>sys)


!    Then User imports required by /EXTERNAL

{perq   J = P1
{perq   %while J#0  %cycle
{perq      xmod == record(J)
{perq      place8(XMOD_Modname,L)
{perq      copy(length(XMOD_Path)+1,addr(XMOD_Path),0,L+4,0)
{perq      L = L + (110>>sys)
{perq      J = xmod_Link
{perq   %repeat

!     Finally any other system imports

%CYCLE I=1,1,MODCOUNT
{EMAS}  %CONTINUE %IF MODUSED(I)=X'FFFF'
{PERQ   %CONTINUE %IF MODUSED(I)<0
        PATH = MODULES(I)
        PLACE8(PATH,L)
        PATH = PATH.".PAS"
{EMAS}  MOVE(LENGTH(PATH)+1,ADDR(PATH),L+8)
{PERQ   COPY(LENGTH(PATH)+1,ADDR(PATH),0,L+4,0)
        L = L+(110>>SYS)
     %REPEAT



!------------------------------------
!      FILL IN ROUTINE NAME TABLE
!------------------------------------
              { IMMEDIATELY AFTER IMPORT TABLE IN SAME BLOCK}

       J = HEAD(11)
       %WHILE J#0 %CYCLE
          R11 == RECORD(J)
          PLACE8(R11_NAME,L + (R11_RTNO*(8>>SYS)))
          J = R11_LINK
       %REPEAT
       S = "F_NULL  "
       %IF MAINEP=0 %THEN PLACE8(S,L)
       L = L + ((maxrt+1)*(8>>SYS))



{EMAS} REVERSE(AD,(L-AD)>>1)    ;! RE-ORDER IMPORT BLOCK BYTES




!------------------------------------------
!         DIAGNOSTIC BLOCKS
!------------------------------------------

       %if diaglength=0 %then h_diagblock=0 %elsestart
         Round to block boundary
         H_DIAGBLOCK = (L-fbase)>>(9-sys)
{emas}   Move(diaglength,Dbase,L)
{perq    Copy(diaglength,Dbase,0,L,0)
         L = L + (Diaglength>>sys)
       %finish




!------------------------------------------
!         CREATE ROUTINE DESCRIPTOR BLOCKS
!------------------------------------------

{PERQ    MOVEBEE
   E(I)=0 %FOR I=0,1,255

   J=HEAD(11)
   %WHILE J#0 %CYCLE
      R11==RECORD(J)
      E(R11_RTNO)=ADDR(R11)
      J=R11_LINK
   %REPEAT


   %IF LANGUAGE = FORTRAN %START
   ROUND TO BLOCK BOUNDARY
      H_ROUTDESCBLOCK = (L-FBASE)>>(9-SYS)
      HALFINTEGER(L) = 1  ;! FIRST ENTRY FOR RT0 IS FIXED
      L=L+(2>>SYS)

   I=1
   %WHILE I<=MAXRT %CYCLE
      %IF E(I)=0 %THEN cerr("Non-contiguopus rts.")
      R11==RECORD(E(I))
      %UNLESS R11_RTNO=0 %START  ;! IGNORE RT0 RECORD
         %IF R11_PLEN#0 %START
           DESC == string(E(I) + (R11_PLEN>>sys))
{PERQ       COPY(LENGTH(DESC)+1,ADDR(DESC),0,L,0)
{EMAS}      MOVE(length(DESC)+1,addr(DESC),L)
{EMAS}      REVERSE(L,(LENGTH(DESC)+2)//2)
            L=L+(((LENGTH(DESC)+2)//2)*(2>>SYS))
         %FINISH
     %FINISH
   I=I+1
   %REPEAT
   %FINISH
%END



!-------------------------------------------
!        CREATE UNRESOLVED REFERENCE BLOCKS
!-------------------------------------------
               { ALSO KNOWN AS PRE-LINK BLOCKS }

   J = head(5)
   %IF J > 0 %START
      ROUND TO BLOCK BOUNDARY
      H_PRELINKBLOCK = (L-FBASE)>>(9-SYS)
      HALFINTEGER(L) = UNSATREFS ; L = L + (2>>SYS)  { FILL IN NUMBER OF REFS }


      %WHILE J#0 %CYCLE
         R1 == RECORD(J)
         PLB == RECORD(L)
         PLB_BLOCK = ((R1_N+REDTAPELEN)>>9)+1
         LI = PLB_BLOCK
         PLB_BYTE OFFSET = (R1_N+REDTAPELEN)-((LI-1)*512)
         PLACE8(R1_NAME,ADDR(PLB_NAME(0)))
{EMAS}   REVERSE(ADDR(PLB_NAME(0)),4)
         ! SET RT DEC
         DESC == string(J+(R1_RID>>sys))
{EMAS}   MOVE(LENGTH(DESC)+1,ADDR(DESC),ADDR(PLB_ROUTDESC(0)))
{PERQ    COPY(LENGTH(DESC)+1,ADDR(DESC),0,ADDR(PLB_ROUTDESC(0)),0)
{EMAS}   REVERSE(ADDR(PLB_ROUTDESC(0)),(LENGTH(DESC)+2)>>1)
         L = L + (((12+(LENGTH(DESC)+2))>>1)*(2>>SYS))
         J = R1_LINK
      %REPEAT
   %FINISHELSE H_PRELINKBLOCK=0

     { WRITE OUT OBJECT FILE }

{PERQ   LI = FBASE
{PERQ   NUMOBJBLOCKS = (L-FBASE+((512>>SYS)-1))>>(9-SYS)

{PERQ   WRITEBLOCK(OBJID,M,LI)  %AND LI=LI+256 %FOR M=0,1,NUMOBJBLOCKS-1

{PERQ   CLOSEFILE(OBJID,NUMOBJBLOCKS,4096)
{EMAS}  INTEGER(FBASE) = L-FBASE   { FILL IN FILE LENGTH}
 %return %unless language=fortran
   selectoutput(0)
   printstring(" Compilation Successful

")

%END   ;! OF QPUT
!*
%endoffile