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

{$I MPL.INC}

CONST LIBDIR = {$IFDEF HPC}'M:\MPL\'{$ELSE}''{$ENDIF};

TYPE

  TERR = (ESYN, EDUP, ENOT);
  TOPT = (ISNO, IS2P, ISDM, ISID, ISSH, ISCP, ISEQ, ISBT, ISLG);
  TSYM = PACKED RECORD CASE BYT OF 1: (P: PSTR127); 2: (I: PTRINT) END;

VAR

  M: TMEM;
  G: PACKED RECORD E: INT; FP: ^TEXT; C: CHAR;
    A: PACKED RECORD S: STR127; X: TOPX; T: TOPT; I: INT END;
    S: PACKED RECORD S: TSYM; N: INT; T: PACKED ARRAY[BYT] OF INT END;
  END;

PROCEDURE WERR(E: TERR); BEGIN G.E := G.E + 1; WRITE('!ERR!: ');
  CASE E OF ESYN: WRITE('SYNTAX'); EDUP: WRITE('DUPLICATE');
    ENOT: WRITE('NOT FOUND') END; WRITELN('? "', G.A.S, '"')
END;

FUNCTION FIND: PINT; VAR S: TSYM; I: INT; BEGIN FIND := NIL; I := 0;
  IF G.A.X = XLDNEG THEN BEGIN I := G.S.N; S := G.S.S;
    WHILE LENGTH(S.P^) <> 0 DO BEGIN
      IF S.P^[0] = G.A.S[0] THEN
      IF S.P^ = G.A.S THEN BEGIN FIND := PTR(ADDR(G.S.T[I])); EXIT END;
      I := I - 1; S.I := S.I + LENGTH(S.P^) + 1
    END
  END ELSE WERR(ESYN)
END;

FUNCTION INCS: PINT; VAR IP: PINT; BEGIN IP := FIND; IF IP = NIL THEN BEGIN
  G.S.S.I := G.S.S.I - LENGTH(G.A.S) - 1; G.S.S.P^ := G.A.S;
  G.S.N := G.S.N + 1; INCS := PTR(ADDR(G.S.T[G.S.N]));
END ELSE INCS := IP END;

PROCEDURE I2(I: INT); BEGIN MOVE(I, M.B[M.N], 2); M.N := M.N + 2 END;
PROCEDURE O0(X: TOPX); BEGIN M.B[M.N] := ORD(X); M.N := M.N + 1 END;
PROCEDURE O1(X: TOPX; I: INT); BEGIN
  M.B[M.N] := ORD(X); M.B[M.N + 1] := I; M.N := M.N + 2
END;
PROCEDURE O2(X: TOPX; I: INT); BEGIN O0(X); I2(I) END;

PROCEDURE O12(I1, I2: TOPX; I: INT);
BEGIN IF I = SEX(I) THEN O1(I1, I) ELSE O2(I2, I) END;

PROCEDURE O2A(X: TOPX; I, A: INT); VAR N: INT;
BEGIN N := M.N; M.N := A; O2(X, I); M.N := N END;

PROCEDURE LDI(I: INT); BEGIN
  IF (I < (ORD(XZEND) - 128)) OR (I >= 128) THEN O12(XIMCHR, XIMINT, I)
  ELSE BEGIN M.B[M.N] := I + 128; M.N := M.N + 1 END
END;

PROCEDURE LEA(I: INT); BEGIN
  IF I >= 0 THEN LDI(I) ELSE O12(XLEAD1, XLEAD2, -I)
END;

PROCEDURE LST; VAR S: TSYM; BEGIN
  S.P := PTR(ADDR(M.B[M.N])); S.P^ := G.A.S; M.N := M.N + LENGTH(G.A.S) + 1
END;

PROCEDURE RCH; BEGIN IF G.C <> CHR(0) THEN G.C := FRDC(G.FP^) END;

