MPL Bytecode Compiler Code

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

{$D-}{$I-}{$R-}{$V-}{$IFDEF CPM}{$A-}{$ENDIF}

{$I MPLDEF.INC}

PROGRAM MPL;

{$I MPLCOM.INC}

TYPE

  TERR = (ESYN, EDUP, ENOT);
  TKOP = (K00, KX2, KMD, KAS, KSH, KCP, KEQ, KBT, KLG);
  TSYM = PACKED RECORD CASE INTEGER OF 1: (P: PSTR127); 2: (I: PTRINT) END;

VAR

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

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

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(K00, 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 '/':BEGIN READLN(GF^); RCH; GOTO 0 END;'=':K2(KX2, X2PDIV);
      '*':BEGIN RCH; REPEAT WHILE NOT (GC IN [CHR(0), '*']) DO RCH; RCH
          UNTIL GC IN [CHR(0), '/']; RCH; GOTO 0 END ELSE K1(KMD, XMDDIV) 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(KEQ,XEQEQU)ELSE K1(KX2,X2PSET);
    '#':CASE GC OF'#':K2(K00,XAPAI1);'=':K2(KX2,X2PMOD)ELSE K1(KMD,XMDMOD)END;
    '&':CASE GC OF'&':K2(KLG,XLGAND);'=':K2(KX2,X2PAND)ELSE K1(KBT,XBTAND)END;
    '*':CASE GC OF'*':K2(K00,XAPAD1);'=':K2(KX2,X2PMUL)ELSE K1(KMD,XMDMUL)END;
    '+':CASE GC OF'+':K2(K00,XAPI1A);'=':K2(KX2,X2PADD)ELSE K1(KAS,XASADD)END;
    '-':CASE GC OF'-':K2(K00,XAPD1A);'=':K2(KX2,X2PSUB)ELSE K1(KAS,XASSUB)END;
    ':':CASE GC OF':':K2(KLG,XLGIOR);'=':K2(KX2,X2PIOR)ELSE K1(KBT,XBTIOR)END;
    '>':CASE GC OF'>':K2(KSH,XSHASR);'=':K2(KCP,XCPGTE)ELSE K1(KCP,XCPGTH)END;
    '^':CASE GC OF'^':K2(K00,XLDINV);'=':K2(KX2,X2PXOR)ELSE K1(KBT,XBTXOR)END;
    '<':CASE GC OF'<':K2(KSH,XSHASL);'=':K2(KCP,XCPLTE);'>':K2(KEQ,XEQNEQ)
        ELSE K1(KCP,XCPLTH)
END END END END;

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

FUNCTION LOC(VAR IP: PINTEGER): BOOL; VAR I: INTEGER; 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: PINTEGER); 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: INTEGER; VAR I: INTEGER; X: TXOP;
BEGIN I := 1; WHILE ISK(KAS, X) DO IF X = XASSUB THEN I := -I; SGN := I END;

FUNCTION NUM: INTEGER; VAR I, J: INTEGER; IP: PINTEGER; 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;

PROCEDURE I2(I: INTEGER); VAR IP: PINTEGER; BEGIN
{$IFDEF CPU68K}MOVE(I, GV.C[GP], 2);
{$ELSE}IP := PTR(ADDR(GV.C[GP])); IP^ := I;
{$ENDIF} GP := GP + 2
END;

PROCEDURE X0(X: TXOP); BEGIN GV.C[GP] := CHR(ORD(X)); GP := GP + 1 END;

PROCEDURE IFX0(A: BOOL; T, F: TXOP); BEGIN
  IF A THEN GV.C[GP] := CHR(ORD(T)) ELSE GV.C[GP] := CHR(ORD(F));
  GP := GP + 1
END;

PROCEDURE X1(X: TXOP; I: INTEGER); BEGIN
  GV.C[GP] := CHR(ORD(X)); GV.C[GP + 1] := CHR(I); GP := GP + 2
END;
PROCEDURE X2(X: TXOP; I: INTEGER); BEGIN X0(X); I2(I) END;

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

PROCEDURE X2A(A: INTEGER; X: TXOP; I: INTEGER); VAR LP: INTEGER;
BEGIN LP := GP; GP := A; X2(X, I); GP := LP END;

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

