! 01 Mar 1986
!
! UTX/32 (Gould V6/V9) Put Interface
! Based on UNIX vsn 4.2 BSD
! Mike Brown, MCMLXXXVI
!
! Tracing control 
! Trace all significant calls on interface if: 
! comreg(26) & 1 # 0 or 
! as directed by calls on procs. Pmonon/Pmonoff 
! Seldom required info controlled by bits of comreg(26) as follows: 
! 4  -  switch on sdb 
! 16 -  File use monitoring 
! 128 - Requests for more space by Malloc, Expand Area etc. 
!
%CONSTINTEGER EMAS = 2900
%CONSTINTEGER EMASA = 370
%CONSTINTEGER HOST = EMASA
!
%IF HOST = EMAS %THEN %START
   %SYSTEMROUTINESPEC PHEX (%INTEGER VALUE)
   %SYSTEMROUTINESPEC MOVE (%INTEGER LEN, FROM, TO)
   %SYSTEMROUTINESPEC FILL (%INTEGER LEN, ADR, FILLER)
   %SYSTEMSTRINGFNSPEC ITOS (%INTEGER VALUE)
   %SYSTEMSTRINGFNSPEC HTOS (%INTEGER VALUE, PLACES)
   %SYSTEMINTEGERMAPSPEC COMREG (%INTEGER INDEX)
%FINISH
%IF HOST = EMASA %THEN %START
   %EXTERNALROUTINESPEC PHEX %ALIAS "S#PHEX" (%INTEGER VALUE)
   %EXTERNALROUTINESPEC MOVE %ALIAS "S#MOVE" (%INTEGER LEN, FROM, TO)
   %EXTERNALROUTINESPEC FILL %ALIAS "S#FILL" (%INTEGER LEN, ADR, FILLER)
   %EXTERNALSTRINGFNSPEC ITOS %ALIAS "S#ITOS" (%INTEGER VALUE)
   %EXTERNALSTRINGFNSPEC HTOS %ALIAS "S#HTOS" (%INTEGER VALUE, PLACES)
   %EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREGMAP" (%INTEGER VALUE)
%FINISH
%EXTERNALROUTINESPEC FREE (%INTEGER ADR)
%EXTERNALROUTINESPEC CSTRING (%STRINGNAME IMPSTRING, %INTEGER AD CSTRING)
%EXTERNALROUTINESPEC PHEXBYTE (%INTEGER VALUE)
%EXTERNALROUTINESPEC EMASCLOSE
%EXTERNALROUTINESPEC FILEWRITE (%INTEGER OBJID, ADR, LEN)
%EXTERNALROUTINESPEC FREE SOURCE AREAS
%EXTERNALINTEGERFNSPEC CREAT (%INTEGER AD, MODE)
%EXTERNALINTEGERFNSPEC LSEEK (%INTEGER OBJID, OFFSET, WHENCE)
%EXTERNALINTEGERFNSPEC MALLOC (%INTEGER SIZE)
%EXTERNALINTEGERFNSPEC REALLOC (%INTEGER OLDPTR, SIZE) 
!
%CONSTINTEGER EXT = 1
%CONSTINTEGER ABS = 2
%CONSTINTEGER TEXT = 4
%CONSTINTEGER DATA = 6
%CONSTINTEGER BSS = 8
%CONSTINTEGER FARTEXT = 10
%CONSTINTEGER SDB = 0
%CONSTINTEGER TRUSTED = 0
%CONSTINTEGER DEFAULT AREA SIZE = (4 * 1024) - 8  ;! 8 for malloc control words 
%CONSTINTEGER ENDOFLIST = 0
%CONSTINTEGER SYMSIZE = 32  ;! Max bytes in a name ( Possibly more would be ok) 
%CONSTINTEGER SYMBOLTABLEENTRYSIZE = 8
%CONSTINTEGER INTSYMSIZE = 12
%CONSTINTEGER INITIALSYMBOLTABLESIZE = DEFAULTAREASIZE
%CONSTINTEGER INFINITY = X'FFFFFE'
%CONSTINTEGER MODE = X'1B4'     ;! Mode of object create, read/write for all
%CONSTINTEGER CODE = 1
%CONSTINTEGER GLA = 2
%CONSTINTEGER SST = 4
%CONSTINTEGER GST = 5
%CONSTINTEGER DIAGS = 6
%CONSTINTEGER SCALAR = 7
%CONSTINTEGER IOTAB = 8
%CONSTINTEGER ZGST = 9
%CONSTINTEGER CNST = 10
%CONSTINTEGER DICTTAB = 18
%CONSTINTEGER SYMTAB = 19
%CONSTINTEGER SETAREAS = 20
%CONSTINTEGER RSIZE = 8                   ;! sizeof(rfm) when sizeof working 
%CONSTINTEGER MAXRELS = DEFAULTAREASIZE // RSIZE   ;! 511 
%CONSTINTEGER MAXLEXLEV = 20
%CONSTINTEGER SIZEOFAREAENTRY = 24
%CONSTSTRING (1) SNL = "
"
!
%OWNINTEGER CREL = 0
%OWNINTEGER NDRELS = 0
%OWNINTEGER NTRELS = 0
%OWNINTEGER STARTLINEAD
%OWNINTEGER LINEAD
%OWNINTEGER RDSIZE = 12
%OWNINTEGER DICTSTART
%OWNINTEGER STARTVARAD
%OWNINTEGER VARAD
%owninteger objid        { File descriptor ID of object file }
%owninteger imp = 0
%owninteger Faulty = 0
%owninteger curlexlev = 0
%owninteger mon = 0                   { Put call monitoring control }
%owninteger NextSym = -1              { Index to symbol table. +1 for each entry }
%owninteger MainEntryPoint = 0
%owninteger Codestart
%owninteger Line = 0                    { Current Line number as set by start}
%OWNINTEGER MAXSYMS
%OWNINTEGER MALMON = 0
%OWNINTEGER MAXDATA = 0
%OWNINTEGER LINESTART = 0
%OWNINTEGER MAXAREA = 0
%OWNINTEGER TOPAREA = 21
%OWNINTEGER FILEMON
%OWNINTEGER DICTAD = 0
%OWNINTEGER MAXDICTAD = 0
%OWNSTRING (32) SRCFILE = "Source Unknown"
!
%RECORDFORMAT RELFM (%INTEGER ADDRESS, DATA)
%RECORDFORMAT RDFM (%INTEGER DISP, LEN, COPIES)
%RECORDFORMAT BLOCKFM (%INTEGER AD, CA, SYM, PSIZE)
%RECORDFORMAT AREAFM (%INTEGER BASE, MAX, LENGTH, SYM, TYPE, LINKDISP)
%RECORDFORMAT HDRFM (%INTEGER MAGIC, TEXT, DATA, BSS, SYMS, ENTRY, TRSIZE, DRSIZE, %C
   STSIZE, TXBASE, NBTEXT, NBDATA, NBBSS, TSTAMP, MSTAMP, SSTAMP, CCVERS, ASVERS, LDVERS) ;! Object file header format
%RECORDFORMAT SYMFM (%INTEGER STRX, %BYTEINTEGER TYPE, DESC, SP1, SP2, %INTEGER VALUE)    ;! Symbol table format
%ownrecord (Symfm) %arrayformat Symafm(0:100000)
%ownrecord (Symfm) %arrayname Syms
%IF HOST = EMAS %THEN %START
   %RECORDFORMAT RFM (%HALFINTEGER HOSTAREA, TGT, %INTEGER HOSTDISP)
   %RECORDFORMAT VARFM (%INTEGER TYPE, DISP, SIZE, %HALFINTEGER VTYPE, AID)
