MPL Bytecode Compiler Code

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

{$A-}{$D-}{$I-}{$R-}{$V-}

PROGRAM MPX;

{$I MPL.INC}

TYPE

  TPAR = PACKED ARRAY[0..9] OF INT;
  TFID = (FINP, FOUT, FMIN, F003, F004, F005, FMAX);
  TLIB = (
    LABRT, LARGC, LARGV, LBGET, LBPUT, LFEND, LFNEW, LFOLD, LFRDC, LFRDS,
    LFWRC, LFWRS, LIABS, LIGET, LIMAX, LIMIN, LIPUT, LISQR, LITOL, LITOR,
    LITOS, LLABS, LLADD, LLDIV, LLMUL, LLSQR, LLSUB, LLTOI, LLTOR, LLTOS,
    LMCMP, LMCPY, LMPOS, LMSET, LRABS, LRADD, LRART, LRCOS, LRDEV, LREXP,
    LRLOG, LRMAX, LRMIN, LRMUL, LRNEG, LRROU, LRSIN, LRSQR, LRSRT, LRSUB,
    LRTOI, LRTOL, LRTOS, LSCMP, LSCPY, LSDEL, LSINS, LSMID, LSPOS, LSTOI,
    LSTOL, LSTOR, LTCLL, LTCLS, LTDEL, LTGXY, LTINS, LTKEY, LTRDC, LTRDK,
    LTRDS, LTWRC, LTWRS, LZEND);

VAR

  GV: TVEC; GA: INT;
  GK: PACKED ARRAY[TXOP] OF (K00, K1P, K2P, KST, KAP);
  GF: PACKED ARRAY[FMIN..FMAX] OF TEXT;
  GR: PACKED RECORD P, B, L, S: INT END;

FUNCTION FNEW(VAR F: TEXT; VAR FN: STR127): INT; BEGIN
  ASSIGN(F, FN); REWRITE(F); FNEW := IORESULT
END;

FUNCTION FEND(VAR F: TEXT): INT;
BEGIN CLOSE(F); FEND := IORESULT END;

FUNCTION FWRC(VAR F: TEXT; C: CHAR): CHAR; BEGIN
  IF C = CHR(10) THEN WRITELN(F) ELSE WRITE(F, C);
  IF IORESULT <> 0 THEN C := CHR(0); FWRC := C
END;

FUNCTION FRDS(VAR F: TEXT; VAR S: STR127): INT;
BEGIN READLN(F, S); FRDS := IORESULT END;

FUNCTION FWRS(VAR F: TEXT; VAR S: STR127): INT;
BEGIN WRITE(F, S); FWRS := IORESULT END;

FUNCTION PRGINT: INT; VAR I: INT;
BEGIN MOVE(GV.C[GR.P], I, 2); GR.P := GR.P + 2; PRGINT := I END;

FUNCTION CALL(L: TLIB; VAR P: TPAR): INT;
VAR FP: PTEXT; S: PACKED ARRAY[0..3] OF PSTR127; A: INT; C: CHAR;

PROCEDURE US(I: INT);
BEGIN A := P[I]; S[I] := PTR(ADDR(GV.C[A])) END;

FUNCTION UF(I: TFID): BOOL; BEGIN A := -1; FP := NIL;
  CASE I OF FMIN..FMAX: FP := PTR(ADDR(GF[I]));
    FINP: FP := PTR(ADDR(INPUT)); FOUT: FP := PTR(ADDR(OUTPUT))
END; UF := FP <> NIL END;

BEGIN A := 0;
  CASE L OF
    LABRT: WRITELN('!!! ABORT !!!');
    LARGC: A := ARGC; LARGV: BEGIN US(0); ARGV(S[0]^, P[1]) END;
    LFEND: IF UF(TFID(P[0])) THEN A := FEND(FP^);
    LFNEW: IF UF(TFID(P[0])) THEN BEGIN US(1); A := FNEW(FP^, S[1]^) END;
    LFOLD: IF UF(TFID(P[0])) THEN BEGIN US(1); A := FOLD(FP^, S[1]^) END;
    LFRDC: IF UF(TFID(P[0])) THEN A := ORD(FRDC(FP^));
    LFRDS: IF UF(TFID(P[0])) THEN BEGIN US(1); A := FRDS(FP^, S[1]^) END;
    LFWRC: IF UF(TFID(P[0])) THEN A := ORD(FWRC(FP^, CHR(P[1])));
    LFWRS: IF UF(TFID(P[0])) THEN BEGIN US(1); A := FWRS(FP^, S[1]^) END;
    LIABS: A := ABS(P[0]);
    LIMAX: BEGIN A := P[0]; IF P[1] > A THEN A := P[1] END;
    LIMIN: BEGIN A := P[0]; IF P[1] < A THEN A := P[1] END;
    LISQR: A := P[0] * P[0];
    LITOS: BEGIN US(1); STR(P[0], S[1]^) END;
    LMCPY: BEGIN A := P[0]; MOVE(GV.C[P[1]], GV.C[A], P[2]) END;
    LMSET: BEGIN A := P[0]; FILLCHAR(GV.C[A], P[2], CHR(P[1])) END;
    LSCPY: BEGIN US(1); US(0); S[0]^ := S[1]^ END;
    LSDEL: BEGIN US(0); DELETE(S[0]^, P[1], P[2]) END;
    LSINS: BEGIN US(1); US(0); INSERT(S[1]^, S[0]^, P[2]) END;
    LSMID: BEGIN US(1); US(0); S[0]^ := COPY(S[1]^, P[2], P[3]) END;
    LSPOS: BEGIN US(1); US(0); A := POS(S[0]^, S[1]^) END;
    LSTOI: BEGIN US(0); VAL(S[0]^, A, GV.I[2]) END;
    LTCLL: CLREOL; LTCLS: CLRSCR; LTDEL: DELLINE; LTGXY: GOTOXY(P[0], P[1]);
    LTINS: INSLINE; LTKEY: A := ORD(KEYPRESSED);
    LTRDC: IF UF(FINP) THEN A := ORD(FRDC(FP^));
    LTRDK: BEGIN READ(KBD, C); A := ORD(C) END;
    LTRDS: IF UF(FINP) THEN BEGIN US(0); A := FRDS(FP^, S[0]^) END;
    LTWRC: IF UF(FOUT) THEN A := ORD(FWRC(FP^, CHR(P[0])));
    LTWRS: IF UF(FOUT) THEN BEGIN US(0); A := FWRS(FP^, S[0]^) END
  END; CALL := A
