MPL Bytecode Compiler Code

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

{$I PASCAL.INC}
{$I MPLTYPE.PAS}

TYPE FAIL=(ESYN,EDUP,EMIS); KIND=(K0,K1,K2,K3,K4,K5,K6,K7,K8);
VAR  GX:CODE; GR:REF; GZ,GI,GE,GP:SHORT; GK:KIND; GO:OPER; GT:PTEXT;
     GC:CHAR; GS:STR127; GV:PACKED ARRAY[0..511] OF SHORT;

PROCEDURE ARGV(VAR S:STR127; I:SHORT); BEGIN
  S:=PARAMSTR(I); FOR I:=1 TO LENGTH(S) DO S[I]:=UPCASE(S[I])
END;

FUNCTION ENTER:BOOL; BEGIN ENTER:=TRUE;
  ASSIGN(GT^,MPLPATH+GS+MPLFEXT); RESET(GT^); IF IORESULT<>0 THEN
  BEGIN ASSIGN(GT^,GS+MPLFEXT); RESET(GT^); ENTER:=IORESULT=0 END END;

PROCEDURE LEAVE; BEGIN
  CLOSE(GT^) (* BUG: MUST REMOVE CLOSE() FOR AMIGA HSPASCAL (?) *)
END;

PROCEDURE RDCH; BEGIN GC:=CHR(0); IF NOT EOF(GT^) THEN READ(GT^,GC) END;

(* TOKEN SCANNER/PARSER *)

FUNCTION META:CHAR; BEGIN IF GC='*' THEN BEGIN RDCH; CASE UPCASE(GC) OF
  '0':GC:=CHR(00);'A':GC:=CHR(07);'B':GC:=CHR(08);'T':GC:=CHR(09);
  'N':GC:=CHR(10);'V':GC:=CHR(11);'P':GC:=CHR(12);'F':GC:=CHR(12);
  'R':GC:=CHR(13);'C':GC:=CHR(13);'E':GC:=CHR(27);'S':GC:=CHR(32)
END END; META:=GC END;

PROCEDURE KO1(K:KIND; O:OPER); BEGIN GK:=K; GO:=O END;
PROCEDURE KO2(K:KIND; O:OPER); BEGIN GK:=K; GO:=O; RDCH END;

