%EXTERNALROUTINE SKIMPAI(%STRING(63) PARAM)
%STRING(15)%FNSPEC READMN(%INTEGERNAME SEP)
%ROUTINESPEC DUMP(%INTEGER ON,RN,BN,DN)
%INTEGERFNSPEC INTSTR(%STRING(15) S)
%STRING(15)%FNSPEC STRINT(%INTEGER N)
%ROUTINESPEC FAULT(%STRING(255) MESS)
%ROUTINESPEC FAIL(%STRING(255) MESS)
%ROUTINESPEC MONITOR
%CONSTSTRING(7)%ARRAY IMN(0:32)="STOP","LOAD","LDA","ADD","SUB","MLT",
  "DIV","EXP","STR","NEG","NOT","SHL","SHR","AND","OR","XOR","BAL","B",
  "BZ","BNZ","BG","BNG","BL","BNL","ADDF","SUBF","MLTF","DIVF","EXPF",
  "NEGF","FLT","FILL","CONST"
%STRING(63) OBJECT,LISTING
%STRING(15)%ARRAY RMN(0:15)
%INTEGERARRAY R(0:15)
%INTEGERARRAY S(0:4095)
%STRING(15) OPN,REG,BASE,DISP
%CONSTINTEGER SL=4095
%CONSTINTEGER DATAMASK=B'0011111000000001111100011111010'
%INTEGER RP,SP,MON,TRON,TROFF,ON,RN,BN,DN,SEP,I,FAULTS,INST,TRACE,PC, %C
  PCL,TRACEPC,EFAD,STACKB,STPR,ACCR,CYC,IC
%SWITCH INS(0:31)
%SWITCH EXT(1:11)
%EXTERNALROUTINESPEC DEFINE(%STRING(63) S)
  %UNLESS PARAM->OBJECT.(",").LISTING %THEN PRINT STRING("PARAMETERS ?
") %AND %STOP
  DEFINE("STREAM01,".OBJECT)
  SELECT INPUT(1)
  DEFINE("STREAM02,".LISTING)
  SELECT OUTPUT(2)
  RMN(0)=""
  R(0)=0
  RP=1
  SP=0
  MON=0
  TRON=0
  TROFF=0
  FAULTS=0
INSTR:! PROCESS NEXT INSTRUCTION
  READ SYMBOL(I) %UNTIL I='$'
  %CYCLE
    I=NEXT SYMBOL
    %IF I=' ' %THEN SKIP SYMBOL %ELSE %EXIT
  %REPEAT
  %IF '0'<=I<='9' %THEN %START    ;! "FAULTS IN PROGRAM"
    %IF I>'0' %THEN FAULT("PROGRAM WAS FAULTY") %AND %STOP
    %IF FAULTS>0 %THEN FAULT("ASSEMBLY FAULTY") %AND %STOP
    READ SYMBOL(I) %UNTIL I=NL
    ->INTERPRET
  %FINISH
  OPN=READMN(SEP)
  %CYCLE ON=0,1,32
    %IF OPN=IMN(ON) %THEN ->GOTOPN
  %REPEAT
  %IF OPN="MONITOR" %THEN MON=1 %AND ->INSTR
  %IF OPN="TRON" %THEN TRON=1 %AND ->INSTR
  %IF OPN="TROFF" %THEN TROFF=1 %AND ->INSTR
  FAULT("INVALID OPERATION : ".OPN.TOSTRING(SEP))
  ->INSTR
GOTOPN:! GET OPERANDS
  %IF SEP#',' %THEN FAULT("INVALID FORMAT : ".OPN.TOSTRING(SEP)) %C
    %AND ->INSTR
  REG=READMN(SEP)
  %IF SEP#',' %THEN FAULT("INVALID FORMAT : ".OPN.",".REG. %C
    TOSTRING(SEP)) %AND ->INSTR
  BASE=READMN(SEP)
  %IF SEP#',' %THEN FAULT("INVALID FORMAT : ".OPN.",".REG. %C
    ",".BASE.TOSTRING(SEP)) %AND ->INSTR
  DISP=READMN(SEP)
  %IF OPN="FILL" %THEN %START
    BN=INTSTR(BASE)
    %IF BN<0 %THEN FAULT("INVALID FILL : ".REG.",".BASE) %AND ->INSTR
    DN=INTSTR(DISP)
    %UNLESS 0<=DN<=X'FFFF' %THEN FAULT("INVALID FILL : ".REG. %C
      ",".BASE.",".DISP) %AND ->INSTR
    CYC=0
    %UNTIL BN=0 %CYCLE
      CYC=CYC+1
      %IF BN>=SP %OR CYC>SP %THEN FAULT("INVALID FILL LIST AT ". %C
        STRINT(SP)) %AND ->INSTR
      I=BN
      BN=S(BN)&X'FFFF'
      S(I)=S(I)&X'FFFF0000'!DN
    %REPEAT
    %IF REG="COT" %THEN PCL=DN-1    ;! PROGRAM COUNTER LIMIT
    ->INSTR
  %FINISH
  %IF OPN="CONST" %THEN %START
    DN=INTSTR(DISP)
    %IF DN<0 %THEN FAULT("INVALID CONSTANT : ".DISP) %AND ->INSTR
    DUMP(0,0,0,DN)
    ->INSTR
  %FINISH
    %IF REG="" %AND OPN#"B" %AND OPN#"STOP" %THEN %C
      FAULT("REGISTER MISSING AT ".STRINT(SP)) %AND RN=0 %AND ->GOTREG
  %CYCLE RN=0,1,RP-1
    %IF REG=RMN(RN) %THEN ->GOTREG
  %REPEAT
  %IF RP=16 %THEN FAULT("EXCESS REGISTER : ".REG) %AND RN=0 %C
     %ELSE RMN(RP)=REG %AND RN=RP %AND RP=RP+1
