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,48,48,16}{$F+}{$S-}{$ENDIF}
{$IFNDEF HPC}{$A-}{$ENDIF}
{$D-}{$I-}{$R-}{$V-}

PROGRAM MPL;

{$I MPL.INC}

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

TYPE

  TERR = (ESYN, EDUP, ENOT);
  TTYP = (ISNO, IS2P, ISDM, ISID, ISSH, ISCP, ISEQ, ISBT, ISLG, ISFN);

  TGLO = PACKED RECORD
    M: TPRG; E: INTEGER;
    A: PACKED RECORD S: STR127; O: TOPR; T: TTYP; I: INTEGER END;
    S: PACKED RECORD S: TSYM; N: INTEGER; T: PACKED ARRAY[BYTE] OF VINTEGER END
  END;

VAR G: ^TGLO; GF: ^TEXT; GC: CHAR;

PROCEDURE ERR(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 LOC(VAR I: INTEGER): BOOLEAN; VAR S: TSYM; BEGIN
  I := 0; LOC := FALSE;
  IF G^.A.O <> XLDNEG THEN ERR(ESYN)
  ELSE BEGIN I := G^.S.N; S := G^.S.S;
    WHILE LENGTH(S.P^) <> 0 DO BEGIN
      IF S.P^ = G^.A.S THEN BEGIN LOC := TRUE; EXIT END;
      I := I - 1; S.I := S.I + LENGTH(S.P^) + 1
    END
  END
END;

FUNCTION REG: INTEGER; VAR I: INTEGER; BEGIN
  IF LOC(I) THEN REG := I
  ELSE 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; REG := G^.S.N
  END
END;

PROCEDURE GEN1(I: INTEGER);
BEGIN G^.M.B[G^.M.N].V := I; G^.M.N := G^.M.N + 1 END;

PROCEDURE GEN2(I: INTEGER);
BEGIN MOVE(I, G^.M.B[G^.M.N], 2); G^.M.N := G^.M.N + 2 END;

PROCEDURE OPR(O: TOPR);
BEGIN G^.M.B[G^.M.N].V := ORD(O); G^.M.N := G^.M.N + 1 END;

PROCEDURE OP1(O: TOPR; I: INTEGER); BEGIN OPR(O); GEN1(I) END;
PROCEDURE OP2(O: TOPR; I: INTEGER); BEGIN OPR(O); GEN2(I) END;

PROCEDURE O12(O1, O2: TOPR; I: INTEGER);
BEGIN IF I = SEX(I) THEN OP1(O1, I) ELSE OP2(O2, I) END;

PROCEDURE O2A(O: TOPR; I, A: INTEGER); VAR N: INTEGER;
BEGIN N := G^.M.N; G^.M.N := A; OP2(O, I); G^.M.N := N END;

PROCEDURE LIM(I: INTEGER); VAR J: INTEGER; BEGIN J := I + 128;
  IF (J >= ORD(XZZZ)) AND (J <= 255) THEN GEN1(J)
  ELSE O12(XIMCHR, XIMINT, I)
END;

PROCEDURE LEA(PC: INTEGER);
BEGIN IF PC >= 0 THEN LIM(PC) ELSE O12(XLEAD1, XLEAD2, -PC) END;

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

PROCEDURE CON(S: STR127; I: INTEGER); BEGIN
  G^.A.S := '.' + S; G^.A.O := XLDNEG; G^.S.T[REG].V := I
END;

PROCEDURE CMD(S: STR127; C: TCMD); BEGIN CON(S, -ORD(C)) END;

PROCEDURE LIB; BEGIN
  IF G^.S.N < 5 THEN BEGIN
    CMD('ABS', CIABS);        CMD('MIN', CIMIN);
    CMD('MAX', CIMAX);        CMD('SQR', CISQR);
    CMD('ARGC', CARGC);       CMD('ARGV', CARGV);
    CMD('FCLOSE', CFCLOSE);   CMD('READC', CREADC);
    CMD('FOPEN', CFOPEN);     CMD('FCREATE', CFCREATE);
    CMD('CLRSCR', CCLRSCR);   CMD('CLREOL', CCLREOL);
    CMD('WRITEC', CWRITEC);   CMD('DELETE', CDELETE);
    CMD('FREADC', CFREADC);   CMD('FWRITEC', CFWRITEC);
    CMD('MEMSET', CMEMSET);   CMD('KEYPRESSED', CKEYPRESSED);
    CMD('MEMMOV', CMEMMOV);   CMD('READKEY', CREADKEY);
    CMD('GOTOXY', CGOTOXY);   CMD('INSERT', CINSERT);
    CMD('INSLINE', CINSLINE); CMD('COPY', CCOPY);
    CMD('DELLINE', CDELLINE); CMD('POS', CPOS);
    CON('FALSE', 0);          CON('TRUE', 1);
    CON('INT', 2);            CON('REAL', 6);
    CON('LONG', 4);           CON('NULL', 0);
    CON('NEXT', 0);           CON('PREV', 1);
    CON('FINP', ORD(FINP));   CON('FOUT', ORD(FOUT));
    CON('FMIN', ORD(FMIN));   CON('FMAX', ORD(FMAX));
    CON('STRING', 128)
  END
END;

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

FUNCTION RMC: 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; RMC := GC
END;

PROCEDURE G1(T: TTYP; O: TOPR); BEGIN G^.A.T := T; G^.A.O := O END;
PROCEDURE G2(T: TTYP; O: TOPR); BEGIN G^.A.T := T; G^.A.O := O; RCH END;

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

FUNCTION ISOPR(O: TOPR): BOOLEAN; BEGIN
  IF G^.A.O = O THEN BEGIN TOK; ISOPR := TRUE END ELSE ISOPR := FALSE
END;

FUNCTION ISTYP(T: TTYP; VAR O: TOPR): BOOLEAN; BEGIN O := G^.A.O;
  IF G^.A.T = T THEN BEGIN TOK; ISTYP := TRUE END ELSE ISTYP := FALSE
END;

FUNCTION SGN: INTEGER; VAR I: INTEGER; O: TOPR; BEGIN I := 1;
  WHILE ISTYP(ISID, O) DO IF O = XIDSUB THEN I := -I; SGN := I
END;

FUNCTION NUM: INTEGER; VAR I, J: INTEGER; BEGIN J := SGN;
  IF G^.A.O = XIMINT THEN BEGIN I := G^.A.I; TOK END
  ELSE BEGIN IF NOT LOC(I) THEN ERR(ENOT);
    WITH G^.S.T[I] DO BEGIN
      IF G^.A.S[1] = '.' THEN BEGIN TOK; I := V END
      ELSE BEGIN TOK;
        IF ISOPR(XLEAD2) THEN I := V ELSE I := G^.M.I[V SHR 1].V
      END
    END
  END; NUM := I * J
END;

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

PROCEDURE EXP; FORWARD;

PROCEDURE ASN(OK: BOOLEAN);
VAR I, J: INTEGER; O: TOPR; ISINT, ID: BOOLEAN; LABEL LOOP;
BEGIN J := SGN;
  CASE G^.A.O OF
    X2PSET: BEGIN TOK; EXP; OPR(XFNEND) END;
    XFNBEG: BEGIN TOK; EXP; IF NOT ISOPR(XFNEND) THEN ERR(ESYN) END;
    XIFNEQ: BEGIN TOK; I := G^.M.N; EXP; OP2(XIFNEQ, I) END;
    XIMINT: BEGIN LIM(G^.A.I * J); J := 1; TOK END;
    XIMSTR: BEGIN OPR(XIMSTR); ARG; TOK END;
    XLDBYT, XLDINT: BEGIN ISINT := G^.A.O = XLDINT; TOK; ASN(FALSE);
      IF OK AND (G^.A.T = IS2P) THEN BEGIN
        IF ISINT THEN O := G^.A.O ELSE O := X2X1(G^.A.O);
        OPR(XPUSHA); TOK; EXP; OPR(O)
      END ELSE IF ISINT THEN OPR(XLDINT) ELSE OPR(XLDBYT)
    END ELSE BEGIN O := G^.A.O; ID := O IN [XAPINC, XAPDEC]; IF ID THEN TOK;
      IF NOT LOC(I) THEN ERR(ENOT);
      WITH G^.S.T[I] DO BEGIN
        IF G^.A.S[1] = '.' THEN BEGIN IF ID THEN ERR(ESYN); LIM(V); TOK; END
        ELSE BEGIN LEA(V); TOK;
          IF ID THEN OPR(O) ELSE IF OK AND (G^.A.T = IS2P) THEN BEGIN
            O := G^.A.O; OPR(XPUSHA); TOK; EXP; OPR(O)
          END ELSE CASE G^.A.O OF
            XAPINC: BEGIN OPR(XAPINP); TOK END;
            XAPDEC: BEGIN OPR(XAPDEP); TOK END;
            XLEAD2: BEGIN TOK END ELSE OPR(XAPGET)
          END
        END
      END
    END
  END;
LOOP: CASE G^.A.O OF
    XLDBYT, XLDINT: BEGIN
      ISINT := G^.A.O = XLDINT; TOK; OPR(XPUSHA); ASN(FALSE);
      IF OK AND (G^.A.T = IS2P) THEN BEGIN
        IF ISINT THEN BEGIN O := G^.A.O; TOK; OPR(XINCA2) END
        ELSE BEGIN O := X2X1(G^.A.O); TOK; OPR(XINCA1) END; EXP; OPR(O)
      END ELSE IF ISINT THEN OPR(XPEINT) ELSE OPR(XPEBYT);
      GOTO LOOP
    END;
    XFNBEG: BEGIN TOK; OPR(XPUSHA); I := 1;
      IF G^.A.O <> XFNEND THEN REPEAT EXP; OPR(XPUSHA); I := I + 1
      UNTIL NOT ISOPR(XFNJMP); LIM(I); OPR(XFNJMP);
      IF NOT ISOPR(XFNEND) THEN ERR(ESYN); GOTO LOOP
    END
  END; IF J < 0 THEN OPR(XLDNEG)
END;

PROCEDURE TYP(T: TTYP); VAR O: TOPR; BEGIN
  IF T = IS2P THEN ASN(TRUE) ELSE BEGIN TYP(PRED(T));
    WHILE ISTYP(T, O) DO BEGIN OPR(XPUSHA); TYP(PRED(T)); OPR(O) END;
  END
END;

PROCEDURE EXP; VAR PEXP, PNOW, PEQU: INTEGER; BEGIN
  PEXP := G^.M.N;
  IF G^.A.O = XPUSHA THEN BEGIN
    TOK; REPEAT EXP UNTIL NOT ISOPR(XIFNOW);
    IF NOT ISOPR(XPULLA) THEN ERR(ESYN)
  END ELSE TYP(ISFN);
  CASE G^.A.O OF
    XIFNEQ: BEGIN TOK; PEQU := G^.M.N; OP2(XIFEQU, 0); EXP;
      OP2(XIFNOW, PEXP); O2A(XIFEQU, G^.M.N, PEQU)
    END;
    XIFEQU: BEGIN TOK; PEQU := G^.M.N; OP2(XIFEQU, 0); EXP;
      IF G^.A.O = XFNJMP THEN BEGIN TOK; PNOW := G^.M.N; OP2(XIFNOW, 0);
        O2A(XIFEQU, G^.M.N, PEQU); EXP; O2A(XIFNOW, G^.M.N, PNOW)
      END ELSE O2A(XIFEQU, G^.M.N, PEQU)
    END
  END
END;

PROCEDURE IMP; FORWARD;

PROCEDURE DEF; VAR I, N: INTEGER; S: TSYM; BEGIN
  WHILE (G^.A.O <> XABORT) AND (G^.E < 1) DO BEGIN
    IF G^.A.O = XIDADD THEN BEGIN TOK; IMP; TOK
    END ELSE BEGIN IF ODD(G^.M.N) THEN G^.M.N := G^.M.N + 1;
      WITH G^.S.T[REG] DO BEGIN WRITELN(G^.M.N: 5, ': ', G^.A.S);
        TOK; IF V <> 0 THEN IF ISOPR(XLEAD2) THEN
          G^.M.I[V SHR 1].V := G^.M.N ELSE ERR(EDUP);
        CASE G^.A.O OF
          XBTIOR: BEGIN TOK; V := NUM END;
          X2PSET: BEGIN TOK; IF V = 0 THEN V := G^.M.N;
            REPEAT
              IF G^.A.O = XIMSTR THEN BEGIN ARG; TOK; END
              ELSE IF ISOPR(XLDBYT) THEN G^.M.N := G^.M.N + NUM
              ELSE IF ISOPR(XLDINT) THEN G^.M.N := G^.M.N + NUM * 2
              ELSE GEN2(NUM)
            UNTIL NOT ISOPR(XFNJMP)
          END;
          XFNBEG: BEGIN
            TOK; IF V = 0 THEN BEGIN V := G^.M.N; GEN2(V + 2) END;
            S := G^.S.S; N := G^.S.N; I := 1;
            IF G^.A.O <> XFNEND THEN REPEAT
              REPEAT IF G^.A.O <> XIFNOW THEN WITH G^.S.T[REG] DO BEGIN
                  IF V <> 0 THEN ERR(EDUP);
                  IF G^.A.S[1] = '.' THEN ERR(ESYN);
                  TOK; V := -I;
                  IF ISOPR(XLDINT) THEN I := I + NUM
                  ELSE IF ISOPR(XLDBYT) THEN I := I + (NUM + 1) DIV 2
                  ELSE I := I + 1
                END
              UNTIL NOT ISOPR(XFNJMP)
            UNTIL NOT ISOPR(XIFNOW);
            IF NOT ISOPR(XFNEND) THEN ERR(ESYN);
            OP1(XFNBEG, I); EXP; OPR(XFNEND);
            FOR I := N + 1 TO G^.S.N DO G^.S.T[I].V := 0;
            G^.S.S := S; G^.S.N := N
          END
        END
      END
    END
  END
END;

PROCEDURE IMP; VAR F: TEXT; TF: ^TEXT; TC: CHAR; BEGIN G^.A.O := XLDNEG;
  WITH G^.S.T[REG] DO IF V = 0 THEN BEGIN
    WRITELN('+FILE: ', G^.A.S); V := 1; G^.A.S := INCDIR + G^.A.S + '.MPL';
    IF FOPEN(F, G^.A.S) <> 0 THEN BEGIN DELETE(G^.A.S, 1, LENGTH(INCDIR));
      IF FOPEN(F, G^.A.S) <> 0 THEN BEGIN ERR(ENOT); EXIT END
    END;
    TF := GF; TC := GC; GF := ADDR(F); GC := CHR(32); LIB; TOK; DEF;
    GF := TF; GC := TC; CLOSE(F) (* BUG: MUST REMOVE CLOSE() FOR AMIGA HSPASCAL (?) *)
  END
END;

PROCEDURE MAIN; VAR F: FILE; I: INTEGER; BEGIN
  IF ARGC < 1 THEN WRITELN('USAGE: MPL <FILE>')
  ELSE BEGIN
    NEW(G); FILLCHAR(G^, SIZEOF(G^), 0); ARGV(G^.A.S, 1);
    G^.S.S.A := ADDR(G^.M.B[MPLMAX]); G^.M.N := 4; G^.A.O := XLDNEG;
    WRITELN; WRITELN('COMPILING'); WRITELN;
    IMP; IF G^.E = 0 THEN BEGIN G^.A.S := 'MAIN'; G^.A.O := XLDNEG;
      IF NOT LOC(I) THEN ERR(ENOT) ELSE WITH G^.S.T[I] DO BEGIN G^.M.P := G^.M.N;
        LEA(V); OPR(XAPGET); OPR(XPUSHA); LIM(1); OPR(XFNJMP); OPR(XABORT)
      END
    END;
    WRITELN; WRITELN(G^.E  : 5, ' ERRORS'); WRITELN(G^.S.N: 5, ' SYMBOLS');
    WRITELN(G^.M.N: 5, ' BYTES'); WRITELN;
    IF G^.E = 0 THEN BEGIN
      ARGV(G^.A.S, 1); ASSIGN(F, G^.A.S + '.MPX'); REWRITE(F);
      IF IORESULT = 0 THEN BEGIN
        BLOCKWRITE(F, G^.M.B, {$IFDEF HPC}G^.M.N{$ELSE}
          (G^.M.N + 127) DIV 128{$ENDIF});
        CLOSE(F); WRITELN('COMPLETE')
      END
    END
  END
END;

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