PROCEDURE NEXT; LABEL 0; BEGIN 0:KO1(K1,OABRT);
  WHILE GC IN [CHR(1)..CHR(32)] DO RDCH; GC:=UPCASE(GC); GS:=GC;
  IF GC IN ['.','A'..'Z'] THEN BEGIN
    RDCH; GC:=UPCASE(GC); WHILE GC IN ['.','A'..'Z','0'..'9'] DO
    BEGIN GS:=GS+GC; RDCH; GC:=UPCASE(GC) END; GO:=OLIM1 END
  ELSE IF GC IN ['0'..'9'] THEN BEGIN GI:=ORD(GC)-ORD('0'); RDCH;
    WHILE GC IN ['0'..'9'] DO BEGIN GI:=GI*10+ORD(GC)-ORD('0');
      GS:=GS+GC; RDCH END; GO:=OLIM2 END ELSE BEGIN RDCH; CASE GS[1] OF
    '''':BEGIN GI:=ORD(META); RDCH; IF GC='''' THEN KO2(K1,OLIM2) END;
    '"':BEGIN GS[0]:=CHR(0); WHILE NOT(GC IN [CHR(0),'"']) DO BEGIN
          GS:=GS+META; RDCH END; IF GC='"' THEN KO2(K1,OLIM3) END;
    '/':CASE GC OF'=':KO2(K2,ODIV4);
        '*':BEGIN RDCH; REPEAT WHILE NOT(GC IN [CHR(0),'*'])DO RDCH;
        RDCH UNTIL GC IN [CHR(0),'/']; RDCH; GOTO 0 END;
        '/':BEGIN READLN(GT^,GS); RDCH; GOTO 0 END ELSE KO1(K3,ODIV2)END;
    '(':GO:=OSET1;')':GO:=OSET2;'[':GO:=OENTR;']':GO:=OEXIT;
    ';':GO:=OABRT;',':GO:=OCALL;'%':GO:=OLD11;'!':GO:=OLD12;
    '?':GO:=OIFEQ;'@':GO:=OJUMP;
    '$':IF GC='='THEN KO2(K1,OCASE)ELSE KO1(K2,OLEAD);
    ':':IF GC=':'THEN KO2(K1,OLD22)ELSE KO1(K1,OIFNE);
    '=':IF GC='='THEN KO2(K6,OTEQ2)ELSE KO1(K2,OSET4);
    '*':IF GC='='THEN KO2(K2,OMUL4)ELSE KO1(K3,OMUL2);
    '\':IF GC='='THEN KO2(K2,OMOD4)ELSE KO1(K3,OMOD2);
    '+':CASE GC OF'+':KO2(K1,OAD2A);'=':KO2(K2,OADD4)ELSE KO1(K4,OADD2)END;
    '-':CASE GC OF'-':KO2(K1,OSU2A);'=':KO2(K2,OSUB4)ELSE KO1(K4,OSUB2)END;
    '#':CASE GC OF'#':KO2(K1,ODREF);'=':KO2(K2,OEQV4)ELSE KO1(K7,OEQV2)END;
    '&':CASE GC OF'&':KO2(K8,OTAN2);'=':KO2(K2,OBAN4)ELSE KO1(K7,OBAN2)END;
    '|':CASE GC OF'|':KO2(K8,OTOR2);'=':KO2(K2,OBOR4)ELSE KO1(K7,OBOR2)END;
    '^':CASE GC OF'^':KO2(K8,OTXO2);'=':KO2(K2,OBXO4)ELSE KO1(K7,OBXO2)END;
    '>':CASE GC OF'>':BEGIN RDCH; IF GC='='THEN KO2(K2,OSHR4)ELSE KO1(K5,OSHR2)END;
        '=':KO2(K6,OTGE2) ELSE KO1(K6,OTGT2)END;
    '<':CASE GC OF'<':BEGIN RDCH; IF GC='='THEN KO2(K2,OSHL4)ELSE KO1(K5,OSHL2)END;
        '=':KO2(K6,OTLE2);'>':KO2(K6,OTNE2)ELSE KO1(K6,OTLT2)END
END END END;

(* SYMBOL TABLE & ERROR LOG *)

PROCEDURE ERR(E:FAIL); BEGIN GE:=SUCC(GE); WRITELN; WRITE(' --> '); CASE E OF
  ESYN:WRITE('SYNTAX'); EDUP:WRITE('DUPLICATE'); EMIS:WRITE('MISSING') END;
  WRITE('? @ "',GS,'"') END;

FUNCTION LOC(VAR PI:PSHORT):BOOL; VAR I:SHORT; R:REF; BEGIN LOC:=FALSE;
  IF GO=OLIM1 THEN BEGIN I:=GZ; R:=GR; WHILE I>0 DO BEGIN I:=PRED(I);
    IF R.S^=GS THEN BEGIN PI:=PTR(ADDR(GV[I])); LOC:=TRUE; EXIT END;
    R.A:=SUCC(R.A+ORD(R.S^[0])) END END ELSE ERR(ESYN) END;

PROCEDURE ADD(VAR PI:PSHORT); BEGIN GR.A:=PRED(GR.A-ORD(GS[0]));
  GR.S^:=GS; GV[GZ]:=0; PI:=PTR(ADDR(GV[GZ])); GZ:=SUCC(GZ) END;

(* BYTECODE GENERATION *)

PROCEDURE WC(C:CHAR); BEGIN GX.C[GP].AT:=C; GP:=SUCC(GP) END;
PROCEDURE WO(O:OPER); BEGIN GX.C[GP].AT:=CHR(ORD(O)); GP:=SUCC(GP) END;
PROCEDURE WI(I:SHORT); VAR PI:PSHORT; BEGIN
  {$IFDEF HPC}MOVE(I,GX.C[GP],2);{$ELSE}PI:=PTR(ADDR(GX.C[GP])); PI^:=I;{$ENDIF}
  GP:=GP+2 END;