PROCEDURE LEA(I: INTEGER);
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[GP])); S.P^ := GA; GP := GP + ORD(GA[0]) + 1 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;
  X2PASL: X := X1PASL; X2PASR: X := X1PASR; X2PSUB: X := X1PSUB;
  X2PXOR: X := X1PXOR; X2PMOD: X := X1PMOD
END; X2X1 := X END;

PROCEDURE EXPR; FORWARD;

PROCEDURE ELEM(K: TKOP; ASINT: BOOL);
VAR I, J: INTEGER; X: TXOP; ISID: BOOL; IP: PINTEGER; LABEL 0;
BEGIN
  IF K > KX2 THEN BEGIN ELEM(PRED(K), FALSE);
    WHILE ISK(K, X) DO BEGIN X0(XPUSHA); ELEM(PRED(K), FALSE); 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 I := GP; NEXT; EXPR; X2(XJMPNE, I) END;
    XIMINT: BEGIN LDI(GI * J); J := 1; NEXT END;
    XIMSTR: BEGIN X0(XIMSTR); LST; NEXT END;
    XLDBYT, XLDINT: BEGIN ASINT := GX = XLDINT; NEXT; ELEM(K00, ASINT);
      IF (K = KX2) AND (GK = KX2) THEN BEGIN
        IF ASINT THEN X := GX ELSE X := X2X1(GX);
        X0(XPUSHA); NEXT; EXPR; X0(X)
      END ELSE IFX0(ASINT, XLDINT, XLDBYT)
    END ELSE BEGIN X := GX; IF (GK = KEQ) OR (GK = KCP) OR (X = XLDINV) THEN
      BEGIN NEXT; ELEM(K00, FALSE); CASE X OF
        XEQEQU:X:=XLDEQU;XEQNEQ:X:=XLDNEQ;XCPGTH:X:=XLDGTH;XCPGTE:X:=XLDGTE;
        XCPLTH:X:=XLDLTH;XCPLTE:X:=XLDLTE END; X0(X)
      END ELSE BEGIN ISID := X IN [XAPI1A, XAPD1A]; IF ISID THEN NEXT;
        IF NOT LOC(IP) THEN ERR(ENOT) ELSE BEGIN IF GA[1] = '.' THEN BEGIN
            IF ISID THEN ERR(ESYN); LDI(IP^); NEXT
          END ELSE BEGIN LEA(IP^); NEXT;
            IF ISID THEN CASE X OF
              XAPI1A: IFX0(ASINT, XAPI2A, XAPI1A);
              XAPD1A: IFX0(ASINT, XAPD2A, XAPD1A)
            END ELSE IF (K = KX2) AND (GK = KX2) THEN BEGIN
              X := GX; X0(XPUSHA); NEXT; EXPR; X0(X)
            END ELSE CASE GX OF XLEAD1: NEXT;
              XAPI1A: BEGIN IFX0(ASINT, XAPAI2, XAPAI1); NEXT END;
              XAPD1A: BEGIN IFX0(ASINT, XAPAD2, XAPAD1); NEXT END
              ELSE X0(XAPLDA)
    END END END END END END;
