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

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

TYPE

  TERR = (ESYN, EDUP, ENOT);
  TKOP = (KNUL, KPOP, KDMM, KSUM, KSHF, KCMP, KEQU, KBIT, KLOG);
  TSYM = PACKED RECORD CASE INT OF 1: (P: PSTR127); 2: (I: PTRINT) END;

VAR

  GV: TVEC; GS: TSYM; GN, GI, GE: INT;
  GT: PACKED ARRAY[0..400] OF INT;
  GF: PTEXT; GC: CHAR; GA: STR127; GX: TXOP; GK: TKOP;

FUNCTION UPCASE(C: CHAR): CHAR; BEGIN
  IF C IN [CHR(97)..CHR(122)] THEN UPCASE := CHR(ORD(C) - 32) ELSE UPCASE := C;
END;

PROCEDURE RCH; BEGIN IF GC <> CHR(0) THEN GC := FRDC(GF^) END;

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

PROCEDURE K1(K: TKOP; X: TXOP); BEGIN GK := K; GX := X END;
PROCEDURE K2(K: TKOP; X: TXOP); BEGIN GK := K; GX := X; RCH END;

PROCEDURE NEXT; LABEL 0; BEGIN
0:WHILE GC IN [CHR(1)..CHR(32)] DO RCH;
  K1(KNUL, XABORT); GC := UPCASE(GC); GA := GC;
  IF GC IN ['.', 'A'..'Z'] THEN BEGIN RCH; GC := UPCASE(GC);
    WHILE GC IN ['.', 'A'..'Z', '0'..'9'] DO BEGIN
      GA := GA + GC; RCH; GC := UPCASE(GC)
    END; GX := XLDNEG
  END ELSE IF GC IN ['0'..'9'] THEN BEGIN GI := ORD(GC) - ORD('0'); RCH;
    WHILE GC IN ['0'..'9'] DO BEGIN GI := GI * 10 + ORD(GC) - ORD('0'); RCH END;
    GX := XIMINT
  END ELSE BEGIN RCH; CASE GA[1] OF
    '''':BEGIN GI := ORD(ESC); RCH; IF GC = '''' THEN BEGIN RCH; GX := XIMINT END END;
    '"':BEGIN GA[0] := CHR(0);
      WHILE NOT (GC IN [CHR(0), '"']) DO BEGIN GA := GA + ESC; RCH END;
      IF GC = '"' THEN BEGIN GX := XIMSTR; RCH END END;
    '/':CASE GC OF '=': K2(KPOP, X2PDIV);
      '/':BEGIN WHILE NOT (GC IN [CHR(0), CHR(10)]) DO RCH; GOTO 0 END;
      '*':BEGIN RCH; REPEAT WHILE NOT (GC IN [CHR(0), '*']) DO RCH; RCH
          UNTIL GC IN [CHR(0), '/']; RCH; GOTO 0 END ELSE K1(KDMM, XDMDIV) END;
    '?':GX:=XJMPEQ;'@':GX:=XJMPNE;';':GX:=XJMPTO;',':GX:=XFNJMP;'(':GX:=XFNBEG;
    ')':GX:=XFNEND;'[':GX:=XPUSHA;']':GX:=XPULLA;'$':GX:=XLEAD1;'%':GX:=XLDBYT;
    '!':GX:=XLDINT;
    '#':IF GC='='THEN K2(KPOP,X2PMOD)ELSE K1(KDMM,XDMMOD);
    '*':IF GC='='THEN K2(KPOP,X2PMUL)ELSE K1(KDMM,XDMMUL);
    '=':IF GC='='THEN K2(KEQU,XEQYES)ELSE K1(KPOP,X2PSET);
    '^':IF GC='='THEN K2(KPOP,X2PXOR)ELSE K1(KBIT,XBTXOR);
    ':':CASE GC OF':':K2(KLOG,XLGIOR);'=':K2(KPOP,X2PIOR)ELSE K1(KBIT,XBTIOR)END;
    '&':CASE GC OF'&':K2(KLOG,XLGAND);'=':K2(KPOP,X2PAND)ELSE K1(KBIT,XBTAND)END;
    '+':CASE GC OF'+':K2(KNUL,XAPINC);'=':K2(KPOP,X2PADD)ELSE K1(KSUM,XIDADD)END;
    '-':CASE GC OF'-':K2(KNUL,XAPDEC);'=':K2(KPOP,X2PSUB)ELSE K1(KSUM,XIDSUB)END;
    '>':CASE GC OF'>':K2(KSHF,XSHSHR);'=':K2(KCMP,XCPGTE)ELSE K1(KCMP,XCPGTH)END;
    '<':CASE GC OF'<':K2(KSHF,XSHSHL);'=':K2(KCMP,XCPLTE);'>':K2(KEQU,XEQNOT)
        ELSE K1(KCMP,XCPLTH)END
  END END;
