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,8,8,8}{$F+}{$S-}{$ENDIF}
{$IFNDEF HPC}{$A-}{$ENDIF}
{$D-}{$I-}{$R-}{$V-}

PROGRAM MPX;

{$I MPL.INC}

TYPE

  INTAT = PACKED ARRAY[BYT] OF INT;

  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
    );

  TFID = (FINP, FOUT, FMIN, F003, F004, F005, FMAX);

FUNCTION FNEW(VAR F: TEXT; VAR FN: STR127): INT; BEGIN
  {$IFDEF HPC}ERASE(FN);{$ENDIF}
  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 FRES(VAR F: TEXT; VAR S: STR127): INT;
BEGIN READLN(F, S); FRES := IORESULT; END;

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

VAR
    M: TMEM;
    G: PACKED RECORD
      A: INT; R: PACKED RECORD P, B, L, S: INT END;
      F: PACKED ARRAY[FMIN..FMAX] OF TEXT;
      X: PACKED ARRAY[TOPX] OF (X00, X1P, X2P, XST, XAP)
    END;

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

FUNCTION CALL(L: TLIB; VAR P: INTAT): INT;
VAR
  FP: ^TEXT; S: PACKED ARRAY[0..3] OF TSYM; A: INT;

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

  FUNCTION UF(I: TFID): BOOLEAN; BEGIN
    A := -1; FP := NIL;
    CASE I OF
      FINP: FP := PTR(ADDR(INPUT)); FOUT: FP := PTR(ADDR(OUTPUT));
      FMIN..FMAX: FP := PTR(ADDR(G.F[I]))
    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^, 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].P^) END;
    LFOLD: IF UF(TFID(P[0])) THEN BEGIN US(1); A := FOLD(FP^, S[1].P^) END;
    LFRDC: IF UF(TFID(P[0])) THEN A := ORD(FRDC(FP^));
    LFRDS: IF UF(TFID(P[0])) THEN BEGIN US(1); A := FRES(FP^, S[1].P^) 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].P^) 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].P^) END;
    LMCPY: BEGIN A := P[0]; MOVE(M.B[P[1]], M.B[A], P[2]) END;
    LMSET: BEGIN A := P[0]; FILLCHAR(M.B[A], P[2], CHR(P[1])) END;
    LSCPY: BEGIN US(1); US(0); S[0].P^ := S[1].P^; END;
    LSDEL: BEGIN US(0); DELETE(S[0].P^, P[1], P[2]) END;
    LSINS: BEGIN US(1); US(0); INSERT(S[1].P^, S[0].P^, P[2]) END;
    LSMID: BEGIN US(1); US(0); S[0].P^ := COPY(S[1].P^, P[2], P[3]) END;
    LSPOS: BEGIN US(1); US(0); A := POS(S[0].P^, S[1].P^) END;
    LSTOI: BEGIN US(0); VAL(S[0].P^, A, M.N) 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: A := ORD(READKEY);
    LTRDS: IF UF(FINP) THEN BEGIN US(0); A := FRES(FP^, S[0].P^) 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].P^) END;
  END; CALL := A
END;

PROCEDURE EXEC;
VAR A, B: INT; BP: PBYT; IP: PINT; IAP: ^INTAT; LABEL 0;
BEGIN
  A := IORESULT;