0:  CASE GX OF
      XLDBYT, XLDINT: BEGIN
        ASINT := GX = XLDINT; NEXT; X0(XPUSHA); ELEM(K00, FALSE);
        IF (K = KX2) AND (GK = KX2) THEN BEGIN
          IF ASINT THEN BEGIN X := GX; NEXT; X0(XINCA2)
          END ELSE BEGIN X := X2X1(GX); NEXT; X0(XINCA1) END; EXPR; X0(X)
        END ELSE IFX0(ASINT, XPEINT, 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: INTEGER; X: TXOP; BEGIN EX := GP;
  IF GX = XPUSHA THEN BEGIN NEXT; REPEAT EXPR UNTIL NOT ISX(XJMPTO);
    IF NOT ISX(XPULLA) THEN ERR(ESYN) END ELSE ELEM(KLG, FALSE);
  IF GX IN [XJMPNE, XJMPEQ] THEN BEGIN X := GX; EQ := GP; X2(XJMPEQ, 0);
    NEXT; EXPR; CASE X OF XJMPNE: BEGIN X2(XJMPTO, EX); X2A(EQ, XJMPEQ, GP)
    END; XJMPEQ: IF GX = XFNJMP THEN BEGIN JP := GP; X2(XJMPTO, 0);
    X2A(EQ, XJMPEQ, GP); NEXT; EXPR; X2A(JP, XJMPTO, GP)
END ELSE X2A(EQ, XJMPEQ, GP) END END END;

PROCEDURE INCL; FORWARD;

PROCEDURE BODY;
VAR ISAD1, ISNEW, ISVAR: BOOL; IP: PINTEGER; N, LN: INTEGER; LS: TSYM;
BEGIN WHILE NOT(GX IN [XABORT, XPULLA]) AND (GE < 1) DO CASE GX OF
  XAPAI1: 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(GP) THEN GP := GP + 1;
    ISAD1 := ISX(XAPAD1); IF ISAD1 THEN BEGIN ISNEW := FALSE;
      ADD(IP); IP^ := GP END ELSE ISNEW := NOT LOC(IP);
    ISVAR := GA[1] <> '.'; WRITE(CHAR(13), GP: 5, ': ', GA); CLREOL;
    IF ISNEW THEN BEGIN ADD(IP); IP^ := GP; NEXT END ELSE BEGIN NEXT;
      IF ISVAR THEN IF ISX(XLEAD1) THEN BEGIN
        IF GV.I[IP^ SHR 1] = 0 THEN GV.I[IP^ SHR 1] := GP ELSE ERR(EDUP)
      END ELSE IF NOT ISAD1 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 GP := GP + NUM
            ELSE IF ISX(XLDINT) THEN GP := GP + NUM * 2
            ELSE I2(NUM) UNTIL NOT ISX(XFNJMP) END;
      XFNBEG: BEGIN IF (ISNEW OR ISAD1) AND ISVAR THEN I2(GP + 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 IF ISVAR THEN I2(0) END END END END;

FUNCTION OPEN(VAR F: TEXT): BOOL; VAR S: STR127; BEGIN OPEN := TRUE;
  S := MPLPATH + GA + MPLFEXT; IF FOLD(F, S) <> 0 THEN BEGIN
    S := GA + MPLFEXT; OPEN := FOLD(F, S) = 0
  END
END;

PROCEDURE INCL; VAR F: TEXT; LF: PTEXT; LC: CHAR; IP: PINTEGER;
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 OF TBLK; I: INTEGER; BEGIN
  ARGV(GA, 1); GA := GA + MPXFEXT; ASSIGN(F, GA); REWRITE(F);
  IF IORESULT = 0 THEN BEGIN
    FOR I := 0 TO (GV.I[0] + SIZEOF(TBLK) - 1) DIV SIZEOF(TBLK) DO WRITE(F, GV.B[I]);
    CLOSE(F)
END END;

PROCEDURE MAIN; VAR IP: PINTEGER; BEGIN
  IF ARGC < 1 THEN WRITELN('USAGE: MPL <FILE>')
  ELSE BEGIN ARGV(GA, 1);
    GS.P := PTR(ADDR(GV.I[MPLIMAX]));
    GE := 0; GN := 0; GP := MPLCODE * 2; GX := XLDNEG;
    WRITELN('COMPILING'); WRITELN;
    INCL; IF GE = 0 THEN BEGIN GA := '.'; GX := XLDNEG;
      IF LOC(IP) THEN BEGIN
        GV.I[MPLBOOT] := GP;
        LDI(IP^); X0(XPUSHA); LDI(1); X0(XFNJMP); X0(XABORT);
        GV.I[MPLSIZE] := GP
      END ELSE ERR(ENOT)
    END;
    WRITELN; WRITELN;
    IF GE <> 0 THEN BEGIN
      WRITELN('FAILED'); WRITELN; WRITELN(GE: 5, ' ERRORS')
    END ELSE BEGIN WRITELN('COMPLETE'); WRITELN;
      WRITELN(GN: 5, ' SYMBOLS'); WRITELN(GP: 5, ' BYTES');
      SAVE;
    END; WRITELN
END END;

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