MPL Bytecode Compiler Code

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

{$I MPLDEF.INC}

PROGRAM MPX;

{$I MPLCOM.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, KX1, KX2, KST, KAP);
  GF: PACKED ARRAY[FMIN..FMAX] OF TEXT;
  GR: PACKED RECORD P, B, L, S: INT END;

{$IFDEF CPM}
FUNCTION READKEY: CHAR; VAR C: CHAR; BEGIN
  READ(KBD, C); READKEY := C;
END;
{$ENDIF}

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

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[MPLSTAT]) 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: 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
    KX1: BEGIN GR.S := GR.S - 1; SP:= PTR(ADDR(GV.C[GV.I[GR.S]]));
      CASE TXOP(B) OF
        X1PASL: SP^[0] := CHR(ORD(SP^[0]) SHL A); X1PASR: 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;
    KX2: BEGIN GR.S := GR.S - 1; IP := PTR(ADDR(GV.I[GV.I[GR.S] SHR 1]));
      CASE TXOP(B) OF
        X2PASR: IF IP^ < 0 THEN IP^ := (IP^ SHR A) OR $8000  ELSE IP^ := IP^ SHR A;
        X2PASL: IP^ := IP^ SHL 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
        XAPLDA: A := IP^;
        XAPI1A: BEGIN IP^:=IP^+1; A:=IP^; END; XAPAI1: BEGIN A:=IP^; IP^:=IP^+1 END;
        XAPD1A: BEGIN IP^:=IP^-1; A:=IP^; END; XAPAD1: BEGIN A:=IP^; IP^:=IP^-1 END;
        XAPI2A: BEGIN IP^:=IP^+2; A:=IP^; END; XAPAI2: BEGIN A:=IP^; IP^:=IP^+2 END;
        XAPD2A: BEGIN IP^:=IP^-2; A:=IP^; END; XAPAD2: BEGIN A:=IP^; IP^:=IP^-2 END
      END; GOTO 0 END;
    KST: BEGIN GR.S := GR.S - 1; IP := PTR(ADDR(GV.I[GR.S]));
      CASE TXOP(B) OF
        XASADD: A := IP^ + A;       XASSUB: A := IP^ - A;
        XBTAND: A := IP^ AND A;     XMDMUL: A := IP^ * A;
        XBTXOR: A := IP^ XOR A;     XBTIOR: A := IP^ OR A;
        XCPGTE: A := ORD(IP^ >= A); XCPGTH: A := ORD(IP^ >  A);
        XCPLTE: A := ORD(IP^ <= A); XCPLTH: A := ORD(IP^ <  A);
        XEQNEQ: A := ORD(IP^ <> A); XEQEQU: A := ORD(IP^ =  A);
        XMDDIV: A := IP^ DIV A;     XMDMOD: A := IP^ MOD A;
        XSHASL: A := IP^ SHL A;
        XSHASR: IF IP^ < 0 THEN A := (IP^ SHR A) OR $8000 ELSE A := IP^ SHR A;
        XLGAND: A := ORD((IP^ <> 0) AND (A <> 0));
        XLGIOR: A := ORD((IP^ <> 0) OR  (A <> 0));
        XLGXOR: A := ORD((IP^ <> 0) XOR (A <> 0));
        XPEBYT: A := ORD(GV.C[A + IP^]);
        XPEINT: A := GV.I[A + (IP^ SHR 1)];
        XPULLA: A := IP^
      END; GOTO 0
    END ELSE
      CASE TXOP(B) OF
        XIMCHR: BEGIN A := SEXT(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; XLDNEG: A := -A; XLDINV: A := NOT A;
        XLDBYT: A := ORD(GV.C[A]); XLDINT: A := GV.I[A SHR 1];
        XLDEQU: A := ORD(A = 0); XLDNEQ: A := ORD(A <> 0);
        XLDGTH: A := ORD(A > 0); XLDGTE: A := ORD(A >= 0);
        XLDLTH: A := ORD(A < 0); XLDLTE: A := ORD(A <= 0);
        XLEAD1: BEGIN A := SEXT(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 OF TBLK; FN: STR127; I: INT; BEGIN
  LOAD := FALSE;
  ARGV(FN, 1); FN := FN + MPXFEXT; ASSIGN(F, FN); RESET(F);
  IF IORESULT = 0 THEN BEGIN
    I := 0; WHILE NOT EOF(F) DO BEGIN
      READ(F, GV.B[I]); I := I + 1;
    END;
    CLOSE(F);
    LOAD := TRUE;
  END;
END;

PROCEDURE INIT; VAR X: TXOP; BEGIN
  FOR X := XABORT TO XZZEND DO CASE X OF
    XAPLDA, XAPD1A, XAPAD1, XAPI1A, XAPAI1, XAPD2A, XAPAD2,
    XAPI2A, XAPAI2: GK[X] := KAP;
    X1PAND, X1PSET, X1PSUB, X1PDIV, X1PADD, X1PIOR,
    X1PMOD, X1PMUL, X1PASL, X1PASR, X1PXOR: GK[X] := KX1;
    X2PAND, X2PSET, X2PSUB, X2PDIV, X2PADD, X2PIOR,
    X2PMOD, X2PMUL, X2PASL, X2PASR, X2PXOR: GK[X] := KX2;
    XPULLA, XBTAND, XBTIOR, XBTXOR, XCPGTE, XCPGTH, XCPLTE,
    XCPLTH, XMDDIV, XMDMOD, XMDMUL, XEQNEQ, XEQEQU, XLGAND,
    XLGIOR, XLGXOR, XSHASL, XSHASR, XASADD, XASSUB, XPEBYT,
    XPEINT: GK[X] := KST ELSE GK[X] := K00
  END;
  GR.S := (GV.I[MPLSIZE] + 1) DIV 2;
  GR.P := GV.I[MPLBOOT];
  GV.I[MPLHEAP] := MPLIMAX * 2;
  GV.I[MPLIMAX] := 0;
END;

{$IFDEF FPC}
PROCEDURE LDEF(FN: STR127); VAR F: TEXT; L: TLIB;
  PROCEDURE WRV(S: STR127; I: INT); BEGIN WRITELN(F, '**', S,':',I) END;
  PROCEDURE WRI(S: STR127; I: INT); BEGIN WRV('.' + S,I) END;
BEGIN
  IF FNEW(F, FN) = 0 THEN BEGIN WRITELN(F, '// AUTO GENERATED LIBDEF');
    FOR L := SUCC(LABRT) TO PRED(LZEND) DO BEGIN
      STR(L,FN); DELETE(FN, 1, 1); WRI(FN,-ORD(L));
    END;
    WRV('MPL.SIZE', MPLSIZE * 2);
    WRV('MPL.BOOT', MPLBOOT * 2);
    WRV('MPL.STAT', MPLSTAT * 2);
    WRV('MPL.HEAP', MPLHEAP * 2);

    WRI('FINP', ORD(FINP)); WRI('FOUT', ORD(FOUT));
    WRI('FMIN', ORD(FMIN)); WRI('FMAX', ORD(FMAX));
    WRI('MAXINT', MAXINT);
    WRI('PNEXT', 0); WRI('PPREV', 1); WRI('PTYPE', -1);
    WRI('FALSE', 0); WRI('TRUE', 1); WRI('NULL',  0);
    WRI('INT.B', 2); WRI('STR.B', 128);
    WRI('REAL.B', 6); WRI('LONG.B', 4);
    FEND(F)
  END
END;
{$ENDIF}

BEGIN
  {$IFDEF FPC}LDEF('LIBDEF.MPL');{$ENDIF}
  IF ARGC < 1 THEN WRITELN('USAGE: MPX <FILE>')
  ELSE IF LOAD THEN BEGIN
    INIT; EXEC; WRITELN; WRITELN('=', GA)
  END ELSE WRITELN('NO INPUT');
  {$IFDEF FPC}READLN;{$ENDIF}
END.