0:B := M.B[G.R.P]; G.R.P := G.R.P + 1;
  IF B >= ORD(XZEND) THEN BEGIN A := B - 128; GOTO 0 END;
  CASE G.X[TOPX(B)] OF
    X1P: BEGIN G.R.S := G.R.S - 1; BP := PTR(ADDR(M.B[M.I[G.R.S]]));
      CASE TOPX(B) OF
        X1PSHL: BP^ := BP^ SHL A; X1PSHR: BP^ := BP^ SHR A;
        X1PDIV: BP^ := BP^ DIV A; X1PMOD: BP^ := BP^ MOD A;
        X1PXOR: BP^ := BP^ XOR A; X1PIOR: BP^ := BP^ OR  A;
        X1PAND: BP^ := BP^ AND A; X1PMUL: BP^ := BP^ * A;
        X1PADD: BP^ := BP^ + A;   X1PSUB: BP^ := BP^ - A;
        X1PSET: BP^ := A;
      END; A := BP^; GOTO 0
    END;
    X2P: BEGIN G.R.S := G.R.S - 1; IP := PTR(ADDR(M.I[M.I[G.R.S] SHR 1]));
      CASE TOPX(B) OF
        X2PSHL: IP^ := IP^ SHL A; X2PSHR: IP^ := WORD(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;
    XAP: BEGIN IP := PTR(ADDR(M.I[A SHR 1]));
      CASE TOPX(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;
    XST: BEGIN G.R.S := G.R.S - 1; IP := PTR(ADDR(M.I[G.R.S]));
      CASE TOPX(B) OF
        XSHSHL: A := IP^ SHL A;     XSHSHR: A := WORD(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 := M.B[A + IP^];
        XPEINT: A := M.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 TOPX(B) OF
        XINCA1: BEGIN IP := PTR(ADDR(M.I[G.R.S - 1])); IP^ := IP^ + A END;
        XINCA2: BEGIN IP := PTR(ADDR(M.I[G.R.S - 1])); IP^ := IP^ + A * 2 END;
        XIMSTR: BEGIN A := G.R.P; G.R.P := G.R.P + M.B[G.R.P] + 1 END;
        XLEAD1: BEGIN A := SEX(M.B[G.R.P]); 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 M.I[G.R.S] := 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(M.B[G.R.P]); G.R.P := G.R.P + 1 END;
        XIMINT: A := PRGINT;
        XIFNOW: G.R.P := PRGINT;
        XLDBYT: A := M.B[A]; XLDINT: A := M.I[A SHR 1];
        XLDNEG: A := -A;
        XFNJMP: BEGIN G.R.S := G.R.S - A; IP := PTR(ADDR(M.I[G.R.S]));
          IF IP^ <= 0 THEN BEGIN
            IAP := PTR(ADDR(M.I[G.R.S + 1])); A := CALL(TLIB(-IP^), IAP^)
          END ELSE BEGIN
            MOVE(G.R, M.I[G.R.S + A], SIZEOF(G.R));
            G.R.L := G.R.S; G.R.P := IP^; G.R.S := G.R.S + A + 4
          END
        END;
        XFNBEG: BEGIN G.R.B := G.R.L + M.B[G.R.P]; G.R.P := G.R.P + 1;
          MOVE(M.I[G.R.S - 4], M.I[G.R.B], SIZEOF(G.R));
          G.R.S := G.R.B + 4
        END;
        XFNEND: MOVE(M.I[G.R.B], G.R, SIZEOF(G.R))
        ELSE BEGIN G.A := A; EXIT
      END
    END
  END; GOTO 0
END;

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

PROCEDURE INIT; VAR X: TOPX;
BEGIN FILLCHAR(G, SIZEOF(G), 0);
  FOR X := XABORT TO XZEND DO CASE X OF
    XAPGET, XAPDEC, XAPDEP, XAPINC, XAPINP: G.X[X] := XAP;
    X1PAND, X1PSET, X1PSUB, X1PDIV, X1PADD, X1PIOR,
    X1PMOD, X1PMUL, X1PSHL, X1PSHR, X1PXOR: G.X[X] := X1P;
    X2PAND, X2PSET, X2PSUB, X2PDIV, X2PADD, X2PIOR,
    X2PMOD, X2PMUL, X2PSHL, X2PSHR, X2PXOR: G.X[X] := 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[X] := XST ELSE G.X[X] := X00
  END;
END;

{$IFDEF FPC}
PROCEDURE LDEF(FN: STR127); VAR F: TEXT; L: TLIB;
  PROCEDURE WRI(S: STR127; I: INT); BEGIN WRITELN(F, '.', S,':',I) END;
BEGIN
  IF FNEW(F, FN) = 0 THEN BEGIN WRITELN(F, '// AUTO GENERATED LIBDEF');
    WRI('FALSE', 0);        WRI('TRUE', 1);
    WRI('INT', 2);          WRI('REAL', 6);
    WRI('LONG', 4);         WRI('NULL', 0);
    WRI('NEXT', 0);         WRI('PREV', 1);
    WRI('FINP', ORD(FINP)); WRI('FOUT', ORD(FOUT));
    WRI('FMIN', ORD(FMIN)); WRI('FMAX', ORD(FMAX));
    WRI('STR', 128);
    FOR L := SUCC(LABRT) TO PRED(LZEND) DO BEGIN
      STR(L,FN); DELETE(FN, 1, 1); WRI(FN,-ORD(L));
    END;
    FEND(F)
  END
END;
{$ENDIF}

BEGIN
  {$IFDEF FPC}LDEF('LIBDEF.MPL');{$ENDIF}
  IF ARGC < 1 THEN WRITELN('USAGE: MPX <FILE>')
  ELSE BEGIN INIT;
    IF LOAD THEN BEGIN
      G.R.P := M.P; G.R.S := (M.N + 1) DIV 2;
      EXEC; WRITELN; WRITELN('=', G.A)
    END ELSE WRITELN('NO INPUT')
  END;
  {$IFDEF FPC}READLN;{$ENDIF}
END.