PROCEDURE WS; VAR R:REF; BEGIN R.S:=PTR(ADDR(GX.C[GP])); R.S^:=GS; GP:=SUCC(GP+ORD(GS[0])) END;

PROCEDURE OC(O:OPER; C:CHAR ); BEGIN WO(O); WC(C) END;
PROCEDURE OI(O:OPER; I:SHORT); BEGIN WO(O); WI(I) END;

PROCEDURE OCI(O:OPER; I:SHORT); BEGIN IF(I>=-128)AND(I<=127)THEN OC(PRED(O),CHR(I)) ELSE OI(O,I) END;
PROCEDURE OAT(P:SHORT; O:OPER; I:SHORT); VAR LP:SHORT; BEGIN LP:=GP; GP:=P; OI(O,I); GP:=LP END;
PROCEDURE ISO(T:BOOL; O:OPER); BEGIN IF T THEN WO(PRED(O)) ELSE WO(O) END;
PROCEDURE LDI(I:SHORT); BEGIN IF(I<(ORD(OOO96)-128))OR(I>=128)THEN OCI(OLIM2,I) ELSE WC(CHR(I+128)) END;

(* MPL COMPILER *)

FUNCTION NUMB:SHORT; VAR I:SHORT; PI:PSHORT; NEG:BOOL; BEGIN
  I:=0; NEG:=GO=OSUB2; IF GK=K4 THEN NEXT;
  IF GO=OLIM2 THEN BEGIN I:=GI; NEXT END
  ELSE IF LOC(PI) THEN BEGIN IF GS[1]='.' THEN BEGIN I:=PI^; NEXT END
    ELSE BEGIN NEXT; IF GO=OLEAD THEN BEGIN I:=PI^; NEXT END
      ELSE I:=GX.I[PI^ SHR 1].AT END END ELSE ERR(EMIS);
  IF NEG THEN NUMB:=-I ELSE NUMB:=I END;

PROCEDURE EXPR; FORWARD; PROCEDURE COMP; FORWARD;

FUNCTION NO(O:OPER):BOOL; BEGIN
  IF GO=O THEN BEGIN NO:=FALSE; NEXT END ELSE NO:=TRUE END;