%FINISH
%IF HOST = EMASA %THEN %START
   %RECORDFORMAT RFM (%SHORTINTEGER HOSTAREA, TGT, %INTEGER HOSTDISP)
   %RECORDFORMAT VARFM (%INTEGER TYPE, DISP, SIZE, %SHORTINTEGER VTYPE, AID)
%FINISH
%OWNRECORD (RFM) %ARRAYFORMAT RAFM (1:100000)
%OWNRECORD (RFM) %ARRAYNAME RELS, STARTRELS
%ownbyteintegerarrayformat codefm (0:infinity)
%ownbyteintegerarrayname codearea
%ownrecord (blockfm) %array blocks (-1:maxlexlev)
%ownrecord (blockfm) %name  parentblock,                                { descriptor of surrounding procedure }
                           curblock                                    { descriptor of current procedure }
%ownrecord (Areafm) %arrayformat AreaAfm (0:10000)
%ownrecord (areaAfm) %arrayname Areas
!
%routinespec fix (%integer type, area, disp, tgt)
%routinespec PSymbol (%string (255) s, %integer type, val)
%ROUTINESPEC M VAR (%INTEGER SWAD, TYPE, AREA, DISP, BYTESIZE, NELS)
!
%routine PERROR (%string (255) s)
   PRINTSTRING(SNL."*** Put Interface Error/ ".S.SNL)
!  %return %if faulty # 0 {try and keep going to allow report of multiple faults }
   %monitor
   %stop
%end
!
!
%EXTERNALINTEGERFN GETSPACE (%INTEGER SIZE)                                   ;! M GETSPACE
   %integer flag
   %if malmon # 0 %then %start
      printstring(" malloc "); write(size,1)
      flag = malloc(size)
      printstring(" flag = "); phex(flag);  newline;
      %if flag + size > maxdata %then maxdata = flag + size
   %finish %else flag = malloc(size)
   %if flag = 0 %then perror(" Malloc out of space ")
   %result = flag
%end
!
%ROUTINE FWRITE (%INTEGER AREA,  OBJID, BYTEAD, LEN)
   %IF MON # 0 %THEN PRINTSTRING("File Write - AREA ".ITOS(AREA)." ".HTOS(BYTEAD,8)." ".ITOS(LEN).SNL)
   Filewrite(objid,bytead,len)
%end
!
%routine File Position (%integer objid, byteoffset, whence)
   %integer newptr
   %IF MON # 0 %THEN PRINTSTRING("   CALL LSEEK - ".ITOS(OBJID)." ".HTOS(BYTEOFFSET,8)." ".ITOS(WHENCE).SNL)
   newptr = LSEEK(objid,byteoffset,whence)
   %IF MON # 0 %THEN PRINTSTRING("   New Ptr = ".HTOS(NEWPTR,8).SNL)
%end
!
%routine expand area (%integer id)
   %integer from, ad, newsize, oldsize, filler, type
                             { This is crude way of implementing segmentation}
                             { by getting a new hole twice the old size and}
                             { copying the data into the front half of it. }
   from = areas(id)_base
   oldsize = areas(id)_max
   type = areas(id)_type
   %if id = 5 %or id > 20 %then filler = 0 %else filler = type >> 24
   %if malmon # 0 %then printstring("EXPAND AREA ".itos(id)." from, oldsize ".htos(from,8)." ".htos(oldsize,8).SNL)
   %if oldsize = 0 %then %start               { First use of this area }
      newsize = default area size
      AD = GETSPACE(NEWSIZE)
      Perror("GETSPACE fails") %if ad = 0         
      %unless type = code %then Fill(newsize,ad,filler)
   %finish %else %start                   { Expansion of existing area }
      NEWSIZE = (OLDSIZE) + 8
      AD = REALLOC(FROM,NEWSIZE) 
        { zero additional area on back }
      FILL(OLDSIZE,AD + (OLDSIZE),FILLER) %UNLESS TYPE = CODE
      %if malmon # 0 %then %start
         printstring("Realloc from to newsize ")
         phex(from)
         space
         phex(ad)
         space
         phex(newsize)
         newline
      %finish
   %finish
   %if id = 0 %then areas == array(ad,areaAfm) { have moved the area table }
   areas(id)_base = ad
   %IF MON # 0 %THEN PRINTSTRING("EXPAND AREA ".ITOS(ID).SNL)
   areas(id)_max = newsize
%end
!
! PUT interface Code passing routines
!
%ROUTINE CHECKCODESIZE (%INTEGER CA)
   %if CA >= areas(CODE)_max - 1024 %then %start
      expand area(CODE)
      codearea == array(areas(CODE)_base,codefm)
   %finish
%end
!
%ROUTINE PH (%INTEGER CA, N)                                                    ;! 16 bits into code stream
   %return %if faulty # 0
   CheckCodeSize(CA)
   CODEAREA(CA + 1) = N & 255
   CODEAREA(CA) = (N >> 8) & 255
%end
!
%ROUTINE PB (%INTEGER CA, N)                                                    ;! Basic opcode planting routine
   %return %if faulty # 0
   CheckCodeSize(CA)
   codearea(CA) <- n
%end
!
%ROUTINE PW (%INTEGER CA, N)                                                    ;! 32 bits into code stream
   %return %if faulty # 0
   CheckCodeSize(CA)
   codearea(CA) = (n >> 24) & 255
   codearea(CA + 1) = (N >> 16) & 255
   codearea(CA + 2) = (N >> 8) & 255
   codearea(CA + 3) =  N & 255
%end
!
%EXTERNALROUTINE M CBYTES (%INTEGER OFFSET, LEN, AD)                            ;! M CODEBYTES
   %INTEGER I
   %IF MON # 0 %THEN %START
      PRINTSTRING("M CBYTES - Len: ".ITOS(LEN)."Offset: ".HTOS(OFFSET,8)." Value: ")
      %IF LEN = 1 %THEN PHEXBYTE(BYTEINTEGER(AD)) %ELSE %START
         %CYCLE I = AD, 1, AD + LEN - 1
            PHEXBYTE(BYTEINTEGER(I))
         %REPEAT
      %FINISH
      NEWLINE
   %FINISH
   %IF LEN = 1 %THEN PB(OFFSET,BYTEINTEGER(AD)) %ELSE %START
      %CYCLE I = AD, 1, AD + LEN - 1
         PB(OFFSET,BYTEINTEGER(I))
         OFFSET = OFFSET + 1
      %REPEAT
   %FINISH
