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}

FUNCTION COMMAND(VAR G: TMPX; CMD: TCMD; ARGS: PINTEGERAT): INTEGER;
VAR
  F: PACKED RECORD CASE BYTE OF 0: (TEX: ^TEXT); 0: (ADR: ADDRESS); END;
  OUT: INTEGER; S0, S1: TSYM;

  FUNCTION USE(FID: TFID): BOOLEAN;
  BEGIN
    OUT := 0; F.TEX := NIL;
    CASE FID OF
      FINP: F.ADR := ADDR(INPUT); FOUT: F.ADR := ADDR(OUTPUT);
      FMIN..FMAX: F.ADR := ADDR(G.F[FID]);
    END;
    USE := F.TEX <> NIL;
  END;

BEGIN
  OUT := 0;
  CASE CMD OF
    CPARAMCOUNT: OUT := PARAMCOUNT;
    CCGETC: IF USE(FINP) THEN OUT := ORD(FGETC(F.TEX^));
    CCLOSE: IF USE(TFID(ARGS^[0])) THEN CLOSE(F.TEX^);
    CCLREOL: CLREOL;
    CCLRSCR: CLRSCR;
    CCPUTC: IF USE(FOUT) THEN OUT := ORD(FPUTC(F.TEX^, CHR(ARGS^[0])));
    CDELLINE: DELLINE;
    CFGETC: IF USE(TFID(ARGS^[0])) THEN OUT := ORD(FGETC(F.TEX^));
    CFILL: FILLCHAR(G.M.BYT[ARGS^[0]], ARGS^[1], CHR(ARGS^[2]));
    CFPUTC: IF USE(TFID(ARGS^[1])) THEN OUT := ORD(FPUTC(F.TEX^, CHR(ARGS^[0])));
    CGOTOXY: GOTOXY(ARGS^[0], ARGS^[1]);
    CINSLINE: INSLINE;
    CKEYPRESSED: OUT := ORD(KEYPRESSED);
    CMOVE: MOVE(G.M.BYT[ARGS^[0]], G.M.BYT[ARGS^[1]], ARGS^[2]);
    CNULL: WRITELN('!!! NULL SYS CALL !!!');
    CREADKEY: OUT := ORD(READKEY);
    CABS: OUT := ABS(ARGS^[0]);
    CMIN: BEGIN OUT := ARGS^[0]; IF ARGS^[1] < OUT THEN OUT := ARGS^[1]; END;
    CMAX: BEGIN OUT := ARGS^[0]; IF ARGS^[1] > OUT THEN OUT := ARGS^[1]; END;
    CRESET, CREWRITE: IF USE(TFID(ARGS^[0])) THEN BEGIN
        S1.A := ADDR(G.M.BYT[ARGS^[1]]);
        CASE CMD OF
          CRESET: OUT := FRESET(F.TEX^, S1.S^);
          CREWRITE: OUT := FREWRITE(F.TEX^, S1.S^);
        END;
      END;
    CDELETE, CPARAMSTR: BEGIN
      S0.A := ADDR(G.M.BYT[ARGS^[0]]);
      CASE CMD OF
        CPARAMSTR: S0.S^ := PARAMSTR(ARGS^[1]);
        CDELETE: DELETE(S0.S^, ARGS^[1], ARGS^[2]);
      END;
    END;
    CPOS, CINSERT: BEGIN
      S0.A := ADDR(G.M.BYT[ARGS^[0]]);
      S1.A := ADDR(G.M.BYT[ARGS^[1]]);
      CASE CMD OF
        CCOPY: S0.S^ := COPY(S1.S^, ARGS^[2], ARGS^[3]);
        CINSERT: INSERT(S0.S^, S1.S^, ARGS^[2]);
        CPOS: OUT := POS(S0.S^, S1.S^);
      END;
    END;
  END;
  COMMAND := OUT;
END;

PROCEDURE EXEC(VAR G: TMPX);

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