FUNCTION ESC: CHAR; BEGIN IF G.C = '*' THEN BEGIN RCH; CASE UPCASE(G.C) OF
  '0': G.C := CHR( 0); 'A': G.C := CHR( 7); 'B': G.C := CHR( 8);
  'T': G.C := CHR( 9); 'N': G.C := CHR(10); 'V': G.C := CHR(11);
  'P': G.C := CHR(12); 'C': G.C := CHR(13); 'S': G.C := CHR(32)
END END; ESC := G.C END;

PROCEDURE T1(T: TOPT; X: TOPX); BEGIN G.A.T := T; G.A.X := X END;
PROCEDURE T2(T: TOPT; X: TOPX); BEGIN G.A.T := T; G.A.X := X; RCH END;

PROCEDURE NEXT; LABEL 0; BEGIN
0:WHILE G.C IN [CHR(1)..CHR(32)] DO RCH;
  T1(ISNO, XABORT); G.C := UPCASE(G.C); G.A.S := G.C;
  IF G.C IN ['.', 'A'..'Z'] THEN BEGIN RCH; G.C := UPCASE(G.C);
    WHILE G.C IN ['.', 'A'..'Z', '0'..'9'] DO BEGIN
      G.A.S := G.A.S + G.C; RCH; G.C := UPCASE(G.C)
    END; G.A.X := XLDNEG END
  ELSE IF G.C IN ['0'..'9'] THEN BEGIN G.A.I := ORD(G.C) - ORD('0'); RCH;
    WHILE G.C IN ['0'..'9'] DO BEGIN G.A.I := G.A.I * 10 + ORD(G.C) - ORD('0');
      RCH END; G.A.X := XIMINT END
  ELSE BEGIN RCH; CASE G.A.S[1] OF
    '''':BEGIN G.A.I := ORD(ESC); RCH; IF G.C = '''' THEN
      BEGIN RCH; G.A.X := XIMINT END END;
    '"':BEGIN G.A.S[0] := CHR(0); WHILE NOT (G.C IN [CHR(0), '"']) DO
      BEGIN G.A.S := G.A.S + ESC; RCH END;
      IF G.C = '"' THEN BEGIN G.A.X := XIMSTR; RCH END END;
    '/':CASE G.C OF '=': T2(IS2P, X2PDIV);
      '/':BEGIN WHILE NOT (G.C IN [CHR(0), CHR(10)]) DO RCH; GOTO 0 END;
      '*':BEGIN RCH; REPEAT WHILE NOT (G.C IN [CHR(0), '*']) DO RCH;
          RCH UNTIL G.C IN [CHR(0), '/']; RCH; GOTO 0 END
      ELSE T1(ISDM, XDMDIV) END;
    '?':G.A.X:=XIFEQU;'@':G.A.X:=XIFNEQ;';':G.A.X:=XIFNOW;',':G.A.X:=XFNJMP;
    '(':G.A.X:=XFNBEG;')':G.A.X:=XFNEND;'[':G.A.X:=XPUSHA;']':G.A.X:=XPULLA;
    '$':G.A.X:=XLEAD2;'%':G.A.X:=XLDBYT;
    '!':IF G.C='='THEN T2(ISEQ,XEQNOT)ELSE G.A.X := XLDINT;
    '^':IF G.C='='THEN T2(IS2P,X2PXOR)ELSE T1(ISBT,XBTXOR);
    '*':IF G.C='='THEN T2(IS2P,X2PMUL)ELSE T1(ISDM,XDMMUL);
    '#':IF G.C='='THEN T2(IS2P,X2PMOD)ELSE T1(ISDM,XDMMOD);
    '=':IF G.C='='THEN T2(ISEQ,XEQYES)ELSE T1(IS2P,X2PSET);
    '+':CASE G.C OF'+':T2(ISNO,XAPINC);'=':T2(IS2P,X2PADD);ELSE T1(ISID,XIDADD)END;
    '-':CASE G.C OF'-':T2(ISNO,XAPDEC);'=':T2(IS2P,X2PSUB);ELSE T1(ISID,XIDSUB)END;
    '<':CASE G.C OF'<':T2(ISSH,XSHSHL);'=':T2(ISCP,XCPLTE);ELSE T1(ISCP,XCPLTH)END;
    '>':CASE G.C OF'>':T2(ISSH,XSHSHR);'=':T2(ISCP,XCPGTE);ELSE T1(ISCP,XCPGTH)END;
    ':':CASE G.C OF':':T2(ISLG,XLGIOR);'=':T2(IS2P,X2PIOR);ELSE T1(ISBT,XBTIOR)END;
    '&':CASE G.C OF'&':T2(ISLG,XLGAND);'=':T2(IS2P,X2PAND) ELSE T1(ISBT,XBTAND)END END
  END;
