!*****************************
!*                           *
!*   Vax VMS PUT INTERFACE   *
!*                           *
!*****************************

!
! Put interface for VAX VMS copyright P.D.Stephens
!
! The problem of a put for VMS is dominated by two problems
!    1) The horrendous object module format which must be tholed
!    2) The jumps which can be short or long PC relative or absolute
!       with the horrid proviso that even the long jump may not reach
!       and absolute jumps are unconditional. Thus put has to
!       be prepared to change jumps to jumps around a long jump.
!
! Outline of a solution
! Code and data is recieved in fragments and built up in areas as images
! The areas are as defined by EMAS and apart from code built up as images
! in space obtained by malloc or eqivalent. The areas start small and are
! expanded if required.
! The code are is a linked list kept in order of code fragments,branches and
! labels. Code fragments are allocated a CA based on all jumps being
! six bytes but there is space in the fragment header for a revised CA.
! In pterminate the fragments are processed the junp sizes determined and
! final CAs allocated to each fragment and label. A further pass fills in
! the jumps.
!
! In Pgenerate object the areas are written out in psects being roughly
! the Emas object file areas.

! Relocations and external symbols are built up in separate areas but all those
! referring to or from codehave to ba adjusted when the final fragment address
! is determined. Hence the pointer to relevant fragment in the tables
!
! relocations and global symbol definitions go out last
!

      { Tracing control }

      { Trace all significant calls on interface if: }
      { comreg(26)&1#0 or }
      { as directed by calls on p,lrocs. Pmonon/Pmonoff }

      { Seldom required info controlled by bits of comreg(26) as follows: }
      { 2 - monitor detailed byte planting}

      { 4  -  switch on sdb }
      { 8  -  Heap access monitored }
      { 16 -  File use monitoring }
      { 128 - Requests for more space by Malloc, Expand Area etc. }
      { X4000 - Decode each instrn as planted }
      { X8000 - Dump file after tidying    }

%OWN %INTEGER decode { print instrs as received }


%CONST %INTEGER trusted=0    { 0 =  check inputs }
%OWN %INTEGER sdb= 0
%INCLUDE "itrimp_hostcodes"
%CONST %INTEGER host=ibmxa
%CONST %INTEGER target=vax
%CONST %INTEGER wordad=0,ext=1,common=128
      {  C  routines used on UNIX   }

%EXTERNAL %INTEGER %FN %SPEC MALLOC(%INTEGER bytesize)
%EXTERNAL %INTEGER %FN %SPEC REALLOC(%INTEGER oldptr,bytesize)
%EXTERNAL %ROUTINE %SPEC FREE(%INTEGER bytead)

!%EXTERNALROUTINESPEC   CSTRING(%STRINGNAME Impstring,%INTEGER bytad Cstring)
!%EXTERNALROUTINESPEC   FREE SOURCE AREAS
%EXTERNAL %INTEGER %MAP %SPEC comreg %ALIAS "S#COMREGMAP"(%INTEGER n)
!%DYNAMICROUTINESPEC        Ccode(%INTEGER start,finish,procbase,ca)
%EXTERNAL %ROUTINE %SPEC Phex %ALIAS "S#PHEX"(%INTEGER n)
%EXTERNAL %STRING (*) %FN %SPEC ITOS %ALIAS "S#ITOS"(%INTEGER i)
%EXTERNAL %STRING (*) %FN %SPEC htos %ALIAS "S#HTOS"(%INTEGER i,size)
%EXTERNAL %ROUTINE %SPEC Fill %ALIAS "S#FILL"(%INTEGER l,ad,filler)
!%EXTERNAL %ROUTINE %SPEC move %ALIAS "S#MOVE"(%INTEGER l,fr,to)
      %IF host=IBMXA %START
      %EXTERNAL %ROUTINE %SPEC ByteMove %ALIAS "S#MOVE"(%INTEGER len,from,to)
      %EXTERNAL %ROUTINE %SPEC emas3exist(%STRING %NAME s, %INTEGER %NAME flag)
      %EXTERNAL %ROUTINE %SPEC emas3destroy(%STRING %NAME s, %INTEGER %NAME flag)
      %EXTERNAL %ROUTINE %SPEC emas3claimchannel(%INTEGER %NAME flag)
      %EXTERNAL %ROUTINE %SPEC emas3(%STRING %NAME cmd,params, %INTEGER %NAME flag)
      %EXTERNAL %ROUTINE %SPEC writesq(%INTEGER ch, %NAME first,last)
      %EXTERNAL %ROUTINE %SPEC opensq(%INTEGER ch)
      %EXTERNAL %ROUTINE %SPEC closesq(%INTEGER ch)
      %FINISH

      { Heap access }

%CONST %INTEGER default area size= (4*1024) - 8  { 8 for malloc control words }
%CONST %INTEGER default code size=256*1024-8
%CONST %INTEGER endoflist=0
%RECORD %FORMAT Heapfm(%INTEGER link,id,disp,spare)
%EXTERNAL %ROUTINE %SPEC Initialise Heap
%EXTERNAL %ROUTINE %SPEC Put on Heap(%INTEGER ID,DISP, %INTEGER %NAME START)
%EXTERNAL %ROUTINE %SPEC Put2 on Heap(%INTEGER ID,DISP,disp2, %INTEGER %NAME START)
%EXTERNAL %INTEGER %FN %SPEC Find and remove from Heap(%INTEGER id, %INTEGER %NAME Start)
%EXTERNAL %INTEGER %FN %SPEC Find on Heap(%INTEGER id, %INTEGER %NAME Start)
%EXTERNAL %ROUTINE %SPEC Free Heap list(%INTEGER %NAME at)

!******************************************************************************
%EXTERNAL %INTEGER CA=0                    { code address}


%CONST %INTEGER SYMSIZE=32  { max bytes in a name ( Possibly more would be ok) }
%CONST %INTEGER SYMBOLTABLEENTRYSIZE= 8
%CONST %INTEGER intsymsize= 12
%CONST %INTEGER InitialSymbolTableSize= defaultareasize
%CONST %INTEGER onemegabyte= (1024*1024)
%CONST %INTEGER twomegabyte= (1024*2*1024)
%CONST %INTEGER infinity= x'FFFFFE'


%CONST %INTEGER mode=K'00664' { mode of object creat, read/write for all }
%OWN %INTEGER objid { File descriptor ID of object file }

%OWN %INTEGER imp= 0
%OWN %INTEGER Faulty=0
%OWN %STRING (32) SrcFile= "source unknown" , Objfile="??"
%OWN %STRING (63) Compiler title="Unknown Compiler"
%OWN %INTEGER curlexlev=0
%OWN %INTEGER mon=0                   { Put call monitoring control }
%owninteger fmon=0;                    ! dump link file monitoring
%OWN %INTEGER NextSym=-1              { Index to symbol table. +1 for each entry }
%OWN %INTEGER NextDBXsym= -1
%OWN %INTEGER MainEntryPoint= 0
%OWN %INTEGER Codestart
%OWN %INTEGER Line=0                    { Current Line number as set by start}
%OWN %INTEGER nextinclude= -2
      %OWN %INTEGER %ARRAY includeindex(1:100)=0(*)
%OWN %INTEGER incommon=0
%OWN %INTEGER channel=0
!
!                               +++++ fragment processing formats and consts ++++
!
%RECORD %FORMAT fragform(%BYTE type,flags, %INTEGER ca,adj,length,flink,blink,
   (%INTEGER instrn,dummy,label,lindex %OR %BYTE %ARRAY code(0:15)))
%CONST %INTEGER fragmax=240;             ! Less than a byte for relocations
%CONST %INTEGER codetype=1,brtype=2,labtype=3,marktype=4,swtype=5,calltype=6,
                pmasktype=7
%CONST %INTEGER codefraglength=24,brfraglength=40,labfraglength=40
%constinteger callfraglength=40
%CONST %BYTE %INTEGER %ARRAY frag lengths(0:7)=32,codefraglength,brfraglength,
                                       labfraglength,codefraglength,labfraglength,
                                       callfraglength,codefraglength;
%CONST %INTEGER defaultjsize=6
!
! fragment flags signify
! 2**0 set unconditional (Brtype only)
! 2**1 set Give proc address (Call type only)
! 2**7 set Byte displacement enough (Branches and calls)
! 2**6 set 16 bit displacement enough ( Branches and calls only)
!


%OWN %INTEGER area1base=0,area1ptr=0,oldptr=0
%OWN %RECORD (fragform) %NAME currfrag,oldfrag


      {<-- SYMBOL VARIABLES -->}

      { This is an internal format, not as found in the object }

%RECORD %FORMAT Symfm(%INTEGER strx, %BYTE %INTEGER type,desc,Proclevel,area,
   %INTEGER value)
      %OWN %RECORD (Symfm) %ARRAY %FORMAT Symafm(0:100000)
%OWN %RECORD (Symfm) %ARRAY %NAME Syms,DBXsyms
%OWN %INTEGER maxsyms,maxDBXsyms

%INCLUDE "ercs04:stabh"

      {<-- RELOCATION VARIABLES -->}

      { This format for internal storage of reloc details }
%RECORD %FORMAT rfm(%BYTE %INTEGER type,hostarea, %SHORT %INTEGER tgt,
   %INTEGER hostdisp,tgtdisp)
%CONST %INTEGER Rsize= 12 { sizeof(rfm) when sizeof working }
%CONST %INTEGER Maxrels=defaultareasize//rsize   { 511 }
      %OWN %RECORD (rfm) %ARRAY %FORMAT rafm(1:100000)
%OWN %RECORD (rfm) %ARRAY %NAME Rels,
                             Startrels
%OWN %INTEGER Crel=0         { current relocation pointer }
%RECORD %FORMAT Relfm(%INTEGER address,data)
%OWN %INTEGER NDrels=0,NTrels=0 { num of rels to .code, .data}



      {<-- CODE AREA VARIABLES -->}

%CONST %INTEGER workfilesize= onemegabyte
%CONST %INTEGER maxlexlev= 20                            { Maximum Lexical Level - assured IMP cannot go deeper than this. }
%RECORD %FORMAT blockfm(%INTEGER ad,CA,jmps,labs,sym,psize)
      %OWN %RECORD (blockfm) %ARRAY blocks(-1:maxlexlev)
%OWN %RECORD (blockfm) %NAME parentblock,                                { descriptor of surrounding procedure }
                           curblock                                    { descriptor of current procedure }

%OWN %INTEGER Linestart=0

      {<--- OBJECT AREAS --->}

%CONST %INTEGER code=1,
              gla=2,
              {free3}
              sst=4,
              gst=5,
              diags=6,
              static=7,
              iotab=8,
              zgst=9,
              Cnst=10,

              DBXsymtab = 17,
              Dicttab= 18,
              Symtab = 19

      %CONST %STRING (6) %ARRAY areanames(1:10)="Code",
                                       "Gla",
                                       "PLT",
                                       "Sst",
                                       "Gst",
                                       "Diags",
                                       "Static",
                                       "Iotab",
                                       "Zgst",
                                       "Cnst"
      %CONST %BYTE %INTEGER %ARRAY UPPER CASE ISO(0:255)= %C
      0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
      16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,
      32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
      48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
      64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
      80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
      96,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
      80,81,82,83,84,85,86,87,88,89,90,123,124,125,126,127,
      128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,
      144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,
      160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,
      176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,
      192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,
      208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,
      224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,
      240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255

%CONST %INTEGER SetAreas= 20
%OWN %INTEGER Max Area= 0     { Number of areas there is space for in the current slot }
%OWN %INTEGER Top Area= 21     { Highest area number used }
%RECORD %FORMAT Areafm(%INTEGER Base,Max,Length,sym, %SHORT psect,type,
   %INTEGER linkdisp)
%CONST %INTEGER sizeofareaentry= 24
      %OWN %RECORD (Areafm) %ARRAY %FORMAT AreaAfm(0:10000)
%OWN %RECORD (areaAfm) %ARRAY %NAME Areas

      { Heap list heads }
%OWN %INTEGER jmpstart,             { Unsatisfied Jumps }
            labstart,             { Labels in scope }
            CallStart,            { Forward Proc instrs. }
            Switchstart,          { Imp Switches }
            GOTOstart             { Fortran Computed GOTO labels }


%OWN %INTEGER filemon

%OWN %INTEGER dictad= 0          { symbol table dictionary pointer }
%OWN %INTEGER maxdictad= 0          { current ad of dictionary end }
%OWN %INTEGER malmon=0
%OWN %INTEGER maxdata=0
%OWN %INTEGER boff=-1,lineca=0
%OWN %INTEGER swad
%OWN %INTEGER Dictstart,dictindex
%OWN %INTEGER olddecode


!******************************************************************************
%INTEGER %FN %SPEC locate cablk(%INTEGER reqca)
%ROUTINE %SPEC fix(%INTEGER type,area,disp,tgt,tdisp)
%ROUTINE %SPEC PSymbol(%STRING (255) s, %INTEGER type,area,val)
%ROUTINE %SPEC DBXsym(%STRING (255) s, %INTEGER type,desc,value)
%ROUTINE %SPEC MSDBvar(%INTEGER swad,type,area,disp,bytesize,nels,nd,l1,u1)
%ROUTINE %SPEC PD4(%INTEGER area,disp,val)
%ROUTINE %SPEC pgenerateobject(%STRING (*) %NAME file)
%INTEGER %FN %SPEC tidy code
!integerfnspec swopof(%INTEGER n)
%ROUTINE %SPEC prepare object
%ROUTINE %SPEC write record(%NAME first,last)
%ROUTINE %SPEC write headers
%ROUTINE %SPEC set loc cntr(%BYTE %ARRAY %NAME buf, %INTEGER %NAME ptr, %INTEGER a,o)
%ROUTINE %SPEC set area offset(%BYTE %ARRAY %NAME buf, %INTEGER %NAME ptr, %INTEGER a,o)
%ROUTINE %SPEC write code
%ROUTINE %SPEC flush buffer(%BYTE %ARRAY %NAME buf, %INTEGER %NAME ptr)
%ROUTINE %SPEC addfrag(%BYTE %ARRAY %NAME buf, %INTEGER %NAME ptr, %INTEGER ad,len)
%ROUTINE %SPEC define psects
%ROUTINE %SPEC close object
%ROUTINE %SPEC ncode1(%INTEGER %NAME b,ca)
%STRING (17) %FN %SPEC vaxdt
!******************************************************************************

%INCLUDE "ercc07:vaxopcodes"

!**********************
!*  SERVICE ROUTINES  *
!**********************



!******************************************************************************
%ROUTINE phexbyte(%INTEGER n)
      printstring(htos(n,2))
%END
%ROUTINE dump(%INTEGER add,length)
      %CONST %BYTE %INTEGER %ARRAY hexds(0:15)='0','1','2','3','4','5','6','7',
                                   '8','9','A','B','C','D','E','F'
%INTEGER i,j,k,ad,end,sptr,val,add0
%STRING (132) s
      ad=addr(s)
      add=add&(-4); add0=add
      newline
      end=add+length; i=1
      s=" "
      %UNTIL add>=end %CYCLE
         j=add+31
         %IF i=0 %AND add+32<end %THEN %START
            %CYCLE k=add,4,add+28
               ->on %IF integer(k)#integer(k-32)
            %REPEAT
            s="O"; ->up
         %FINISH
on:
         byteinteger(ad+2)='('; sptr=3
         k=add-add0
         %CYCLE i=28,-4,0
            byteinteger(ad+sptr)=hexds((k>>i)&15)
            sptr=sptr+1
         %REPEAT
         byteinteger(ad+sptr)=')'
         byteinteger(ad+sptr+1)=' '
         sptr=sptr+2
         %CYCLE k=add,4,add+28
            val=integer(k)
            %CYCLE i=28,-4,0
               byteinteger(ad+sptr)=hexds((val>>i)&15)
               sptr=sptr+1
            %REPEAT
            byteinteger(ad+sptr)=' '
            sptr=sptr+1
         %REPEAT
         byteinteger(ad+sptr)=nl
         byteinteger(addr(s))=sptr
         printstring(s)
         s=" "
up:      add=add+32
         i=0
      %REPEAT
%END;                                    !routine dump
%ROUTINE PERROR(%STRING (255) s)
      Printstring("

*** Put Interface Error/ ".s."
")
!  %RETURN %IF faulty#0 {try and keep going to allow report of multiple faults }
      dump(area1base,area1ptr+32)
      %MONITOR
      %STOP
%END

!*****************************************************************************
      { This is the interface to MALLOC  }

%EXTERNAL %INTEGER %FN Get Space(%INTEGER size{bytes})
%INTEGER flag

      %IF malmon#0 %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( %C
         " Not enough Swap space. (Perhaps background task has reduced space available".%C
         "?)  ")
      %RESULT=flag
%END


!***********************************************
!***************************************************************************
%ROUTINE expand area(%INTEGER id)
%INTEGER from,ad,newsize,oldsize,filler,type
%STRING (63) name

      { 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 %C
         (from,8)." ".htos(oldsize,8)."
")
      %IF oldsize=0 %START { First use of this area }

         newsize=default area size
         %IF id=code %THEN newsize=default code size
         ad=Get Space(newsize)>>wordad
         Perror("Get Space fails") %IF ad=0
         %UNLESS type=code %THEN Fill(newsize,ad,filler)

      %FINISH %ELSE %START { Expansion of existing area }

         newsize=(oldsize*2)+8
         ad=REALLOC(from<<wordad,newsize)>>wordad
         { zero additional area on back }
         Fill(oldsize,ad+(oldsize>>wordad),filler) %UNLESS type=code
         %IF malmon#0 %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
      areas(id)_max=newsize
      %IF id=1 %THEN area1base=ad
%END


!******************************************************************************



!*********************************************
!* PUT interface Code passing routines       *
!*********************************************

%ROUTINE Newfrag(%INTEGER type)
!***********************************************************************
!*    Start a new fragment of specified type finish previous one       *
!***********************************************************************
%INTEGER i
      oldfrag==currfrag; oldptr=area1ptr
      i=CA-oldfrag_ca;                   ! no of code bytes in this frag
      oldfrag_length=i
      %IF oldfrag_type=codetype %OR currfrag_type=marktype  %or currfrag_type=pmasktype %START
         %IF i=0 %THEN oldptr=currfrag_blink %AND ->set
         area1ptr=(area1ptr+i+codefraglength+3)&(-4)
      %ELSE
         area1ptr=area1ptr+fraglengths(oldfrag_type)
      %FINISH
      oldfrag_flink=area1ptr
set:
      %IF area1ptr>=areas(CODE)_max-1024 %START
         expand area(CODE)
      %FINISH
      currfrag==record(area1base+area1ptr)
      currfrag=0
      currfrag_type=type
      currfrag_blink=oldptr
      currfrag_ca=CA
%END
%INTEGER %FN locate cablk(%INTEGER reqca)
!***********************************************************************
!*    Return the offset of the fragment which includes reqca           *
!**********************************************************************
%RECORD (fragform) %NAME frag
%INTEGER i
      frag==currfrag
      %IF reqca>ca %THEN perror("Forward relocation??")
      %CYCLE
         i=frag_blink
         %IF frag_type=codetype %OR frag_type=marktype%or frag_type=Pmasktype %START
            %IF reqca>=frag_ca %THEN %RESULT=addr(frag)-area1base
         %FINISH
         %IF i=0 %THEN perror("Code unlocatable")
         frag==record(area1base+I)
      %REPEAT
%END
%EXTERNAL %ROUTINE PH(%INTEGER n)
!***********************************************************************
!*    16 bits into code stream                                         *
!***********************************************************************
%INTEGER i
      %RETURN %IF faulty#0
      i=CA-currfrag_ca
      %IF i>=fragmax %THEN newfrag(codetype) %AND i=0
      i=i+codefraglength+area1base+area1ptr
      byteinteger(i)=n&255
      byteinteger(i+1)=(n>>8)&255
      CA=CA+2
%END


%EXTERNAL %ROUTINE PB(%INTEGER n)
!***********************************************************************
!*    Put 16 bits into the code stream                                 *
!***********************************************************************
%INTEGER i
      %RETURN %IF faulty#0
      %if mon&2 #0 %then %start
         printstring("PB"); write(n,4); write(Ca,4)
         newline
      %finish
      i=CA-currfrag_ca
      %IF i>=fragmax %THEN newfrag(codetype) %AND i=0
      i=i+codefraglength+area1base+area1ptr
      byteinteger(i)<-n
      CA=CA+1
%END

%ExternalROUTINE Popcode(%INTEGER n)
!***********************************************************************
!*    Plant an opcode normally one byte but allowing 2byte forms       *
!***********************************************************************
      %IF n<=255 %THEN pb(N) %AND %RETURN
      %IF n>>8=X'FD' %THEN Pb(X'FD') %and Pb(N&255) %AND %RETURN
      Perror("Funny opcode given")
%END
%EXTERNAL %ROUTINE PW(%INTEGER n) { 32 bits into code stream }
%INTEGER i
      %RETURN %IF faulty#0
      i=CA-currfrag_ca
      %IF i>=fragmax %THEN newfrag(codetype) %AND i=0
      i=i+codefraglength+area1base+area1ptr
      byteinteger(i+3)=(n>>24)&255
      byteinteger(i+2)=(n>>16)&255
      byteinteger(i+1)=(n>>8)&255
      byteinteger(i)=n&255
      CA=CA+4
%END
%externalroutine Plit(%integer Literal,size)
!***********************************************************************
!*    Output a literal chosing between Literal and Immediate forms     *
!***********************************************************************
      %if 0<=Literal<=63 %then PB(Literal) %and %return
      PB(X'8F')
      %if size=1 %then PB(Literal ) %and %return
      %if size=2 %then PH(literal) %and %return
      PW(Literal)
%end

!***********************************************************************
!*
%EXTERNAL %ROUTINE pcodebytes(%INTEGER len,ad)
%INTEGER i,bad,j

!   %IF mon#0 %START
!      printstring(" pcodebytes  len  = ".itos(len))
!      space
!      bad = ad*(target+1)
!      %IF len=1 %THEN phexbyte(byteinteger(bad)) %ELSESTART
!         %CYCLE i=bad,1,bad+len-1
!            %IF i&1=0 %THEN j=i+1 %ELSE j=i-1
!            Phexbyte(byteinteger(j))
!         %REPEAT
!      %FINISH
!      newline
!   %FINISH

      %RETURN %IF faulty#0
      bad=ad<<wordad
      %IF len=1 %THEN pb(byteinteger(bad)) %ELSE %START
         %CYCLE i=bad,1,bad+len-1
            %IF i&1=0 %THEN j=i+1 %ELSE j=i-1
            Pb(byteinteger(j))
         %REPEAT
      %FINISH
%END
!*
!***********************************************************************
!*
%EXTERNAL %INTEGER prev= 0

!*
!***********************************************************************
!*

%EXTERNAL %ROUTINE PBdisp(%INTEGER Bmode,disp)
!***********************************************************************
!*    Plant base and Disp operand. Bmode is the longword mode          *
!*    it is reduced if byte or word offset enough                      *
!***********************************************************************
%INTEGER i
      %RETURN %IF faulty#0
      i=CA-currfrag_ca
      %IF i>=fragmax %THEN newfrag(codetype) %AND i=0
      i=i+codefraglength+area1base+area1ptr
      %IF-128<=disp<=127 %THEN %START
         byte integer(i)=Bmode-X'40'
         byteinteger(I+1)=disp&x'FF'
         CA=CA+2
      %FINISH %ELSE %IF X'FFFF8000'<=disp<=X'7FFF' %START
         byteinteger(i)=Bmode-X'20'
         byteinteger(I+1)=disp&255
         byteinteger(I+2)=(disp>>8)&255
         CA=CA+3
      %FINISH %ELSE %START
         PB(Bmode)
         PW(disp)
      %FINISH
%END
!*
!***********************************************************************
!*

%EXTERNAL %ROUTINE PFixdisp(%INTEGER type,tgt,tdisp)

      %IF mon#0 %START
         printstring("  PfixDisp type = ")
         write(type,1)
         printstring(" to ")
         write(tgt,1)
         printstring(" + ")
         write(tdisp,1)
         printstring(" CA = ")
         phex(ca)
!         space
!         phex(addr(codearea(CA)))
         newline
      %FINISH

      %RETURN %IF faulty#0
      FIX(4,CODE,CA,tgt,tdisp)
      PW(0)
%END



%EXTERNAL %ROUTINE PJIndex(%INTEGER op,label,reg1,reg2)
      %IF mon#0 %THEN printstring("  PJIndex
")
%END
%EXTERNAL %ROUTINE pprocentry(%INTEGER ad)
      %IF mon#0 %THEN printstring("  pprocentry
")
%END



!******************************************************************************
%EXTERNAL %ROUTINE Plinestart(%INTEGER lineno)
%OWN %INTEGER lastline= -1

      %RETURN %IF faulty#0
      %IF mon#0 %THEN printstring(" Plinestart - lineno: ".itos(lineno)."  at ".itos %C
         (ca)."
")
      Linestart=CA
      Lineca=ca %unless decode#0;  ! restrict plinedecode to 1 line
                                   ! unless  full decoding requested
      Line=Lineno
      %IF sdb#0 %START { save data for line map }
         %RETURN %IF lineno=0
         %IF line=1 %START { include file ? }
            nextinclude=nextinclude+1
            %IF nextinclude>0 %THEN DBXsym("",SOL,includeindex(nextinclude),linestart)
         %FINISH
         { sdb gets confused by repeated line numbers }
         %IF lineno#lastline %THEN Dbxsym("",SLINE,lineno,CA)
         lastline=lineno
      %FINISH
%END

%EXTERNAL %ROUTINE plinedecode
      %IF mon#0 %THEN %start
         printstring("  plinedecode")
         write(lineca,4); write(ca,4)
      %finish
      %RETURN %IF faulty#0
      %IF boff=-1 %OR CA<lineca %THEN Boff=locate cablk(0)
      ncode1(Boff,lineca) %WHILE lineca<CA
      newline
%END
%EXTERNAL %INTEGER %FN Pmarker(%INTEGER halfwords)
!***********************************************************************
!*    Set a marker so that a code value (normally const) can be given  *
!*    later. Set up a new fragment of marktype and return its offset   *
!***********************************************************************
%INTEGER start
      %RESULT=0 %IF faulty#0
      newfrag(marktype)
      start=area1ptr
      %IF mon#0 %THEN printstring("
  PMark: ".itos(CA))
      CA=CA+2*halfwords
      newfrag(codetype)
      %RESULT=start
%END
%EXTERNAL %ROUTINE PSetOpd(%INTEGER MarkerID,Offset,New Value)
!***********************************************************************
!*    Fill the new value in the marker set by prvious routine          *
!***********************************************************************
%INTEGER at
%RECORD (fragform) %NAME Marker
      %RETURN %IF faulty#0
      %if Mon#0 %Start
         Printstring("
Pset opnd"); write(markerid,5); write(offset,2); write(Newvalue,5)
         newline
      %finish
      marker==record(area1base+Markerid)
      %IF marker_type#marktype %THEN Perror("Invalid Marker")
      at=addr(marker)+codefraglength+2*offset
      byteinteger(at)=newvalue&255; byteinteger(at+1)=(newvalue>>8)&255
%END
%EXTERNAL %ROUTINE PLabel(%INTEGER id)
!***********************************************************************
!*    Note a label and record it. Nothing can be done till code has    *
!*    been adjusted for branches that wont reach                       *
!***********************************************************************
%RECORD (Heapfm) %NAME Jmp,goto,sw
%INTEGER LabelDisp,at,i,j,k

      %IF decode#0 %START
         printstring("L".itos(id).":
")
      %FINISH

      newfrag(labtype)
      currfrag_Label=id
      %IF trusted=0 %AND find on heap(id,labstart)#0 %THEN %C
         Perror("Label set twice".itos(id))
      { remember the label unless it is a single shot and has been used }
      PutonHeap(id,area1ptr,Labstart)
      newfrag(codetype)
!
!  %IF imp=0 %START   { See if any Computed GOTOS used this label }
!     %CYCLE
!        i=find and remove from heap(id,GOTOstart)  {any gotos use this lab? }
!        %EXIT %IF i = 0                            { out if none or last }
!        goto == record(i)
!        k =Find on Heap(goto_disp{switchID},Switchstart)  { locate info on sw}
!        sw == record(k)
!        %IF decode#0 %START
!          printstring("
!goto: "); write(sw_disp,1); write(sw_spare,1); write(k,1); newline
!        %FINISH
!        j =  Labeldisp - SW_spare { swCA }           { plug for sw table }
!        %IF host=ibmxa %THEN j = (j<<16)!(j>>16)
!        PD4( SST, SW_disp{ tablead}+((goto_spare-1){index}*4), j)
!     %REPEAT
!   %FINISH
%END


%EXTERNAL %ROUTINE PJump(%INTEGER op,id,mask)
!***********************************************************************
!*    Record a jump Instrucn. Nothing more can be done till all        *
!*    fragment sizes have been finalised                               *
!*    The byte displacement forms only are expected for Op             *
!*    If the long forms are required they are used when disp is known  *
!***********************************************************************
%constbyteintegerarray conds(0:31)= %c
         BSBB(2),BGTR(2),BLSS(2),BNEQ(2),BEQL(2),BGEQ(2),BLEQ(2),BRB(2),
         BSBB(2),BGTRU(2),BLSSU(2),BNEQ(2),BEQL(2),BGEQU(2),BLEQU(2),BRB(2);
%RECORD (Heapfm) %NAME Lab
%INTEGER i,j
%STRING (255) s

      %RETURN %IF faulty#0
      S=""
      j=OP; 
      %IF op=Bcond %THEN j=conds(mask)
      newfrag(Brtype)
      currfrag_label=id
      currfrag_instrn=j<<24
      %IF op#Bcond %THEN currfrag_flags=1
      Ca=Ca+defaultjsize
      newfrag(codetype)
%END

%EXTERNAL %ROUTINE Pswitch(%INTEGER TableAd,Lower,Upper)
!***********************************************************************
!*    Define a switch table at tablead in sst                          *
!***********************************************************************
%RECORD (Heapfm) %NAME SW
      %RETURN %IF faulty#0
      %if Tablead+4*(upper-lower+1)>-areas(sst)_max %then expandarea(SST)
      Put2 on Heap(TableAd,lower,upper,Switchstart)
      %IF Imp=0 %START
         SWad=TABLEAD;                  ! Fortran only 1 active at a time
      %FINISH
%END
%EXTERNAL %ROUTINE PswitchLabel(%INTEGER tablead,entry)
!***********************************************************************
!*    Imp flavour SW label entry is CA                                 *
!***********************************************************************
%INTEGER i,j
%RECORD (Heapfm) %NAME Lab,SW

      %IF decode#0 %THEN PRINTSTRING("SW".ITOS(ENTRY)." OF SWITCH L".ITOS(tablead)) %C
         %AND newline
      %RETURN %IF faulty#0

      i=FindonHeap(tablead,Switchstart)
      Perror("PswitchLabel - Switch does not exist ") %IF trusted=0 %AND i=0
      SW==record(i)
      newfrag(swtype)
      j=4*(entry-sw_disp{lower})+tablead+areas(sst)_base
      integer(j)=area1ptr;                ! store frag offset into swtable
      currfrag_label=entry
      currfrag_lindex=i
      newfrag(codetype)
%END

%EXTERNAL %ROUTINE Pswitchval(%INTEGER Tablead,index,label)
!***********************************************************************
!*   Fortran flavout. SW(index) is at Label                            *
!***********************************************************************
%RECORD (Heapfm) %NAME SW
%INTEGER i,j
      %IF decode#0 %THEN PRINTSTRING("GOTO index:".ITOS(index)." IS Label: ".itos %C
         (Label)) %AND newline
      %RETURN %IF faulty#0
      %if swad#tablead %then perror("Fortan switces?")
      j=areas(sst)_base+tablead+4*index
      integer(j)=X'80000000'!label;   ! Label no & marker into sst
%END
%externalroutine psdefault(%integer Tablead,Label)
!***********************************************************************
!*    All unset entries in this switch to go to Label                  *
!***********************************************************************
%record(heapFm)%name SW
%integer i,j,k,lower,upper
      %if decode#0 %then printstring("Psdefault") %and newline
      i=Find on heap(Tablead,Switchstart)
      %if i=0 %then Perror("Nonexistent switch")
      Sw==record(i)
      lower=sw_disp; upper=sw_spare
      j=areas(4)_base+tablead
      %for i=lower,1,upper %cycle
         k=integer(j)
         %if k=0 %then integer(j)=X'80000000'!Label
        j=j+4
      %repeat
%end


!***********************************
!*                                 *
!* Put Interface Passing of Data   *
!*                                 *
!***********************************

%RECORD %FORMAT rdfm(%INTEGER disp,len,copies)
%CONST %INTEGER rdsize= 12

!******************************************************************************
%EXTERNAL %ROUTINE PDBYTES(%INTEGER CurArea,Disp,len,ad)
%RECORD (Areafm) %NAME A
%INTEGER i,bad,j,to,encoded,from
%RECORD (rdfm) %NAME r

      %RETURN %IF faulty#0
      %IF mon#0 %START
         printstring("  PD ( ".itos(Curarea)." len  = ".itos(len)." Disp=")
         write(disp,5)
         space
         bad=ad<<wordad
         %IF len=1 %THEN phexbyte(byteinteger(bad)) %ELSE %START
            %CYCLE i=bad,1,bad+len-1
               %IF i&1=0 %THEN j=i+1 %ELSE j=i-1
               Phexbyte(byteinteger(j))
            %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 %START
         Perror("bad displacement ") %IF disp<0 %OR disp>4000000
      %FINISH

      from=ad<<wordad { from Byte address }

      %IF encoded#0 %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<<wordad)+((rdsize<<wordad)*2)+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 %START {adjacent areas }

            to=((A_base+A_Linkdisp)<<wordad)+rdsize+R_len
            R_len=R_len+len

         %FINISH %ELSE %START { new start required }

            %IF host=ibmxa %START
               to=(A_base+A_Linkdisp+((rdsize+R_len+1)//2)+1)&(-2) {4b bnd}
            %FINISH %ELSE %START
               to=(A_base+A_Linkdisp+rdsize+R_len+3)&(-4)
            %FINISH

            R==record(to)
            A_linkdisp=to-A_base
            R_disp=disp
            R_len=len
            R_copies=1
            to=(to<<wordad)+rdsize

         %FINISH

      %FINISH %ELSE %START { normal mapped area }

         expand area(Curarea) %WHILE disp+len>A_max
         to=(A_Base<<wordad)+disp

      %FINISH

      %IF host=vax %START
         **from; **to; **len; *MVB
      %FINISH %ELSE %START
         ByteMove(len,from,to)
      %FINISH

%END


!******************************************************************************
%EXTERNAL %ROUTINE PD(%INTEGER area,Disp,Databyte)
%INTEGER i

      %RETURN %IF faulty#0
                                         !%RETURN %IF databyte=0
      %IF host=ibmxa %THEN i=databyte<<24 %ELSE i=databyte
      PDbytes(area,disp,1,addr(i))
%END

!******************************************************************************
!%EXTERNALROUTINE PD2(%INTEGER area, Disp, DataDoublebyte)
!  %RETURN %IF faulty#0
!  %RETURN %IF datadoublebyte=0
!  PDbytes(area,disp,2,addr(datadoublebyte)+1)
!%END

!******************************************************************************
%EXTERNAL %ROUTINE PD4(%INTEGER area,Disp,DataQuadbyte)
      %RETURN %IF faulty#0
                                         !%RETURN %IF dataquadbyte=0
      PDbytes(area,disp,4,addr(dataquadbyte))
%END

!******************************************************************************
%EXTERNAL %ROUTINE PDPATTERN(%INTEGER area,disp,ncopies,len,ad)
%INTEGER i,savemon,bad,j,k
%RECORD (Areafm) %NAME A
%INTEGER to,encoded,from
%RECORD (rdfm) %NAME r

      %RETURN %IF faulty#0
      %IF mon#0 %START
         printstring(" PDPattern( area = "); write(area,1)
         printstring(", disp = "); write(disp,1)
         printstring(", ncopies = "); write(ncopies,1)
         printstring(" filler = ")
         bad=ad<<wordad
         %CYCLE i=bad,1,bad+len-1
            %IF i&1=0 %THEN j=i+1 %ELSE j=i-1
            Phexbyte(byteinteger(j))
         %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 %START
         Perror("bad displacement ") %IF disp<0 %OR disp>4000000
      %FINISH

      from=ad<<wordad { copy to byte boundaries }
      %IF encoded#0 %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<<wordad)+(rdsize<<wordad)+R_len+len+3>A_max
         %IF host=ibmxa %START
            to=(A_base+A_linkdisp+((rdsize+r_len+1)//2)+1)&(-2)
         %FINISH %ELSE %START
            to=(A_base+A_linkdisp+rdsize+R_len+3)&(-4)
         %FINISH
         R==record(to)
         A_linkdisp=to-A_base
         R_disp=disp
         R_len=len
         R_copies=ncopies
         to=(to<<wordad)+rdsize

         %IF host=vax %START
            **from; **to; **len; *MVB
         %FINISH %ELSE ByteMove(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<<wordad)+disp

            %IF host=vax %START
               **from; **to; **len; *MVB
            %FINISH %ELSE ByteMove(len,from,to)
         %REPEAT
      %FINISH


%END



!**************************************************************
%ROUTINE place in dict(%STRING (*) %NAME name, %INTEGER %NAME set)
!***********************************************************************
!*    Stuff off name text and return key==offset from dictstart        *
!***********************************************************************
%INTEGER l
      l=(length(name)+2)&(-2)
      %IF dictad+l>maxdictad %START
         Expand area(dicttab)
         dictstart=areas(dicttab)_base
         dictad=dictstart+dictindex
         maxdictad=dictstart+(areas(dicttab)_max>>wordad)
      %FINISH

      string(dictad)=name
      set=dictindex
      dictad=dictad+l
      dictindex=dictindex+l
%END


!**********************************************
!*                                            *
!* Put Interface RELOCATION and REFERENCES    *
!*                                            *
!**********************************************

!******************************************************************************
%ROUTINE Psymbol(%STRING (255) name, %INTEGER type,area,Value)
!***********************************************************************
!*     remember a name and its properties for inclusion in the         *
!*     object file symbol tables                                       *
!*     names are piled end to end in the dictionary                    *
!*    area and value are not relevant for references                   *
!*    Internal procedures also go into the symbol table PDS presumes   *
!*    this is for consistency between internal and external calls      *
!*      The EXT bit (2**0) is not set for internals                    *
!***********************************************************************
%RECORD (Symfm) %NAME Sym
%INTEGER i

      %RETURN %IF faulty#0
      NextSym=NextSym+1
      %IF nextsym>=maxsyms %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)) %unless %C
         trusted#0 %or -1<=SYM_strx<=0
      Sym=0

      place in dict(name,sym_strx) { remember name in dictionary and set sym_ad }
      { to its word address }

      Sym_area=area
      Sym_type=type
      Sym_value=Value
%END


!*****************************************************************************
!   PXNAME  -  EXTERNAL PROCEDURE SPEC
!*****************************************************************************
%EXTERNAL %INTEGER %FN PXname(%INTEGER type, %STRING (255) %NAME s)
      { 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

      %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 %START { found a reference }
            %IF name=string(dictstart+sym_strx) %START { name already in place }
               %IF mon#0 %THEN printstring("  PXname:(rep) ".s." symID = ".itos(i+20)."
")
               %RESULT=i+20
            %FINISH
         %FINISH
      %REPEAT

      Psymbol(name,EXT,0,0) { first occurrence of name }
      %IF mon#0 %THEN printstring("  PXname: ".s." symID = ".itos(nextsym+20)."
")
      %RESULT=NextSym+20
%END

!******************************************************************************
%ROUTINE FIX(%INTEGER type,area,disp,tgt,tdisp)
!***********************************************************************
!*      Record a relocation request: Add addr tarea,tdisp to           *
!*    word in hostarea at disp. Type is size (2 or 4) . Big numbers    *
!*    are for specials eg 254=end of list. 255=new block               *
!***********************************************************************
%RECORD (rfm) %NAME R
%RECORD (fragform) %NAME frag
%INTEGER ad,i


      %IF trusted=0 %START
         Perror("Fix - Bad relocation request") %IF %C
            type<200 %AND (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 %START { start next block of relocations }
            %IF malmon#0 %THEN printstring("
      Space for relocation tables ")
            ad=Get Space(defaultareasize)>>wordad
            R_type=255;                  !  marker in type field that this is not a reloc
                                         ! , but contains addr of next block
            r_hostdisp=ad
            crel=0
            rels==array(ad,rafm)
         %FINISH %ELSE %EXIT
      %REPEAT


      %IF type<200 %START { if it is a genuine reloc request , count it }
         %IF area=Gla %OR area=IOtab %OR area=Static %THEN ndrels=ndrels+1 %ELSE %C
            ntrels=ntrels+1
      %FINISH
      %IF area=code %START;              ! allow for frag adjustment
         i=locate cablk(disp);           ! by finding the relevant fragment
         frag==record(area1base+i);      ! map onto fragment
         disp=i!(disp-frag_ca)<<24;      ! fragments must be short!
      %FINISH
      %IF tgt=code %START;               ! again must allow for adjustment
         i=locate cablk(tdisp)
         frag==record(area1base+i);      ! map onto fragment
         tdisp=i!(tdisp-frag_ca)<<24;    ! fragments must be short!
      %FINISH
      R_type=type
      R_tgt=Tgt;                         ! Note reloc usually means remember 4 values, but
      R_hostarea=area;                   ! in this m/c have got tgt disp written in
      R_hostdisp=disp;                   ! host word already
      R_tgtdisp=tdisp
%END

!******************************************************************************
!   PFIX  -  REQUEST A 32bit RELOCATION
!******************************************************************************
%EXTERNAL %ROUTINE Pfix(%INTEGER Hostarea,disp,tgtarea,tgtdisp)
      { A relocation request: set word in area, displacement = 'disp' bytes,}
      { the address of area 'targetareaid', displacent = targetdisp.}
%RECORD (Areafm) %NAME A
%INTEGER %NAME tgt

      %RETURN %IF faulty#0
      A==areas(HostArea)
      %IF trusted=0 %START
         Perror("Pfix - bad displacement ") %IF disp<0 %OR disp>4000000
      %FINISH
      expand area(Hostarea) %WHILE disp+4>A_max

      FIX(4,Hostarea,disp,tgtarea,tgtdisp)
      %IF mon#0 %THEN printstring("  PFIX( ".itos(Hostarea)."/".htos(disp,
         8)." -> ".itos(tgtarea)."/".htos(tgtdisp,8)."
")
%END


!******************************************************************************
%EXTERNAL %ROUTINE PDxref(%INTEGER Area,disp,Length, %STRING (255) %NAME Name)
%INTEGER type,id,i
%RECORD (symfm) %NAME sym
%STRING (32) s

      %RETURN %IF faulty#0

      { Find any earlier reference of this name }

      %CYCLE i=0,1,nextsym
         sym==syms(i)
         %IF sym_type=Ext %START { found a reference }
            %IF name=string(dictstart+sym_strx) %THEN %C
               { name already in place }id=i+20 %AND ->Found
         %FINISH
      %REPEAT

      s="_".name
      Psymbol(s,EXT,0,0) { first occurrence of name }
      id=nextsym+20
Found:
      fix(4,area,disp,id,0);             ! I expect a Pxname to have been done earlier
      %IF mon#0 %THEN printstring("
  PDXREF( ".itos(area)."/".htos(disp,8)." -> ".itos(id))
%END


!******************************************************************************
%EXTERNAL %ROUTINE Pdataentry(%STRING (255) %NAME name, %INTEGER area,maxlen,disp)
%STRING (255) s

      %RETURN %IF faulty#0
      %IF mon#0 %THEN printstring(" PDataentry( ".itos(area)."/".htos(disp,
         8)." len ".itos(maxlen).name."
")
      s="_".name
      Psymbol(s,DATA!EXT,area,disp)
%END




!--------------------------------------------------------
!
!    The next three routines deal with PROCEDURES
!
!--------------------------------------------------------


!******************************************************************************
!    PNEXTSYMBOL - LOCAL PROCEDURE SPEC
!******************************************************************************
%EXTERNAL %INTEGER %FN PNextSymbol { reserve a space in the symbol table }
      %RESULT=0 %IF faulty#0
      nextsym=Nextsym+1
      %IF nextsym>=maxsyms %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)."
")
      syms(nextsym)_value=-1;           !  mark as Forward ref
      syms(nextsym)_strx=-1;            ! mark as name not yet known
      syms(nextsym)_Proclevel=Curlexlev+1
      %RESULT=Nextsym+20
%END


!*****************************************************************************
!   PCALL - CALL A  PROCEDURE
!*****************************************************************************
%EXTERNAL %ROUTINE PCall(%INTEGER id,Numpars)
!***********************************************************************
!*    Plant a call or (id -ve) obtain addres of proc to pass as formal *
!*    CALLS is used. Externals are relocated by position independent   *
!*   proc ref (allows sharing). Other are filled as for jumps          *
!***********************************************************************
%RECORD (Heapfm) %NAME Proc
%RECORD (symfm) %NAME sym
%INTEGER i,j,ind,OP

      %RETURN %IF faulty#0
      %IF id<0 %THEN %Start
         ind=1
         id=-id
         op=MOVAL
      %ELSE
         ind=0
         Op=CALLS
      %finish
      %IF mon#0 %THEN printstring("  Pcall: ID = ".itos(id)." ".itos(syms(Id-20) %C
         _proclevel)." ".itos(syms(Id-20)_type)."
")
      sym==syms(Id-20)
      new frag (call type)
      Currfrag_lindex=Id
      currfrag_flags=ind<<1
      Popcode(Op)
      %if ind=0 %then Plit(Numpars,4)
      CA=CA+5
      currfrag_length=CA-Currfrag_ca
      newfrag(codetype)
      %if INd#0 %then PB(X'50')
%END { of PCALL }


!*****************************************************************************
!   PPROC - START A NEW PROCEDURE
!*****************************************************************************
%EXTERNAL %ROUTINE Pproc(%STRING (255) %NAME name, %INTEGER props,pars,
   %INTEGER %NAME ID)
      { PROPS&1   = External   }
      { PROPS&2   = No ASFW    }
      { PROPS&16  = Side Entry (pars>>16=localsize) }
      { PROPS>>31 = Main entry }
      { pars = numpars << 16 ! paramsize }
%INTEGER type,save,areaid,i,Mask,j,at
%STRING (255) rest,S
%RECORD (symfm) %NAME sym
%RECORD (Heapfm) %NAME Call
%OWN %INTEGER firstproc= 0

      ID=1 %AND %RETURN %IF faulty#0
      %IF mon#0 %START
         printstring("  PProc: ".name." ID = ".itos(id))
         printstring(" Npars = "); write(pars>>16,1)
         printstring(" Psize = "); write(pars&x'ffff',1)
!         %IF sdb#0 %THEN printstring(" line = ") %AND write(lineno,1)
         space; phex(props)
      %FINISH


      %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 Pnextsymbol }
      { 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 %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 %C
               ID=i+20 %AND sym_strx=0 {reset for unused check }
         %REPEAT
      %FINISH

      save=0
      %IF ID#-1 %THEN save=nextsym %AND nextsym=id-1-20
      %IF props>>31=1 %OR s="_s_go" %START
         Main Entry Point=CA
         s="_MAIN__"
!     s = "_main"
      %FINISH

      %IF CA&1#0 %START { Align Proc start on 2 byte boundary }
         PB(NOP)
      %FINISH

      Psymbol(S,type,code,Area1ptr!(CA-Currfrag_ca)<<24) { make symbol table entry }
      syms(nextsym)_proclevel=CurLexLev
      %IF ID#-1 %THEN nextsym=save %ELSE ID=Nextsym+20
      %IF mon#0 %THEN printstring(" symID = ".itos(ID)."
")
      %if Props&1#0 %then mask=X'CFFC' %else mask=X'C3FC'
      newfrag(Pmasktype)
      PH(Mask);                ! Register save mask at entry point
       newfrag(codetype)
      %if Props&1#0 %start
         POpcode(MOVL); PB(X'9F')
         PW(0)
         Fix(4,Code,CA-4,Gla,0)
         PB(X'5B');             ! Gla -R11 by fixed up instrn
         POpcode(MOVL); PB(X'9F')
         PW(0)
         Fix(4,Code,CA-4,Cnst,0)
         PB(X'5A');             ! CNST -R10 by fixed up instrn
      %finish
%END

!*************************************************************************

%EXTERNAL %INTEGER %FN PPARAMSIZE
      %RESULT=0 %IF faulty#0
      %RESULT=curblock_psize
%END

!*************************************************************************

%EXTERNAL %ROUTINE PPROCEND(%INTEGER localsize)
%RECORD (Heapfm) %NAME Jmp
%INTEGER at,size

      %IF mon#0 %START
         printstring("  PProc END: localsize(bytes) =")
         write(localsize,1)
         newline
      %FINISH

      %RETURN %IF faulty#0
%END


!**********************************
!* Put Interface - Miscellaneous  *
!**********************************


!******************************************************************************
%EXTERNAL %ROUTINE Preversebytes
%END

!****************************************************************************
%EXTERNAL %INTEGER %FN Pcommon(%STRING (255) %NAME Name)
%STRING (255) s

      %RESULT=0 %IF faulty#0
      %IF mon#0 %THEN printstring("Pcommon - ".name."
")
      Toparea=Toparea+1
      %IF toparea>maxarea %START
         expand area(0)
         maxarea=areas(0)_max//sizeofareaentry
      %FINISH
      %IF name="F#BLCM" %THEN s="__BLNK__" %ELSE s="_".name
      Psymbol(s,EXT,0,Toparea) { put area table index in _value temporarily }
      areas(toparea)_sym=nextsym+20
      %RESULT=nextsym+20
%END


!*******************************************************************
%EXTERNAL %ROUTINE Pendcommon(%INTEGER id,length,props)
%INTEGER area

      %RETURN %IF faulty#0
      %IF mon#0 %START
         printstring("P end common ".itos(id)."  length = ")
         phex(length)
         newline
      %FINISH
      area=syms(id-20)_value
      areas(area)_length=length
      syms(id-20)_value=length
%END

%ROUTINE DBXsym(%STRING (255) name, %INTEGER type,desc,value)
      { remember  name and its properties for inclusion in the }
      { symbol table }
%RECORD (symfm) %NAME sym
%INTEGER i

      nextDBXsym=nextDBXsym+1
      %IF nextDBXsym>=maxDBXsyms %START
         expand area(DBXsymtab)
         DBXsyms==array(areas(DBXsymtab)_base,symafm)
         maxDBXsyms=areas(DBXsymtab)_max//intsymsize
      %FINISH
      sym==DBXsyms(nextDBXsym)
      sym=0
      %IF name="" %THEN sym_strx=0 %ELSE place in dict(name,sym_strx)
      %IF type=SOL %THEN sym_strx=desc %AND desc=0
      sym_type<-type
      %IF type=SLINE %THEN sym_area=desc>>8 %AND sym_proclevel=desc&255 %ELSE %C
         sym_desc<-desc
      sym_value=value
%END



!*******************************************************************
%EXTERNAL %ROUTINE MsdbVAR(%INTEGER swad,vtype,area,disp,bytesize,nels,ndims,lower1,
   upper1)
!*******************************************************************
      { Take details of variables and encode for SDB }

%STRING (63) sinfo
%STRING (*) %NAME s
%OWN %STRING (12) fnresult="Fn result"
%INTEGER dicad,ad,i,defno,type,desc,value
      %CONST %STRING (40) %ARRAY defs(1:10) = %C
"integer*1:t1=r1;0;255",
 "integer*2:t2=r2;-32768;32767;",
 "integer:t3=r3;-2147483648;2147483647;",
 "real:t4=r4;4;0;",
 "double precision:t5=r5;8;0;",
 "complex:t6=r6;8;0",
 "double complex:t7=r7;16;0;",
 "logical*2:t8=r8;0;32767;",
 "logical:t9=r9;0;2147483747;",
 "char:t10=r10;0;127;"

      %OWN %INTEGER %ARRAY trigger(1:10) = 0(10)

%CONST %INTEGER integer= 1,  { Fortran dictionary types }
              real    = 2,
              complex = 3,
              logical = 4,
              character= 5


      %RETURN %IF faulty#0
      %IF swad=0 %THEN s==fnresult %ELSE s==string(swad)
      %IF mon#0 %AND bytesize#0 %START
         printstring("DBXVAR: ".s." type = ")
         phex(vtype)
         printstring(" area/disp/len/nels/ndims/lower1/upper1  = ")
         write(area,1)
         space; phex(disp)
         write(bytesize,1)
         write(nels,1)
         write(ndims,1)
         write(lower1,1)
         write(upper1,1)
         newline
      %FINISH

      %IF swad=0 %START { fn result }
         DBXsyms(nextDBXsym)_desc=bytesize
         %RETURN
      %FINISH

      type=vtype
      vtype=vtype&127
      %IF vtype=integer %START
         %IF bytesize=4 %THEN defno=3 %ELSE %IF bytesize=2 %THEN defno=2 %ELSE defno=1
      %FINISH %ELSE %IF vtype=real %START
         %IF bytesize=4 %THEN defno=4 %ELSE defno=5
      %FINISH %ELSE %IF vtype=complex %START
         %IF bytesize=4 %THEN defno=6 %ELSE defno=7
      %FINISH %ELSE %IF vtype=logical %START
         %IF bytesize=4 %THEN defno=9 %ELSE defno=8
      %FINISH %ELSE %IF vtype=character %START
         defno=10
         nels=bytesize
         bytesize=0
         lower1=1
         upper1=nels
      %FINISH

      %IF trigger(defno)=0 %START { First use of this type }
         DBXsym(defs(defno),Lsym,0,0)
         trigger(defno)=1
      %FINISH
      desc=bytesize
      %IF type&128#0 %THEN type=PSYM %ELSE type=stsym
      %IF incommon#0 %THEN type=GSYM %AND area=incommon
      value=disp
      %IF type=stsym %OR type=gsym %THEN value=(area<<24)!disp { adjust at end }
      %IF type=PSYM %THEN sinfo=string(swad).":v" %AND value=value+8 %ELSE %C
         sinfo=string(swad).":V"
      nels=nels-1 { nels=1 means is a variable not a single element array }
      %IF nels>0 %THEN sinfo=sinfo."ar".itos(defno).";".itos(lower1).";".itos(upper1).";"
      sinfo=sinfo.itos(defno)
      DBXsym(sinfo,type,desc,value)
%END

%EXTERNAL %ROUTINE MSDBcmnstart(%STRING %NAME s, %INTEGER id)
%STRING (63) ss

      %IF mon#0 %THEN printstring("    Msdbcmnstart ".s) %AND write(id,1) %AND newline
      %IF s="F#BLCM" %THEN ss="_BLNK__" %ELSE ss=s
      DBXsym(ss,BCOMM,0,0)
      incommon=id
%END

%EXTERNAL %ROUTINE MSDBcmnend(%STRING %NAME s, %INTEGER id)
%STRING (63) ss

      %IF mon#0 %THEN printstring("    Msdbcmnend ".s) %AND newline
      %IF s="F#BLCM" %THEN ss="_BLNK__" %ELSE ss=s
      DBXsym(ss,ECOMM,0,0)
      incommon=0
%END



!*****************************************************************************
%EXTERNAL %ROUTINE Pfaulty
      { 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("PFAULTY
")
      Faulty=1
%END

!*****************************************************************************
!  Psetobject - Pass object file name in to be opened
!*****************************************************************************

%EXTERNAL %ROUTINE Psetfiles(%STRING (255) %NAME Srcname,objfilename)
      Srcfile<-Srcname
      Objfile<-objfilename
%END


!******************************************************************************
!   PINITIALISE - CODE GENERATION BEGINS WITH THIS CALL
!******************************************************************************
%EXTERNAL %ROUTINE PINITIALISE(%INTEGER language,props,sourcead)
%INTEGER i,j,com26
%STRING (63) name
%STRING (32) lang
%OWN %RECORD (Areafm) ZeroArea
      %IF mon#0 %THEN printstring("  Pinitialise
")
      %RETURN %IF faulty#0
      %IF language=1 %THEN lang="IMP80" %AND imp=1 %ELSE lang="FORTRAN77"
      com26=comreg(26)
   mon=com26&3
      %IF com26&128#0 %THEN malmon=1
      %IF com26&16#0 %THEN filemon=1
      %IF com26&x'4000'#0 %THEN decode=1
      fmon=com26>>15&1
      %IF com26&4#0 %THEN sdb=1
      Compiler title=string(sourcead)
      %IF host=IBMXA %START
      %BEGIN
      %EXTERNAL %ROUTINE %SPEC jinit %ALIAS "ICL9caJINIT"
         jinit;                          ! Needed to initialise malloc
      %END
      %FINISH
      %IF language=1 %THEN plinestart(0) { give p_rts a valid line number }

!    Free Source Areas                 { release consource claimed space }
      area1base=0; area1ptr=0
      oldptr=0
      Codestart=32
      nextsym=-1
      curblock==blocks(0) { Set pointer to dummy outer level }


      Rels==array(Get Space(defaultareasize)>>wordad,
         rafm) { grab an area for reloc table }
      Startrels==Rels { Note reloc table sections are not contiguous so dont need to be 'areas' }

      InitialiseHeap

      Areas==array(addr(ZeroArea),Areaafm) { Start of area table }
      expand area(0)
      MaxArea=areas(0)_max//sizeofareaentry
      expand area(1)
      currfrag==record(area1base)
      currfrag=0;                        ! type 0 record to start
      newfrag(codetype)

      dictindex=0
      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 }

      %IF sdb#0 %THEN DBXsym(srcfile,so,0,0)

%END


!***************************************************************************
! PTERMINATE - CODE GENERATOR CLOSES WITH THIS CALL TO ESTABLISH AREA LENGTHS
!***************************************************************************

%EXTERNAL %ROUTINE PTERMINATE(%INTEGER adareasizes)

%INTEGER i,ad,l,sect

      %RETURN %IF faulty#0
      integer(adareasizes)=tidy code { let compiler know how large code was }
 
      %IF mon#0 %THEN printstring("
    Arealengths from pterminate (2 - max ) are:
")
      ad=adareasizes
      %CYCLE i=1,1,10
         l=integer(AD)
         ad=ad+(4>>wordad)
         %IF mon#0 %THEN write(l,1)
         l=(l+7)&(-8) { Keep areas tidy on 8 word boundaries }
         Perror("Pterminate - Area ".itos(i)." has incorrect length ") %IF %C
            trusted=0 %AND l=0 %AND areas(i)_max#0
         areas(i)_length=l
      %REPEAT
      %if fmon#0 %then  dump(area1base,area1ptr+32)
      %IF Faulty=0 %THEN pgenerateobject(Objfile)
%END





!*****************************************************************************
!     PGENERATE - FINAL PHASE OF COMPILATION IS CREATE OBJECT FILE
!******************************************************************************
%EXTERNAL %ROUTINE PgenerateObject(%STRING (*) %NAME objfilename)
!%RECORD %FORMAT HDRfm(%INTEGER Magic,text,data,bss,syms,entry,trsize,drsize)
%INTEGER textlen,datalen,symlen,ad,j
%INTEGER filler,bufptr
%INTEGER i,datastart,bsslen,l,linkdisp,kad
%INTEGER %ARRAY areastart(1:toparea)
%RECORD (rdfm) %NAME rd
%BYTE %ARRAY buff(0:511)
      %CONST %BYTE %INTEGER %ARRAY order(2:10) = 7,2,8,10,4,5,6,3,9

      %RETURN %UNLESS faulty=0
      buff(0)=2; bufptr=1;               ! TIR record coming
      %IF malmon#0 %THEN printstring("
max data before object generation = ".itos(maxdata))

      areastart(i)=0 %FOR i=1,1,toparea


      {---- WORK OUT SIZE OF MAJOR PARTS OF OBJECT FILE ---}


      Textlen=areas(1)_length
      DataStart=Codestart+textlen
      Symlen=((NextSym+1)*12)+((nextDBXsym+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 ---------------}
      {------------------------------------------------------}

      { Areas are to be assembled in DATA in the following order }

      {  First areas being relocated:     GLA      }
      {                                   IOTAB    }
      {                                   STATIC   }
      {  Next areas initialised, but               }
      {    not relocated.                 CNST     }
      {                                   SST      }
      {                                   GST      }
      {                                   DIAGS    }
      {                      INITIALISED  COMMONS  }

      {  And in BSS, areas which are               }
      {  set to zero and not relocated    ZGST     }
      {                                            }
      {  and               UNINITIALISED COMMONS   }


!**********************************************
      { This routine is for the efficient patterning of a data area }
      { eg. If the area is to be filled with the unnassigned byte }
      {     or a data i*n statement is taking effect }

%ROUTINE PATTERN(%INTEGER fileid,ncopies,l,bad)
%BYTE %INTEGER %ARRAY b(0:511)
%INTEGER i,left,j,ad,to,filler,blen,bufsize

      ad=addr(b(0))<<wordad
      { if l > 512 ? } { First fill the buffer with the pattern }
      %IF l=1 %OR l=4 %START;            !  single byteor word pattern
         %IF l=4 %START
            filler=31;                   ! Vax code for fill with 32 bits
            buff(bufptr)=3;              ! word literal coming
            %FOR i=1,1,4 %CYCLE
               %IF host=IBMXA %THEN buff(bufptr+i)=byteinteger(bad+4-i) %ELSE %C
                  buff(bufptr+1)=byteinteger(bad-1+i)
            %REPEAT
            bufptr=bufptr+5
         %ELSE
            filler=29;                   ! Vax code for fill with bytes
            buff(bufptr)=1; buff(bufptr+1)=bad
            bufptr=bufptr+2
         %FINISH
         buff(bufptr)=3;                 ! Another word coming
         buff(bufptr+1)=l&255
         buff(bufptr+2)=l>>8&255
         buff(bufptr+3)=l>>16&255
         buff(bufptr+4)=l>>24
         buff(bufptr+5)=filler
         bufptr=bufptr+6
         %RETURN
      %FINISH
      bufsize=0
      %CYCLE i=1,1,ncopies
         to=ad+bufsize
         %IF host=vax %START
            **bad; **to; **l; *MVB
         %FINISH %ELSE ByteMove(l,bad,to)
         bufsize=bufsize+l
         %IF bufsize+l>511 %THEN %EXIT
      %REPEAT
      left=ncopies*l

      { And then write it out }

      %CYCLE
         %IF left>bufsize %THEN blen=bufsize %ELSE blen=left
         left=left-blen
         add frag(buff,bufptr,ad,blen)
      %REPEAT %UNTIL left<=0

%END



      { PLACE ZEROED AREAS IN 'BSS' }


      %IF areas(zgst)_length>0 %AND areas(zgst)_max=0 %THEN %START
         bsslen=areas(zgst)_length
      %FINISH

      datalen=0
      %CYCLE i=1,1,toparea
         %CONTINUE %IF areas(i)_type=code
         %CONTINUE %IF (i=zgst %AND bsslen#0)
         %CONTINUE %IF i>setareas %AND areas(i)_max=0 { uninit. common }
         datalen=datalen+areas(i)_length
      %REPEAT



      { Work out start position of ERCC sub-areas in 'DATA' }
      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 %START {  common }
            %IF imp#0 %THEN %EXIT
            %CONTINUE %IF areas(i)_max=0 { uninitialised cmn }
            i=areas(i)_sym-setareas { Initialised common }
            syms(i)_type=EXT!DATA { is not described as common }
            syms(i)_value=ad-DataStart { but as external data }
         %FINISH %ELSE areastart(i)=ad-datastart { remember for sdb records }
         ad=ad+l
      %REPEAT


!      {----------- FILL IN THE OBJECT FILE HEADER ---------------------}
!
!
!      {All sizes in the UNIX header are in bytes }
!
!      Hdr=0
!      %IF host=ibmxa %START
!         Hdr_magic=x'01070000'
!         Hdr_text=(Textlen<<16)!(Textlen>>16)
!         Hdr_data=(Datalen<<16)!(Datalen>>16)
!         Hdr_bss=(Bsslen<<16)!(Bsslen>>16)
!         Hdr_syms=(Symlen<<16)!(Symlen>>16)
!         Hdr_entry=(MainEntryPoint<<16)!(MainEntryPoint>>16)
!         i=8*(trctr-1)
!         Hdr_trsize=(i<<16)!(i>>16)
!         i=8*(drctr-1)
!         Hdr_drsize=(i<<16)!(i>>16)
!      %FINISH %ELSE %START
!         Hdr_magic=x'00000107'
!         Hdr_text=Textlen
!         Hdr_data=Datalen
!         Hdr_bss=Bsslen
!         Hdr_syms=Symlen
!         Hdr_entry=MainEntryPoint
!         Hdr_trsize=8*(trctr-1)
!         Hdr_drsize=8*(drctr-1)
!      %FINISH
      prepare object
      write headers
      define psects
      { --- WRITE OUT CODE NOW-------}

      write code

!***********************************************************************
!*    Process switches fill adjusted addresses into SST                *
!***********************************************************************

%begin
%integer Link,i,j,k,lower,upper,Tablead,l
%record(HeapFm)%name SW,Lab
%record(Fragform)%name Frag
      Link=switchstart
      %while Link>0 %cycle
      sw==record(link)
         lower=Sw_disp; upper=SW_spare
         tablead=SW_id+areas(SST)_base
         k=Tablead
         %for i=lower,1,upper %cycle
            j=Integer(k)
            %if j>0 %Start;             ! Fragoffset of sw type frag
               frag==record(area1base+j)
               integer(k)=frag_ca+frag_Adj
            %finish %else %if J<0 %start;! Label number in SST
               L=findonheap(J&X'7FFFFFFF',Labstart)
                %if l=0 %then Perror("Label for SW not set")
               Lab==record(L)
               Frag==record(area1base+Lab_disp)
               integer(k)=frag_ca+Frag_adj
            %finish
                                       ! j=zero means not set and is left
            k=k+4
         %repeat
         Link=SW_LINK
      %repeat
      freeheaplist(switchstart)
%end


      {------------------------------------------------------}
      {------------- MOVE AREAS INTO POSITION ---------------}
      {------------------------------------------------------}

      { ---  PLACE INITIALISED DATA AREAS IN 'DATA'  --- }

      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=5 %OR i>setareas %START { encoded area }

            filler=areas(i)_type>>24
            %IF filler#0 %START { to be pre-patterned }
               set loc cntr(buff,bufptr,j,0); ! set linker cntr to area start
               pattern(objid,l,1,filler)
            %FINISH
            %IF areas(i)_base=0 %AND i>setareas %THEN %CONTINUE
            linkdisp=0
            %CYCLE { Through area frags.}
               RD==record(areas(i)_base+linkdisp)
               set loc cntr(buff,bufptr,j,RD_disp)
               kad=((areas(i)_base+linkdisp)<<wordad)+rdsize
               %IF RD_copies>1 %START
                  %IF RD_len=1 %THEN kad=byteinteger(kad)
                  pattern(objid,RD_copies,RD_len,kad)
               %FINISH %ELSE add frag(Buff,bufptr,kad,RD_len)
               linkdisp=(linkdisp+((RD_len+rdsize+wordad)>>wordad)+3)&(-4)
            %REPEAT %UNTIL Addr(RD)-areas(i)_base=areas(i)_linkdisp
         %FINISH %ELSE %START;           ! mapped area
            %IF areas(i)_base#0 %START;  ! has any initialisation been recvd?
               set loc cntr(buff,bufptr,j,0); ! set linker cntr to area start
               add frag(buff,bufptr,areas(i)_base,l)
               FREE(areas(i)_base<<wordad)
            %FINISH
         %FINISH

         flush buffer(Buff,bufptr) %if bufptr>1
      %REPEAT



      {-----------------------------------------------------------}
      {------------- SORT OUT RELOCATION  ------------------------}
      {-----------------------------------------------------------}
      { Relocs.  pass a symbol table index in their rel. field }


%BEGIN
%ROUTINE %SPEC prepare reloc(%INTEGER size,harea,hdisp)
%ROUTINE %SPEC relocate(%INTEGER size,tarea,tdisp)
%RECORD (rfm) %NAME R
%INTEGER i,type,TgtSym,hostdisp
%INTEGER trctr,drctr,tgtdisp,Extern
%RECORD (fragform) %NAME frag
      Fix(254,0,0,0,0) { 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_type
         hostdisp=R_hostdisp
         %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
         Extern=0

         %IF Tgtsym>=Setareas %START { symbol id not an area }
            { Could be common,data xref or proc. }

!            tgtsym=tgtsym-Setareas
!            TgtSymType=syms(Tgtsym)_type

!            %IF TgtSymType=EXT!TEXT %START
!               { An Xref has turned out to be an externalroutine in this module}
!               { Fill it in like a local call and ditch the Relocation request}
!               A=((Syms(Tgtsym)_value-(hostdisp-(1+type)))&x'3FFFFFFF')!x'C0000000'
!               ->skip
!            %FINISH
         %FINISH %ELSE %START { area id to be used }
         %FINISH

!
! relocations to or from code are recorded based on approx ca
! locate the fragment and extract adjustment to give correct ca
!
         %IF R_hostarea=CODE %START
            frag==record(area1base+hostdisp&X'FFFFFF')
            Perror("Illegal code relocation(host)") %UNLESS frag_type=codetype
            hostdisp=frag_ca+frag_adj+hostdisp>>24; ! top byte =offset in frag
         %FINISH
         %IF R_tgt=code %and tgtdisp#0 %START
            frag==record(area1base+tgtdisp&X'FFFFFF')
            Perror("Illegal code relocation(TGT)") %UNLESS frag_type=codetype
            tgtdisp=frag_ca+frag_adj+tgtdisp>>24
         %FINISH
!
! do the relocation in steps: adj linkers counter &pick up original
! then set new address add and storeback
!
         prepare reloc(type,R_hostarea,hostdisp)
         relocate(type,R_tgt,tgtdisp)
         %IF mon#0 %START
            printstring(" Fix ")
            write(R_hostarea,1)
            printstring(" + ")
            phex(hostdisp)
            write(tgtdisp,5); space
            write(tgtsym,1)
            %IF tgtsym>setareas %THEN %C
               printstring(" ".string(syms(tgtsym-setareas)_strx+dictstart))
            newline
         %FINISH
         i=i+1
      %REPEAT
      flush buffer(buff,bufptr) %IF bufptr>1
%ROUTINE prepare reloc(%INTEGER size,harea,hdisp)
!***********************************************************************
!*    First part of relocation                                         *
!*    Set the linkers location counter to the word or longword         *
!*    Fetch the original contents of the word (=0 >99.9% )             *
!***********************************************************************
      set loc cntr(buff,bufptr,harea,hdisp)
      set area offset(buff,bufptr,harea,hdisp)
      %IF size=4 %THEN size=3
      buff(bufptr)=size+8;               ! fetch 8,16 or 32 bits
      bufptr=bufptr+1
%END
%ROUTINE relocate(%INTEGER size,tarea,tdisp)
!***********************************************************************
!*    Set required address to top of linker stack                      *
!*     add to original contents and store at loc cntr                  *
!***********************************************************************
%INTEGER i
%RECORD (symfm) %NAME csym
%STRING (32) name
      %IF tarea<setareas %START;         ! to address in this module
         set area offset(buff,bufptr,tarea,tdisp)
      %ELSE;                             ! to something external
         csym==syms(tarea-setareas)
         name<-string(dictstart+csym_strx)
         buff(bufptr)=0;                 ! stach addr of external
         bufptr=bufptr+1
         %FOR i=0,1,length(name) %CYCLE
            buff(bufptr)=upper case iso(charno(name,i))
            bufptr=bufptr+1
         %REPEAT
      %FINISH
      buff(bufptr)=51;                   ! add value to original contents
      %IF size=4 %THEN size=3
      buff(bufptr+1)=size+32;            ! store 8,16 or 32 bits back
      bufptr=bufptr+2
      flush buffer(buff,bufptr) { %if bufptr>256}
%END
%END


      {------------------------------------------------------------}
      {------ WRITE OUT SYMBOL TABLE RECORDS ----------------------}
      {------------------------------------------------------------}
!
! only external entries are relevant. Defns have area and value set
! in the symbol table. Commins have an index to area which has details
! including the psect number. Here we form up and write out a VMs
! global symbol entry for each symbol adding psect and offset
! for definitions. The allocation of psercts for  is done in define psects
!
%BEGIN
%RECORD (symfm) %NAME s
%INTEGER i,j,strx,area,l,def,type,psect,value
%record(fragform)%name frag
%STRING (32) xname
      buff(0)=1; bufptr=1;               ! Global symbols coming
      %FOR i=0,1,nextsym %CYCLE
         s==syms(i)
         strx=s_strx
         type=S_type; value=S_value
         %CONTINUE %IF type&EXT=0;       ! ignore internal symbols
         xname=string(dictstart+strx)
         buff(bufptr)=1;                 ! Symbol defn
         %IF type&(\(Common!EXT))=0 %THEN def=0 %ELSE def=1
         buff(bufptr+1)=0;               ! Type is undefined
         buff(bufptr+2)=8!def<<1;        ! Strong not absolute, def?
         buff(bufptr+3)=0
         bufptr=bufptr+4
         %IF def#0 %START
            %IF type&common=0 %THEN psect=s_area-1 %ELSE psect=areas(value)_psect
            %IF s_area=code %THEN %START
               frag==record(area1base+value&X'ffffff')
              value=frag_ca+frag_adj+value>>24
            %FINISH
            buff(bufptr)=psect
            buff(bufptr+1)<-value
            buff(bufptr+2)<-value>>8
            buff(bufptr+3)<-value>>16
            buff(bufptr+4)<-value>>24
            bufptr=bufptr+5
         %FINISH
         buff(bufptr)=length(xname)
         %FOR j=1,1,length(xname) %CYCLE
            buff(bufptr+j)=upper case iso(charno(xname,j))
         %REPEAT
         bufptr=bufptr+1+length(xname)
         flush buffer(buff,bufptr) %AND buff(0)=1 {%if bufptr>256}
      %REPEAT

      {**** Now put out the DBX symbols if debugging data required ****}

!      %IF sdb#0 %START
!         %CYCLE i=0,1,nextDBXsym
!            s==DBXsyms(i)
!                                         !%IF s_type=FUN %OR s_type=SLINE %OR s_type=SO %THEN s_value=s_value+textlen
!            %IF s_type=stsym %OR s_type=gsym %START
!               area=s_value>>24
!               %IF area<20 %THEN l=textlen+areastart(area)
!               %IF area=9 %THEN l=l+datalen
!               s_value=s_value&x'ffffff'
!               %IF area<20 %THEN s_value=s_value+l
!                                         !%IF area>=20 %START  { common }
!                                         !%IF syms(area-setareas)_type=EXT!DATA %START  { initialised }
!                                         !s_value=syms(area-setareas)_value+s_value
!                                         !%FINISH
!                                         !%FINISH
!               %IF area=9 %THEN s_type=LCSYM
!
!            %FINISH
!         %REPEAT
!       %FINISH
%END
      FREE(addr(syms(0))<<wordad)


      %IF malmon#0 %THEN printstring("
    max data before object generation = ".itos(maxdata)."
    ")
      close object
%END

!****************************************************************************
%EXTERNAL %ROUTINE PMonon
      mon=1
      olddecode=decode
      decode=1
%END

!******************************************************************************
%EXTERNAL %ROUTINE Pmonoff
      mon=0
      decode=olddecode
%END

!******************************************************************************
%EXTERNAL %ROUTINE Ptraceon
!  %RETURN %IF faulty#0
!  decode = 1
%END

!******************************************************************************
%EXTERNAL %ROUTINE Ptraceoff
!  %RETURN %IF faulty#0
!  decode = 0
%END
%INTEGER %FN tidy code
!***********************************************************************
!*    Figure out branch sizes and then assign final addresses for all  *
!*    code fragments. This is done via an adjustment. The provisional  *
!*    address must stay unchanged for any relocations.                 *
!***********************************************************************
%RECORD (heapfm) %NAME heap
%RECORD (fragform) %NAME frag,next frag,lab frag,proc frag
%record(Symfm)%name sym
%SWITCH sw(0:7)
%INTEGER link,adj,size,lab,i,distance,op,Id,entryad
      newfrag(0);                        ! termonate final fragment
      oldfrag_flink=-1;                  ! with a negative marker
      link=0; adj=0;                     ! no adjustments as yet
      %WHILE link>=0 %CYCLE
         frag==record(area1base+link)
         link=frag_flink
         frag_adj=adj
         ->sw(frag_type)
sw(BRtype):                              ! a jump
         lab=frag_label
         nextfrag==record(area1base+link)
         labfrag==record(area1base+nextfrag_flink); ! many forward junmps will be to here
         %UNLESS labfrag_type=labtype %AND labfrag_label=lab %START
            i=find on heap(Lab,Labstart)
            %IF i=0 %THEN Perror("Unset Label".itos(lab))
            heap==record(i)
            labfrag==record(area1base+heap_disp)
            %IF labfrag_type#labtype %THEN Perror("Fragments in a twist")
         %FINISH
         distance=imod(frag_ca-labfrag_ca)
         %IF distance<=127 %THEN %Start
         size=2
         frag_flags=frag_flags!128
      %finish %ELSE %IF distance<=x'7fff' %THEN %start
         size=5
         Frag_flags=Frag_flags!64
      %finish %ELSE size=7
         op=frag_instrn
         %IF frag_flags&1#0 {uncond set} %AND size>2 %THEN size=size-2
         adj=adj-6+size
         frag_length=size;               ! Must fill at calculated size
         frag_lindex=addr(labfrag)-area1base
         %CONTINUE
sw(calltype):                           ! Calls
      Id=frag_lindex
      sym==syms(Id-20)
      %if sym_type&EXT#0 %then %continue;   ! externals not adjusted
      proc frag==record(area1base+Sym_value&X'FFFFFF')
      entry ad=procfrag_ca+sym_value>>24
      distance=imod(frag_ca-entry ad)
      %if distance<=127 %Start
         size=2; frag_flags=frag_flags!128
      %finish %else %if distance<=X'7FFF' %start
         size=3; frag_flags=frag_flags!64
      %finish %else size=5
      adj=adj-5+size
      frag_length=frag_length-5+size
      %continue

sw(*):
      %REPEAT
      %RESULT=CA+adj
%END
%INTEGER %FN swopof(%INTEGER n)
%INTEGER j
      j=n>>24!(n&x'ff0000')>>8
      j=j!(n&x'ff00')<<8!n<<24
      %RESULT=j
%END
%ROUTINE prepare object
!***********************************************************************
!*    Opens the object file destroying the previous one
!***********************************************************************
%INTEGER flag
%STRING (127) pars
      %IF host=IBMXA %START
         emas3exist(objfile,flag)
         %IF flag#0 %THEN emas3destroy(objfile,flag)
         %IF flag#0 %THEN perror("Objectfile protected or inaccessible")
         emas3claimchannel(channel)
         pars=itos(channel).",".objfile.",,V512"
         emas3("DEFINE",pars,flag)
         opensq(channel)
      %ELSE
      %FINISH
%END
%ROUTINE write record(%NAME start,finish)
!***********************************************************************
!*     outputs a record to the file with monitoring                    *
!***********************************************************************
%INTEGER i,j,k
      %IF filemon#0 %START
         printstring("record to file type="); write(byteinteger(addr(start)),3)
         k=addr(finish)-addr(start)+1
         printstring("len="); write(k,3)
         newline
         %FOR i=0,1,63 %CYCLE
            phexbyte(byteinteger(addr(start)+i))
            %EXIT %IF i>=k
            space %IF i&15=15
         %REPEAT
         newline
      %FINISH
      %IF host=IBMXA %START
         writesq(channel,start,finish)
      %ELSE
      %FINISH
%END
%ROUTINE flush buffer(%BYTE %ARRAY %NAME buff, %INTEGER %NAME ptr)
!***********************************************************************
!*    Flush a general buffer                                           *
!***********************************************************************
      write record(buff(0),buff(ptr-1))
      buff(0)=2;                         ! TIR record assumed
      ptr=1
%END
%ROUTINE add frag(%BYTE %ARRAY %NAME buf, %INTEGER %NAME ptr, %INTEGER ad,len)
!***********************************************************************
!*    Add code or data to the buffer within the 128 limit of VMS       *
!***********************************************************************
%INTEGER wl,j
      %CYCLE
         %IF len>128 %THEN wl=128 %ELSE wl=len
         buf(ptr)<--wl
         %FOR j=0,1,wl-1 %CYCLE
            buf(ptr+j+1)=byteinteger(ad+j)
         %REPEAT
         ptr=ptr+wl+1
         %IF ptr>256 %THEN flush buffer(buf,ptr)
         ad=ad+wl; len=len-wl
      %REPEAT %UNTIL len=0
%END
%ROUTINE write headers
!***********************************************************************
!*     Output the global header, compiler title and source name        *
!*     header records                                                  *
!***********************************************************************
%INTEGER i,j,k
%STRING (17) dt
%BYTE %ARRAY buff(0:511)
      buff(0)=0;                         ! recordtype = header
      buff(1)=0;                         ! Header type = global header
      buff(2)=0;                         ! Structure type=0 (original structure?)
      buff(3)=0; buff(4)=2;              ! Max record =512 (2*256)
      string(addr(buff(5)))="IMP80MODULE"
      i=6+buff(5)
      string(addr(buff(i)))="Version 1"
      i=i+1+buff(i)
      dt=vax dt;                         ! Creation date & time
      %FOR j=0,1,16 %CYCLE
         k=charno(dt,j+1)
         buff(j+i)=k; buff(j+i+17)=k
      %REPEAT
      i=i+34
      write record(buff(0),buff(i));     ! Output global header
      buff(1)=1;                         ! Compiler title header
      string(addr(buff(2)))=Compiler title
      %IF buff(2)>35 %THEN buff(2)=35
      i=buff(2)+2
      write record(buff(0),buff(i))
      buff(1)=2;                         !  Source id header
      string(addr(buff(2)))=Srcfile
      i=buff(2)+2
      write record(buff(0),buff(i))
                                         ! Could put a copyright record in here
%END
%ROUTINE define psects
!***********************************************************************
!*    All emas areas (10) are defined here as psects in order          *
!*    Thus the VMS psect no is the emas area-1                         *
!*    The lengths of all areas are known by the time this RT is called *
!***********************************************************************
%INTEGER i,j,k,bptr,psect
%STRING (31) name
%RECORD (symfm) %NAME sym
%CONST %INTEGER exec=B'011001001',read=B'010001001',writ=B'110001001'
      %CONST %SHORT %INTEGER %ARRAY pprops(1:10)=exec,writ,read(2),writ,
                                       read,writ(3),read
%BYTE %ARRAY buff(0:511)

      buff(0)=1; bptr=1;                 ! record type=GSD
      %FOR i=1,1,10 %CYCLE
         buff(bptr)=0;                   ! psect defn
         buff(bptr+1)=3;                 ! 16 byte aligned
         j=pprops(i);                    ! area properties
         buff(bptr+2)=j&255; buff(bptr+3)=j>>8
         j=areas(i)_length
         %IF host#target %THEN j=swop of(j)
         buff(bptr+4)=j>>24
         buff(bptr+5)<-j>>16
         buff(bptr+6)<-j>>8
         buff(bptr+7)<-j
!
         name=areanames(i)
         j=length(name)
         %FOR k=0,1,j %CYCLE
            buff(bptr+k+8)=upper case iso(charno(name,k))
         %REPEAT
         bptr=bptr+9+j
      %REPEAT
      write record(buff(0),buff(bptr-1))
      buff(0)=1; bptr=1
      psect=10;                          ! next psect= #10
      %FOR i=setareas,1,toparea %CYCLE
         %IF areas(i)_length=0 %THEN %CONTINUE
         areas(i)_psect=psect
         psect=psect+1
         buff(bptr)=0;                   ! psect defn
         buff(bptr+1)=3;                 ! 16 byte aligned
         j=writ!4;                       ! area properties write with overlay
         buff(bptr+2)=j&255; buff(bptr+3)=j>>8
         j=areas(i)_length
         %IF host#target %THEN j=swop of(j)
         buff(bptr+4)=j>>24
         buff(bptr+5)<-j>>16
         buff(bptr+6)<-j>>8
         buff(bptr+7)<-j
!
         sym==syms(areas(i)_sym-20)
         name=string(dictstart+sym_strx)
         j=length(name)
         %FOR k=0,1,j %CYCLE
            buff(bptr+k+8)=upper case iso(charno(name,k))
         %REPEAT
         bptr=bptr+9+j
         flush buffer(buff,bptr) %AND buff(0)=1 %IF bptr>256
      %REPEAT
      flush buffer(buff,bptr) %IF bptr>1
%END


%ROUTINE set area offset(%BYTE %ARRAY %NAME buf, %INTEGER %NAME ptr, %INTEGER area,
   offset)
!***********************************************************************
!*    set the top word of linker stack to an address                   *
!***********************************************************************
      buf(ptr+1)=area-1;                 ! Psect no
      %IF offset>=128 %START
         buf(ptr)=6
         buf(ptr+2)=offset&255
         buf(ptr+3)=offset>>8&255
         buf(ptr+4)=offset>>16&255
         buf(ptr+5)=offset>>24
         ptr=ptr+6
      %ELSE
         buf(ptr)=4
         buf(ptr+2)=offset
         ptr=ptr+3
      %FINISH
%END;                                    ! of set area offset
%ROUTINE set loc cntr(%BYTE %ARRAY %NAME buf, %INTEGER %NAME ptr, %INTEGER area,offset)
!***********************************************************************
!*    Set the linkers location counter to area and arbitary offset     *
!***********************************************************************
      set area offset(buf,ptr,area,offset)
      buf(ptr)=80;                       ! pop stacktop to counter
      ptr=ptr+1
      %IF ptr>256 %THEN flush buffer(buf,ptr)
%END
%ROUTINE write code
!***********************************************************************
!*    All the refences are resolved. write out the code fragments      *
!*    and generate the correct branches. Some action for switches can  *
!*    be done in this pass if traditional method used                  *
!***********************************************************************
%ROUTINE %SPEC branch(%RECORD (fragform) %NAME freg)
%BYTE %ARRAY buff(0:511)
%SWITCH sw(0:7)
%string(15)name
%RECORD (fragform) %NAME frag,proc frag
%record(SymFm)%name Sym
%INTEGER bufptr,link,size,Id,opcode,I,at,entryad,distance
      buff(0)=2; bufptr=1;               ! TIR records
      set loc cntr(buff,bufptr,code,0)
      link=0
      %WHILE link>=0 %CYCLE
         frag==record(area1base+link)
         link=frag_flink
         ->sw(frag_type)
Sw(codetype):
Sw(marktype):
Sw(pmasktype):
         add frag(buff,bufptr,addr(frag)+codefraglength,frag_length)
         %CONTINUE

Sw(brtype):
         branch(frag)
         %CONTINUE
Sw(labtype):                             ! No action needed
         %CONTINUE
Sw(Calltype):                           ! Calls external & internal
      Id=Frag_lindex
      sym==syms(Id-20)
      size=5; opcode=X'EF';             ! pc longdisp mode
      %if frag_flags&64#0 %then size=3 %and opcode=X'CF'
      %if frag_flags&128#0 %then size=2 %and opcode=X'AF'
      %if Sym_type&EXT#0 %then %Start;  ! relocate to external
         add frag(buff,bufptr,addr(frag)+codefraglength,frag_length-size)
                                        ! add the call opcode and parameter specifier
         flush buffer(buff,bufptr) %if bufptr>1
         buff(0)=2;                     ! relocation coming
         buff(1)=0; bufptr=2
         name<-string(dictstart+sym_strx)
         %for i=0,1,length(name) %cycle
            buff(bufptr)=uppercaseiso(charno(name,i))
            bufptr=bufptr+1
         %repeat
         buff(bufptr)=28;               ! store PICR
         bufptr=bufptr+1
         flush buffer(Buff,bufptr)
         %continue
      %finish
      at=addr(frag)+codefraglength+frag_length-size
      byteinteger(at)=opcode
      proc frag==record(area1base+sym_value&X'FFFFFF')
      entryad=proc frag_ca+proc frag_adj+sym_value>>24
      distance=entry ad-(frag_ca+frag_adj)
      byteinteger(at+1)=distance&255
      byteinteger(at+2)=distance>>8&255
      %if size>3 %then %start
         byteinteger(at+3)=distance>>16&255
         byteinteger(at+4)=distance>>24
      %finish
      ->sw(codetype);                   ! output completed fragment
Sw(Swtype):                             ! Not sure what to do yet
Sw(*):
      %REPEAT
      flush buffer(buff,bufptr) %IF bufptr>1
      %RETURN
%ROUTINE branch(%RECORD (fragform) %NAME frag)
!***********************************************************************
!*    output the branch                                                *
!*    The lindex field should point to the label (Set by tidy frags)   *
!***********************************************************************
%INTEGER disp,size,uncond,op,label
%RECORD (fragform) %NAME labfrag
      op=frag_instrn>>16&255
      uncond=frag_flags&1;               ! Set if unconditional
      label=frag_label
      size=frag_length;                  ! Size assigned by tidy must be used
      labfrag==record(area1base+frag_lindex)
      Perror("Label??") %UNLESS labfrag_type=labtype %AND labfrag_label=label
      disp=labfrag_ca+labfrag_adj-(frag_ca+frag_adj)
      %IF size=2 %START
         Perror("Cannot reach nearlab") %IF imod(disp)>127
         buff(bufptr)<--2
         buff(bufptr+1)=op
         buff(bufptr+2)<-disp
         bufptr=bufptr+3
         %RETURN
      %FINISH
      %IF uncond=0 %START;               ! jump round jump
         buff(bufptr)<--2
         buff(bufptr+1)=op!1;            ! flips most conditions
         buff(bufptr+2)=size+2
      %FINISH
      %IF size=3 %OR (size=5 %AND uncond=0) %START
         buff(bufptr)<--3
         %IF uncond=1 %THEN op=op+20 %ELSE op=X'31' {BRW}
         Perror("Cant reach Farlab") %IF imod(disp)>x'7fff'
         buff(bufptr+1)=op
         buff(bufptr+2)=disp&255
         buff(bufptr+3)<-disp>>8
         bufptr=bufptr+4
         %RETURN
      %FINISH
      %IF size=5 %OR size=7 %START
         buff(bufptr)<--5
         %IF size=7 %THEN op=X'17' %ELSE op=op+6
         buff(bufptr+1)=op
         buff(bufptr+2)=disp&255
         buff(bufptr+3)=disp>>8&255
         buff(bufptr+4)=disp>>16&255
         buff(bufptr+5)=disp>>24
         bufptr=bufptr+7
         %RETURN
      %FINISH
      Perror("Funny branch")
%END
%END
%ROUTINE close object
%BYTE %ARRAY buff(0:7)
      buff(0)=3;                         ! EOM record
      buff(1)=0;                         ! No fatal errors
      write record(buff(0),buff(1))
      %IF host=IBMXA %START
         closesq(channel)
      %ELSE
      %FINISH
%END
%STRING (17) %FN vaxdt
%STRING (3) d,m,y,h,min,sec
%STRING (17) s,t
%INTEGER i
      %IF host=IBMXA %START
      %EXTERNAL %ROUTINE %SPEC emas3date(%STRING (*) %NAME s)
      %EXTERNAL %ROUTINE %SPEC emas3time(%STRING (*) %NAME s)
         %CONST %STRING (3) %ARRAY month(1:12)="jan","feb","mar","apr","may","jun",
                                        "jly","aug","sep","oct","nov","dec"

         emas3date(s)
         s->d.("/").m.("/").y
         i=10*(charno(m,1)-'0')+charno(m,2)-'0'
         t=d."-".month(i)."-19".y
         emas3time(s)
         s->h.(".").min.(".").sec
         t=t." ".h.":".min
         %RESULT=t
      %ELSE
      %FINISH
%END
!
! The rest of the file is devoted to disassembly
!
%OWN %INTEGER impliedsize
%ownstring(127)hext,decodet
%INTEGER %FN getcbyte(%INTEGER %NAME boff,ca)
!***********************************************************************
!*    Extract a byte from the instruction stream                       *
!***********************************************************************
%INTEGER i
%constinteger fragmask=B'11010110'
%RECORD (fragform) %NAME frag
      frag==record(area1base+boff)
      %WHILE frag\==currfrag %AND (1<<frag_type&fragmask=0 %OR ca>=frag_ca+frag_length) %CYCLE
         boff=frag_flink
         frag==record(area1base+boff)
         ca=frag_ca
      %REPEAT
      i=byteinteger(area1base+boff+codefraglength+ca-frag_ca)
      hext=hext.htos(i,2)
      ca=ca+1
      %RESULT=i
%END
%INTEGER %FN getchalf(%INTEGER %NAME boff,ca)
!***********************************************************************
!*    Extract two bytes from the instruction stream low order first    *
!***********************************************************************
%INTEGER i
      i=getcbyte(boff,ca)
      %RESULT=getcbyte(boff,ca)<<8!i
%END
%INTEGER %FN getcword(%INTEGER %NAME boff,ca)
!***********************************************************************
!*   Extract 4 bytes from the instruction stream low order first       *
!***********************************************************************
%INTEGER i
      i=getchalf(boff,ca)
      %RESULT=getchalf(boff,ca)<<16!i
%END
%INTEGER %FN opcodeandtype(%INTEGER %NAME boff,ca)

      %CONST %STRING (6) %ARRAY vaxi(0:511) = %C
{  00->03}    "HALT  ","NOP   ","REI   ","BPT   ",
{  04->07}    "RET   ","RSB   ","LDPCTX","SVPCTX",
{  08->0B}    "CVTPS ","CVTSP ","INDEX ","CRC   ",
{  0C->0F}    "PROBER","PROBEW","INSQUE","REMQUE",
{  10->13}    "BSBB  ","BRB   ","BNEQ  ","BEQL  ",
{  14->17}    "BGTR  ","BLEQ  ","JSB   ","JMP   ",
{  18->1B}    "BGEQ  ","BLSS  ","BGTRU ","BLEQU ",
{  1C->1F}    "BVC   ","BVS   ","BGEQU ","BLSSU ",
{  20->23}    "ADDP4 ","ADDP6 ","SUBP4 ","SUBP6 ",
{  24->27}    "CVTPT ","MULP  ","CVTTP ","DIVP  ",
{  28->2B}    "MOVC3 ","CMPC3 ","SCANC ","SPANC ",
{  2C->2F}    "MOVC5 ","CMPC5 ","MOVTC ","MOVTUC",
{  30->33}    "BSBW  ","BRW   ","CVTWL ","CVTWB ",
{  34->37}    "MOVP  ","CMPP3 ","CVTPL ","CMPP4 ",
{  38->3B}    "EDITPC","MATCHC","LOCC  ","SKPC  ",
{  3C->3F}    "MOVZWL","ACBW  ","MOVAW ","PUSHAW",
{  40->43}    "ADDF2 ","ADDF3 ","SUBF2 ","SUBF3 ",
{  44->47}    "MULF2 ","MULF3 ","DIVF2 ","DIVF3 ",
{  48->4B}    "CVTFB ","CVTFW ","CVTFL ","CVTRFL",
{  4C->4F}    "CVTBF ","CVTWF ","CVTLF ","ACBF  ",
{  50->53}    "MOVF  ","CMPF  ","MNEGF ","TSTF  ",
{  54->57}    "EMODF ","POLYF ","CVTFD ","??    ",
{  58->5B}    "ADAWI ","??    ","??    ","??    ",
{  5C->5F}    "INSQHI","INSQTI","REMQHI","REMQTI",
{  60->63}    "ADDD2 ","ADDD3 ","SUBD2 ","SUBD3 ",
{  64->67}    "MULD2 ","MULD3 ","DIVD2 ","DIVD3 ",
{  68->6B}    "CVTDB ","CVTDW ","CVTDL ","CVTRDL",
{  6C->6F}    "CVTBD ","CVTWD ","CVTLD ","ACBD  ",
{  70->73}    "MOVD  ","CMPD  ","MNEGD ","TSTD  ",
{  74->77}    "EMODD ","POLYD ","CVTDF ","??    ",
{  78->7B}    "ASHL  ","ASHQ  ","EMUL  ","EDIV  ",
{  7C->7F}    "CLRQ  ","MOVQ  ","MOVAQ ","PUSHAQ",
{  80->83}    "ADDB2 ","ADDB3 ","SUBB2 ","SUBB3 ",
{  84->87}    "MULB2 ","MULB3 ","DIVB2 ","DIVB3 ",
{  88->8B}    "BISB2 ","BISB3 ","BICB2 ","BICB3 ",
{  8C->8F}    "XORB2 ","XORB3 ","MNEGB ","CASEB ",
{  90->93}    "MOVB  ","CMPB  ","MCOMB ","BITB  ",
{  94->97}    "CLRB  ","TSTB  ","INCB  ","DECB  ",
{  98->9B}    "CVTBL ","CVTBW ","MOVZBL","MOVZBW",
{  9C->9F}    "ROTL  ","ACBB  ","MOVAB ","PUSHAB",
{  A0->A3}    "ADDW2 ","ADDW3 ","SUBW2 ","SUBW3 ",
{  A4->A7}    "MULW2 ","MULW3 ","DIVW2 ","DIVW3 ",
{  A8->AB}    "BISW2 ","BISW3 ","BICW2 ","BICW3 ",
{  AC->AF}    "XORW2 ","XORW3 ","MNEGW ","CASEW ",
{  B0->B3}    "MOVW  ","CMPW  ","MCOMW ","BITW  ",
{  B4->B7}    "CLRW  ","TSTW  ","INCW  ","DECW  ",
{  B8->BB}    "BISPSW","BICPSW","POPR  ","PUSHR ",
{  BC->BF}    "CHMK  ","CHME  ","CHMS  ","CHMU  ",
{  C0->C3}    "ADDL2 ","ADDL3 ","SUBL2 ","SUBL3 ",
{  C4->C7}    "MULL2 ","MULL3 ","DIVL2 ","DIVL3 ",
{  C8->CB}    "BISL2 ","BISL3 ","BICL2 ","BICL3 ",
{  CC->CF}    "XORL2 ","XORL3 ","MNEGL ","CASEL ",
{  D0->D3}    "MOVL  ","CMPL  ","MCOML ","BITL  ",
{  D4->D7}    "CLRL  ","TSTL  ","INCL  ","DECL  ",
{  D8->DB}    "ADWC  ","SBWC  ","MTPR  ","MFPR  ",
{  DC->DF}    "MOVPSL","PUSHL ","MOVAL ","PUSHAL",
{  E0->E3}    "BBS   ","BBC   ","BBSS  ","BBCS  ",
{  E4->E7}    "BBSC  ","BBCC  ","BBSSI ","BBCCI ",
{  E8->EB}    "BLBS  ","BLBC  ","FFS   ","FFC   ",
{  EC->EF}    "CMPV  ","CMPZV ","EXTV  ","EXTZV ",
{  F0->F3}    "INSV  ","ACBL  ","AOBLSS","AOBLEQ",
{  F4->F7}    "SOBGEQ","SOBGTR","CVTLB ","CVTLW ",
{  F8->FB}    "ASHP  ","CVTLP ","CALLG ","CALLS ",
{  FC->FF}    "XFC   ","??    ","??    ","??    ",
{FD00->FD03}  "??    ","??    ","??    ","??    ",
{FD04->FD07}  "??    ","??    ","??    ","??    ",
{FD08->FD0B}  "??    ","??    ","??    ","??    ",
{FD0C->FD0F}  "??    ","??    ","??    ","??    ",
{FD10->FD13}  "??    ","??    ","??    ","??    ",
{FD14->FD17}  "??    ","??    ","??    ","??    ",
{FD18->FD1B}  "??    ","??    ","??    ","??    ",
{FD1C->FD1F}  "??    ","??    ","??    ","??    ",
{FD20->FD23}  "??    ","??    ","??    ","??    ",
{FD24->FD27}  "??    ","??    ","??    ","??    ",
{FD28->FD2B}  "??    ","??    ","??    ","??    ",
{FD2C->FD2F}  "??    ","??    ","??    ","??    ",
{FD30->FD33}  "??    ","??    ","CVTDH ","CVTGF ",
{FD34->FD37}  "??    ","??    ","??    ","??    ",
{FD38->FD3B}  "??    ","??    ","??    ","??    ",
{FD3C->FD3F}  "??    ","??    ","??    ","??    ",
{FD40->FD43}  "ADDG2 ","ADDG3 ","SUBG2 ","SUBG3 ",
{FD44->FD47}  "MULG2 ","MULG3 ","DIVG2 ","DIVG3 ",
{FD48->FD4B}  "CVTGB ","CVTGW ","CVTGL ","CVTRGL",
{FD4C->FD4F}  "CVTBG ","CVTWG ","CVTLG ","ACBG  ",
{FD50->FD53}  "MOVG  ","CMPG  ","MNEGG ","TSTG  ",
{FD54->FD57}  "EMODG ","POLYG ","CVTGH ","??    ",
{FD58->FD5B}  "??    ","??    ","??    ","??    ",
{FD5C->FD5F}  "??    ","??    ","??    ","??    ",
{FD60->FD63}  "ADDH2 ","ADDH3 ","SUBH2 ","SUBH3 ",
{FD64->FD67}  "MULH2 ","MULH3 ","DIVH2 ","DIVH3 ",
{FD68->FD6B}  "CVTHB ","CVTHW ","CVTHL ","CVTRHL",
{FD6C->FD6F}  "CVTBH ","CVTWH ","CVTLH ","ACBH  ",
{FD70->FD73}  "MOVH  ","CMPH  ","MNEGH ","TSTH  ",
{FD74->FD77}  "EMODH ","POLYH ","CVTHG ","??    ",
{FD78->FD7B}  "??    ","??    ","??    ","??    ",
{FD7C->FD7F}  "CLRO  ","MOVO  ","MOVAO ","PUSHAO",
{FD80->FD83}  "??    ","??    ","??    ","??    ",
{FD84->FD87}  "??    ","??    ","??    ","??    ",
{FD88->FD8B}  "??    ","??    ","??    ","??    ",
{FD8C->FD8F}  "??    ","??    ","??    ","??    ",
{FD90->FD93}  "??    ","??    ","??    ","??    ",
{FD94->FD97}  "??    ","??    ","??    ","??    ",
{FD98->FD9B}  "CVTFH ","CVTFG ","??    ","??    ",
{FD9C->FD9F}  "??    ","??    ","??    ","??    ",
{FDA0->FDA3}  "??    ","??    ","??    ","??    ",
{FDA4->FDA7}  "??    ","??    ","??    ","??    ",
{FDA8->FDAB}  "??    ","??    ","??    ","??    ",
{FDAC->FDAF}  "??    ","??    ","??    ","??    ",
{FDB0->FDB3}  "??    ","??    ","??    ","??    ",
{FDB4->FDB7}  "??    ","??    ","??    ","??    ",
{FDB8->FDBB}  "??    ","??    ","??    ","??    ",
{FDBC->FDBF}  "??    ","??    ","??    ","??    ",
{FDC0->FDC3}  "??    ","??    ","??    ","??    ",
{FDC4->FDC7}  "??    ","??    ","??    ","??    ",
{FDC8->FDCB}  "??    ","??    ","??    ","??    ",
{FDCC->FDCF}  "??    ","??    ","??    ","??    ",
{FDD0->FDD3}  "??    ","??    ","??    ","??    ",
{FDD4->FDD7}  "??    ","??    ","??    ","??    ",
{FDD8->FDDB}  "??    ","??    ","??    ","??    ",
{FDDC->FDDF}  "??    ","??    ","??    ","??    ",
{FDE0->FDE3}  "??    ","??    ","??    ","??    ",
{FDE4->FDE7}  "??    ","??    ","??    ","??    ",
{FDE8->FDEB}  "??    ","??    ","??    ","??    ",
{FDEC->FDEF}  "??    ","??    ","??    ","??    ",
{FDF0->FDF3}  "??    ","??    ","??    ","??    ",
{FDF4->FDF7}  "??    ","??    ","CVTHF ","CVTHD ",
{FDF8->FDFB}  "??    ","??    ","??    ","??    ",
{FDFC->FDFF}  "??    ","??    ","??    ","??    "


!
! Format codes 0-7 = number of normal operand
!      A normal operand has the same implied size as the opcode
!       16-18 Branches with 1,2 or 4 byte offsets
!       19 Bit branches 2 normal operands then byte disp
!       20 Bit branches 1 normal operand then byte disp
!       21 Calls
!       32 Special format for ACB
!       33 Special for Case
!
      %CONST %BYTE %INTEGER %ARRAY vaxopf(0:511) = %C
{  00->0F}    0,0,0,0,0,0,0,0,4,4,6,4,3,3,2,2,
{  10->1F}    16(6),18,18,16(8),
{  20->2F}    4,6,4,6,5,6,5,6,3,3,4,4,5,5,6,6,
{  30->3F}    17,17,2,2,3,3,3,4,4,4,3,3,2,32,2,2,
{  40->4F}    2,3,2,3,2,3,2,3,2,2,2,2,2,2,2,32,
{  50->5F}    2,2,2,1,5,3,2,0,2,0,0,0,2,2,2,2,
{  60->6F}    2,3,2,3,2,3,2,3,2,2,2,2,2,2,2,32,
{  70->7F}    2,2,2,1,5,3,2,0,3,3,4,4,1,2,2,1,
{  80->8F}    2,3,2,3,2,3,2,3,2,3,2,3,2,3,2,33,
{  90->9F}    2,2,2,2,1,1,1,1,2,2,2,2,3,32,2,1,
{  A0->AF}    2,3,2,3,2,3,2,3,2,3,2,3,2,3,2,33,
{  B0->BF}    2,2,2,2,1,1,1,1,1,1,1,1,1,1,1,1,
{  C0->CF}    2,3,2,3,2,3,2,3,2,3,2,3,2,3,2,33,
{  D0->DF}    2,2,2,2,1,1,1,1,2,2,2,2,1,1,2,1,
{  E0->EF}    19(8),20(2),4(6),
{  F0->FF}    4,32,19,19,20,20,2,2,6,3,2,21,0(4),
{FD00->FD0F}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FD10->FD1F}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FD00->FD0F}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FD30->FD3F}  0,0,2,2,0,0,0,0,0,0,0,0,0,0,0,0,
{FD40->FD4F}  2,3,2,3,2,3,2,3,2,2,2,2,2,2,2,32,
{FD50->FD5F}  2,2,2,1,5,3,2,0,0,0,0,0,0,0,0,0,
{FD60->FD6F}  2,3,2,3,2,3,2,3,2,2,2,2,2,2,2,32,
{FD70->FD7F}  2,2,2,1,5,3,2,0,0,0,0,0,1,2,2,1,
{FD80->FD8F}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FD90->FD9F}  0,0,0,0,0,0,0,0,2,2,0,0,0,0,0,0,
{FDA0->FDAF}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FDB0->FDBF}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FDC0->FDCF}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FDD0->FDDF}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FDE0->FDEF}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FDF0->FDFF}  0,0,0,0,0,0,2,2,0,0,0,0,0,0,0,0

      %CONST %BYTE %INTEGER %ARRAY vaxisize(0:511) = %C
{  00->0F}    0,0,0,0,0,0,0,0,4,4,6,4,3,3,2,2,
{  10->1F}    1(6),4,4,1(8),
{  20->2F}    4,6,4,6,5,6,5,6,1(8),
{  30->3F}    2,2,2,2,3,3,3,4,4,4,3,3,2,2,2,2,
{  40->4F}    4(16),
{  50->5F}    4(7),0,2,0,0,0,4,4,4,4,
{  60->6F}    8(16),
{  70->7F}    8(7),0,4,8,4,4,8,8,8,8,
{  80->8F}    1(16),
{  90->9F}    1(16),
{  A0->AF}    2(16),
{  B0->BF}    4(10),4,4,2,2,2,2,
{  C0->CF}    4(16),
{  D0->DF}    4(16),
{  E0->EF}    4(16),
{  F0->FF}    4,4,4,4,4,4,4,4,6,4,4,4,0(4),
{FD00->FD0F}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FD10->FD1F}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FD00->FD0F}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FD30->FD3F}  0,0,2,2,0,0,0,0,0,0,0,0,0,0,0,0,
{FD40->FD4F}  8(16),
{FD50->FD5F}  8(7),0,0,0,0,0,0,0,0,0,
{FD60->FD6F}  16(16),
{FD70->FD7F}  16(7),0,0,0,0,0,16,16,16,16,
{FD80->FD8F}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FD90->FD9F}  0,0,0,0,0,0,0,0,4,4,0,0,0,0,0,0,
{FDA0->FDAF}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FDB0->FDBF}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FDC0->FDCF}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FDD0->FDDF}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FDE0->FDEF}  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
{FDF0->FDFF}  0,0,0,0,0,0,16,16,0,0,0,0,0,0,0,0