END;

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

FUNCTION LOC(VAR IP: PINT): BOOL; VAR I: INT; S: TSYM; BEGIN LOC := FALSE;
  IF GX = XLDNEG THEN BEGIN I := GN; S := GS; WHILE I > 0 DO BEGIN
    I := I - 1; IF S.P^ <> GA THEN S.I := S.I + ORD(S.P^[0]) + 1
    ELSE BEGIN IP := PTR(ADDR(GT[I])); LOC := TRUE; EXIT END
END END ELSE ERR(ESYN) END;

PROCEDURE ADD(VAR IP: PINT); BEGIN GS.I := GS.I - ORD(GA[0]) - 1;
  GS.P^ := GA; GT[GN] := 0; IP := PTR(ADDR(GT[GN])); GN := GN + 1
END;

FUNCTION ISX(X: TXOP): BOOL;
BEGIN IF GX = X THEN BEGIN NEXT; ISX := TRUE END ELSE ISX := FALSE END;

FUNCTION ISK(K: TKOP; VAR X: TXOP): BOOL;
BEGIN X := GX; IF GK = K THEN BEGIN NEXT; ISK := TRUE END ELSE ISK := FALSE END;

FUNCTION SGN: INT; VAR I: INT; X: TXOP;
BEGIN I := 1; WHILE ISK(KSUM, X) DO IF X = XIDSUB THEN I := -I; SGN := I END;

FUNCTION NUM: INT; VAR I, J: INT; IP: PINT; BEGIN I := 0; J := SGN;
  IF GX = XIMINT THEN BEGIN I := GI; NEXT
  END ELSE IF LOC(IP) THEN BEGIN IF GA[1] = '.' THEN BEGIN I := IP^; NEXT
  END ELSE BEGIN NEXT; IF ISX(XLEAD1) THEN I := IP^ ELSE I := GV.I[IP^ SHR 1]
END END ELSE ERR(ENOT); NUM := I * J END;

FUNCTION X2X1(X: TXOP): TXOP; 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 I2(I: INT); VAR IP: PINT; BEGIN
{$IFDEF HPC}MOVE(I, GV.C[GV.N], 2);
{$ELSE}IP := PTR(ADDR(GV.C[GV.N])); IP^ := I;
{$ENDIF} GV.N := GV.N + 2
END;
PROCEDURE X0(X: TXOP); BEGIN GV.C[GV.N] := CHR(ORD(X)); GV.N := GV.N + 1 END;
PROCEDURE X1(X: TXOP; I: INT); BEGIN
  GV.C[GV.N] := CHR(ORD(X)); GV.C[GV.N + 1] := CHR(I); GV.N := GV.N + 2
END;
PROCEDURE X2(X: TXOP; I: INT); BEGIN X0(X); I2(I) END;

PROCEDURE X12(A, B: TXOP; I: INT);
BEGIN IF I = SEX(I) THEN X1(A, I) ELSE X2(B, I) END;

PROCEDURE X2A(A: INT; X: TXOP; I: INT); VAR N: INT;
BEGIN N := GV.N; GV.N := A; X2(X, I); GV.N := N END;

PROCEDURE LDI(I: INT); BEGIN
  IF (I < (ORD(XZZEND) - 128)) OR (I >= 128) THEN X12(XIMCHR, XIMINT, I)
  ELSE BEGIN GV.C[GV.N] := CHR(I + 128); GV.N := GV.N + 1 END
END;

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

PROCEDURE LST; VAR S: TSYM;
BEGIN S.P := PTR(ADDR(GV.C[GV.N])); S.P^ := GA; GV.N := GV.N + ORD(GA[0]) + 1 END;

PROCEDURE EXPR; FORWARD;

