%CONSTINTEGER EMAS=0,PERQ=1,SYS=perq
%EXTERNALROUTINE QCODE(%INTEGER START,FINISH,CA,MODE)
! %EXTERNALROUTINESPEC DUMP(%INTEGER A,B,C,D)
 %IF SYS=EMAS %START; %SYSTEMROUTINESPEC PHEX(%INTEGER N) ; %FINISHELSESTART

%ROUTINE PHEX(%INTEGER N)

%CONSTBYTEINTEGERARRAY K(0:15)='0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
%HALFINTEGER I,J
%CYCLE J=1,-1,0
   %CYCLE I=12,-4,0
       PRINTSYMBOL(K((HALFINTEGER(ADDR(N)+J)>>I)&15))
   %REPEAT
%REPEAT
%END
%FINISH
!*TOP
!****************************************************************************
!*                                                                          *
!*             PERQ QCODE DISSASSEMBLER 
!*                                                                          *
!****************************************************************************
!*
!*
!*    MODE IS :-
!                 1  - ASCII EQUIVELANT IS PRINTED
!                 2  - NO HEX AD IS PRINTED
!                 4  - DECIMAL AD IS PRINTED
!                 8  - NO SEGMENT NUMBER IS GIVEN
!                 16  -  HEX EQUIVELANT IS PRINTED
!                 32  - LINES ARE PADDED TO COMMON END POINT

