{P-CODE INTERPRETER}
CONST U=15;BPLIM=5;SIZE=500;SIZE1=480;
VAR Z,P,B,T,BP,P0,TP,CMD,I,J,K,STOP:INTEGER;
   S:ARRAY[SIZE] OF INTEGER;
   TRACE:ARRAY[U] OF INTEGER;
  MN:ARRAY[26] OF INTEGER;
   BREAK:ARRAY[BPLIM] OF INTEGER;
{IMPORTANT GLOBAL VARIABLES:
  P: PROGRAM COUNTER     B:BASE POINTER
  T:STACK POINTER        BP:BREAK POINT INDEX
  TP: TRACE STACK PTR    K:INSTRUCTION COUNTER
  S: DATA STACK          Z: STARTING ADDRESS OF P-CODE}

FUNC BASE(LEV);
 VAR B1:INTEGER;
 BEGIN B1:=B;
 WHILE LEV>0 DO BEGIN
 B1:=S[B1];LEV:=LEV-1 END;
 BASE:=B1
 END {BASE};

PROC INIT;
 VAR I:INTEGER;
 BEGIN T:=0;B:=1;P:=0;STOP:=0;
S[1]:=0;S[2]:=0;S[3]:=-1;
  P0:=0;TP:=U;K:=0;
 FOR I:=0 TO U DO TRACE[I]:=-1
 END {INIT};

PROC CRLF;
 BEGIN WRITE (13,10) END;

PROC EXEC;
 VAR X,A,L,F,IDX:INTEGER;
  BEGIN X:=P SHL 2 + Z;
  A:=MEM[X+3] SHL 8 + MEM[X+2];
  TP:=TP+1;IF TP>U THEN TP:=0;
  TRACE[TP]:=P;
  P:=P+1;P0:=P;K:=K+1;
  F:=MEM[X];
  IF F<=8 THEN IDX:=0
  ELSE BEGIN IDX:=1;F:=F-16 END;
  CASE F OF
 0:BEGIN T:=T+1;S[T]:=A END;
 1: CASE A OF
   0: BEGIN {RETURN}
      T:=B-1;B:=S[T+2];P:=S[T+3] END;
   1: S[T]:=-S[T];
   2: BEGIN T:=T-1;S[T]:=S[T]+S[T+1] END;
   3: BEGIN T:=T-1;S[T]:=S[T]-S[T+1] END;
   4: BEGIN T:=T-1;S[T]:=S[T]*S[T+1] END;
   5: BEGIN T:=T-1;S[T]:=S[T] DIV S[T+1] END;
   6: S[T]:=S[T] AND 1; {TEST FOR ODD}
   7: BEGIN T:=T-1; S[T]:=S[T] MOD S[T+1] END;
   8: BEGIN T:=T-1; S[T]:=S[T]=S[T+1] END;
   9: BEGIN T:=T-1; S[T]:=S[T]<>S[T+1] END;
  10: BEGIN T:=T-1; S[T]:=S[T]<S[T+1] END;
  11: BEGIN T:=T-1; S[T]:=S[T]>=S[T+1] END;
  12: BEGIN T:=T-1; S[T]:=S[T]>S[T+1] END;
  13: BEGIN T:=T-1; S[T]:=S[T]<=S[T+1] END;
  14: BEGIN T:=T-1; S[T]:=S[T] OR S[T+1] END;
  15: BEGIN T:=T-1; S[T]:=S[T] AND S[T+1] END;
  16: S[T] := NOT S[T];
  17: BEGIN T:=T-1; S[T]:=S[T] SHL S[T+1] END;
  18: BEGIN T:=T-1; S[T]:=S[T] SHR S[T+1] END;
 19: S[T]:=S[T]+1;
  20: S[T]:=S[T]-1;
  21: BEGIN {COPY}
   T:=T+1;S[T]:=S[T-1] END
ELSE BEGIN WRITE(' ILLEGAL OPR');CRLF;STOP:=1 END
END {CASE OF A};
 2: BEGIN {LOAD}
     L:=MEM[X+1];
     IF L=255 THEN S[T]:=MEM[S[T]]
     ELSE BEGIN IF IDX THEN A:=A+S[T];
       T:=T+1-IDX;S[T]:=S[BASE(L)+A] END
  END;
3:BEGIN {STORE}
  L:=MEM[X+1];
  IF L=255 THEN BEGIN
  MEM[S[T-1]]:=S[T];T:=T-2 END
 ELSE BEGIN
 IF IDX THEN A:=S[T-1]+A;
  S[BASE(L)+A]:=S[T];T:=T-1-IDX END
  END;