PROCEDURE ELEM(K: TKOP);
VAR I, J: INT; X: TXOP; ISINT, ISSUM: BOOL; IP: PINT; LABEL 0;
BEGIN
  IF K > KPOP THEN BEGIN ELEM(PRED(K));
    WHILE ISK(K, X) DO BEGIN X0(XPUSHA); ELEM(PRED(K)); X0(X) END
  END ELSE BEGIN J := SGN; CASE GX OF
    X2PSET: BEGIN NEXT; EXPR; X0(XFNEND) END;
    XFNBEG: BEGIN NEXT; EXPR; IF NOT ISX(XFNEND) THEN ERR(ESYN) END;
    XJMPNE: BEGIN NEXT; I := GV.N; EXPR; X2(XJMPNE, I) END;
    XIMINT: BEGIN LDI(GI * J); J := 1; NEXT END;
    XIMSTR: BEGIN X0(XIMSTR); LST; NEXT END;
    XLDBYT, XLDINT: BEGIN ISINT := GX = XLDINT; NEXT; ELEM(KNUL);
      IF (K = KPOP) AND (GK = KPOP) THEN BEGIN
        IF ISINT THEN X := GX ELSE X := X2X1(GX);
        X0(XPUSHA); NEXT; EXPR; X0(X)
      END ELSE IF ISINT THEN X0(XLDINT) ELSE X0(XLDBYT)
    END ELSE BEGIN X := GX; ISSUM := X IN [XAPINC, XAPDEC];
      IF ISSUM THEN NEXT; IF LOC(IP) THEN BEGIN
        IF GA[1] = '.' THEN BEGIN IF ISSUM THEN ERR(ESYN);
          LDI(IP^); NEXT END ELSE BEGIN LEA(IP^); NEXT;
          IF ISSUM THEN X0(X) ELSE IF (K = KPOP) AND (GK = KPOP) THEN
          BEGIN X := GX; X0(XPUSHA); NEXT; EXPR; X0(X)
          END ELSE CASE GX OF
            XAPINC: BEGIN X0(XAPINP); NEXT END;
            XAPDEC: BEGIN X0(XAPDEP); NEXT END;
            XLEAD1: BEGIN NEXT END ELSE X0(XAPGET)
          END
        END
      END ELSE ERR(ENOT)
    END END;
0:  CASE GX OF
      XLDBYT, XLDINT: BEGIN
        ISINT := GX = XLDINT; NEXT; X0(XPUSHA); ELEM(KNUL);
        IF (K = KPOP) AND (GK = KPOP) THEN BEGIN
          IF ISINT THEN BEGIN X := GX; NEXT; X0(XINCA2)
          END ELSE BEGIN X := X2X1(GX); NEXT; X0(XINCA1) END; EXPR; X0(X)
        END ELSE IF ISINT THEN X0(XPEINT) ELSE X0(XPEBYT);
        GOTO 0 END;
      XFNBEG: BEGIN NEXT; X0(XPUSHA); I := 1; IF GX <> XFNEND THEN
        REPEAT EXPR; X0(XPUSHA); I := I + 1 UNTIL NOT ISX(XFNJMP);
        LDI(I); X0(XFNJMP); IF NOT ISX(XFNEND) THEN ERR(ESYN); GOTO 0
      END
    END; IF J < 0 THEN X0(XLDNEG)
  END;
END;

PROCEDURE EXPR; VAR EX, JP, EQ: INT; X: TXOP; BEGIN EX := GV.N;
  IF GX = XPUSHA THEN BEGIN NEXT; REPEAT EXPR UNTIL NOT ISX(XJMPTO);
    IF NOT ISX(XPULLA) THEN ERR(ESYN) END ELSE ELEM(KLOG);
  IF GX IN [XJMPNE, XJMPEQ] THEN BEGIN X := GX; EQ := GV.N; X2(XJMPEQ, 0);
    NEXT; EXPR; CASE X OF XJMPNE: BEGIN X2(XJMPTO, EX); X2A(EQ, XJMPEQ, GV.N)
    END; XJMPEQ: IF GX = XFNJMP THEN BEGIN JP := GV.N; X2(XJMPTO, 0);
    X2A(EQ, XJMPEQ, GV.N); NEXT; EXPR; X2A(JP, XJMPTO, GV.N)
    END ELSE X2A(EQ, XJMPEQ, GV.N) END END
END;

PROCEDURE INCL; FORWARD;