!*
!*   THIS ARRAY CONTAINS THE INSTRUCTION MNEMONICS FOR THE PERQ.
!*    THE EIGTH CHARACTER CONTAINS THE LENGTH IN BYTES OF THE INSTRUCTION.
!*      (EXCEPTION/ IF THIS IS NINE THEN SPECIAL HANDLING IS REQUIRED)
!*    THE NEXT THREE DIGITS REVEAL THE TYPE OF THE FIRST THREE PARAMETERS.
!*         0  -  NO PARAMATER
!*         U  -  UNSIGNED BYTE
!*         B  -  SIGNED BYTE
!*         W  -  SIGNED 16 BIT WORD
!*         D  -  DOUBLE WORD (32 BITS)
!*
!*
%CONSTSTRING(11) %ARRAY OPS(0:255) = %C
"LDC0   1000","LDC1   1000","LDC2   1000","LDC3   1000","LDC4   1000","LDC5   1000",
"LDC6   1000","LDC7   1000","LDC8   1000","LDC9   1000","LDC10  1000","LDC11  1000",
"LDC12  1000","LDC13  1000","LDC14  1000","LDC15  1000","LDCMO  1000","LDCB   2B00",
"LDCW   3W00","LSA    9U00","ROTSHI 2U00","STIND  1000","LDCN   1000","LDB    1000",
"STB    1000","LDCH   1000","LDP    1000","STP    1000","STCH   1000","EXGO   6WUW",
"LAND   1000","LOR    1000","LNOT   1000","EQUBOOL1000","NEQBOOL1000","LEQBOOL1000",
"LESBOOL1000","GEQBOOL1000","GTRBOOL1000","EQUI   1000","NEQI   1000","LEQI   1000",
"LESI   1000","GEQI   1000","GTRI   1000","****   1000","****   1000","****   1000",
"****   1000","****   1000","****   1000","EQUSTR 1000","NEQSTR 1000","LEQSTR 1000",
"LESSTR 1000","GEQSTR 1000","GTRSTR 1000","EQUBYT 2U00","NEQBYT 2U00","LEQBYT 2U00",
"LESBYT 2U00","GEQBYT 2U00","GTRBYT 2U00","EQUPOWR1000","NEQPOWR1000","LEQPOWR1000",
"SGS    1000","GEQPOWR1000","SRS    1000","EQUWORD2U00","NEQWORD2U00","ABI    1000",
"ADI    1000","NGI    1000","SBI    1000","MPI    1000","DVI    1000","MODI   1000",
"CHK    1000","****   1000","****   1000","****   1000","****   1000","****   1000",
"****   1000","****   1000","****   1000","****   1000","INN    1000","UNI    1000",
"INT    1000","DIF    1000","EXIT   4WU0","NOOP   1000","REPL   1000","REPL2  1000",
"MMS    1000","MES    1000","LVRD   5WUU","LSSN   1000","XJP    9WWW","PSW    1000",
"RASTER 1000","STARTIO1000","****   1000","INTOFF 1000","INTON  1000","LDLB   2U00",
"LDLW   3W00","LDL0   1000","LDL1   1000","LDL2   1000","LDL3   1000","LDL4   1000",
"LDL5   1000","LDL6   1000","LDL7   1000","LDL8   1000","LDL9   1000","LDL10  1000",
"LDL11  1000","LDL12  1000","LDL13  1000","LDL14  1000","LDL15  1000","LLAB   2U00",
"LLAW   3W00","STLB   2U00","STLW   3W00","STL0   1000","STL1   1000","STL2   1000",
"STL3   1000","STL4   1000","STL5   1000","STL6   1000","STL7   1000","LDOB   2U00",
"LDOW   3W00","LDO0   1000","LDO1   1000","LDO2   1000","LDO3   1000","LDO4   1000",
"LDO5   1000","LDO6   1000","LDO7   1000","LDO8   1000","LDO9   1000","LDO10  1000",
"LDO11  1000","LDO12  1000","LDO13  1000","LDO14  1000","LDO15  1000","LOAB   2U00",
"LOAW   3W00","STOB   2U00","STOW   3W00","STO0   1000","STO1   1000","STO2   1000",
"STO3   1000","STO4   1000","STO5   1000","STO6   1000","STO7   1000","MVBB   2U00",
"MVBW   1000","MOVB   2U00","MOVW   1000","INDB   2U00","INDW   3W00","LDIND  1000",
"SIND1  1000","SIND2  1000","SIND3  1000","SIND4  1000","SIND5  1000","SIND6  1000",
"SIND7  1000","LGAWW  5WW0","STMW   1000","STDW   1000","SAS    1000","ADJ    2U00",
"CALL   2U00","CALLV  1000","ATPB   2B00","ATPW   1000","WCS    1000","JCS    1000",
"LDGB   3UU0","LDGW   4UW0","LGAB   3UU0","LGAW   4UW0","STGB   3UU0","STGW   4UW0",
"****   1000","****   1000","RETURN 1000","MMS2   1000","MES2   1000","LDTP   1000",
"JMPB   2B00","JMPW   3W00","JFB    2B00","JFW    3W00","JTB    2B00","JTW    3W00",
"JEQB   2B00","JEQW   3W00","JNEB   2B00","JNEW   3W00","IXP    2U00","LDIB   3UU0",
"LDIW   4UW0","LIAB   3UU0","LIAW   4UW0","STIB   3UU0","STIW   4UW0","IXAB   2U00",
"IXAW   1000","IXA1   1000","IXA2   1000","IXA3   1000","IXA4   1000","TLATE1 1000",
"TLATE2 1000","TLATE3 1000","EXCH   1000","EXCH2  1000","INCB   2U00","INCW   3W00",
"CALLXB 3UU0","CALLXW 4WU0","LDMC   9U00","LDDC   5D00","LDMW   1000","LDDW   1000",
"STLATE 2U00","****   1000","ENABLE 5WUU","RAISE  6WUW","LDAP   1000","****   1000",
"****   1000","****   1000","****   1000","****   1000","ROPS   2U00","INCDDS 1000",
"LOPS   2U00","****   1000","BREAK  1000","REFILL 1000"
!
%CONSTSTRING(7) %ARRAY  SLOPS(0:14)= %C
"CVTLI","CVTL","ADL","NGL","SBL","MPL","DVL","MODL","ABL","EQULONG",
"NEQLONG","LEQLONG","LESLONG","GEQLONG","GTRLONG"
%CONSTSTRING(7) %ARRAY SROPS(0:15)= %C
"TNC","FLT","ADR","NGR","SBR","MPR","DVR","RND","ABR","EQUREAL","NEQREAL","LEQREAL","LESREAL",
"GEQREAL","GTRREAL","****"