VAR A, B, C: INTEGER; LABEL LOOP;
BEGIN
  A := 0;
  LOOP: C := G.M.BYT[G.R.P].U8; G.R.P := G.R.P + 1;
  IF C >= ORD(XZZZ) THEN BEGIN A := C - 128; GOTO LOOP; END;
  CASE G.X[TOPR(C)] OF
    X1AS: BEGIN
      G.R.S := G.R.S - 1;
      WITH G.M.BYT[G.M.INT[G.R.S].U16] DO BEGIN
        CASE TOPR(C) OF
          X1ASADD: U8 := U8 + A;
          X1ASAND: U8 := U8 AND A;
          X1ASDIV: U8 := U8 DIV A;
          X1ASIOR: U8 := U8 OR A;
          X1ASSHL: U8 := U8 SHL A;
          X1ASSHR: U8 := U8 SHR A;
          X1ASMUL: U8 := U8 * A;
          X1ASSET: U8 := A;
          X1ASSUB: U8 := U8 - A;
          X1ASXOR: U8 := U8 XOR A;
        END;
        A := U8;
      END;
      GOTO LOOP;
    END;
    X2AS: BEGIN
      G.R.S := G.R.S - 1; B := G.M.INT[G.R.S].I16;
      IF B < 0 THEN B := G.R.L - B ELSE B := B SHR 1;
      WITH G.M.INT[B] DO BEGIN
        CASE TOPR(C) OF
          X2ASADD: I16 := I16 + A;
          X2ASAND: I16 := I16 AND A;
          X2ASDIV: I16 := I16 DIV A;
          X2ASIOR: I16 := I16 OR A;
          X2ASSHL: U16 := U16 SHL A;
          X2ASSHR: U16 := U16 SHR A;
          X2ASMUL: I16 := I16 * A;
          X2ASSET: I16 := A;
          X2ASSUB: I16 := I16 - A;
          X2ASXOR: I16 := I16 XOR A;
        END;
        A := I16;
      END;
      GOTO LOOP;
    END;
    XPOP: BEGIN
      G.R.S := G.R.S - 1;
      WITH G.M.INT[G.R.S] DO CASE TOPR(C) OF
        XBITAND: A := I16 AND A;
        XBITIOR: A := I16 OR A;
        XBITXOR: A := I16 XOR A;
        XCMPGTE: A := ORD(I16 >= A);
        XCMPGTH: A := ORD(I16 > A);
        XCMPLTE: A := ORD(I16 <= A);
        XCMPLTH: A := ORD(I16 < A);
        XDMMDIV: A := I16 DIV A;
        XDMMMOD: A := I16 MOD A;
        XDMMMUL: A := I16 * A;
        XEQUNOT: A := ORD(I16 <> A);
        XEQUYES: A := ORD(I16 = A);
        XGETACC: A := I16;
        XGETCHR: A := SHORTINT(G.M.BYT[A + I16].U8);
        XGETINT: A := G.M.INT[A + (U16 SHR 1)].I16;
        XLOGAND: A := ORD((I16 <> 0) AND (A <> 0));
        XLOGIOR: A := ORD((I16 <> 0) OR (A <> 0));
        XLOGXOR: A := ORD((I16 <> 0) XOR (A <> 0));
        XSHFSHL: A := U16 SHL A;
        XSHFSHR: A := U16 SHR A;
        XSUMADD: A := I16 + A;
        XSUMSUB: A := I16 - A;
      END;
      GOTO LOOP;
    END;
    XPSH: BEGIN
      WITH G.M.INT[G.R.S] DO CASE TOPR(C) OF
        XPSHACC: I16 := A;
        XPSHCHR: BEGIN I16 := SHORTINT(G.M.BYT[G.R.P].U8); G.R.P := G.R.P + 1; END;
        XPSHINT: I16 := PRGINT;
      END;
      G.R.S := G.R.S + 1;
      GOTO LOOP;
    END;
    X1AD: BEGIN
      B := SHORTINT(G.M.BYT[G.R.P].U8); G.R.P := G.R.P + 1;
      IF B < 0 THEN B := G.R.L - B ELSE B := B SHR 1;
      WITH G.M.INT[B] DO CASE TOPR(C) OF
        X1ADGET: A := I16;
        X1ADDEC: BEGIN I16 := I16 - 1; A := I16; END;
        X1ADDEP: BEGIN A := I16; I16 := I16 - 1; END;
        X1ADINC: BEGIN I16 := I16 + 1; A := I16; END;
        X1ADINP: BEGIN A := I16; I16 := I16 + 1; END;
      END;
      GOTO LOOP;
    END;
    X2AD: BEGIN
      B := PRGINT; IF B < 0 THEN B := G.R.L - B ELSE B := B SHR 1;
      WITH G.M.INT[B] DO CASE TOPR(C) OF
        X2ADGET: A := I16;
        X2ADDEC: BEGIN I16 := I16 - 1; A := I16; END;
        X2ADDEP: BEGIN A := I16; I16 := I16 - 1; END;
        X2ADINC: BEGIN I16 := I16 + 1; A := I16; END;
        X2ADINP: BEGIN A := I16; I16 := I16 + 1; END;
      END;
      GOTO LOOP;
    END ELSE CASE TOPR(C) OF
      XLDACHR: A := SHORTINT(G.M.BYT[A].U8);
      XLDAINT: A := G.M.INT[A SHR 1].I16;
      XIDXCHR: WITH G.M.INT[G.R.S - 1] DO I16 := I16 + A;
      XIDXINT: WITH G.M.INT[G.R.S - 1] DO I16 := I16 + A * 2;
      XLDANEG: A := -A;
      XLDICHR: BEGIN A := SHORTINT(G.M.BYT[G.R.P].U8); G.R.P := G.R.P + 1; END;
      XLDIINT: A := PRGINT;
      XLDISTR: BEGIN A := G.R.P; G.R.P := G.R.P + G.M.BYT[G.R.P].U8 + 1; END;
      XJMPNOW: G.R.P := PRGINT;
      XJMPEQU: BEGIN B := PRGINT; IF A =  0 THEN G.R.P := B; END;
      XJMPNEQ: BEGIN B := PRGINT; IF A <> 0 THEN G.R.P := B; END;
      XLEACHR: BEGIN
        A := SHORTINT(G.M.BYT[G.R.P].U8); G.R.P := G.R.P + 1;
        IF A < 0 THEN A := (G.R.L - A) * 2;
      END;
      XLEAINT: BEGIN A := PRGINT; IF A < 0 THEN A := (G.R.L - A) * 2; END;
      XFUNJMP: BEGIN
        G.R.S := G.R.S - A;
        WITH G.M.INT[G.R.S] DO IF I16 <= 0 THEN BEGIN
          A := COMMAND(G, TCMD(-I16), ADDR(G.M.INT[G.R.S + 1]));
        END ELSE BEGIN
          MOVE(G.R, G.M.INT[G.R.S + A], SIZEOF(G.R));
          G.R.L := G.R.S; G.R.P := I16; G.R.S := G.R.S + A + 4;
          A := A - 1;
        END;
      END;
      XFUNBEG: BEGIN
        G.R.B := G.R.L + G.M.BYT[G.R.P].U8; G.R.P := G.R.P + 1;
        MOVE(G.M.INT[G.R.S - 4], G.M.INT[G.R.B], SIZEOF(G.R));
        G.R.S := G.R.B + 4;
      END;
      XFUNEND: MOVE(G.M.INT[G.R.B], G.R, SIZEOF(G.R));
      ELSE BEGIN G.A := A; EXIT; END;
    END;
  END;
  GOTO LOOP;