GOTREG:%IF BASE="EXT" %AND OPN="BAL" %THEN ON=31 %AND BN=0 %AND->GOTBASE
%CYCLE BN=0,1,RP-1
    %IF BASE=RMN(BN) %THEN ->GOTBASE
  %REPEAT
  %IF RP=16 %THEN FAULT("EXCESS REGISTER : ".BASE) %AND BN=0 %C
    %ELSE RMN(RP)=BASE %AND BN=RP %AND RP=RP+1
GOTBASE:DN=INTSTR(DISP)
  %UNLESS 0<=DN<=X'FFFF' %THEN FAULT("INVALID DISPLACEMENT : ". %C
    DISP) %AND DN=0
  DUMP(ON,RN,BN,DN)
  ->INSTR
!-----------------------------------------------------------------------
INTERPRET:! INTERPRETATION SECTION
  TRACE=0
  STPR=0
  ACCR=0
  %CYCLE I=0,1,RP-1
    %IF RMN(I)="STP" %THEN STPR=I
    %IF RMN(I)="ACC" %THEN ACCR=I
    R(I)=0
  %REPEAT
  STACKB=SP
  %WHILE SP<=SL %THEN S(SP)=X'80000000' %AND SP=SP+1
  IC=0
  PC=0
EXI:! EXECUTE INSTRUCTION
  %IF IC>10000 %THEN FAIL("10000 INSTRUCTIONS EXECUTED")
  %UNLESS 0<=PC<=PCL %THEN FAIL("PC OUT OF BOUNDS")
  INST=S(PC)
  TRACEPC=PC
  PC=PC+1
  %IF INST&X'80000000'#0 %THEN MONITOR
  %IF INST&X'40000000'#0 %THEN TRACE=1
  %IF INST&X'20000000'#0 %THEN TRACE=0
  ON=INST>>24&X'1F'
  RN=INST>>20&X'F'
  BN=INST>>16&X'F'
  DN=INST&X'FFFF'
  EFAD=R(BN)+DN
  %IF 1<<ON&DATAMASK#0 %THEN %START
    %UNLESS PCL<EFAD<=SL %THEN FAIL("DATA ADDRESS ". %C
      STRINT(EFAD)." OUT OF BOUNDS")
    %IF S(EFAD)=X'80000000' %THEN FAIL("UNASSIGNED VARIABLE AT ". %C
      STRINT(EFAD))
  %FINISH %ELSE %START
    %IF ON=8 %THEN %START
      %UNLESS STACKB<=EFAD<=SL %THEN FAIL("STR ADDRESS ". %C
        STRINT(EFAD)." OUT OF BOUNDS")
    %FINISH
  %FINISH
  ->INS(ON)