END;

FUNCTION ISOP(X: TOPX): BOOLEAN; BEGIN IF G.A.X = X THEN
BEGIN NEXT; ISOP := TRUE END ELSE ISOP := FALSE END;

FUNCTION ISTY(T: TOPT; VAR X: TOPX): BOOLEAN; BEGIN X := G.A.X;
  IF G.A.T = T THEN BEGIN NEXT; ISTY := TRUE END ELSE ISTY := FALSE
END;

FUNCTION SIGN: INT; VAR I: INT; X: TOPX; BEGIN I := 1;
  WHILE ISTY(ISID, X) DO IF X = XIDSUB THEN I := -I; SIGN := I
END;

FUNCTION NUMB: INT; VAR I, J: INT; IP: PINT; BEGIN I := 0; J := SIGN;
  IF G.A.X = XIMINT THEN BEGIN I := G.A.I; NEXT END
  ELSE BEGIN IP := FIND; IF IP = NIL THEN WERR(ENOT) ELSE BEGIN
    IF G.A.S[1] = '.' THEN BEGIN NEXT; I := IP^ END
    ELSE BEGIN NEXT; IF ISOP(XLEAD2) THEN I := IP^ ELSE I := M.I[IP^ SHR 1]
    END END
  END; NUMB := I * J
END;

FUNCTION X2X1(X: TOPX): TOPX; BEGIN CASE X OF
  X2PADD: X := X1PADD; X2PAND: X := X1PAND; X2PDIV: X := X1PDIV;
  X2PIOR: X := X1PIOR; X2PMUL: X := X1PMUL; X2PSET: X := X1PSET;
  X2PSHL: X := X1PSHL; X2PSHR: X := X1PSHR; X2PSUB: X := X1PSUB;
  X2PXOR: X := X1PXOR; X2PMOD: X := X1PMOD
END; X2X1 := X END;

PROCEDURE EXPR; FORWARD;

PROCEDURE ELEM(OK: BOOLEAN);
VAR I, J: INT; X: TOPX; ISINT, ISSUM: BOOLEAN; IP: PINT; LABEL 0;
BEGIN J := SIGN;
  CASE G.A.X OF
    X2PSET: BEGIN NEXT; EXPR; O0(XFNEND) END;
    XFNBEG: BEGIN NEXT; EXPR; IF NOT ISOP(XFNEND) THEN WERR(ESYN) END;
    XIFNEQ: BEGIN NEXT; I := M.N; EXPR; O2(XIFNEQ, I) END;
    XIMINT: BEGIN LDI(G.A.I * J); J := 1; NEXT END;
    XIMSTR: BEGIN O0(XIMSTR); LST; NEXT END;
    XLDBYT, XLDINT: BEGIN ISINT := G.A.X = XLDINT; NEXT; ELEM(FALSE);
      IF OK AND (G.A.T = IS2P) THEN BEGIN
        IF ISINT THEN X := G.A.X ELSE X := X2X1(G.A.X);
        O0(XPUSHA); NEXT; EXPR; O0(X) END
      ELSE IF ISINT THEN O0(XLDINT) ELSE O0(XLDBYT) END
    ELSE BEGIN X := G.A.X; ISSUM := X IN [XAPINC, XAPDEC]; IF ISSUM THEN NEXT;
      IP := FIND; IF IP = NIL THEN WERR(ENOT) ELSE BEGIN
        IF G.A.S[1] = '.' THEN BEGIN IF ISSUM THEN WERR(ESYN); LDI(IP^); NEXT; END
        ELSE BEGIN LEA(IP^); NEXT;
          IF ISSUM THEN O0(X) ELSE IF OK AND (G.A.T = IS2P) THEN BEGIN
            X := G.A.X; O0(XPUSHA); NEXT; EXPR; O0(X) END
          ELSE CASE G.A.X OF
            XAPINC: BEGIN O0(XAPINP); NEXT END;
            XAPDEC: BEGIN O0(XAPDEP); NEXT END;
            XLEAD2: BEGIN NEXT END ELSE O0(XAPGET)
          END
        END
      END
    END
  END;
