%CONSTINTEGER EMAS=1,PERQ=0,SYS=EMAS
%CONSTINTEGER NOTSYS = (SYS+1)&1
!
!***********************************************************
!*                                                         *
!*    PROGRAM TO ANALYSE A PERQ OBJECT                     *
!***********************************************************


!
!
! Procedures which will be specially interpreted:
!
! 
!
{PERQ   %EXTERNALHALFINTEGERFNSPEC OPENFILE(%INTEGER FILE, %HALFINTEGERNAME BLOCKS,BITS)
{PERQ   %EXTERNALROUTINESPEC NEWSEG(%INTEGER AD,%HALFINTEGER SIZE,INC,MAXSIZE)
{PERQ   %EXTERNALROUTINESPEC READBLOCK(%HALFINTEGER FILEID,BLOCK,%INTEGER AD)
{EMAS} %DYNAMICINTEGERFNSPEC RDFILEAD(%STRING(63) S)
{EMAS} %DYNAMICINTEGERFNSPEC NWFILEAD(%STRING(15) S,%INTEGER PGS)
{EMAS} %SYSTEMROUTINESPEC PHEX(%INTEGER I)
%RECORDFORMAT OBJF(%INTEGER NEXTFREEBYTE, CODERELST, PSIZE,  %C
         FILETYPE, SUM, DATETIME, LDRELST, OFM)
%CONSTINTEGER MAXSEG=32
!
! 
!
!-------------------------------------------------------------------------------
!
{EMAS}  %EXTERNALROUTINE QOBJANAL(%STRING(255) FILE)
{PERQ   %BEGIN
%INCLUDE "ERCS06.PERQ_IMPORTS"
%INTEGER INBASE,I,J
{PERQ  %HALFINTEGER BITS
{PERQ   %HALFINTEGER BLOCKS
{PERQ   %INTEGER FILEID
%CONSTSTRING(30) %ARRAY LEXPL(1:10)=" Procedure entries ",
                                   " Procedure references ",
                                   "","","",
                                   " Area definitions ",
                                   " Data initialisation ",
                                   " 16 bit Relocations ",
                                   " 32 bit Relocations ",
                                   " Root filename "

%CONSTSTRING(10) %ARRAY AREAEXPL(1:7)="CODE","GLA","","SST","UST"," 6 ",""
%INTEGER RLINK
%INTEGER NUMIMPS,IMPBLOCKS
%INTEGER LOC, LINK,LDATAAD
%INCLUDE "QLFORMATS"
%OWNINTEGER UNSATREFS=0
%byteintegerarrayformat pdescfm(0:255)
%byteintegerarrayname PDESC
%INTEGER GLAAD
%INTEGER RT
{PERQ  %STRING(110) FILE
%STRING (31) IDEN

{PERQ %ROUTINE PHEX(%INTEGER N)
{PERQ 
{PERQ %CONSTBYTEINTEGERARRAY K(0:15)='0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
{PERQ %HALFINTEGER I,J
{PERQ %CYCLE J=1,-1,0
{PERQ    %CYCLE I=12,-4,0
{PERQ        PRINTSYMBOL(K((HALFINTEGER(ADDR(N)+J)>>I)&15))
{PERQ    %REPEAT
{PERQ %REPEAT
{PERQ %END

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

{PERQ   %STRING(255) %FN READLINE
{PERQ   %INTEGER CH,I,J,K
{PERQ    %OWNHALFINTEGER SOMETHING=0
{PERQ    %STRING(255) S

{PERQ    S=""
{PERQ    CH=0
{PERQ    SOMETHING=0

{PERQ       %CYCLE
{PERQ        READSYMBOL(CH)
{PERQ     %IF CH=' ' %START
{PERQ       %IF SOMETHING#0 %THEN %EXIT %ELSE %CONTINUE
{PERQ     %FINISH
{PERQ        SOMETHING=1
{PERQ        S=S.TOSTRING(CH)
{PERQ     %REPEAT
{PERQ     SKIPSYMBOL  {NL}
{PERQ      %RESULT=S
{PERQ    %END



%ROUTINE PRINT8(%BYTEINTEGERARRAYNAME B)
{PERQ    %HALFINTEGER I
{EMAS}    PRINTSYMBOL(B(1))
{EMAS}    PRINTSYMBOL(B(0))
{EMAS}    PRINTSYMBOL(B(3))
{EMAS}    PRINTSYMBOL(B(2))
{EMAS}    PRINTSYMBOL(B(5))
{EMAS}    PRINTSYMBOL(B(4))
{EMAS}    PRINTSYMBOL(B(7))
{EMAS}    PRINTSYMBOL(B(6))
{PERQ     PRINTSYMBOL(B(I)) %FOR I=0,1,7
%END
 
%ROUTINE PBYTE(%HALFINTEGER I)
   %CONSTBYTEINTEGERARRAY HX(0:15)='0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
   
    PRINTSYMBOL(HX((I>>4)&15))
    PRINTSYMBOL(HX(I&15))
%END


%ROUTINE PRINTDESC(%BYTEINTEGERARRAYNAME B)
   %constbyteintegerarray ptype(0:15)='#','I','R','X','L','C','H','#'(*)
   %constbyteintegerarray psize(0:15)='0','0','0','1','2','4','8','0'(*)
   %INTEGER i,size,type
{perq       %if b(1)=x'ff' %then printstring("      ") %elsestart
{PERQ        %IF B(1)=0 %THEN PRINTSTRING("   RTN,") %ELSE %START
{PERQ           PRINTSYMBOL(PTYPE(B(1)&15))
{PERQ           PRINTSYMBOL('*')
{PERQ           PRINTSYMBOL(PSIZE(B(1)>>4))
{PERQ          PRINTSTRING(" FN,")
{PERQ    %FINISH
{perq    %finish
         %if b(0)<=1 %then printstring("      No Parameters") %and %return
{perq    %cycle i=2,1,2+b(0)-2
{perq       space
{perq      %if b(i)=x'80' %then printstring("Rtn") %elsestart
{perq       size=b(i)>>4
{perq       type=b(i)&15
{perq       printsymbol(ptype(type))
{perq      printsymbol('*')
{perq       printsymbol(psize(size))
{perq      %finish
{perq    %repeat
{EMAS}  
{EMAS}    I=1
{EMAS}    %WHILE I<=b(0) %CYCLE
{EMAS}       SPACE
{EMAS}      PBYTE(B(I+1))
{EMAS}      %EXIT %IF I+1>B(1)+1
{EMAS}      SPACE
{EMAS}       PBYTE(B(I))
{EMAS}       I=I+(2>>SYS)
{EMAS}    %REPEAT
%END




%ROUTINE PREV(%INTEGER AD)
   %INTEGER I,LEN

{EMAS}    LEN = BYTEINTEGER(AD+1)
{EMAS}    %STRING(255) S
{EMAS} 
{EMAS}    %CYCLE I=0,2,((LEN+1)//2)*2
{EMAS}       HALFINTEGER(ADDR(S)+I)=BYTEINTEGER(AD+I)!(BYTEINTEGER(AD+I+1)<<8)
{EMAS}    %REPEAT
{EMAS}    PRINTSTRING(S)
{PERQ     PRINTSTRING(STRING(AD))
%END


{PERQ  NEWLINE
{PERQ   PRINTSTRING(" FILE NAME:")
{PERQ   FILE = READLINE
{PERQ   FILEID=OPENFILE(ADDR(FILE),BLOCKS,BITS)
{PERQ   INBASE=0
{PERQ   NEWSEG(ADDR(INBASE)+1,BLOCKS+1,1,BLOCKS+1)
{PERQ   J = INBASE
{PERQ   %CYCLE I=0,1,BLOCKS
{PERQ       READBLOCK(FILEID,I,J)
{PERQ       J = J + 256
{PERQ    %REPEAT




printstring("File: ".file)






{EMAS}  INBASE = RDFILEAD(FILE)
{EMAS}   NEWLINE
{EMAS}  PRINTSTRING("Total size (including header):    ")
{EMAS}    phex(integer(Inbase))
{EMAS}   NEWLINE
{EMAS}  PRINTSTRING("Offset of Load Data:              ")
{EMAS}     phex(integer(inbase+24))
{EMAS}   NEWLINE
{EMAS}  PRINTSTRING("Offset of Object file map:        ")
{EMAS}     phex(integer(inbase+28))
{EMAS} INBASE = INBASE+X'220'

NEWLINE
PRINT STRING("***************
* Perq Header *
***************")

{PERQ  H==RECORD(INBASE)
{EMAS} H == RECORD(INBASE-X'200')
PRINTSTRING("
Flag:  ")
WRITE(H_FLAGS,1)
PRINTSTRING("   Qcode Version: ")
WRITE(H_QVERSION,1)
NEWLINE
PRINTSTRING("Module: ")
PRINT8(H_MODULE)
NEWLINE
PRINTSTRING("Source:   ")
PREV(ADDR(H_SOURCEFILE))
NEWLINE
PRINTSTRING("Number of Imported Segments: ")
WRITE(H_NUMIMPS,1)
NEWLINE
PRINTSTRING("Import Table Block No:       ")
WRITE(H_IMPBLOCK,1)
NEWLINE
PRINTSTRING("Global Data Size (in words) : ")
WRITE(H_GDSIZE,1)
NEWLINE
PREV(ADDR(H_VERSION))
NEWLINE
PRINTSTRING("Pre-link Block No:")
WRITE(H_PRELINKBLOCK,1)
NEWLINE
PRINTSTRING("Diagnostics Block No:")
WRITE(H_DIAGBLOCK,1)
NEWLINE

PRINTSTRING("Routine Parameter Descriptor Block No: ")
WRITE(H_ROUTDESCBLOCK,1)
NEWLINE


printstring("
***************
* Code Header *
***************
")
printstring("(All word offsets from code start)
")
printstring("Dict:  ")

{PERQ   INBASE=INBASE+256
       CH == RECORD(INBASE)


phex(ch_dict)
printstring("  Rts:  ")
phex(ch_rts)
printstring("  Ldata:  ")
phex(ch_ldata)
printstring("  Area map:  ")
phex(ch_map)
newline
      LDATAAD = INBASE+(CH_LDATA<<SYS)
      LDATA==ARRAY(LDATAAD,LDATAFM)
                                        !LOAD DATA

printstring("*************
* Load Data *
*************
(All word offsets from Ldata start)
")
%cycle i=1,1,ldata(0)
   %continue %if ldata(i)=0
   write(i,2)
   spaces(2)
   phex(ldata(i))
   printstring("  ".lexpl(i))
   %IF I=10 %THEN PRINTSTRING("   - ") %AND PREV(LDATAAD+(LDATA(10)<<SYS))
   newline
%repeat


PRINTSTRING("******************
*  Imports       *
******************")
NEWLINE
IMPORTS == ARRAY(INBASE+((H_IMPBLOCK-1)*(512>>NOTSYS)),IMPAFM)
%FOR I=0,1,H_NUMIMPS-1 %CYCLE
  PRINTSTRING("Module: ")
   PRINT8(IMPORTS(I)_MOD)
   SPACES(3)
PRINTSTRING("    from File: ")
   PREV(ADDR(IMPORTS(I)_FILE))
   NEWLINE
%REPEAT



      AMAP==ARRAY(INBASE+(CH_MAP<<sys),AMAPFM)
                                        !OBJECT FILE MAP

printstring("*******************
* Object file Map *
*******************
       Offset    Length      Properties
")
%cycle i=1,1,6
   write(i,2)
   spaces(2)
   phex(amap(i)_Start)
  SPACES(4)
   phex(amap(i)_len)
   spaces(4)
   phex(amap(i)_props)
   printstring("   ".areaexpl(i))

   newline
%REPEAT

       DICTIONARY == ARRAY(INBASE+(CH_DICT<<sys),DICTAFM)
GLAAD = INBASE+(AMAP(2)_START<<sys)
printstring("*********************
* Procedure entries *
*********************
")
!
! NOW PRINT MAP OF ENTRY POINTS
!
      PRINTSTRING("NAME                          ENTRY ID     PS    RPS    LTS  ENTRY   EXIT     LL")
      NEWLINE
      LINK=LDATA(1);                    !HEAD OF CODE EP LIST
      %WHILE LINK#0 %CYCLE
         L1==RECORD(LDATAAD+(LINK<<sys))
         PREV(ADDR(L1_NAME))
{PERQ           SPACES(32-LENGTH(L1_NAME))
{EMAS}          SPACES(32-BYTEINTEGER(ADDR(L1_NAME)+1))
         RT=L1_RTNO
         WRITE(RT,3)
         SPACES(2)
         WRITE(DICTIONARY(RT)_PS,6)
         WRITE(DICTIONARY(RT)_RPS,6)
         WRITE(DICTIONARY(RT)_LTS,5)
         WRITE(DICTIONARY(RT)_ENTRY,5)
         WRITE(DICTIONARY(RT)_EXIT,6)
         WRITE(DICTIONARY(RT)_LL,6)
         NEWLINE
         LINK=L1_LINK
      %REPEAT
!



%if H_ROUTDESCBLOCK#0 %Start
   I = INBASE + ((H_ROUTDESCBLOCK-1)*(512>>notsys))
   printstring("*******************************
* Entry Parameter Descriptors *
*******************************
")
   printstring(" Entry ID     Parameter descriptor")
   J = 0
   %while J<CH_RTS %cycle
      PDESC == ARRAY(I,PDESCFM)
      newline
      write(J,5)
      spaces(5)
      PRINTDESC(PDESC)
      I = I + (((PDESC(1)+2)>>1<<1)>>notsys)
      J = J + 1
   %repeat
   newline
%finish




%IF H_PRELINKBLOCK#0 %START

I = INBASE + ((H_PRELINKBLOCK-1)*(512>>notsys))
UNSATREFS=HALFINTEGER(I)

   PRINTSTRING("*************************
* Unresolved References *
*************************
")
PRINTSTRING(" Name    Block : Disp       Parameter descriptor")

I=I+(2>>notsys)
J=0
%WHILE J<UNSATREFS %CYCLE
   PLB == RECORD(I)
   NEWLINE
   PRINT8(PLB_NAME)
   SPACES(2)
   WRITE(PLB_BLOCK,3)
   PRINTSTRING(" : ")
   WRITE(PLB_BYTE OFFSET,1)
   SPACES(5)
   PRINTDESC(PLB_ROUTDESC)
   I=I+(12+(PLB_ROUTDESC(0)+2)>>1<<1)>>NOTSYS   { (0) IF PERQ
   J=J+1
%REPEAT
NEWLINE
%FINISH

%IF LDATA(2)#0 %START
PRINTSTRING("*******************************
* System procedure references *
*******************************")
printstring("
  rtno   name   ")

l2 == record(ldataad+(ldata(2)<<sys))
%while addr(l2)>ldataad %cycle
newline
  write(l2_rt,3)
  spaces(3)
   prev(addr(l2_name))
   l2 == record(ldataad+(l2_link<<sys))
%Repeat
%FinIsh 



%if ldata(6)#0 %start
newline
   printstring("********************
* Area definitions *
********************
   name                           Area  Length Properties
")
   l6 == record(ldataad+(ldata(6)<<sys))
   %while addr(L6) > ldataad %cycle
      Prev(addr(L6_name))
{perq spaces(32-length(L6_name))
{emas} spaces(32-byteinteger(addr(l6_name)+1))
      write(L6_area no,4)
      space
     PHEX(L6_LENGTH)
      space
      phex(l6_props)
      l6 == record(ldataad+(L6_link<<sys))
       NEWLINE
   %repeat
%finish

%IF LDATA(8)#0 %START
NEWLINE
printstring("******************************
* 16 bit relocation requests *
******************************

")
l8 == record(ldataad+(ldata(8)<<sys))
printstring(" Relocate GLA + displacement(words)  by  displacement(words)
")
%while addr(l8)>ldataad %cycle
%cycle i=1,1,l8_num
phex(l8_disp(i))
spaces(2)
phex(halfinteger(Glaad)+(l8_disp(i)<<sys))
%if i&1=0 %then newline %else spaces(6)
%Repeat
l8==record(ldataad+(l8_Link<<sys))
%repeat
%finish

newline

%IF LDATA(9)#0 %START
PRINTSTRING("**********************
* 32 bit relocations *
**********************
( Relocate GLA + displacement(words) by area + displacement)
")
l9 == record(ldataad+(ldata(9)<<sys))
%while addr(l9)>ldataad %cycle
%cycle i=1,1,l9_num
phex(l9_fix(i)_disp)
spaces(2)
%IF L9_FIX(I)_AREA<7 %THENC
printstring("  ".areaexpl(l9_fix(i)_area)." + ") %ELSEC
WRITE(L9_FIX(I)_AREA,4) %AND PRINTSTRING(" + ")
J = L9_FIX(I)_DISP<<sys
! PHEX((HALFINTEGER(GLAAD+J)<<16)!HALFINTEGER(GLAAD+J+(1<<sys)))
Phex(integer(GLaad+j))
%if i&1=0 %then newline %else spaces(6)
%Repeat
l9 == record(ldataad+(l9_link<<sys))
%repeat


%if ldata(7)#0 %start
   printstring("
******************
* Data Fragments *
******************
  area    disp.    copies    length
")
   l7 == record(ldataad+(ldata(7)<<sys))
   %while addr(l7)>ldataad %cycle
      write(l7_area,4)
      spaces(4)
      phex(l7_disp)
      space
      write(l7_copies,4)
      space
      write(l7_len,7)
      newline
      l7 == record(ldataad+(l7_link<<sys))
   %repeat
%finish


%finish
{EMAS}        %END; ! OBJFILEMAP
{PERQ   %ENDOFPROGRAM
!
!-------------------------------------------------------------------------------
!
{EMAS} %ENDOFFILE