INS(0):PRINT STRING("
STOPPED AT ".STRINT(TRACEPC).", ".STRINT(IC)." INSTRUCTIONS EXECUTED
") %AND %STOP
INS(1):R(RN)=S(EFAD) ; ->TRACEP
INS(2):%IF RN=STPR %AND EFAD<R(STPR) %THEN %START
    ! CLEAR OLD AREA BACK TO UNASSIGNED
    %CYCLE I=EFAD+2,1,R(STPR)+2
      S(I)=X'80000000' %UNLESS I>SL
    %REPEAT
  %FINISH
  R(RN)=EFAD
  ->TRACEP
INS(3):R(RN)=R(RN)+S(EFAD) ; ->TRACEP
INS(4):R(RN)=R(RN)-S(EFAD) ; ->TRACEP
INS(5):R(RN)=R(RN)*S(EFAD) ; ->TRACEP
INS(6):R(RN)=R(RN)//S(EFAD) ; ->TRACEP
INS(7):R(RN)=R(RN)**S(EFAD) ; ->TRACEP
INS(8):S(EFAD)=R(RN) ; ->TRACEP
INS(9):R(RN)=-R(RN) ; ->TRACEP
INS(10):R(RN)=\R(RN) ; ->TRACEP
INS(11):R(RN)=R(RN)<<S(EFAD) ; ->TRACEP
INS(12):R(RN)=R(RN)>>S(EFAD) ; ->TRACEP
INS(13):R(RN)=R(RN)&S(EFAD) ; ->TRACEP
INS(14):R(RN)=R(RN)!S(EFAD) ; ->TRACEP
INS(15):R(RN)=R(RN)!!S(EFAD) ; ->TRACEP
INS(16):R(RN)=PC ; PC=EFAD ; ->TRACEP
INS(17):PC=EFAD ; ->TRACEP
INS(18):%IF R(RN)=0 %THEN PC=EFAD ; ->TRACEP
INS(19):%IF R(RN)#0 %THEN PC=EFAD ; ->TRACEP
INS(20):%IF R(RN)>0 %THEN PC=EFAD ; ->TRACEP
INS(21):%IF R(RN)<=0 %THEN PC=EFAD ; ->TRACEP
INS(22):%IF R(RN)<0 %THEN PC=EFAD ; ->TRACEP
INS(23):%IF R(RN)>=0 %THEN PC=EFAD ; ->TRACEP
INS(24):REAL(ADDR(R(RN)))=REAL(ADDR(R(RN)))+REAL(ADDR(S(EFAD)))
  ->TRACEP
INS(25):REAL(ADDR(R(RN)))=REAL(ADDR(R(RN)))-REAL(ADDR(S(EFAD)))
  ->TRACEP
INS(26):REAL(ADDR(R(RN)))=REAL(ADDR(R(RN)))*REAL(ADDR(S(EFAD)))
  ->TRACEP
INS(27):REAL(ADDR(R(RN)))=REAL(ADDR(R(RN)))/REAL(ADDR(S(EFAD)))
  ->TRACEP
INS(28):REAL(ADDR(R(RN)))=REAL(ADDR(R(RN)))**S(EFAD)
  ->TRACEP
INS(29):REAL(ADDR(R(RN)))=-REAL(ADDR(R(RN))) ; ->TRACEP
INS(30):REAL(ADDR(R(RN)))=R(RN) ; ->TRACEP
INS(31):%IF STPR=0 %THEN FAIL("REGISTER STP NOT DEFINED FOR I/O". %C
    " ROUTINE CALL")
  ->EXT(DN)
EXT(1):READ SYMBOL(S(S(R(STPR)+2))) ; ->TRACEP
EXT(2):%IF ACCR=0 %THEN FAIL("REGISTER ACC NOT DEFINED FOR ". %C
    "'NEXT SYMBOL' I/O FUNCTION CALL")
  R(ACCR)=NEXT SYMBOL
  ->TRACEP
EXT(3):SKIP SYMBOL ; ->TRACEP
EXT(4):PRINT SYMBOL(S(R(STPR)+2)) ; ->TRACEP
EXT(5):SPACE ; ->TRACEP
EXT(6):SPACES(S(R(STPR)+2)) ; ->TRACEP
EXT(7):NEWLINE ; ->TRACEP
EXT(8):NEWLINES(S(R(STPR)+2)) ; ->TRACEP
EXT(9):NEWPAGE
EXT(10):READ(S(S(R(STPR)+2))) ; ->TRACEP
EXT(11):WRITE(S(R(STPR)+2),S(R(STPR)+3))
TRACEP:IC=IC+1
  %IF TRACE#0 %THEN PRINT STRING("  ".STRINT(TRACEPC))
->EXI
!-----------------------------------------------------------------------
%STRING(15)%FN READMN(%INTEGERNAME SEP)
%STRING(255) S
%INTEGER FLAG
  S=""
  FLAG=0
  %CYCLE
    READ SYMBOL(SEP)
    %IF '0'<=SEP<='9' %OR 'A'<=SEP<='Z' %THEN %START
      %IF LENGTH(S)<255 %THEN S=S.TOSTRING(SEP) %ELSE FLAG=1
    %FINISH %ELSE %START
      %IF SEP#' ' %THEN %EXIT
    %FINISH
  %REPEAT
  %IF LENGTH(S)>15 %OR FLAG#0 %THEN FAULT("INVALID MNEMONIC : ".S) %C
     %AND %RESULT="" %ELSE %RESULT=S
%END
!-----------------------------------------------------------------------
%ROUTINE DUMP(%INTEGER ON,RN,BN,DN)
  %IF SP>SL %THEN FAULT("PROGRAM TOO BIG") %AND %STOP
  S(SP)=MON<<31!TRON<<30!TROFF<<29!ON<<24!RN<<20!BN<<16!DN
  SP=SP+1
  MON=0
  TRON=0
  TROFF=0
%END
!-----------------------------------------------------------------------
%INTEGERFN INTSTR(%STRING(15) S)
%INTEGER VALUE,D,I
  VALUE=0
  %CYCLE I=1,1,LENGTH(S)
    D=CHARNO(S,I)
    %UNLESS '0'<=D<='9' %THEN %RESULT=-1
    VALUE=VALUE*10+D-'0'
  %REPEAT
  %RESULT=VALUE
%END
!-----------------------------------------------------------------------
%STRING(15)%FN STRINT(%INTEGER N)
%STRING(15) R
%STRING(1) S
  R=""
  %IF N<0 %THEN N=-N %AND S="-" %ELSE S=""
  %UNTIL N=0 %THEN R=TOSTRING(N-N//10*10+'0').R %AND N=N//10
  %RESULT=S.R
%END
!-----------------------------------------------------------------------
%ROUTINE FAULT(%STRING(255) MESS)
  PRINT STRING("
".STRINT(SP)."$   ".MESS."
")
  FAULTS=FAULTS+1
%END
!-----------------------------------------------------------------------
%ROUTINE FAIL(%STRING(255) MESS)
  PRINT STRING("
*  ".MESS."
PC=".STRINT(TRACEPC))
  MONITOR
  %STOP
%END
!-----------------------------------------------------------------------
%ROUTINE MONITOR
%STRING(15) V
  NEWLINE
  %IF RP>1 %THEN %START
    %CYCLE I=1,1,RP-1
      PRINT STRING(RMN(I)."  ".STRINT(R(I))."
")
    %REPEAT
  %FINISH
  %IF STPR#0 %AND R(STPR)>STACKB %THEN %START
    PRINT STRING("(".STRINT(STACKB).")")
    %CYCLE I=STACKB,1,R(STPR)+17
      %IF S(I)=X'80000000' %THEN V="?" %ELSE V=STRINT(S(I))
      PRINT STRING("  ".V)
    %REPEAT
    NEWLINE
  %FINISH
%END
%END
%ENDOFFILE