END;

PROCEDURE START; VAR MPX: ^TMPX; OPR: TOPR; BIN: FILE;
BEGIN
  IF PARAMCOUNT < 1 THEN WRITELN('USAGE: MPX <FILE>')
  ELSE BEGIN
    NEW(MPX); FILLCHAR(MPX^, SIZEOF(MPX^), 0);
    FOR OPR := XFINISH TO XZZZ DO CASE OPR OF
        XPSHACC, XPSHCHR, XPSHINT: MPX^.X[OPR] := XPSH;
        X1ADGET, X1ADDEC, X1ADDEP, X1ADINC, X1ADINP: MPX^.X[OPR] := X1AD;
        X2ADGET, X2ADDEC, X2ADDEP, X2ADINC, X2ADINP: MPX^.X[OPR] := X2AD;
        X1ASAND, X1ASSET, X1ASSUB, X1ASDIV, X1ASADD, X1ASIOR,
        X1ASMUL, X1ASSHL, X1ASSHR, X1ASXOR: MPX^.X[OPR] := X1AS;
        X2ASAND, X2ASSET, X2ASSUB, X2ASDIV, X2ASADD, X2ASIOR,
        X2ASMUL, X2ASSHL, X2ASSHR, X2ASXOR: MPX^.X[OPR] := X2AS;
        XGETACC, XBITAND, XBITIOR, XBITXOR, XCMPGTE, XCMPGTH, XCMPLTE,
        XCMPLTH, XDMMDIV, XDMMMOD, XDMMMUL, XEQUNOT, XEQUYES, XLOGAND,
        XLOGIOR, XLOGXOR, XSHFSHL, XSHFSHR, XSUMADD, XSUMSUB, XGETCHR,
        XGETINT: MPX^.X[OPR] := XPOP;
        ELSE MPX^.X[OPR] := XNUL;
      END;
    ASSIGN(BIN, PARAMSTR(1) + '.MPX'); RESET(BIN);
    IF IORESULT = 0 THEN BEGIN
      BLOCKREAD(BIN, MPX^.M.BYT, FILESIZE(BIN)); CLOSE(BIN);
      MPX^.R.P := MPX^.M.ENT;
      MPX^.R.S := (MPX^.M.SIZ + 1) DIV 2;
      EXEC(MPX^);
      WRITELN;
      WRITELN('=', MPX^.A);
    END;
  END;
END;

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