%END
!
!%owninteger prev = 0
!!
!%EXTERNALROUTINE M DUMPINSTR (%STRINGNAME S)                                    ;! M DUMPINSTR
!   %integer i
!   printstring("  ("); phex(prev); printstring(") ")   
!   Phexbyte(codearea(i)) %for i=prev,1,CA-1  
!   %IF CA - PREV < 16 %THEN SPACES(16 - (CA - PREV))
!   PRINTSTRING("   ".S.SNL)
!%end
!!
!%EXTERNALROUTINE M DISP (%INTEGER DISP)                                         ;! M DISP
!   %if -64 <= disp <= 63 %then codearea(CA) = disp & X'7F' %and CA = CA + 1 %else %c
!   %if -8192 <= disp <= 8191 %then %start
!      disp = ((disp & X'3FFF') ! X'8000')
!      codearea(CA + 1) = disp & 255
!      codearea(CA) = (disp >> 8) & 255
!      CA = CA + 2
!   %finish %else %c
!   %if -16777215 <= disp <= 16777215 %then PW((disp & X'3FFFFFFF') ! X'C0000000') %else %c 
!   Perror("M DISP - Disp too large ")
!%end
!!
!%EXTERNALROUTINE M FIXDISP (%INTEGER TYPE, TGT, TDISP)                          ;! M FIXDISP
!   %if mon # 0 %then %start
!      printstring("  M FIXDISP type = ")
!      write(type,1)
!      printstring(" to ")
!      write(tgt,1)
!      printstring(" + ")
!      write(tdisp,1)
!      printstring(" CA = ")
!      phex(ca)
!      space
!      phex(addr(codearea(CA)))
!      newline
!   %finish
!   FIX( 0,CODE,CA,tgt)
!   tdisp = tdisp + (CA-prev)
!   PW(X'C0000000'!tdisp)
!%end
!
%ROUTINE REMLINE (%INTEGER LINENO, CODEAD)    ;! Save data for line map
                                { 6 bytes per line format is }
                                { byte type , 3byte disp, 2byte line number }
                                { type  0 = line and disp }
                                {     255 = end of block. disp = ad of next }
                                {       1 = proc start }
   %owninteger maxlinead, ad, typedisp, lin, lastline