!
%IF SYS=EMAS %START
%SYSTEMSTRINGFNSPEC ITOS(%INTEGER I)
%FINISHELSESTART
   %STRING(15) %FN ITOS(%INTEGER K)
      %INTEGER REM,NUM,NF
      %STRING(15) STR

      STR=""
      %IF K<0 %START
         NF=1
         K = K *(-1)
      %FINISH
      %CYCLE
         NUM=K
         K = K//10
         REM = NUM-(K*10)
         STR = TOSTRING(REM+'0').STR
         %IF K=0 %THEN %EXIT
      %REPEAT
      %IF NF=1 %THEN STR = "-".STR
      %RESULT = STR
   %END
%FINISH
%ROUTINESPEC PRINTLINE
%ROUTINESPEC PRAD(%INTEGER AD)
%STRING(4) %FNSPEC HTOS(%HALFINTEGER N)
%ROUTINESPEC PRAX(%INTEGER AD,LEN)
%CONSTINTEGER ASCII=1,NOHEXAD=2,DECAD=4,NOSEG=8,HEXEQUIV=16,PAD=32
%CONSTSTRING(1) %ARRAY HX(0:15)="0","1","2","3","4","5","6","7","8", 
"9","A","B","C","D","E","F"
%BYTEINTEGERARRAYFORMAT BFM(0:10000)
%BYTEINTEGERARRAYNAME B,A,T
%INTEGER DISP,OPD
%HALFINTEGER OPDTYPE
%INTEGER MIN,MAX,CTLEN
%INTEGER PC,TOPPC,I,J,K
%HALFINTEGER OPCODE
%STRING(11) MNEMONIC
%OWNINTEGER OUTSTANDING=0
%OWNINTEGER LL=0
%INTEGER OLDMODE
%HALFINTEGER SYM
%INTEGER ADPC,JUMP,PR,PAR1,PAR3
%INTEGER TO
%INTEGER AD,SEG
%INTEGER INSL
%STRING(255) TEXT
%STRING(255) LINE
%STRING(6) NUM
 
%CONSTINTEGER LSA = 19 , LDMC = 236 , XJP = 100 , LDDC = 237, LOPS=252,ROPS=250