4:BEGIN  {CALL}
 L:=MEM[X+1];
 IF L=255 THEN BEGIN CALL(S[T]);T:=T-1 END
  ELSE BEGIN
   S[T+1]:=BASE(L);S[T+2]:=B;
   S[T+3]:=P;B:=T+1;P:=A END
 END;
5:IF T>(SIZE1-A) THEN BEGIN
 WRITE(' STACK OVFL');CRLF;STOP:=1 END
   ELSE T:=T+A;
6: P:=A; {JUMP}
7: BEGIN IF S[T]=MEM[X+1] THEN P:=A; {JPC}
  T:=T-1 END;
8: CASE A OF {CSP}
  0:BEGIN T:=T+1;READ (S[T]) END;{IN CHAR}
 1:BEGIN WRITE (S[T]);T:=T-1 END; {OUT CHAR}
  2:BEGIN T:=T+1; READ (S[T]#) END; {IN NUMBER}
  3:BEGIN WRITE(S[T]#); T:=T-1 END; {OUT NUMBER}
  4:BEGIN T:=T+1; READ(S[T]%) END; {IN HEX}
  5:BEGIN WRITE(S[T]%);T:=T-1 END; {OUT HEX}
  8:BEGIN  {OUT STRING}
     FOR IDX:=T-S[T] TO T-1 DO WRITE(S[IDX]);
      T:=T-S[T]-1 END
    ELSE BEGIN WRITE(' ILLEGAL CSP');CRLF;STOP:=1 END
 END{CASE OF A}
ELSE BEGIN WRITE(' ILLEGAL OPCODE');CRLF;STOP:=1 END
 END{CASE OF F}
END; {EXEC}
 
PROC CODE(PC);  {PRINT CODE}
 VAR X,N,IDX:INTEGER;
 BEGIN X:=PC SHL 2 + Z; N:=MEM[X]*3;
  IF N<=24 THEN IDX:=' '
  ELSE BEGIN N:=N-48;IDX:='X' END;
 WRITE('  ',PC#,'  ',MN[N],MN[N+1],MN[N+2],IDX,
 '  ',MEM[X+1]#,',',MEM[X+3] SHL 8 +MEM[X+2]#); CRLF
 END {CODE};
 
PROC CKBP {CHECK BREAKPOINT};
  VAR I:INTEGER;
  BEGIN IF P<0 THEN STOP:=1
  ELSE BEGIN
  FOR I:=1 TO BP DO
   IF BREAK[I]=P THEN BEGIN
  WRITE(' BREAK:');CODE(P);
    STOP:=1 END END
 END {CKBP};
 
 BEGIN {MAIN}
  FOR I:=0 TO 26 DO
   MN[I]:=MEM[I+%1E80];{MNEMONICS ARE IN MEMORY}
  WRITE('ADDR?');READ(Z%);CRLF;
   INIT;CODE(P);BP:=0;
   REPEAT WRITE('>');READ(CMD);
    CASE CMD OF
 'R':BEGIN STOP:=0;REPEAT EXEC;CKBP UNTIL STOP END;
 'S':BEGIN EXEC;CODE(P) END;
 'X':BEGIN
      WRITE('  P=',P#,' B=',B#,' T=',T#,
         ' S[T]=',S[T]#,' S[T-1]=',S[T-1]#);CRLF
     END;
 'G':BEGIN INIT;REPEAT EXEC;CKBP UNTIL STOP END;
 'T':BEGIN WRITE(' *TRACE*');CRLF;
   FOR I:=0 TO U DO BEGIN
    TP:=TP+1;IF TP>U THEN TP:=0;
    IF TRACE[TP]>=0 THEN CODE(TRACE[TP]) END
  END;
 'K':BEGIN READ(I#);
    FOR J:=I TO I+6 DO
     WRITE('  ',S[J]#);CRLF
   END;
 'B':IF BP<BPLIM THEN BEGIN
    BP:=BP+1;WRITE(BP#,':');
    READ(BREAK[BP]#);CRLF END;
 'C':BEGIN {CLEAR BP}
     BP:=0;CRLF END;
 'Y':BEGIN FOR I:=1 TO BP DO
     WRITE('  ',BREAK[I]#);CRLF END;
 'E':BEGIN READ(P0#);CODE(P0) END;
 'U':IF P0>0 THEN BEGIN
      P0:=P0-1;CODE(P0) END;
 'N':BEGIN P0:=P0+1;CODE(P0) END;
 'Q':P:=-1
    ELSE BEGIN WRITE('??');CRLF END
 END {CASE OF CMD}
 UNTIL P<0;
 CRLF; WRITE(K#,' INSTR. EXECUTED.');CRLF
END {MAIN}.