END;

PROCEDURE EXEC;
VAR A, B: INT; SP: PSTR127; IP: PINT; IAP: ^TPAR; LABEL 0;
BEGIN
  A := IORESULT;
0:B := ORD(GV.C[GR.P]); GR.P := GR.P + 1;
  IF B >= ORD(XZZEND) THEN BEGIN A := B - 128; GOTO 0 END;
  CASE GK[TXOP(B)] OF
    K1P: BEGIN GR.S := GR.S - 1; SP:= PTR(ADDR(GV.C[GV.I[GR.S]]));
      CASE TXOP(B) OF
        X1PSHL: SP^[0] := CHR(ORD(SP^[0]) SHL A); X1PSHR: SP^[0] := CHR(ORD(SP^[0]) SHR A);
        X1PDIV: SP^[0] := CHR(ORD(SP^[0]) DIV A); X1PMOD: SP^[0] := CHR(ORD(SP^[0]) MOD A);
        X1PXOR: SP^[0] := CHR(ORD(SP^[0]) XOR A); X1PIOR: SP^[0] := CHR(ORD(SP^[0]) OR  A);
        X1PAND: SP^[0] := CHR(ORD(SP^[0]) AND A); X1PMUL: SP^[0] := CHR(ORD(SP^[0]) * A);
        X1PADD: SP^[0] := CHR(ORD(SP^[0])   + A); X1PSUB: SP^[0] := CHR(ORD(SP^[0]) - A);
        X1PSET: SP^[0] := CHR(A) END; A := ORD(SP^[0]); GOTO 0 END;
    K2P: BEGIN GR.S := GR.S - 1; IP := PTR(ADDR(GV.I[GV.I[GR.S] SHR 1]));
      CASE TXOP(B) OF
        X2PSHL: IP^ := IP^ SHL A; X2PSHR: IP^ := IP^ SHR A;
        X2PDIV: IP^ := IP^ DIV A; X2PMOD: IP^ := IP^ MOD A;
        X2PXOR: IP^ := IP^ XOR A; X2PIOR: IP^ := IP^ OR A;
        X2PAND: IP^ := IP^ AND A; X2PMUL: IP^ := IP^ * A;
        X2PADD: IP^ := IP^ + A;   X2PSUB: IP^ := IP^ - A;
        X2PSET: IP^ := A END; A := IP^; GOTO 0 END;
    KAP: BEGIN IP := PTR(ADDR(GV.I[A SHR 1]));
      CASE TXOP(B) OF
        XAPGET: A := IP^;
        XAPINC: BEGIN IP^:=IP^+1; A:=IP^; END; XAPINP: BEGIN A:=IP^; IP^:=IP^+1 END;
        XAPDEC: BEGIN IP^:=IP^-1; A:=IP^; END; XAPDEP: BEGIN A:=IP^; IP^:=IP^-1 END
      END; GOTO 0 END;
    KST: BEGIN GR.S := GR.S - 1; IP := PTR(ADDR(GV.I[GR.S]));
      CASE TXOP(B) OF
        XSHSHL: A := IP^ SHL A;     XSHSHR: A := IP^ SHR A;
        XDMDIV: A := IP^ DIV A;     XDMMOD: A := IP^ MOD A;
        XBTXOR: A := IP^ XOR A;     XBTIOR: A := IP^ OR A;
        XBTAND: A := IP^ AND A;     XDMMUL: A := IP^ * A;
        XIDADD: A := IP^ + A;       XIDSUB: A := IP^ - A;
        XCPGTE: A := ORD(IP^ >= A); XCPGTH: A := ORD(IP^ >  A);
        XCPLTE: A := ORD(IP^ <= A); XCPLTH: A := ORD(IP^ <  A);
        XEQNOT: A := ORD(IP^ <> A); XEQYES: A := ORD(IP^ =  A);
        XPULLA: A := IP^;
        XPEBYT: A := ORD(GV.C[A + IP^]);
        XPEINT: A := GV.I[A + (IP^ SHR 1)];
        XLGAND: A := ORD((IP^ <> 0) AND (A <> 0));
        XLGIOR: A := ORD((IP^ <> 0) OR  (A <> 0));
        XLGXOR: A := ORD((IP^ <> 0) XOR (A <> 0))
      END; GOTO 0
    END ELSE
      CASE TXOP(B) OF
        XIMCHR: BEGIN A := SEX(ORD(GV.C[GR.P])); GR.P := GR.P + 1 END;
        XIMINT: A := PRGINT;
        XIMSTR: BEGIN A := GR.P; GR.P := GR.P + ORD(GV.C[GR.P]) + 1 END;
        XINCA1: BEGIN IP := PTR(ADDR(GV.I[GR.S - 1])); IP^ := IP^ + A END;
        XINCA2: BEGIN IP := PTR(ADDR(GV.I[GR.S - 1])); IP^ := IP^ + A * 2 END;
        XJMPEQ: BEGIN B := PRGINT; IF A =  0 THEN GR.P := B END;
        XJMPNE: BEGIN B := PRGINT; IF A <> 0 THEN GR.P := B END;
        XJMPTO: GR.P := PRGINT;
        XLDBYT: A := ORD(GV.C[A]); XLDINT: A := GV.I[A SHR 1];
        XLDNEG: A := -A; XLDNOT: A := NOT A;
        XLDLEQ: A := ORD(A = 0); XLDLNE: A := ORD(A <> 0);
        XLDLGT: A := ORD(A > 0); XLDLLT: A := ORD(A <  0);
        XLEAD1: BEGIN A := SEX(ORD(GV.C[GR.P])); GR.P := GR.P + 1; A := (GR.L + A) * 2 END;
        XLEAD2: BEGIN A := PRGINT; A := (GR.L + A) * 2 END;
        XPUSHA: BEGIN GV.I[GR.S] := A; GR.S := GR.S + 1 END;
        XFNJMP: BEGIN GR.S := GR.S - A; IP := PTR(ADDR(GV.I[GR.S]));
          IF IP^ <= 0 THEN BEGIN
            IAP := PTR(ADDR(GV.I[GR.S + 1])); A := CALL(TLIB(-IP^), IAP^)
          END ELSE BEGIN
            MOVE(GR, GV.I[GR.S + A], SIZEOF(GR));
            GR.L := GR.S; GR.P := IP^; GR.S := GR.S + A + 4
          END
        END;
        XFNBEG: BEGIN GR.B := GR.L + ORD(GV.C[GR.P]); GR.P := GR.P + 1;
          MOVE(GV.I[GR.S - 4], GV.I[GR.B], SIZEOF(GR));
          GR.S := GR.B + 4
        END;
        XFNEND: MOVE(GV.I[GR.B], GR, SIZEOF(GR))
        ELSE BEGIN GA := A; EXIT
      END
    END
  END; GOTO 0