0:CASE G.A.X OF
    XLDBYT, XLDINT: BEGIN
      ISINT := G.A.X = XLDINT; NEXT; O0(XPUSHA); ELEM(FALSE);
      IF OK AND (G.A.T = IS2P) THEN BEGIN
        IF ISINT THEN BEGIN X := G.A.X; NEXT; O0(XINCA2) END
        ELSE BEGIN X := X2X1(G.A.X); NEXT; O0(XINCA1) END; EXPR; O0(X)
      END ELSE IF ISINT THEN O0(XPEINT) ELSE O0(XPEBYT);
      GOTO 0 END;
    XFNBEG: BEGIN NEXT; O0(XPUSHA); I := 1; IF G.A.X <> XFNEND THEN
      REPEAT EXPR; O0(XPUSHA); I := I + 1 UNTIL NOT ISOP(XFNJMP);
      LDI(I); O0(XFNJMP); IF NOT ISOP(XFNEND) THEN WERR(ESYN); GOTO 0
    END
  END; IF J < 0 THEN O0(XLDNEG)
END;

PROCEDURE OPER(T: TOPT); VAR X: TOPX; BEGIN
  IF T = IS2P THEN ELEM(TRUE) ELSE BEGIN OPER(PRED(T));
    WHILE ISTY(T, X) DO BEGIN O0(XPUSHA); OPER(PRED(T)); O0(X) END;
  END
END;

PROCEDURE EXPR; VAR PEXP, PNOW, PEQU: INT; BEGIN PEXP := M.N;
  IF G.A.X <> XPUSHA THEN OPER(ISLG) ELSE BEGIN NEXT;
    REPEAT EXPR UNTIL NOT ISOP(XIFNOW); IF NOT ISOP(XPULLA) THEN WERR(ESYN)
  END;
  CASE G.A.X OF
    XIFNEQ: BEGIN NEXT; PEQU := M.N; O2(XIFEQU, 0); EXPR;
      O2(XIFNOW, PEXP); O2A(XIFEQU, M.N, PEQU) END;
    XIFEQU: BEGIN NEXT; PEQU := M.N; O2(XIFEQU, 0); EXPR;
      IF G.A.X = XFNJMP THEN BEGIN NEXT; PNOW := M.N; O2(XIFNOW, 0);
        O2A(XIFEQU, M.N, PEQU); EXPR; O2A(XIFNOW, M.N, PNOW) END
      ELSE O2A(XIFEQU, M.N, PEQU) END
  END
END;

PROCEDURE COMP; FORWARD;

