MPL Bytecode Compiler Code

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

{$IFDEF FPC}{$MODE TP}{$S-}{$ENDIF}
{$IFDEF HPC}{$M 8,48,48,16}{$F+}{$S-}{$ENDIF}
{$IFNDEF HPC}{$A-}{$ENDIF}
{$D-}{$I-}{$R-}{$V-}

PROGRAM MPX;

{$I MPL.INC}

TYPE

  TINTAT = PACKED ARRAY[BYTE] OF INTEGER;

  TGLO = PACKED RECORD
    M: TPRG; A: INTEGER; R: PACKED RECORD P, B, L, S: INTEGER END;
    F: PACKED ARRAY[FMIN..FMAX] OF TEXT;
    X: PACKED ARRAY[TOPR] OF (X00, X1P, X2P, XST, XAP)
  END;

VAR G: ^TGLO;

FUNCTION COMMAND(C: TCMD; VAR P: TINTAT): INTEGER;
VAR
  F: PACKED RECORD CASE BYTE OF 0: (P: ^TEXT); 0: (A: ADDRESS) END;
  S: PACKED ARRAY[0..3] OF TSYM; A: INTEGER;

  PROCEDURE US(I: INTEGER); BEGIN
    A := P[I]; S[I].A := ADDR(G^.M.B[A])
  END;

  FUNCTION UF(I: TFID): BOOLEAN; BEGIN
    A := -1; F.P := NIL;
    CASE I OF
      FINP: F.A := ADDR(INPUT); FOUT: F.A := ADDR(OUTPUT);
      FMIN..FMAX: F.A := ADDR(G^.F[I])
    END; UF := F.P <> NIL
  END;

BEGIN A := 0;
  CASE C OF
    CABORT        : WRITELN('!!! ABORT !!!');
    CARGC         : A := ARGC;
    CARGV         : BEGIN US(0); ARGV(S[0].P^, P[1]) END;
    CCLREOL       : CLREOL;
    CCLRSCR       : CLRSCR;
    CCOPY         : BEGIN US(0); US(3); STRINGCOPY(S[0].P^, P[1], P[2], S[3].P^) END;
    CDELETE       : BEGIN US(0); DELETE(S[0].P^, P[1], P[2]) END;
    CDELLINE      : DELLINE;
    CFCLOSE       : IF UF(TFID(P[0])) THEN A := FCLOSE(F.P^);
    CFCREATE      : IF UF(TFID(P[0])) THEN BEGIN US(1); A := FCREATE(F.P^, S[1].P^) END;
    CFOPEN        : IF UF(TFID(P[0])) THEN BEGIN US(1); A := FOPEN(F.P^, S[1].P^) END;
    CFREADC       : IF UF(TFID(P[0])) THEN A := ORD(FREADC(F.P^));
    CFREADS       : IF UF(TFID(P[0])) THEN BEGIN US(1); A := FWRITES(F.P^, S[1].P^) END;
    CFWRITEC      : IF UF(TFID(P[0])) THEN A := ORD(FWRITEC(F.P^, CHR(P[1])));
    CFWRITES      : IF UF(TFID(P[0])) THEN BEGIN US(1); A := FWRITES(F.P^, S[1].P^) END;
    CGOTOXY       : GOTOXY(P[0], P[1]);
    CIABS         : A := ABS(P[0]);
    CIMAX         : BEGIN A := P[0]; IF P[1] > A THEN A := P[1] END;
    CIMIN         : BEGIN A := P[0]; IF P[1] < A THEN A := P[1] END;
    CINSERT       : BEGIN US(0); US(1); INSERT(S[0].P^, S[1].P^, P[2]) END;
    CINSLINE      : INSLINE;
    CISQR         : A := P[0] * P[0];
    CISTR         : BEGIN US(2); STR(P[0]:P[1], S[2].P^) END;
    CIVAL         : BEGIN US(0); VAL(S[0].P^, A, G^.M.N) END;
    CKEYPRESSED   : A := ORD(KEYPRESSED);
    CMEMMOV       : BEGIN A := P[0]; MOVE(G^.M.B[P[1]], G^.M.B[A], P[2]) END;
    CMEMSET       : BEGIN A := P[0]; FILLCHAR(G^.M.B[A], P[2], CHR(P[1])) END;
    CPOS          : BEGIN US(0); US(1); A := POS(S[0].P^, S[1].P^) END;
    CREADC        : IF UF(FINP) THEN A := ORD(FREADC(F.P^));
    CREADKEY      : A := ORD(READKEY);
    CREADS        : IF UF(FINP) THEN BEGIN US(0); A := FREADS(F.P^, S[0].P^) END;
    CWRITEC       : IF UF(FOUT) THEN A := ORD(FWRITEC(F.P^, CHR(P[0])));
    CWRITES       : IF UF(FOUT) THEN BEGIN US(0); A := FWRITES(F.P^, S[0].P^) END;
  END;
  COMMAND := A