END;

FUNCTION LOAD: BOOL; VAR F: FILE; BEGIN LOAD := FALSE;
  ARGV(GV.S, 1); GV.S := GV.S + MPXEXT; ASSIGN(F, GV.S); RESET(F);
  IF IORESULT = 0 THEN BEGIN LOAD := TRUE;
    BLOCKREAD(F, GV, FILESIZE(F)); LOAD := IORESULT = 0;
    CLOSE(F);
  END;
END;

PROCEDURE INIT; VAR X: TXOP; BEGIN
  FOR X := XABORT TO XZZEND DO CASE X OF
    XAPGET, XAPDEC, XAPDEP, XAPINC, XAPINP: GK[X] := KAP;
    X1PAND, X1PSET, X1PSUB, X1PDIV, X1PADD, X1PIOR,
    X1PMOD, X1PMUL, X1PSHL, X1PSHR, X1PXOR: GK[X] := K1P;
    X2PAND, X2PSET, X2PSUB, X2PDIV, X2PADD, X2PIOR,
    X2PMOD, X2PMUL, X2PSHL, X2PSHR, X2PXOR: GK[X] := K2P;
    XPULLA, XBTAND, XBTIOR, XBTXOR, XCPGTE, XCPGTH, XCPLTE,
    XCPLTH, XDMDIV, XDMMOD, XDMMUL, XEQNOT, XEQYES, XLGAND,
    XLGIOR, XLGXOR, XSHSHL, XSHSHR, XIDADD, XIDSUB, XPEBYT,
    XPEINT: GK[X] := KST ELSE GK[X] := K00
  END;
END;

BEGIN
  IF ARGC < 1 THEN WRITELN('USAGE: MPX <FILE>')
  ELSE IF LOAD THEN BEGIN
    INIT; GR.S := (GV.I[0] + 1) DIV 2; GR.P := GV.I[1];
    EXEC; WRITELN; WRITELN('=', GA)
  END ELSE WRITELN('NO INPUT');
END.