!  %return %if lineno=0 %or lineno>9998  { ignore IMP silly lines }
!  %return %if lineno=lastline           { ignore duplicated lines }
!  %return %if curlexlev=0               { wait for proc before passing line }
!  %if linead + 6 >maxlinead %start      { open a new block }
!    ad = GETSPACE(defaultareasize) // 2   
!    %if startlinead=0 %start            { First block }
!      startlinead=ad
!    %finish %else %start                    { Subsequent blocks }
!      integer(linead) = (255 << 24) ! ad    { set type to end of block }
!    %finish
!    maxlinead = ad + (defaultareasize // 2)
!    linead = ad
!  %finish
!  %if lineno<0 %start                  { proc id ie. procedure start }
!    typedisp = (1 << 24) ! (-lineno)    { type =1 ; disp = proc id }
!    lin = line
!    lastline = line
!  %finish %else %start 
!    typedisp  = CA     { type = 0 ; disp = posn in proc of linestart }  
!    lin = lineno
!    lastline = lineno
!  %finish
!  halfinteger(linead)   =  typedisp>>16
!  halfinteger(linead + 1) =  typedisp & X'FFFF' 
!  halfinteger(linead + Y2) =  lin
!  linead = linead + 3
%end
!
%EXTERNALROUTINE M LINESTART (%INTEGER LINENO, CODEAD)                          ;! M LINESTART
   %owninteger lastline = -1
   %return %if faulty # 0
   %IF MON # 0 %THEN PRINTSTRING("M LINESTART - LINENO: ".ITOS(LINENO).SNL)
   LINESTART = CODEAD
   Line = Lineno
   %if sdb # 0 %then %start              { save data for line map }
      %IF LINENO # LASTLINE %THEN REMLINE(LINENO,CODEAD) %ELSE LASTLINE = LINENO
   %finish
%end
!
! Put Interface Passing of Data   
!
%EXTERNALROUTINE M DBYTES (%INTEGER CURAREA, DISP, LEN, AD)                     ;! M DBYTES
   %record (Areafm) %name A
   %integer i, bad, to, encoded, from
   %record (rdfm) %name r
   %return %if faulty # 0
   %if mon # 0 %then %start
      PRINTSTRING("M DBYTES(".ITOS(CURAREA)." LEN: ".ITOS(LEN)." DISP: ".ITOS(DISP)." VALUE: ")
      BAD = AD
      %if len = 1 %then phexbyte(byteinteger(bad)) %else %start
         %cycle i = bad, 1, bad + len - 1
            PHEXBYTE(BYTEINTEGER(I))
         %repeat
      %finish
      newline
   %finish
   %if curarea = 5 %or curarea > 20 %then encoded = 1 %else encoded = 0
   %if curarea > 20 %then curarea = syms(curarea - 20)_value { common }
   A == areas(CurArea)
   %if trusted = 0 %then %start
      Perror("bad displacement ") %if disp < 0 %or disp > 4000000
   %finish
   FROM = AD   ;! copy to byte boundaries 
   %if encoded # 0 %then %start                    { encoded area }
      %if A_max = 0 %then expand area(curarea) %and A_linkdisp = 0   {first use }
      R == RECORD(A_base + A_linkdisp)
      %WHILE (A_LINKDISP) + (RDSIZE) + R_LEN + LEN + 3 > A_MAX %CYCLE
         expand area(curarea)
         R == RECORD(A_base + A_linkdisp)
      %repeat
      %if (disp = R_disp + R_len) %and R_copies <= 1 %then %start {adjacent areas }
         TO = (A_BASE + A_LINKDISP) + RDSIZE + R_LEN
         R_len = R_len + len
      %finish %else %start  { new start required }
         TO = (A_BASE + A_LINKDISP + ((RDSIZE + R_LEN + 1)) + 1) & (-2) ;! 4b bnd
         R == RECORD(to)
         A_linkdisp = to - A_base
         R_disp = disp
         R_len = len
         R_copies = 1
         TO = TO + RDSIZE
      %finish 
   %finish %else %start  { normal mapped area }
      expand area(Curarea) %while disp + len > A_max
      TO = A_BASE + DISP
   %finish
   MOVE(LEN,FROM,TO)
%end
!
%EXTERNALROUTINE M D (%INTEGER AREA, DISP, DATABYTE)                            ;! M D
   %integer i
   %return %if faulty # 0
   %return %if databyte = 0
   i = databyte << 24
   M DBYTES(AREA,DISP,1,ADDR(I))
%end
!
%EXTERNALROUTINE M D2 (%INTEGER AREA, DISP, DATADOUBLEBYTE)                     ;! M D2
   %return %if faulty # 0
   %return %if datadoublebyte = 0
   M DBYTES(AREA,DISP,2,ADDR(DATADOUBLEBYTE) + 1)
%end
!
%EXTERNALROUTINE M D4 (%INTEGER AREA, DISP, DATAQUADBYTE)                       ;! M D4
   %return %if faulty # 0
   %return %if dataquadbyte = 0
   M DBYTES(AREA,DISP,4,ADDR(DATAQUADBYTE))
%end
!
%EXTERNALROUTINE M DPATTERN (%INTEGER AREA, DISP, NCOPIES, LEN, AD)             ;! M DPATTERN
   %integer i, bad
   %record (Areafm) %name A
   %integer to, encoded, from
   %record (rdfm) %name r
   %return %if faulty # 0
   %if mon # 0 %then %start
      printstring(" M DPATTERN( area = "); write(area,1)
      printstring(", disp = "); write(disp,1)
      printstring(", ncopies = "); write(ncopies,1)
      printstring(" filler = ")
      BAD = AD
      %cycle i = bad, 1, bad + len - 1
         PHEXBYTE(BYTEINTEGER(I))
      %repeat
      newline
   %finish
   %return %if len = 4 %and integer(ad) = 0 %and areas(area)_type >> 4 = 0
   ncopies = 1 %if ncopies = 0
   %if area = 5 %or area > 20 %then encoded = 1 %else encoded = 0
   %if area > 20 %then area = syms(area - 20)_value { common }
   A == areas(Area)
   %if trusted = 0 %then %start
      Perror("bad displacement ") %if disp < 0 %or disp > 4000000
   %finish
   FROM = AD   ;! copy to byte boundaries 
   %if encoded # 0 %then %start                    { encoded area }
     %if A_max = 0 %then expand area(area) %and A_linkdisp = 0   {first use }
     R == RECORD(A_base + A_linkdisp)
     EXPAND AREA(AREA) %WHILE (A_LINKDISP) + (RDSIZE) + R_LEN + LEN + 3 > A_MAX
     TO = (A_BASE + A_LINKDISP + ((RDSIZE + R_LEN + 1)) + 1) & (-2) {4b bnd}
     R == RECORD(to)
     A_linkdisp = to - A_base
     R_disp = disp
     R_len = len
     R_copies = ncopies
     TO = TO + RDSIZE
     MOVE(LEN,FROM,TO)
   %finish %else %start  { normal mapped area }
      %cycle i = 1, 1, ncopies
         expand area(area) %while disp + len > A_max
         TO = A_BASE + DISP
         MOVE(LEN,FROM,TO)
      %repeat
   %finish
%end
!
%routine place in dict (%stringname name, %integername set)
   %integer wl
   WL = (LENGTH(NAME) + 2)   ;! Put the name into the dictionary 
   %if dictad + wl > maxdictad %then %start
      %if malmon # 0 %then printstring(SNL."Space for dictionary block ".SNL)
      DICTAD = GETSPACE(DEFAULTAREASIZE)
      dictstart = dictad
      MAXDICTAD = DICTAD + DEFAULTAREASIZE
   %finish
   string(dictad) = name
   set = dictad - dictstart    
   dictad = dictad + wl
   %IF MON # 0 %THEN PRINTSTRING("PLACE IN DICT - ".NAME."  DICTAD: ".HTOS(DICTAD,8).SNL)
%end
!
! Put Interface RELOCATION and REFERENCES
!
%routine Psymbol (%string (255) name, %integer type, Value)
                 { remember a name and its properties for inclusion in the }
                 { object file symbol tables }
                 { names are piled end to end in the dictionary }
   %record (Symfm) %name Sym
   %integer i
   %IF MON # 0 %THEN PRINTSTRING("P SYMBOL- ".NAME.SNL)
   NextSym = NextSym + 1
   %if nextsym >= maxsyms %then %start
      expand area(symtab)
      syms == array(areas(symtab)_base,symafm)
      maxsyms = areas(symtab)_max // intSymSize
   %finish
   length(NAME) = SYMSIZE %if length(NAME) > SYMSIZE
   Sym == Syms(NextSym)
   perror("PSYMBOL - OVERWRITING A SYMBOL TABLE ENTRY, ID= ".ITOS(NEXTSYM)) %IF  trusted = 0 %and SYM_strx # 0
   Sym = 0
   place in dict(name,sym_strx) ;! Remember name in dictionary and set sym_ad to its word address 
   Sym_type = type 
   Sym_value = Value
%end
!
%EXTERNALINTEGERFN M XNAME (%INTEGER TYPE, %STRINGNAME S)                       ;! M XNAME
   ! Xrefs are used many times so establish mapping to integer ID early
   ! and save on holding/passing of strings
   %string (32) name, rest
   %integer i
   %record (symfm) %name sym
   %IF MON # 0 %THEN PRINTSTRING("M XNAME NAME: ".S.SNL)
   %result = 0 %if faulty # 0
   name <- S
   %if name -> ("s#").rest %then name = "_s_".rest %ELSE name = "_".name
   ! Look to see if this is a repeated reference
   %cycle i = 0, 1, nextsym   
      sym == syms(i)
      %if sym_type = Ext %then %start  { found a reference }
         %if name = string(dictstart + sym_strx) %then %start { name already in place }
            %IF MON # 0 %THEN PRINTSTRING("  M XNAME:(REP) ".S." SYMID = ".ITOS(I + 20).SNL)
            %result = i + 20
         %finish
      %finish
   %repeat
   Psymbol(name,EXT,0)                      { first occurrence of name }
   %if mon # 0 %then printstring("  M XNAME: ".s." symID = ".itos(nextsym + 20).SNL)
   %result = NextSYm + 20
%end
!
%routine FIX (%integer type, area, disp, tgt)                                   ;! Remember a reloc. request 
   %record (rfm) %name R
   %integer ad
   %IF MON # 0 %THEN %START
      PRINTSTRING("FIX(".ITOS(TYPE).",".ITOS(AREA).",".ITOS(DISP).",".ITOS(TGT).")".SNL)
   %FINISH
   %if trusted = 0 %then %start
     Perror("Fix - Bad relocation request") %ifc
           area < 1 %or area > nextsym + 20 %or tgt < 1 %or tgt > nextsym + 20
   %finish
   %cycle
      Crel = Crel + 1
      R == rels(crel)
      %if Crel + 1 > Maxrels %then %start   { start next block of relocations }
         %if malmon # 0 %then printstring(SNL."   Space for relocation tables ")
         AD = GETSPACE(DEFAULTAREASIZE)
         {R_type=255}        { marker in type field that this is not a reloc}
                             { , but contains addr of next block            }
         r_hostdisp = (255 << 24) ! ad
         crel = 0
         rels == array(ad,rafm)
      %finish %else %exit
   %repeat
   %if type < 200 %then %start   { if it is a genuine  reloc request , count it }
      %if area = Gla %or area = Iotab %then ndrels = ndrels + 1 %else ntrels = ntrels + 1
   %finish
   {R_type=type}
   R_tgt = Tgt              { Note reloc usually means remember 4 values, but }
%if area>11 %then %monitor %and %stop
   R_hostarea = area        { in this m/c have got tgt disp written in        }
   R_hostdisp = (type << 24) ! disp   { host word already }
%end
!
!   M FIX  -  REQUEST A 32bit RELOCATION
!
%EXTERNALROUTINE M FIX (%INTEGER HOSTAREA, DISP, TGTAREA, TGTDISP)              ;! M FIX
                          { A relocation request: set word in area, displacement = 'disp' bytes,
                          { the address of area 'targetareaid', displacent = targetdisp.}
   %record (Areafm) %name A
   %integername tgt
   %return %if faulty # 0
   A == areas(HostArea)
   %if trusted = 0 %then %Start
     Perror("M FIX - bad displacement ") %if disp < 0 %or disp > 4000000
   %finish
   expand area(Hostarea) %while disp + 4 > A_max
!  %if tgtarea = code %then tgtarea = tgtdisp %and tgtdisp = 0
   TGT == INTEGER(AREAS(HOSTAREA)_BASE + (DISP))
   tgt = tgt + tgtdisp
   FIX(4,Hostarea,disp,tgtarea)   
   %if mon # 0 %then printstring("M FIX( ".itos(Hostarea)."/".htos(disp,6)." -> ".itos(tgtarea)."/".htos(tgtdisp,6).SNL)
%end
!
!***%EXTERNALROUTINE M DXREF (%INTEGER AREA, DISP, LENGTH, %STRINGNAME NAME)        ;! M DXREF
%EXTERNALROUTINE M DXREF (%INTEGER AREA, DISP, LENGTH)
!   %integer type, id, i
!   %record (symfm) %name sym
!   %string (32) s
!   %STRING (32) NAME ;!************TEMP************
!   NAME = "????"     ;!************TEMP************
!   %return %if faulty # 0
!   { Find any earlier reference of this name }
!   %cycle i = 0, 1, nextsym   
!      sym == syms(i)
!      %if sym_type = Ext %then %start  { found a reference }
!         %if name = string(dictstart + sym_strx) %thenc { name already in place }
!         id = i + 20 %and -> Found
!      %finish
!   %repeat
!   s = "_".name
!   Psymbol(s,EXT,0)        { first occurrence of name }
!   id = nextsym + 20
!Found:              
!   fix(4,area,disp,id) { I expect a M XNAME to have been done earlier }
!   %if mon # 0 %then printstring("
!   M DXREF( ".itos(area)."/".htos(disp,8)." -> ".itos(id))
%END
!
%EXTERNALROUTINE M DATAENTRY (%STRINGNAME NAME, %INTEGER AREA, MAXLEN, DISP)    ;! M DATAENTRY
   %string (255) s
   %return %if faulty # 0
   %if mon # 0 %then printstring(" M DATAENTRY( ".itos(area)."/".htos(disp,8)." len ".itos(maxlen).name.SNL)
   s = "_".name
   Psymbol(s,DATA ! EXT,disp)
%end
!
%EXTERNALINTEGERFN M NEXTSYMBOL                                                 ;! M NEXTSYMBOL
   ! Reserve a space in the symbol table
   %result = 0 %if faulty # 0
   nextsym = Nextsym + 1
   %if nextsym >= maxsyms %then %start
      expand area(symtab)
      syms == array(areas(symtab)_base,symafm)
      maxsyms = areas(symtab)_max // SymbolTableEntrySize
   %finish
   %if mon # 0 %then printstring("Symbol reserved: ".itos(nextsym + 20).SNL)
   syms(nextsym)_value = -1                ;! Mark as Forward ref
   %result = Nextsym + 20
%end
!
!    M ENTRY - SIDE CODE ENTRY
!
%EXTERNALINTEGERFN M ENTRY (%INTEGER INDEX, CODEDISP, %STRINGNAME NAME)         ;! M ENTRY
   %string (255) S
   %result = 0 %if faulty # 0
   S = "_".name
   length(S) = 32 %if length(S) > 32
   Psymbol(S,EXT ! TEXT,CODEDISP)               { make symbol table entry }
   %if mon # 0 %then printstring("M ENTRY: ".itos(nextsym + 20).SNL)
!  %if sdb # 0 %then M VAR(syms(nextsym)_strx,0{flag delim},nextsym,line,0,1{flag M ENTRY})  { add proc to variable list }
   %result = Nextsym + 20
%end
!
! M PROC - START A NEW PROCEDURE
!
%EXTERNALROUTINE M PROC (%STRINGNAME NAME, %INTEGER PROPS, CODEAD ,%INTEGERNAME ID) ;! M PROC
                              { PROPS & 1    =  External   }
                              { PROPS&2    =  No ASFW    }
                              { PROPS>>31  =  Main entry }
   %integer type, save, areaid, i, CGRT, at
   %string (255) rest, S
   %record (symfm) %name sym
   ID = 1 %and %return %if faulty # 0
   %if mon # 0 %then %start
      printstring("M PROC: ".name." ID = ".itos(id))
      space; phex(props); NEWLINE
   %finish
   Parentblock == Curblock           { COPE WITH NESTED PROCEDURES }
   curlexlev = curlexlev + 1
   Curblock == blocks(curlexlev)
   %if props & 1 # 0 %then type = EXT ! TEXT %else type = TEXT
   %if name -> ("s#").rest %then S = "_s_".rest %else S = "_".name
   length(S) = 32 %if length(S) > 32
   ! If this procedure has been declared as a spec previously then a M NEXTSYMBOL
   ! will have reserved the symbol table entry 'ID' for it
   ! If there was no spec then ID will <=0
   %if imp = 0 %and id = -1 %then %start
      ! Fortran may well have placed a reference to this entry earlier 
      ! Search backwards and overwrite (first case only) 
      %cycle i = nextsym, -1, 1   
         sym == syms(i)
         %IF SYM_TYPE = EXT %AND S = STRING(DICTSTART + SYM_STRX) %THEN %START
            ID = I + 20
            SYM_STRX = 0        ;! Reset for unused check
         %FINISH
      %repeat
   %finish
   save = 0
   %if ID # -1 %then save = nextsym %and nextsym = id - 1 - 20
   %if props >> 31 = 1 %or s = "_s_go" %then %start
      Main Entry Point =  CODEAD
!      s = "_MAIN__"
       s = "_main"
      TYPE = EXT ! FARTEXT
!    %if line = 0 %then M LINESTART(1) { temp }
   %finish
!   %if CA & 1 # 0 %start   { Align Proc start on 2 byte boundary }
!       PREV = CA     ;! USED TO BE CALL OF P STARTINSTR
!***       PB(X'A2')
!    %finish
    Psymbol(S,type,CODEAD)                   { make symbol table entry }
    %if ID # -1 %then nextsym = save %else ID = Nextsym + 20
    %if mon # 0 %then printstring(" symID = ".itos(ID).SNL)
!   %if S -> ("_p_").rest %then CGRT = 1 %else CGRT = 0
!   PREV = CA             ;! USED TO BE CALL OF P STARTINSTR
!***   PB(B'10000010')  { Enter }
!***   PB(B'11111110')  { save every reg except 'result' }
!  %if CGRT=1 %then PB(0)         %elsec  { save nothing ? for comp. gen rts }
!                   PB(B'11111000')   2    { save regs 3 to 7 as expected by C}
!  %if props&2=0 %start  { claim local space - Opd filled in at Proc end }
!     curblock_CA =CA
!***     PH(X'0080')
!  %finish %else %start
!     curblock_CA =-1
!***     PB(0)    { claim NO local space }
!  %finish
!  curblock_psize = pars & X'FFFF'
! %unless sdb=0 %or CGRT=1 %Start { ignore compiler generated rts}
!   remline(-(ID-20))      { add proc to line number map }
!   M VAR(syms(ID-20)_strx,0,ID-20,line,0,0)  { add proc to variable list }
! %finish
%end
!
%EXTERNALROUTINE M PROCEND                                                      ;! M PROCEND
   %if mon # 0 %then %start
      PRINTSTRING("M PROC END".SNL)
   %finish
   %IF TRUSTED = 0 %AND CURLEXLEV = 0 %THEN PERROR("M PROCEND - too many proc ends".SNL)
   Curblock == Parentblock
   curlexlev = curlexlev - 1
   Parentblock == blocks(curlexlev - 1)
%end
!
! Put Interface - Miscellaneous 
!
%EXTERNALROUTINE M REVERSEBYTES (%INTEGER AREA, DISP, LEN)                      ;! M REVERSEBYTES
%END
!
%EXTERNALINTEGERFN M COMMON (%STRINGNAME NAME)                                  ;! M COMMON
%string(63) s
   %result = 0 %if faulty # 0
   %IF MON # 0 %THEN PRINTSTRING("P COMMON - ".NAME.SNL)
   Toparea = Toparea + 1
   %if toparea > maxarea %then %start
      expand area(0) 
      maxarea = areas(0)_max // sizeof(areas(0))
   %finish
  %if name="F#BLCM" %then s="__BLCM__" %else s="_".name
   Psymbol(s,EXT,Toparea)  { put area table index in _value temporarily }
   areas(toparea)_sym = nextsym + 20
   %result = nextsym + 20
%end
!
%EXTERNALROUTINE M ENDCOMMON (%INTEGER ID, LENGTH)                              ;! M ENDCOMMON
   %return %if faulty # 0
   %if mon # 0 %then %start
      PRINTSTRING("P END COMMON ".ITOS(ID)."  LENGTH = ")
      phex(length)
      newline
   %finish
   areas(syms(id - 20)_value)_length = length
   syms(id - 20)_value = length
%end
!
%EXTERNALROUTINE M VAR (%INTEGER SWAD, VTYPE, AREA, DISP, BYTESIZE, NELS)       ;! M VAR
                       { Take details of variables and encode for SDB }
   %owninteger maxvarad
   %record (varfm) %name v
   %stringname s
   %integer dicad,ad,i
   %return %if faulty # 0
   s == string(swad)
   %if mon # 0 %and bytesize # 0 %then %start 
      printstring("M VAR: ".s." type = ")
      phex(vtype)
      printstring(" area/disp/len/nels  = ")
      write(area,1)
      space; phex(disp)
      write(bytesize,1)
      write(nels,1)
      newline
   %finish
                                { type  0 = variable info }
                                {     255 = end of block. disp = ad of next}
!  %if varad + 16 > maxvarad %start       { open a new block }
!    ad = GETSPACE(defaultareasize) // 2
!    %if startvarad = 0 %start           { First block }
!      startvarad = ad 
!    %finish %else %start                    { Subsequent blocks }
!      v == RECORD(varad)                { Map onto old block for final entry !}
!      v_type = 255 << 24                  { set type to end of block }
!      v_disp=ad                         { address of next block }
!    %finish
!    maxvarad = ad + (defaultareasize // 2)
!    varad = ad                          { Map onto new block now }
!  %finish
!  %if bytesize = 0 %start  { procedure } 
!    dicad = swad
!  %finish %else %start         { variable }
!   { Upper case L is ignored by SDB so translate variable names to lower case!}
!    %cycle i= (addr(s)*2) + 1,1,(addr(s)*2) + length(s)
!      %if 'A'<=byteinteger(i)<='Z' %then byteinteger(i)=byteinteger(i) + 32
!    %repeat
!    placeindict(s,dicad)
!  %finish
!  v == RECORD(varad)
!  v_type = dicad   { implicit type = 0 }
!  v_disp = disp
!  v_size = (bytesize << 24) ! nels
!  v_vtype = vtype
!  v_aid = area
!  varad = varad + 8
%end
!
%EXTERNALROUTINE M FAULTY                                                       ;! M FAULTY
  { Code generator has encountered a user error. Code requests should no }
  { longer be checked and minimum work done in PUT }
   %if mon # 0 %then printstring("M FAULTY".SNL)
   Faulty = 1
%end
!
%EXTERNALROUTINE M SETFILES (%STRINGNAME SRCNAME, OBJFILENAME)                  ;! M SETFILES
   %string (255) S
   %integerarray Cname(0:64)
   %IF MON # 0 %THEN PRINTSTRING("M SETFILES - SRC: ".SRCNAME." OBJ: ".OBJFILENAME.SNL)
   S = SRCname
   %if length(s) > 32 %then length(s) = 32
   Srcfile = S 
   CSTRING(objfilename,addr(Cname(0)))
   Objid = CREAT(addr(cname(0)),mode)
   %if objid = -1 %then Perror(" Failed to create/open object ")
%end
!
! M INITIALISE - CODE GENERATION BEGINS WITH THIS CALL
!
%EXTERNALROUTINE M INITIALISE (%INTEGER LANGUAGE, PROPS, SOURCEAD)              ;! M INITIALISE
   %integer i
   %string (63) name
   %string (32) lang
   %ownrecord (Areafm) ZeroArea
   %IF MON # 0 %THEN PRINTSTRING("M Initialise".SNL)
   %return %if faulty # 0 
   %if language = 1 %then lang  = "IMP80" %and imp = 1 %else lang = "FORTRAN77"
   %if comreg(26) & 128 # 0 %then malmon = 1
   %if comreg(26) & 16 # 0 %then filemon = 1 
!     %if comreg(26) & 4 # 0 %then sdb=1
   %if language = 1 %then M LINESTART(0,0) { give p_rts a valid line number }
   Free Source Areas                 { release consource claimed space }
   Codestart = 32
   curblock == blocks(0)       { Set pointer to dummy outer level }
   RELS == ARRAY(GETSPACE(DEFAULTAREASIZE),RAFM)  ;! grab an area for reloc table
   Startrels == Rels                      { Note reloc table sections are not contiguous so dont need to be 'areas' }
   Areas == array(addr(ZeroArea),Areaafm)  { Start of area table }
   expand area(0)
   MaxArea = areas(0)_max // sizeofareaentry
   name = "123"        { Put a dummy 4 byte entry into the symbol table }
   place in dict(name,i) { to leave space for its length to be filled in }
%end
!
! M TERMINATE - CODE GENERATOR CLOSES WITH THIS CALL TO ESTABLISH AREA LENGTHS
!
%EXTERNALROUTINE M TERMINATE (%INTEGER ADAREASIZES)
   %INTEGER I, AD, L
   %return %if faulty # 0
   %if mon # 0 %then %start
      PRINTSTRING("M TERMINATE".SNL)
      PRINTSTRING("    Arealengths from Mterminate are:".SNL)
      %cycle i = 0, 1, 9
         WRITE(INTEGER(ADAREASIZES + (I * 4)),1)
      %REPEAT
      NEWLINE
   %finish
   ad = adareasizes
   %cycle i = 1, 1, 10
      L = INTEGER(AD)
      AD = AD + 4
      l = (l + 7) & (-8)  { Keep areas tidy on 8 word boundaries }
!      Perror("Mterminate - Area ".itos(i)." has incorrect length".SNL) %if trusted = 0 %and i # 1 %and l = 0 %and areas(i)_max # 0  
      areas(i)_length = l
   %repeat
%end
!
! M GENERATE - FINAL PHASE OF COMPILATION IS CREATE OBJECT FILE
!
%EXTERNALROUTINE M GENERATEOBJECT (%STRINGNAME OBJFILENAME )                    ;! M GENERATEOBJECT
   %record (hdrfm) hdr
   %INTEGER TEXTLEN, DATALEN, SYMLEN, AD, J, FILLER, I, DATASTART, BSSLEN, L, %C
      LINKDISP, AREABASE, KAD, SFT, SNT, Dataoffset
   %integerarray areastart(1:toparea)
   %record (rdfm) %name rd
   %string (255) s
   %constbyteintegerarray order (2:10) = 2, 8, 10, 7, 4, 5, 6, 3, 9
   !
   ! Object file area allocations:
   !
   ! Near Text: 3
   ! Far  Text: 1, 10, 4, 6
   ! Near Data: 2, 8
   ! Far  Data: 5
   ! Far  BSS:  9
   !
   %routine PATTERN (%integer fileid, ncopies, l, bad)
      %byteintegerarray b(0:511)
      %integer i, left, ad, to, blen, bufsize
      AD = ADDR(B(0))
      { if l > 512 ? }  { First fill the buffer with the pattern }
      %if l = 1 %then %Start { single byte pattern }
         FILL(512,AD,BAD)  ;! bad contains filler byte if  l=1 
         bufsize = 512
      %finish %else %start { multiple byte pattern }
         bufsize = 0
         %cycle i = 1, 1, ncopies
            to = ad + bufsize
            MOVE(1,BAD,TO)
            bufsize = bufsize + l
            %if bufsize + l > 511 %then %exit
         %repeat
      %finish
      left = ncopies * l
      { And then write it out }
      %cycle
         %if left > bufsize %then blen = bufsize %else blen = left
         left = left - blen
         Fwrite(15,fileid,ad,blen)
      %repeat %until left <= 0
   %end
   !
   %ROUTINE RELOCATIONS
      ! Output UTX header, code area, data areas and relocations to object file
      %record (Relfm) %array TR(0:nTrels + 1)      ;! Build code reloc table here
      %record (Relfm) %array DR(0:nDrels + 1)      ;! Build data reloc table here
      %record (rfm) %name R
      %integer i, j, vad, type, TgtSym, A, hostdisp, format, Tgtsymtype, X
      %integer trctr, drctr, tgtdisp, rdisp, Extern, Gtgtsym
      %INTEGERARRAY SIZES (0:15)                                                ;! Array for private header info
      %record (relfm) %name rel
      %CONSTINTEGER MEMREF = 2                 ;! Memory Reference Instruction type relocation
      %CONSTINTEGER ABSCONST = 0               ;! Absolute Constant type relocation
      %CONSTINTEGER ADDRCONST = 1              ;! Address  Constant type relocation
      %CONSTBYTEINTEGERARRAY XREF (1:10) = %C
         10,  6,  4,  10, 12, 10,  0,  6, 14, 10
      FIX(254,2,2,20)                          ;! Put an end marker on the relocations
      Rels == Startrels
      trctr = 1
      drctr = 1
      i = 1
      %cycle                 { Through list of Relocation requests }
         R == Rels(i)
         Type = R_hostdisp >> 24
         hostdisp = R_hostdisp & X'FFFFFF'
         %if type = 254 %then %exit                 ;! End of relocs
         %if type = 255 %then rels == array(hostdisp,rafm)%and i = 1 %and %continue      { next block }
         TgtSym = R_tgt
   !     tgtdisp = r_tgtdisp
         tgtdisp = 0
         Extern = 0
         %if Tgtsym >= Setareas %then %start               { symbol id not an area }
                                        { Could be common,data xref or proc. }
            tgtsym = tgtsym - Setareas
            TgtSymType = syms(Tgtsym)_type
!            %if TgtSymType = EXT ! TEXT %then %start
!               ! An Xref has turned out to be an external routine in this module
!               ! Fill it in like a local call and ditch the Relocation request
!               -> skip
!            %finish
            %if TgtSymType = EXT %then Extern = 1 %else tgtsym = TEXT
             Gtgtsym=Tgtsym
         %finish %else %start                   { area id to be used }
            tgtdisp = areastart(tgtsym)
            A = AREAS(R_HOSTAREA)_BASE + HOSTDISP
            INTEGER(A) = INTEGER(A) + AREASTART(TGTSYM)
            GTGTSYM = XREF(TGTSYM)
!            %if R_hostarea = CODE %then tgtdisp = tgtdisp + (Textlen - hostdisp)
         %finish
         ! Work out where the relocation entry is and where it points
         %IF R_HOSTAREA = CODE %OR R_HOSTAREA = 3 %THEN %START                  ;! Text Relocation
            rel == TR(trctr - 1)
            trctr = trctr + 1
            %IF R_HOSTAREA = CODE %THEN %START
               %IF TGTSYM = GLA %OR TGTSYM = 3 %OR TGTSYM = IOTAB %THEN FORMAT = MEMREF %ELSE FORMAT = ADDRCONST
            %FINISH %ELSE FORMAT = ADDRCONST
         Vad=Hostdisp+Areastart(R_Hostarea)
         %FINISH %ELSE %START                                                   ;! Data Relocation
            rel == DR(drctr - 1)
            drctr = drctr + 1
            FORMAT = ADDRCONST
            VAD = HOSTDISP + AREASTART(R_HOSTAREA) - Dataoffset
         %finish
         ! Fill in relocation entry
         REL_ADDRESS = VAD
         ! Format of data word is SYMBOL:24 ; PCREL:1 (Not used on UTX) ; LENGTH:2 ; EXTERN:1 ; FORMAT:4
         { if extern=0 then symbol is target type }
         REL_DATA = (GTGTSYM << 8) ! (0 << 7) ! (2 << 5) ! (EXTERN << 4) ! (FORMAT)
         i = i + 1
       %repeat
      !
      ! Fill in the object file header (all sizes in the UTX header are in bytes)
      HDR = 0
      HDR_MAGIC = X'00000107'
      HDR_TEXT = TEXTLEN                                                        ;! Total size of Text Area
      HDR_DATA = DATALEN
      HDR_BSS = BSSLEN
      HDR_SYMS = SYMLEN
      HDR_ENTRY = MAINENTRYPOINT
      HDR_TRSIZE = 8 * (TRCTR - 1)
      HDR_DRSIZE = 8 * (DRCTR - 1)
      HDR_STSIZE = DICTAD - DICTSTART
      HDR_NBTEXT = SFT                                                          ;! Size of Far Text
      HDR_NBDATA = AREAS(5)_LENGTH                                              ;! Size of Far Data
      HDR_NBBSS = BSSLEN                                                        ;! Size of Far BSS
      FWRITE(0,OBJID,ADDR(HDR),76)
      !
      ! Write out private header information (area sizes etc)
      SIZES(0) = X'4550434C'
      %CYCLE X = 1, 1, 15
         %IF X < 11 %THEN SIZES(X) = AREAS(X)_LENGTH %ELSE SIZES(X) = 0
      %REPEAT
      FWRITE(11,OBJID,ADDR(SIZES(0)),64)
      !
      ! Write out Text Areas
      %IF AREAS(3)_BASE # 0 %THEN %START                                        ;! Area 3
         L = AREAS(3)_LENGTH - 64
         FWRITE(3,OBJID,AREAS(3)_BASE + 64,L)
         FREE(AREAS(3)_BASE)
      %FINISH
      FWRITE(1,OBJID,ADDR(CODEAREA(0)),AREAS(1)_LENGTH)                         ;! Area 1
      %IF AREAS(10)_BASE # 0 %THEN %START                                       ;! Area 10
         L = AREAS(10)_LENGTH
         FWRITE(10,OBJID,AREAS(10)_BASE,L)
         FREE(AREAS(10)_BASE)
      %FINISH
      %IF AREAS(4)_BASE # 0 %THEN %START                                        ;! Area 4
         L = AREAS(4)_LENGTH
         FWRITE(4,OBJID,AREAS(4)_BASE,L)
         FREE(AREAS(4)_BASE)
      %FINISH
      %IF AREAS(6)_BASE # 0 %THEN %START                                        ;! Area 6
         L = AREAS(6)_LENGTH
         FWRITE(6,OBJID,AREAS(6)_BASE,L)
         FREE(AREAS(6)_BASE)
      %FINISH
      !
      ! Move Data areas into position
      ad = DataStart     
      %CYCLE I = 2, 1, TOPAREA
         %IF I = 3 %OR I = 4 %OR I = 6 %OR I = 10 %THEN %CONTINUE
         l = areas(i)_length
         %continue %if l = 0 %or (i = zgst %and bsslen # 0)
         %continue %if areas(i)_type = code
         %if i = 5 %or i > setareas %then %Start   { encoded area }
            areabase = LSEEK(Objid,0,1) {where am I?}
            filler = areas(i)_type >> 24
            %if filler # 0 %then %start   { to be pre-patterned }
               pattern(objid,l,1,filler)
               FilePosition(Objid,areabase,0) { put file back to start of area }
            %finish
            %if areas(i)_base = 0 %then %start
               %if i > setareas %then %continue %else -> empty
            %finish
            linkdisp = 0
            %cycle                                 { Through area frags.}
               RD == RECORD(areas(i)_base + linkdisp) 
               FilePosition(Objid,RD_disp + areabase,0)
               KAD = (AREAS(I)_BASE + LINKDISP) + RDSIZE
               %if RD_copies > 1 %then %start
                  %if RD_len = 1 %then kad = byteinteger(kad)
                  pattern(objid,RD_copies,RD_len,kad) 
               %finish %else FWRITE(I,Objid,kad,RD_len)
               LINKDISP = (LINKDISP + ((RD_LEN + RDSIZE + 1)) + 1) & (-2)
            %repeat %until Addr(RD) - areas(i)_base = areas(i)_linkdisp
      empty:
            FilePosition(Objid,areabase + l,0)    
         %finish %else %start            { mapped area }
            %if areas(i)_base # 0 %then %start    { has any initialisation been recvd? }
               FWRITE(I,OBJID,AREAS(I)_BASE,L)
               FREE(AREAS(I)_BASE)
            %finish %else FILE POSITION(Objid,l,1)
         %finish
      %repeat
      !
      ! Write out relocation tables
      %IF NTRELS > 0 %THEN FWRITE(12,OBJID,ADDR(TR(0)),8 * (TRCTR - 1))
      %IF NDRELS > 0 %THEN FWRITE(12,OBJID,ADDR(DR(0)),8 * (DRCTR - 1))
   %END
   !
   %ROUTINE SYMBOL TABLES
      ! Output symbol tables to object file
      %record (symfm) %name s
      %IF HOST = EMAS %THEN %START
         %HALFINTEGERARRAY BUF (0:6 * (NEXTSYM + 1))
      %FINISH
      %IF HOST = EMASA %THEN %START
         %SHORTINTEGERARRAY BUF (0:6 * (NEXTSYM + 1))
      %FINISH
      %integer i, j, strx
      %CYCLE I = 0, 1, NEXTSYM 
         s == syms(i)
         j = i * 6
         STRX = S_STRX
         BUF(J) = STRX >> 16 ;! cannnot use a record array because of 4 byte 
         BUF(J + 1) = STRX & X'FFFF'     ;! alignment 
         BUF(J + 2) = S_TYPE << 8
         BUF(J + 3) = S_DESC
         %if s_type = EXT ! DATA %then s_value = s_value + textlen
         %IF S_TYPE = X'A1' %OR S_TYPE = X'B' %THEN S_VALUE = S_VALUE + SNT
         BUF(J + 4) = S_VALUE >> 16
         BUF(J + 5) = S_VALUE & X'FFFF'
      %repeat
      j = j + 6
      FWRITE(13,OBJID,ADDR(BUF(0)),J * 2)
   %END
   !
   %ROUTINE DICTIONARY
      ! Output dictionary (string table) to object file
      %integer i, j
      %byteintegerarrayformat bfm(0:255)
      %byteintegerarrayname b
      %IF MON # 0 %THEN %START
         PRINTSTRING("OUTPUT DICTIONARY - DICTAD: ".HTOS(DICTAD,8)." DICTSTART: ".HTOS(DICTSTART,8).SNL)
      %FINISH
      J = DICTAD - DICTSTART
      INTEGER(DICTSTART) = J   ;! Fill in string table length 
      I = DICTSTART + 4
      %cycle
         S = STRING(I)
         L = BYTEINTEGER(I)          ;! L = LENGTH(S)
         b == array(i,bfm)
         b(j - 1) = b(j) %for j = 1,1,l 
         b(l) = 0
         I = I + L + 1
      %repeat %until i = Dictad
      FWRITE(14,OBJID,DICTSTART,DICTAD - DICTSTART)
   %END
   !
   !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++Main routine start
   !
   %return %unless faulty = 0
   %IF MON # 0 %THEN PRINTSTRING("M GENERATE".SNL)
!   PRINTSTRING(SNL."Max data before object generation = ".HTOS(MAXDATA,4))
   areastart(i) = 0 %for i = 1,1,toparea
   ! Work out size of major parts of object file
   SFT = AREAS(1)_LENGTH + AREAS(10)_LENGTH + AREAS(4)_LENGTH + AREAS(6)_LENGTH
   SNT = AREAS(3)_LENGTH
   TEXTLEN = SFT + SNT
   DataStart = Codestart + textlen
   Symlen = (NextSym + 1) * 12
   bsslen = 0    { Only the Zero-Gst area goes directly }
                                 { into BSS. The linker will look after }
                                 { the uninit. commons which also       }
                                 { belong in BSS.                       }
   !
   ! MOVE AREAS INTO POSITION
   %if  areas(zgst)_length > 0 %and areas(zgst)_max = 0 %then %start
      bsslen = areas(zgst)_length
   %finish
   datalen = 0
!   %CYCLE I = 2, 1, TOPAREA
!      %continue %if areas(i)_type = code
!      %continue %if (i = zgst %and bsslen # 0)
!      %continue %if i > setareas %and areas(i)_max = 0
!      DATALEn = datalen + areas(i)_length
!   %repeat
   DATALEN = AREAS(2)_LENGTH + AREAS(8)_LENGTH + AREAS(5)_LENGTH
   ad = DataStart
   %cycle j = 2, 1, toparea
      %if j < 11 %then i = order(j) %else i = j {strict order on data areas }
      l = areas(i)_length
      %continue %if l = 0 %or (i = zgst %and bsslen # 0)
      %continue %if areas(i)_type = code
      %if i > setareas %then %start  {  common  }
         %if imp # 0 %then %exit
         %continue %if areas(i)_max = 0 { uninitialised cmn }
         i = areas(i)_sym - 20 
         syms(i)_value = ad - DataStart
      %finish %else %START
         AREASTART(3) = 0
         AREASTART(1) = AREAS(3)_LENGTH
         AREASTART(10) = AREAS(1)_LENGTH + AREASTART(1)
         AREASTART(4) = AREAS(10)_LENGTH + AREASTART(10)
         AREASTART(6) = AREAS(4)_LENGTH + AREASTART(4)
         AREASTART(5) = Areas(6)_Length + Areastart(6)
         AREASTART(2) = AREAS(5)_LENGTH + Areastart(5)
         AREASTART(8) = AREAS(2)_LENGTH + AREASTART(2)
         Dataoffset = Areastart(5)
      %FINISH
      ad = ad + l
   %repeat 
   ! Output generated fragments to object file in final order
   RELOCATIONS
   SYMBOL TABLES
   FREE(ADDR(SYMS(0)))
   DICTIONARY
   EMASCLOSE                             ;! Tidy up file header (EMAS only)
%END
!
%EXTERNALROUTINE M MONON
   MON = 1
%END
!
%EXTERNALROUTINE M MONOFF
   MON = 0
%END
!
%EXTERNALROUTINE M TRACEON
%END
!
%EXTERNALROUTINE M TRACEOFF
%END
!
%ENDOFFILE