!
!
!  PRINTSTRING("
! QCODE(")
! PHEX(START)
! SPACE
! PHEX(FINISH)
! SPACE
! PHEX(CA)
! PRINTSTRING(")")
! NEWLINE
! DUMP(START,FINISH,0,0)
 SEG = (START)>>16
PC=0
%if finish<start %then toppc=finish %elsestart
TOPPC = FINISH - START
%if sys=perq %then toppc=toppc*2
%finish
LL=0
B == ARRAY(START,BFM)
!
%WHILE PC < TOPPC %CYCLE
   LINE=""
   ADPC=START+PC+OUTSTANDING
  OUTSTANDING=0 
   OPCODE = B(PC)
   MNEMONIC = OPS(OPCODE)
   LENGTH(MNEMONIC)=7
   PRAD(PC+CA)                                                  ;!PRINT ADDRESS OF INSTRUCTION
   LINE = LINE." "
   DISP=1
  A == ARRAY(ADDR(MNEMONIC),BFM)
   INSL = A(8) - '0'
   PR = INSL

   %IF INSL = 9 %START                                          ;! DEAL WITH INSTRUCTIONS OF VARIABLE LENGTH
      %IF OPCODE=LDMC %THEN INSL=2+(B(PC+1)*2)  %AND PR=2 %ELSESTART
         ! CHECK FOR WORD ALIGNED PARAMS
         %IF (OPCODE=XJP     %OR  OPCODE=LSA  ) %AND (PC+CA)&1=0 %THen disp=2
         %IF OPCODE = XJP   %START     ;! CASE JUMP
            MIN = (B(PC+2)<<8)!B(PC+1)
            %IF MIN>>15# 0 %THEN MIN=MIN!X'FFFF0000'
            MAX = (B(PC+4)<<8)!B(PC+3)
            %IF MAX>>15#0 %THEN MAX=MAX!X'FFFF0000'
            CTLEN= MAX-MIN+1
            INSL = DISP+6+(CTLEN*2)
            PR = DISP+6
         %FINISHELSE %IF OPCODE = LSA  %THEN   INSL = DISP+1+B(PC+DISP) %AND PR=DISP+1
      %FINISH
   %FINISH
%IF SYS=EMAS %START 
%IF ADPC+INSL>start+toppc+1  %AND toppc#1 %START
   PRINTSTRING("
QCODE/ BAD INPUT - instruction at ")
PHEX(ADPC)
PRINTSTRING(" of length ")
WRITE(INSL,1)
PRINTSTRING(" bytes")
PRINTSTRING(" and finish ad =")
PHEX(FINISH)
NEWLINE
OUTSTANDING=(ADPC+INSL)-FINISH
%RETURN
%FINISH
%FINISH


   %IF MODE&ASCII#0 %OR MODE&HEXEQUIV#0 %START
      %IF INSL>PR %THEN PRAX(PC,PR) %ELSE PRAX(PC,INSL)     ;!  PRINT ASCII AND HEX EQUIVELANT
   %FINISH
!    %IF MODE&HEXEQUIV#0 %START
!       LINE=LINE."  " %FOR I=PR,1,9
!    %FINISH

   %IF OPCODE=LOPS %START    ;! ESCAPETO LONG OPS
      LINE=LINE." ".SLOPS(B(PC+1))
     LL=LENGTH(LINE)+18
      ->NXTINT
   %FINISH

   %IF OPCODE=ROPS %START   ;! ESCAPE TO REAL OPS
      LINE = LINE." ".SROPS(B(PC+1))
      LL = LENGTH(LINE)+18
     ->NXTINT
   %FINISH
  

   LINE = LINE." ".MNEMONIC."  "
   %IF 204<=OPCODE<=213 %THEN JUMP=1 %ELSE JUMP=0
LL=LENGTH(LINE)+18

   %CYCLE I=9,1,11
      OPDTYPE=A(I)
      %EXIT %IF OPDTYPE='0'
      OPD=B(PC+DISP)
      %IF OPDTYPE='U' %START
         NUM = ITOS(OPD) 
         DISP=DISP+1
         ->NXT
      %FINISH%ELSE%IF OPDTYPE='B' %START
         %IF OPD>>7#0 %THEN OPD=OPD!X'FFFFFF00'
         NUM = ITOS(OPD) 
         DISP=DISP+1
         ->NXT
      %FINISH%ELSE%IF OPDTYPE='W' %START
         OPD=(B(PC+DISP+1)<<8)!OPD
         %IF OPD>>15#0 %THEN OPD=OPD!X'FFFF8000'
         NUM = ITOS(OPD) 
         DISP=DISP+2
         ->NXT
      %FINISH%ELSEIF OPDTYPE='D' %START
         OPD=(B(PC+DISP+1)<<24)!(OPD<<16)! %C
                       (B(PC+DISP+3)<<8)! %C
                       (B(PC+DISP+2))
         LINE=LINE." "
          %EXIT
      %FINISH
NXT:  %IF I=9 %THEN PAR1=OPD %ELSE PAR3=OPD
      NUM = NUM ." " %WHILE LENGTH(NUM)<6
      LINE = LINE.NUM
   %REPEAT

   %IF JUMP=1 %START
      LINE=LINE." to "
      TO = CA+PC+OPD +INSL
         TO=TO&X'FFFF'   ;! SUPPRESS PRINTING OF SEG NUMBER
      PRAD(TO)
   %FINISH
 
      %IF OPCODE=LDDC %START
       LINE=LINE.HTOS(HALFINTEGER(ADDR(OPD)+(2>>SYS)))
        LINE=LINE.HTOS(HALFINTEGER(ADDR(OPD)))
      %FINISH

      %IF OPCODE=LSA %START
          T == ARRAY(ADDR(TEXT),BFM)
          T(I)=B(PC+DISP+I-1) %FOR I=0,1,PAR1+1
         %CYCLE I=0,1,LENGTH(TEXT)
            T(I+1)='.' %UNLESS 32<=T(I+1)<=123
         %REPEAT
         LINE=LINE."     """.TEXT.""""
      %FINISH

   PRINTLINE
   LINE=""
 

%IF SYS=EMAS %START
      %IF OPCODE=XJP %START
         J=ADPC+DISP  ;! START AD OF CASE BLOCK
         %CYCLE I=MIN,1,MAX
           LINE=LINE."      ".ITOS(I)." to "
           AD = J+((I-MIN)*2)
         K = BYTEINTEGER(AD)!(BYTEINTEGER(AD+1)<<8)
       %IF K>>15#0 %THEN K=K!X'FFFF0000'
        PRAD(PC+CA+K)
             PRINT LINE
             LINE=""
         %REPEAT
        LINE = "       or default to "
        PRAD(PC+CA-2+PAR3)
         PRINT LINE
        LINE=""
      %FINISH
   !
   ! PRINT OUT REMAINDER OF LARGE INSTRUCTIONS
   !
%IF OPCODE=LDMC %OR MODE&ASCII#0 %OR MODE&HEXEQUIV#0 %START
      J=INSL-PR
      I=0
      AD = CA+PC+PR
      OLDMODE=MODE
       MODE=MODE!HEXEQUIV
      %WHILE I<J %CYCLE
         PRAD(AD)
         LINE=LINE." "
         %IF J-I>7 %THEN PRAX(AD-CA,8) %ELSE PRAX(AD-CA,J-I)
         AD=AD+8
         I=I+8
          PRINTLINE
          LINE=""
      %REPEAT
       MODE=OLDMODE
   %FINISH
%FINISH

NXTINT:
   PC=PC+INSL
     PRINTLINE %UNLESS LINE=""
%REPEAT
%RETURN
!!
!!
 
 
%ROUTINE PRINTLINE

   PRINTSTRING("
".LINE)
    %IF MODE&PAD#0 %AND LENGTH(LINE)<LL %THEN SPACES(LL-LENGTH(LINE))
  %IF MODE<0 %THEN PRINTSTRING("!")
%END

%ROUTINE PRAD(%INTEGER A)
   %STRING(9) S
   %INTEGER SEG,AD,I
   !
   SEG = A>>16
   A= A&X'FFFF'
   %IF SEG#0  %AND MODE&NOSEG=0 %then LINE=LINE.HTOS(SEG)."/"
   %IF MODE&NOHEXAD=0 %START
     LINE=LINE.HTOS(A)
   %FINISH
   %IF MODE&DECAD#0 %START
       S=" (".ITOS(A).")"
      S=S." " %WHILE LENGTH(S)<8
      LINE=LINE.S
   %FINISH
%END    ;! OF PRAD
!
!
%ROUTINE PRAX(%INTEGER A,LEN)
   %INTEGER I,SYM,AD,J
   !
   %if mode&ascii#0 %start
      I=0
      %CYCLE
         SYM = B(A+I)
         %IF 32<=SYM<=123 %THEN LINE=LINE.TOSTRING(SYM) %ELSE LINE=LINE."."
         I=I+1
      %REPEAT %UNTIL I=LEN
      J=I&7
      %IF J=0 %THEN J=8
      LINE=LINE." " %AND J=J+1 %WHILE J<10
   %finish
   %if mode&hexequiv#0 %start
     line = line."  "
      i=0
      %cycle
         sym=b(a+i)
         line=line.hx(sym>>4).hx(sym&15)
         i=i+1
      %repeat %until i=len
     j=i&7
     %if j=0 %then j=8
      line=line."  " %and j=j+1 %while j<10
   %finish
%END    ;! OF PRAX

%STRING(4) %FN HTOS(%HALFINTEGER N)

   %INTEGER I,J,L
   %STRING(4) S

   S=""
   %CYCLE I=12,-4,0
      J=N
     L=0
      J=J>>1 %AND L=L+1 %WHILE I>L
      J=J&15
      S = S.HX(J)
   %REPEAT
   %RESULT=S
%END

%END   ;! OF QCODE
!
!
!
%ENDOFFILE