%RECORD (fragform) %NAME frag,prevfrag
%INTEGER opcode,offset,oldca
      oldca=ca
      opcode=getcbyte(boff,ca)
      offset=opcode
      %IF opcode=x'FD' %THEN %START
         offset=256+getcbyte(boff,ca)
         opcode=offset!X'FD00'
      %FINISH
      frag==record(area1base+boff)
      %if frag_type=Pmasktype %then %start
         opcode=getcbyte(boff,ca);    ! second byte of mask
         decodet=decodet."Entry Mask"
         %result=0
      %finish
      prevfrag==record(area1base+frag_blink)
      %IF prevfrag_type=labtype %AND prevfrag_ca=oldca %START
         printstring("
".HTOS(Oldca,4)."  Label".itos(prevfrag_label).":")
      %FINISH
      decodet=decodet.vaxi(offset)." "
      impliedsize=vaxisize(offset)
      %RESULT=vaxopf(offset)
%END
%ROUTINE pnormal opnd(%INTEGER %NAME boff,ca, %INTEGER isize)
!***********************************************************************
!*    Extract and output an operamd. Isize (implied size) is only      *
!*    relevant for operands in the instruction stream                  *
!***********************************************************************
%INTEGER i,j,opspec,R,mode,disp,oldca
%SWITCH sw(0:23)
      %CONST %STRING (3) %ARRAY Rn(0:15)="R0","R1","R2","R3","R4","R5","R6","R7",
                                "R8","R9","R10","R11","AP","FP","SP","PC"

      oldca=ca
      opspec=getcbyte(boff,ca)
      mode=opspec>>4
      R=opspec&15
      %IF mode>=8 %AND R=15 %THEN mode=mode+8; ! PC modes now 16-23
      ->sw(mode)
SW(0):
SW(1):
SW(2):
SW(3):                                   ! literal mode
      decodet=decodet."=".itos(opspec)
      %RETURN
SW(4):                                   ! indexed mode
      pnormalopnd(boff,ca,isize)
      decodet=decodet."+[".Rn(R)."]"
      %RETURN
SW(5):                                   ! Register mode
      decodet=decodet.Rn(R)
      %RETURN
SW(7):                                   ! autodecrement mode
      decodet=decodet."-"
SW(6):                                   ! Register deferred mode
SW(8):                                   ! Auto increment
      decodet=decodet."(".Rn(R).")"
      %IF 8<=mode<=9 %THEN decodet=decodet."+"
      %RETURN
SW(9):                                   !  Autoinc deferred
      decodet=decodet."@"; ->SW(8)
SW(10):
SW(11):
SW(18):
SW(19):                                  ! Byte disp various
      disp=getcbyte(Boff,ca)
      %if disp&128#0 %then disp=disp!X'FFFFFF00'; ->com
SW(12):
SW(13):
SW(20):
SW(21):                                  ! Word disp various
      disp=getchalf(Boff,ca)
      %if disp&X'8000'#0 %then disp=disp!X'FFFF0000'; ->com
SW(14):
SW(15):
SW(22):
SW(23):                                  ! Longword disp various
      disp=getcword(Boff,ca)
com:
      %IF mode>15 %THEN disp=disp+oldca; ! pc relative
      %IF mode&1#0 %THEN decodet=decodet."@"
      decodet=decodet.itos(disp)
      %RETURN %IF mode>15
      ->SW(6)
sw(16):                                  ! Immediate mode
      disp=0; j=0
      %FOR i=1,1,isize %CYCLE
         disp=disp!getcbyte(Boff,ca)<<j
         j=j+8
      %REPEAT
      %if disp&1<<(j-1)#0 %then disp=disp!(-1)<<j
      decodet=decodet."I=".itos(disp)
      %RETURN
SW(17):                                  ! disp=getcword(Boff,ca)
      disp=getcword(Boff,ca)
      decodet=decodet."@=".itos(disp)
%END;                                    ! p normal opnd
%ROUTINE ncode1(%INTEGER %NAME boff,ca)
%RECORD (fragform) %NAME frag
%SWITCH SW(0:10)
%INTEGER i,j,Id
%record(Symfm)%name Sym
%string(255)text
      hext=HTOS(ca,4)."    "
      decodet=""
      j=opcode and type(Boff,ca)
      %IF j<=7 %START
         %FOR i=1,1,j %CYCLE
            pnormalopnd(Boff,ca,impliedsize)
            decodet=decodet."," %UNLESS i=j
         %REPEAT
         ->prin
      %FINISH
      ->SW(J-16) %if j<=26
      ->prin
sw(0):
sw(1):
sw(2):                                   ! Jumps
      frag==record(area1base+boff)
      decodet=decodet."<Label".itos(frag_label).">"
      ca=ca+frag_length
      ->prin
sw(5):                                  ! CALLS
      pnormalopnd(Boff,ca,4)
      frag==record(Area1base+boff)
      ->Prin %unless frag_type=calltype
      Id=Frag_lindex
      sym==syms(id-20)
      %if Sym_type&EXT#0 %then text=" External Call" %c
         %else text=" Internal call"
      %if sym_Strx>=0 %then text=text." to ".string(dictstart+sym_Strx)
      decodet=decodet."<< ".text." >>"
      ca=frag_ca+frag_length
      ->Prin
sw(*):
prin:
      newline
      printstring(hext)
      %if length(hext)<32 %then spaces(32-length(hext))
       printstring(decodet)
%END
%END %OF %FILE