PROCEDURE ELEM(K:KIND; IS1:BOOL); VAR I:SHORT; PI:PSHORT; O:OPER; STEP:BOOL;
LABEL 0; BEGIN
  IF K>K2 THEN BEGIN ELEM(PRED(K),TRUE);
    WHILE K=GK DO BEGIN O:=GO; NEXT; WO(OSET1); ELEM(PRED(K),TRUE); WO(O) END
  END ELSE BEGIN CASE GO OF
    OCASE:BEGIN NEXT; ELEM(K0,IS1); WO(OCASE) END;
    OSET1:BEGIN NEXT; EXPR; IF GO=OSET2 THEN NEXT ELSE ERR(EMIS) END;
    OSET4:BEGIN NEXT; EXPR; WO(OEXIT) END;
    OJUMP:BEGIN I:=GP; NEXT; EXPR; OI(OIFNE,I) END;
    OLIM2:BEGIN LDI(GI); NEXT END; OLIM3:BEGIN WO(OLIM3); WS; NEXT END;
    OLD11,OLD12:BEGIN IS1:=GO=OLD11; NEXT; ELEM(K0,IS1);
      IF(K=GK)AND(K=K2)THEN BEGIN IF GO=OLEAD THEN ERR(ESYN); WO(OSET1);
        O:=GO; NEXT; EXPR; IF IS1 THEN WO(PRED(O)) ELSE WO(O) END
      ELSE ISO(IS1,OLD12) END
    ELSE BEGIN O:=GO; IF GK IN [K3,K4,K5,K6] THEN BEGIN
      NEXT; ELEM(K1,TRUE); WO(PRED(O)) END
      ELSE BEGIN STEP:=O IN [OAD2A,OSU2A]; IF STEP THEN NEXT; IF LOC(PI) THEN
        IF GS[1]='.' THEN BEGIN IF STEP THEN ERR(ESYN); LDI(PI^); NEXT END
        ELSE BEGIN IF PI^<0 THEN BEGIN LDI(-PI^); WO(OLEAD) END ELSE LDI(PI^);
          NEXT; IF STEP THEN ISO(IS1,O) ELSE IF(K=GK)AND(K=K2)THEN BEGIN
            IF GO=OLEAD THEN NEXT ELSE BEGIN WO(OSET1); O:=GO; NEXT; EXPR; WO(O)
          END END ELSE CASE GO OF
            OAD2A:BEGIN ISO(IS1,OADA2); NEXT END;
            OSU2A:BEGIN ISO(IS1,OSUA2); NEXT END
            ELSE WO(ODREF) END END ELSE ERR(EMIS) END END END;
  IF K>K0 THEN BEGIN 0:CASE GO OF
    OLD11,OLD12:BEGIN WO(OSET1); IS1:=GO=OLD11; NEXT; ELEM(K0,TRUE);
      IF(K=GK)AND(K=K2)THEN BEGIN ISO(IS1,OIDX2); O:=GO; NEXT; IF O=OLEAD THEN
        WO(OSET2) ELSE BEGIN EXPR; IF IS1 THEN WO(PRED(O)) ELSE WO(O) END END
      ELSE ISO(IS1,OLD22); GOTO 0 END;
    OSET1:BEGIN WO(OSET1); I:=1; NEXT; IF GO<>OSET2 THEN
      REPEAT EXPR; WO(OSET1); I:=SUCC(I) UNTIL NO(OCALL);
      LDI(I); WO(OCALL); IF GO=OSET2 THEN NEXT ELSE ERR(EMIS); GOTO 0 END END
END END END;

PROCEDURE EXPR; VAR EX,JP,EQ:SHORT; O:OPER; BEGIN EX:=GP;
  IF GO=OENTR THEN BEGIN REPEAT NEXT; EXPR UNTIL GO<>OABRT;
    IF GO=OEXIT THEN NEXT ELSE ERR(EMIS) END ELSE ELEM(K8,TRUE);
  IF GO IN [OJUMP,OIFEQ] THEN BEGIN O:=GO; EQ:=GP; OI(OIFEQ,0); NEXT; EXPR;
    CASE O OF OJUMP:BEGIN OI(OJUMP,EX); OAT(EQ,OIFEQ,GP) END;
      OIFEQ:IF GO=OIFNE THEN BEGIN JP:=GP; OI(OJUMP,0); OAT(EQ,OIFEQ,GP);
        NEXT; EXPR; OAT(JP,OJUMP,GP) END ELSE OAT(EQ,OIFEQ,GP) END END END;

