MPL Bytecode Compiler Code

(* MPL - MICRO PROGRAMMING LANGUAGE / COPYRIGHT (C) 2017-2018 DEREK JOHN EVANS *)

TYPE TERR = (ESYN, EDUP, ENOT);
PROCEDURE ERR(E: TERR); BEGIN GE := SUCC(GE); WRITELN; WRITE(' --> ');
  CASE E OF ESYN: WRITE('SYNTAX'); EDUP: WRITE('DUPLICATE');
    ENOT: WRITE('NOT FOUND') END; WRITE('? "', GS, '"') END;

FUNCTION LOC(VAR PI: PI16): BOOL; VAR I: I16; S: REF; BEGIN LOC := FALSE;
  IF GX = XLIM1 THEN BEGIN I := GN; S := GR; WHILE I > 0 DO BEGIN I := PRED(I);
    IF S.S^ = GS THEN BEGIN PI := PTR(ADDR(GT[I])); LOC := TRUE; EXIT END;
    S.I := SUCC(S.I + ORD(S.S^[0])) END END ELSE ERR(ESYN) END;

PROCEDURE ADD(VAR PI: PI16); BEGIN GR.I := PRED(GR.I - ORD(GS[0]));
  GR.S^ := GS; GT[GN] := 0; PI := PTR(ADDR(GT[GN])); GN := SUCC(GN) END;

FUNCTION ISX(X: TXOP): BOOL; BEGIN IF GX = X THEN BEGIN NEXT; ISX := TRUE END ELSE ISX := FALSE END;
FUNCTION ISK(K: TKIN; VAR X: TXOP): BOOL; BEGIN X := GX; IF GK = K THEN BEGIN NEXT; ISK := TRUE END ELSE ISK := FALSE END;

PROCEDURE I2(I: I16); VAR PI: PI16; BEGIN {$IFDEF HPC}MOVE(I, GV.C[GP], 2);
  {$ELSE}PI := PTR(ADDR(GV.C[GP])); PI^ := I;{$ENDIF}GP := GP + 2 END;

PROCEDURE X0(X: TXOP); BEGIN GV.C[GP] := CHR(ORD(X)); GP := SUCC(GP) END;
PROCEDURE X1(X: TXOP; I: I16); BEGIN GV.C[GP] := CHR(ORD(X)); GV.C[SUCC(GP)] := CHR(I); GP := GP + 2 END;
PROCEDURE X2(X: TXOP; I: I16); BEGIN GV.C[GP] := CHR(ORD(X)); GP := SUCC(GP); I2(I) END;
PROCEDURE XB(X: TXOP; B: BOOL); BEGIN IF B THEN X := PRED(X); GV.C[GP] := CHR(ORD(X)); GP := SUCC(GP) END;
PROCEDURE XI(X: TXOP; I: I16); BEGIN IF (I >= -128) AND (I <= 127) THEN X1(PRED(X), I) ELSE X2(X, I) END;
PROCEDURE XAT(P: I16; X: TXOP; I: I16); VAR LP: I16; BEGIN LP := GP; GP := P; X2(X, I); GP := LP END;

PROCEDURE LDI(I: I16); BEGIN IF (I < (ORD(XZEND) - 128)) OR (I >= 128) THEN XI(XLIM2, I)
  ELSE BEGIN GV.C[GP] := CHR(I + 128); GP := SUCC(GP) END END;

PROCEDURE STS; VAR S: REF; BEGIN S.S := PTR(ADDR(GV.C[GP])); S.S^ := GS; GP := SUCC(GP + ORD(GS[0])) END;