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

  TPARAMS = PACKED ARRAY[0..7] OF INTEGER;

  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): INTEGER; BEGIN
  {$IFDEF HPC}ERASE(FN);{$ENDIF}
  ASSIGN(F, FN); REWRITE(F); FNEW := IORESULT
END;

FUNCTION FEND(VAR F: TEXT): INTEGER; 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): INTEGER;
BEGIN READLN(F, S); FRDS := IORESULT; END;

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

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

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

FUNCTION CALL(L: TLIB; VAR P: TPARAMS): INTEGER;
VAR
  FP: ^TEXT; S: PACKED ARRAY[0..3] OF PSTR127; A: INTEGER;

  PROCEDURE US(I: INTEGER); BEGIN
    A := P[I]; S[I] := PTR(ADDR(GV.C[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(GF[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[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.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 := 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: INTEGER; SP: PSTR127; IP: PINTEGER; IAP: ^TPARAMS; LABEL 0;
BEGIN
  A := IORESULT;
0:B := ORD(GV.C[GR.P]); GR.P := GR.P + 1;
  IF B >= ORD(XZEND) 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^ := 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;
    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 := 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 := 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
        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;
        XIMSTR: BEGIN A := GR.P; GR.P := GR.P + ORD(GV.C[GR.P]) + 1 END;
        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;
        XIFEQU: BEGIN B := PRGINT; IF A =  0 THEN GR.P := B END;
        XIFNEQ: BEGIN B := PRGINT; IF A <> 0 THEN GR.P := B END;
        XIMCHR: BEGIN A := SEX(ORD(GV.C[GR.P])); GR.P := GR.P + 1 END;
        XIMINT: A := PRGINT;
        XIFNOW: GR.P := PRGINT;
        XLDBYT: A := ORD(GV.C[A]); XLDINT: A := GV.I[A SHR 1];
        XLDNEG: A := -A;
        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: BOOLEAN; VAR F: FILE; BEGIN
  LOAD := FALSE; ARGV(GV.S, 1); ASSIGN(F, GV.S + '.MPX'); RESET(F);
  IF IORESULT = 0 THEN BEGIN
    BLOCKREAD(F, GV, FILESIZE(F));
    CLOSE(F); LOAD := TRUE;
  END;
END;

PROCEDURE INIT; VAR X: TXOP; BEGIN
  FOR X := XABORT TO XZEND 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;

{$IFDEF FPC}
PROCEDURE LDEF(FN: STR127); VAR F: TEXT; L: TLIB;
  PROCEDURE WRI(S: STR127; I: INTEGER); 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
      GR.P := GV.P; GR.S := (GV.N + 1) DIV 2;
      EXEC; WRITELN; WRITELN('=', GA)
    END ELSE WRITELN('NO INPUT')
  END;
  {$IFDEF FPC}READLN;{$ENDIF}
END.