PROCEDURE BODY; VAR AIMP,AVAR:BOOL; PI:PSHORT; I,LZ:SHORT; LR:REF;
BEGIN WHILE NOT(GO IN [OABRT,OEXIT])AND(GE=0) DO CASE GO OF
  ODREF:REPEAT NEXT; COMP; NEXT UNTIL GO<>OCALL;
  OENTR:BEGIN LR:=GR; LZ:=GZ; NEXT; BODY; GR:=LR; GZ:=LZ;
    IF GO=OEXIT THEN NEXT ELSE ERR(EMIS) END
  ELSE BEGIN IF ODD(GP) THEN WO(OADD1); AIMP:=GO=OLD22;IF AIMP THEN NEXT;
    WRITE(CHR(13),GP:5,': ',GS); CLREOL;
    IF GO<>OLIM1 THEN ERR(ESYN) ELSE BEGIN AVAR:=GS[1]<>'.';
      IF AIMP THEN IF LOC(PI) THEN IF AVAR THEN GX.I[PI^ SHR 1].AT:=GP
        ELSE ERR(ESYN) ELSE ERR(EMIS) ELSE BEGIN ADD(PI); PI^:=GP END;
      IF GE=0 THEN BEGIN NEXT; CASE GO OF
        OIFNE:BEGIN NEXT; PI^:=NUMB END;
        OSET4:REPEAT NEXT; CASE GO OF
            OLD11:BEGIN NEXT; GP:=GP+NUMB END;
            OLD12:BEGIN NEXT; GP:=GP+NUMB SHL 1 END;
            OLIM3:BEGIN WS; NEXT END ELSE WI(NUMB) END UNTIL GO<>OCALL;
        OSET1:BEGIN (*WRITELN;*) IF AVAR THEN IF NOT AIMP THEN WI(GP+2); NEXT;
          LR:=GR; LZ:=GZ; I:=1; IF GO<>OSET2 THEN
          REPEAT REPEAT IF GO<>OABRT THEN IF(GO<>OLIM1)OR(GS[1]='.')THEN ERR(ESYN)
            ELSE BEGIN ADD(PI); PI^:=-I; NEXT; CASE GO OF
              OLD11:BEGIN NEXT; I:=I+SUCC(NUMB) SHR 1 END;
              OLD12:BEGIN NEXT; I:=I+NUMB END ELSE I:=SUCC(I) END;
            END UNTIL NO(OCALL) UNTIL NO(OABRT);
          IF GO=OSET2 THEN NEXT ELSE ERR(EMIS); LDI(I); WO(OENTR); EXPR; WO(OEXIT);
          GR:=LR; GZ:=LZ END ELSE IF AVAR THEN ERR(ESYN) END END END END END END;

PROCEDURE COMP; VAR T:TEXT; LT:PTEXT; LC:CHAR; PI:PSHORT; BEGIN
  LT:=GT; LC:=GC; GT:=PTR(ADDR(T)); GC:=CHR(32); GO:=OLIM1;
  IF NOT LOC(PI) THEN BEGIN ADD(PI); IF ENTER THEN BEGIN
    NEXT; BODY; LEAVE END ELSE ERR(EMIS) END; GT:=LT; GC:=LC; END;

(* FRONT END *)

PROCEDURE SAVE; VAR F:FILE OF RCHAR128; I:SHORT; BEGIN ARGV(GS,1);
  GS:=GS+MPXFEXT; ASSIGN(F,GS); REWRITE(F); IF IORESULT=0 THEN BEGIN
    FOR I:=0 TO PRED(GX.I[MPLHEAP].AT+SIZEOF(RCHAR128)) DIV SIZEOF(RCHAR128) DO
    BEGIN WRITE(F,GX.B[I]) END; CLOSE(F) END END;

PROCEDURE MAIN; VAR PI:PSHORT; BEGIN WRITELN;
  WRITELN('MPL COMPILER / COPYRIGHT (C) 2017-2018 DEREK JOHN EVANS');
  IF PARAMCOUNT<1 THEN WRITELN('USAGE: MPL <FILE>')
  ELSE BEGIN ARGV(GS,1); GR.S:=PTR(ADDR(GX.I[MPLMAXI]));
    FOR GI:=0 TO MPLMAXI DO GX.I[GI].AT:=0;
    GE:=0; GZ:=0; GP:=MPLPROG SHL 1;
    WRITELN; WRITELN('COMPILING'); WRITELN; COMP;
    IF GE=0 THEN BEGIN GS:='.'; GO:=OLIM1; IF LOC(PI) THEN BEGIN
        GX.I[MPLCASE].AT:=GP; LDI(PI^); WO(OSET1); LDI(1); WO(OCALL); WO(OABRT);
        GX.I[MPLNULL].AT:=1234; GX.I[MPLHEAP].AT:=GP END
      ELSE ERR(EMIS) END; WRITELN; WRITELN; IF GE<>0 THEN BEGIN
      WRITELN('FAILED'); WRITELN; WRITELN(GE:5,' ERRORS') END
    ELSE BEGIN WRITELN(GZ:5,' SYMBOLS'); WRITELN(GP:5,' BYTES');
      SAVE; WRITELN; WRITELN('COMPLETED') END END; WRITELN END;

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