PROCEDURE BODY; VAR ISEND, ISNEW, ISVAR: BOOL; IP: PINT; N, LN: INT; LS: TSYM;
BEGIN WHILE NOT(GX IN [XABORT, XPULLA]) AND (GE < 1) DO CASE GX OF
  XJMPTO: BEGIN NEXT; INCL; NEXT END;
  XPUSHA: BEGIN LS := GS; LN := GN; NEXT; BODY; GS := LS; GN := LN;
    IF NOT ISX(XPULLA) THEN ERR(ESYN)
  END ELSE BEGIN IF ODD(GV.N) THEN GV.N := GV.N + 1;
    ISEND := ISX(XFNEND); IF ISEND THEN BEGIN ISNEW := FALSE;
      ADD(IP); IP^ := GV.N END ELSE ISNEW := NOT LOC(IP);
    ISVAR := GA[1] <> '.'; WRITELN(GV.N: 5, ': ', GA);
    IF ISNEW THEN BEGIN ADD(IP); IP^ := GV.N; NEXT END ELSE BEGIN NEXT;
      IF ISVAR AND ISX(XLEAD1) THEN BEGIN
        IF GV.I[IP^ SHR 1] = 0 THEN GV.I[IP^ SHR 1] := GV.N
        ELSE ERR(ESYN)
      END ELSE IF NOT ISEND THEN ERR(EDUP)
    END; IF GE = 0 THEN CASE GX OF
      XBTIOR: BEGIN NEXT; IP^ := NUM END;
      X2PSET: BEGIN
          NEXT; REPEAT IF GX = XIMSTR THEN BEGIN LST; NEXT END
          ELSE IF ISX(XLDBYT) THEN GV.N := GV.N + NUM
          ELSE IF ISX(XLDINT) THEN GV.N := GV.N + NUM * 2
          ELSE I2(NUM) UNTIL NOT ISX(XFNJMP) END;
      XFNBEG: BEGIN IF (ISNEW OR ISEND) AND ISVAR THEN I2(GV.N + 2);
        NEXT; LS := GS; LN := GN; N := 1; IF GX <> XFNEND THEN
        REPEAT REPEAT IF GX <> XJMPTO THEN IF GA[1] = '.' THEN ERR(ESYN)
        ELSE BEGIN ADD(IP); NEXT; IP^ := -N; (* TODO: CHECK FOR DUP LOCALS *)
          IF ISX(XLDBYT) THEN N := N + (NUM + 1) DIV 2
          ELSE IF ISX(XLDINT) THEN N := N + NUM ELSE N := N + 1
        END UNTIL NOT ISX(XFNJMP) UNTIL NOT ISX(XJMPTO);
        IF NOT ISX(XFNEND) THEN ERR(ESYN);
        X1(XFNBEG, N); EXPR; X0(XFNEND); GS := LS; GN := LN
      END ELSE I2(0)
    END
  END END;
END;

FUNCTION OPEN(VAR F: TEXT): BOOL; VAR S: STR127; BEGIN OPEN := TRUE;
  WRITELN('+FILE: ', GA); S := MPLDIR + GA + MPLEXT; IF FOLD(F, S) <> 0 THEN
  BEGIN S := GA + MPLEXT; OPEN := FOLD(F, S) = 0 END
END;

PROCEDURE INCL; VAR F: TEXT; LF: PTEXT; LC: CHAR; IP: PINT;
BEGIN GX := XLDNEG; IF NOT LOC(IP) THEN BEGIN ADD(IP);
  IF NOT OPEN(F) THEN ERR(ENOT) ELSE BEGIN
    LF := GF; LC := GC; GF := PTR(ADDR(F)); GC := CHR(32);
    NEXT; BODY; GF := LF; GC := LC; CLOSE(F)
    (* BUG: MUST REMOVE CLOSE() FOR AMIGA HSPASCAL (?) *)
  END
END END;

PROCEDURE SAVE; VAR F: FILE; BEGIN
  ARGV(GA, 1); GA := GA + MPXEXT; ASSIGN(F, GA); REWRITE(F);
  IF IORESULT = 0 THEN BEGIN
    BLOCKWRITE(F, GV, {$IFDEF HPC}GV.N{$ELSE}(GV.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 ARGV(GA, 1);
    GE := 0; GN := 0; GV.N := 4; GX := XLDNEG; GS.P := PTR(ADDR(GV.C[MEMMAX]));
    WRITELN; WRITELN('COMPILING'); WRITELN;
    INCL; IF GE = 0 THEN BEGIN GA := 'MAIN'; GX := XLDNEG;
      IF LOC(IP) THEN BEGIN GV.P := GV.N;
        LEA(IP^); X0(XAPGET); X0(XPUSHA); LDI(1); X0(XFNJMP); X0(XABORT)
      END ELSE ERR(ENOT)
    END;
    WRITELN; WRITE('COMPILE '); IF GE <> 0 THEN BEGIN
      WRITELN('FAIL'); WRITELN; WRITELN(GE: 5, ' ERRORS')
    END ELSE BEGIN
      WRITELN('DONE'); WRITELN;
      WRITELN(GN: 5, ' SYMBOLS'); WRITELN(GV.N: 5, ' BYTES');
      SAVE;
    END; WRITELN
  END
END;

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