PROCEDURE BODY; VAR I, N: INT; S: TSYM; IP: PINT; BEGIN
  WHILE (G.A.X <> XABORT) AND (G.E < 1) DO BEGIN
    IF G.A.X = XIFNOW THEN BEGIN NEXT; COMP; NEXT END
    ELSE BEGIN IF ODD(M.N) THEN M.N := M.N + 1;
      IP := INCS; WRITELN(M.N: 5, ': ', G.A.S); NEXT;
      IF IP^ <> 0 THEN IF ISOP(XLEAD2) THEN M.I[IP^ SHR 1] := M.N ELSE WERR(EDUP);
      CASE G.A.X OF XBTIOR: BEGIN NEXT; IP^ := NUMB END;
        X2PSET: BEGIN NEXT; IF IP^ = 0 THEN IP^ := M.N;
          REPEAT
            IF G.A.X = XIMSTR THEN BEGIN LST; NEXT; END
            ELSE IF ISOP(XLDBYT) THEN M.N := M.N + NUMB
            ELSE IF ISOP(XLDINT) THEN M.N := M.N + NUMB * 2
            ELSE I2(NUMB)
          UNTIL NOT ISOP(XFNJMP) END;
        XFNBEG: BEGIN NEXT; IF IP^ = 0 THEN BEGIN IP^ := M.N; I2(IP^ + 2) END;
          S := G.S.S; N := G.S.N; I := 1;
          IF G.A.X <> XFNEND THEN REPEAT
            REPEAT IF G.A.X <> XIFNOW THEN BEGIN
                IP := INCS;
                IF IP^ <> 0 THEN WERR(EDUP); IF G.A.S[1] = '.' THEN WERR(ESYN);
                NEXT; IP^ := -I; IF ISOP(XLDINT) THEN I := I + NUMB
                ELSE IF ISOP(XLDBYT) THEN I := I + (NUMB + 1) DIV 2
                ELSE I := I + 1
              END
            UNTIL NOT ISOP(XFNJMP)
          UNTIL NOT ISOP(XIFNOW);
          IF NOT ISOP(XFNEND) THEN WERR(ESYN);
          O1(XFNBEG, I); EXPR; O0(XFNEND);
          FOR I := N + 1 TO G.S.N DO G.S.T[I] := 0;
          G.S.S := S; G.S.N := N
        END
      END
    END
  END
END;

PROCEDURE COMP; VAR F: TEXT; TF: ^TEXT; TC: CHAR; IP: PINT; BEGIN
  G.A.X := XLDNEG; IP := INCS; IF IP^ = 0 THEN
  BEGIN IP^ := 1; WRITELN('+OPEN: ', G.A.S); G.A.S := LIBDIR + G.A.S + '.MPL';
    IF FOLD(F, G.A.S) <> 0 THEN BEGIN DELETE(G.A.S, 1, LENGTH(LIBDIR));
      IF FOLD(F, G.A.S) <> 0 THEN BEGIN WERR(ENOT); EXIT END
    END;
    TF := G.FP; TC := G.C; G.FP := PTR(ADDR(F)); G.C := CHR(32); NEXT; BODY;
    G.FP := TF; G.C := TC; CLOSE(F) (* BUG: MUST REMOVE CLOSE() FOR AMIGA HSPASCAL (?) *)
  END
END;

PROCEDURE SAVE; VAR F: FILE; BEGIN
  ARGV(G.A.S, 1); ASSIGN(F, G.A.S + '.MPX'); REWRITE(F);
  IF IORESULT = 0 THEN BEGIN
    BLOCKWRITE(F, M.B, {$IFDEF HPC}M.N{$ELSE}(M.N + 127) div 128{$ENDIF});
    CLOSE(F);
  END
END;

PROCEDURE MAIN; VAR IP: PINT; BEGIN
  IF ARGC < 1 THEN WRITELN('USAGE: MPL <FILE>')
  ELSE BEGIN FILLCHAR(G, SIZEOF(G), 0); ARGV(G.A.S, 1);
    G.S.S.P := PTR(ADDR(M.B[MEMMAX])); M.N := 4; G.A.X := XLDNEG;
    WRITELN; WRITELN('COMPILING'); WRITELN;
    COMP; IF G.E = 0 THEN BEGIN G.A.S := 'MAIN'; G.A.X := XLDNEG;
      IP := FIND; IF IP = NIL THEN WERR(ENOT) ELSE BEGIN M.P := M.N;
        LEA(IP^); O0(XAPGET); O0(XPUSHA); LDI(1); O0(XFNJMP); O0(XABORT)
      END
    END;
    WRITELN; WRITE('COMPILE '); IF G.E <> 0 THEN BEGIN
      WRITELN('FAIL'); WRITELN; WRITELN(G.E: 5, ' ERRORS') END
    ELSE BEGIN
      WRITELN('DONE'); WRITELN;
      WRITELN(G.S.N: 5, ' SYMBOLS'); WRITELN(M.N: 5, ' BYTES');
      SAVE;
    END; WRITELN
  END
END;

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