END;

FUNCTION PRGINT: INTEGER; VAR I: INTEGER;
BEGIN MOVE(G^.M.B[G^.R.P], I, 2); G^.R.P := G^.R.P + 2; PRGINT := I END;

PROCEDURE EXEC; VAR P: ^TINTAT; A, B: INTEGER; LABEL LOOP;
BEGIN
  LOOP: B := G^.M.B[G^.R.P].V; G^.R.P := G^.R.P + 1;
  IF B >= ORD(XZZZ) THEN BEGIN A := B - 128; GOTO LOOP END;
  CASE G^.X[TOPR(B)] OF
    X1P: BEGIN G^.R.S := G^.R.S - 1;
      WITH G^.M.B[G^.M.I[G^.R.S].V] DO BEGIN
        CASE TOPR(B) OF
          X1PSHL: V := V SHL A; X1PSHR: V := V SHR A;
          X1PDIV: V := V DIV A; X1PMOD: V := V MOD A;
          X1PXOR: V := V XOR A; X1PIOR: V := V OR  A;
          X1PAND: V := V AND A; X1PMUL: V := V * A;
          X1PADD: V := V + A;   X1PSUB: V := V - A; X1PSET: V := A;
        END; A := V;
      END; GOTO LOOP
    END;
    X2P: BEGIN G^.R.S := G^.R.S - 1;
      WITH G^.M.I[G^.M.I[G^.R.S].V SHR 1] DO BEGIN
        CASE TOPR(B) OF
          X2PSHL: V := V SHL A; X2PSHR: V := WORD(V) SHR A;
          X2PDIV: V := V DIV A; X2PMOD: V := V MOD A;
          X2PXOR: V := V XOR A; X2PIOR: V := V OR  A;
          X2PAND: V := V AND A; X2PMUL: V := V * A;
          X2PADD: V := V + A;   X2PSUB: V := V - A; X2PSET: V := A;
        END; A := V;
      END; GOTO LOOP
    END;
    XAP: BEGIN
      WITH G^.M.I[A SHR 1] DO CASE TOPR(B) OF
        XAPGET: A := V;
        XAPINC: BEGIN V:=V+1; A:=V; END; XAPINP: BEGIN A:=V; V:=V+1 END;
        XAPDEC: BEGIN V:=V-1; A:=V; END; XAPDEP: BEGIN A:=V; V:=V-1 END;
      END; GOTO LOOP
    END;
    XST: BEGIN G^.R.S := G^.R.S - 1;
      WITH G^.M.I[G^.R.S] DO CASE TOPR(B) OF
        XSHSHL: A := V SHL A;     XSHSHR: A := WORD(V) SHR A;
        XDMDIV: A := V DIV A;     XDMMOD: A := V MOD A;
        XBTXOR: A := V XOR A;     XBTIOR: A := V OR  A;
        XBTAND: A := V AND A;     XDMMUL: A := V * A;
        XIDADD: A := V + A;       XIDSUB: A := V - A;
        XCPGTE: A := ORD(V >= A); XCPGTH: A := ORD(V >  A);
        XCPLTE: A := ORD(V <= A); XCPLTH: A := ORD(V <  A);
        XEQNOT: A := ORD(V <> A); XEQYES: A := ORD(V =  A);
        XPULLA: A := V;
        XPEBYT: A := G^.M.B[A + V].V;
        XPEINT: A := G^.M.I[A + (V SHR 1)].V;
        XLGAND: A := ORD((V <> 0) AND (A <> 0));
        XLGIOR: A := ORD((V <> 0) OR  (A <> 0));
        XLGXOR: A := ORD((V <> 0) XOR (A <> 0));
      END; GOTO LOOP
    END ELSE CASE TOPR(B) OF
      XINCA1: WITH G^.M.I[G^.R.S - 1] DO V := V + A;
      XINCA2: WITH G^.M.I[G^.R.S - 1] DO V := V + A * 2;
      XIMSTR: BEGIN A := G^.R.P; G^.R.P := G^.R.P + G^.M.B[G^.R.P].V + 1 END;
      XLEAD1: BEGIN A := SEX(G^.M.B[G^.R.P].V); G^.R.P := G^.R.P + 1; A := (G^.R.L + A) * 2 END;
      XLEAD2: BEGIN A := PRGINT; A := (G^.R.L + A) * 2 END;
      XPUSHA: BEGIN G^.M.I[G^.R.S].V := A; G^.R.S := G^.R.S + 1 END;
      XIFEQU: BEGIN B := PRGINT; IF A =  0 THEN G^.R.P := B END;
      XIFNEQ: BEGIN B := PRGINT; IF A <> 0 THEN G^.R.P := B END;
      XIMCHR: BEGIN A := SEX(G^.M.B[G^.R.P].V); G^.R.P := G^.R.P + 1 END;
      XIMINT: A := PRGINT;
      XIFNOW: G^.R.P := PRGINT;
      XLDBYT: A := G^.M.B[A].V; XLDINT: A := G^.M.I[A SHR 1].V;
      XLDNEG: A := -A;
      XFNJMP: BEGIN
        G^.R.S := G^.R.S - A;
        WITH G^.M.I[G^.R.S] DO IF V <= 0 THEN BEGIN
          P := ADDR(G^.M.I[G^.R.S + 1]); A := COMMAND(TCMD(-V), P^)
        END ELSE BEGIN
          MOVE(G^.R, G^.M.I[G^.R.S + A], SIZEOF(G^.R));
          G^.R.L := G^.R.S; G^.R.P := V; G^.R.S := G^.R.S + A + 4
        END
      END;
      XFNBEG: BEGIN
        G^.R.B := G^.R.L + G^.M.B[G^.R.P].V; G^.R.P := G^.R.P + 1;
        MOVE(G^.M.I[G^.R.S - 4], G^.M.I[G^.R.B], SIZEOF(G^.R));
        G^.R.S := G^.R.B + 4
      END;
      XFNEND: MOVE(G^.M.I[G^.R.B], G^.R, SIZEOF(G^.R));
      ELSE BEGIN G^.A := A; EXIT END;
    END;
  END; GOTO LOOP
END;

PROCEDURE MAIN; VAR O: TOPR; F: FILE; BEGIN
  IF ARGC < 1 THEN WRITELN('USAGE: MPX <FILE>')
  ELSE BEGIN
    NEW(G); FILLCHAR(G^, SIZEOF(G^), 0);
    FOR O := XABORT TO XZZZ DO CASE O OF
      XAPGET, XAPDEC, XAPDEP, XAPINC, XAPINP: G^.X[O] := XAP;
      X1PAND, X1PSET, X1PSUB, X1PDIV, X1PADD, X1PIOR,
      X1PMOD, X1PMUL, X1PSHL, X1PSHR, X1PXOR: G^.X[O] := X1P;
      X2PAND, X2PSET, X2PSUB, X2PDIV, X2PADD, X2PIOR,
      X2PMOD, X2PMUL, X2PSHL, X2PSHR, X2PXOR: G^.X[O] := X2P;
      XPULLA, XBTAND, XBTIOR, XBTXOR, XCPGTE, XCPGTH, XCPLTE,
      XCPLTH, XDMDIV, XDMMOD, XDMMUL, XEQNOT, XEQYES, XLGAND,
      XLGIOR, XLGXOR, XSHSHL, XSHSHR, XIDADD, XIDSUB, XPEBYT,
      XPEINT: G^.X[O] := XST ELSE G^.X[O] := X00
    END;
    ARGV(G^.M.S, 1); ASSIGN(F, G^.M.S + '.MPX'); RESET(F);
    IF IORESULT <> 0 THEN WRITELN('NO INPUT') ELSE BEGIN
      BLOCKREAD(F, G^.M.B, FILESIZE(F)); CLOSE(F);
      G^.R.P := G^.M.P; G^.R.S := (G^.M.N + 1) DIV 2;
      EXEC; WRITELN; WRITELN('=', G^.A)
    END
  END
END;

BEGIN
  MAIN; {$IFDEF FPC}READLN;{$ENDIF}
END.