MPL Bytecode Compiler Code

(* MPL - MICRO PROGRAMMING LANGUAGE / COPYRIGHT (C) 2017-2018 DEREK JOHN EVANS *)
(* NOTE: CP/M END ADDRESS = E000 *)

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

PROGRAM MPL; {$I PASCAL.INC}

CONST TOM=12287; (* 12287=24K 16382=~32K *)

TYPE

  OPR=({$I MPLOPR.INC});
  ERR=(ESYN,EDUP,EMIS); LEV=(L0,L1,L2,L3,L4,L5,L6,L7,L8);

VAR

  GM:PACKED RECORD CASE INTEGER OF
    0:(V:PACKED ARRAY[(VNIL,VTOM,VAUX,VTMP,VPRG)] OF INTEGER);
    1:(I:PACKED ARRAY[0..TOM] OF RSHORT);
    2:(C:PACKED ARRAY[0..0] OF RCHAR);
    3:(B:PACKED ARRAY[0..0] OF RCHAR128);
  END;

  GR:REF; GI,GE,GP,GZ:INTEGER; GL:LEV; GO:OPR; GF:^TEXT;
  GC:CHAR; GS:STR127; GV:PACKED ARRAY[0..511] OF INTEGER;

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

FUNCTION OPEN:BOOLEAN; BEGIN OPEN:=TRUE; ASSIGN(GF^,{$IFDEF HPC}'M:\MPL\'+{$ENDIF}GS);
  RESET(GF^); IF IORESULT<>0 THEN BEGIN ASSIGN(GF^,GS); RESET(GF^); OPEN:=IORESULT=0 END END;
PROCEDURE SHUT; BEGIN CLOSE(GF^); IF GO<>OABRT THEN FAIL(ESYN) END;
PROCEDURE RDCH; BEGIN GC:=CHR(0); IF NOT EOF(GF^) THEN READ(GF^,GC) END;
PROCEDURE ARGV(VAR S:STR127; I:INTEGER); BEGIN S:=PARAMSTR(I);
  FOR I:=1 TO LENGTH(S) DO S[I]:=UPCASE(S[I]) END;

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 LO1(L:LEV;O:OPR); BEGIN GL:=L; GO:=O END;
PROCEDURE LO2(L:LEV;O:OPR); BEGIN GL:=L; GO:=O; RDCH END;

PROCEDURE NEXT; LABEL 0; BEGIN 0:LO1(L1,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 LO2(L1,OLIM2) END;
    '"':BEGIN GS[0]:=CHR(0); WHILE NOT(GC IN [CHR(0),'"']) DO BEGIN
          GS:=GS+META; RDCH END; IF GC='"' THEN LO2(L1,OLIM3) END;
    '/':CASE GC OF'=':LO2(L2,ODIV4);
        '*':BEGIN RDCH; REPEAT WHILE NOT(GC IN [CHR(0),'*'])DO RDCH;
        RDCH UNTIL GC IN [CHR(0),'/']; RDCH; GOTO 0 END;
        '/':BEGIN READLN(GF^,GS); RDCH; GOTO 0 END ELSE LO1(L3,ODIV2)END;
    '(':GO:=OSET1;')':GO:=OSET2;'[':GO:=OENTR;']':GO:=OLEAV;',':GO:=OIDX1;
    '%':GO:=OLD11;'!':GO:=OLD12;'@':GO:=OJUMP;'?':GO:=OTEST;';':GO:=OIDX2;
    ':':IF GC=':'THEN LO2(L1,OCALL)ELSE GO:=OJPNE;'$':LO1(L2,OLEAD);
    '*':IF GC='='THEN LO2(L2,OMUL4)ELSE LO1(L3,OMUL2);
    '=':IF GC='='THEN LO2(L6,OTEQ2)ELSE LO1(L2,OSET4);
    '\':IF GC='='THEN LO2(L2,OMOD4)ELSE LO1(L3,OMOD2);
    '#':CASE GC OF'#':LO2(L1,OLOAD);'=':LO2(L2,OEQV4)ELSE LO1(L7,OEQV2)END;
    '&':CASE GC OF'&':LO2(L8,OTAN2);'=':LO2(L2,OBAN4)ELSE LO1(L7,OBAN2)END;
    '+':CASE GC OF'+':LO2(L1,OAD2A);'=':LO2(L2,OADD4)ELSE LO1(L4,OADD2)END;
    '-':CASE GC OF'-':LO2(L1,OSU2A);'=':LO2(L2,OSUB4)ELSE LO1(L4,OSUB2)END;
    '^':CASE GC OF'^':LO2(L8,OTXO2);'=':LO2(L2,OBXO4)ELSE LO1(L7,OBXO2)END;
    '|':CASE GC OF'|':LO2(L8,OTOR2);'=':LO2(L2,OBOR4)ELSE LO1(L7,OBOR2)END;
    '>':CASE GC OF'>':BEGIN RDCH; IF GC='='THEN LO2(L2,OSHR4)ELSE LO1(L5,OSHR2)END;
        '=':LO2(L6,OTGE2) ELSE LO1(L6,OTGT2)END;
    '<':CASE GC OF'<':BEGIN RDCH; IF GC='='THEN LO2(L2,OSHL4)ELSE LO1(L5,OSHL2)END;
        '=':LO2(L6,OTLE2);'>':LO2(L6,OTNE2)ELSE LO1(L6,OTLT2)END END END END;

FUNCTION LOC(VAR PI:PINTEGER):BOOLEAN; VAR I:INTEGER; R:REF; BEGIN LOC:=FALSE;
  IF GO=OLIM1 THEN BEGIN I:=GZ; R:=GR; WHILE I>0 DO BEGIN I:=PRED(I);
    IF R.PS^=GS THEN BEGIN PI:=PTR(ADDR(GV[I])); LOC:=TRUE; EXIT END;
    R.I:=SUCC(R.I+ORD(R.PS^[0])) END END ELSE FAIL(ESYN) END;

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

PROCEDURE WS; VAR R:REF; BEGIN R.P:=ADDR(GM.C[GP]); R.PS^:=GS; GP:=SUCC(GP+ORD(GS[0])) END;
PROCEDURE WI(I:INTEGER); BEGIN MOVE(I,GM.C[GP],2); GP:=GP+2 END;
PROCEDURE WC(C:CHAR); BEGIN GM.C[GP].AT:=C; GP:=SUCC(GP) END;
PROCEDURE WO(O:OPR); BEGIN GM.C[GP].AT:=CHR(ORD(O)); GP:=SUCC(GP) END;
PROCEDURE WOB(O:OPR;B:BOOLEAN); BEGIN IF B THEN WO(PRED(O)) ELSE WO(O) END;
PROCEDURE WOC(O:OPR;C:CHAR); BEGIN WO(O); WC(C) END;
PROCEDURE WOI(O:OPR;I:INTEGER); BEGIN WO(O); WI(I) END;
PROCEDURE WOCI(O:OPR;I:INTEGER); BEGIN IF(I>=-128)AND(I<128)THEN WOC(PRED(O),CHR(I)) ELSE WOI(O,I) END;
PROCEDURE WOIP(O:OPR;I,P:INTEGER); VAR LP:INTEGER; BEGIN LP:=GP; GP:=P; WOI(O,I); GP:=LP END;
PROCEDURE WLIM(I:INTEGER); BEGIN IF(I<(ORD(OOO96)-128))OR(I>=128)THEN WOCI(OLIM2,I) ELSE WC(CHR(I+128)) END;

FUNCTION NUMB:INTEGER; VAR I:INTEGER; PI:PINTEGER; NEG:BOOLEAN; BEGIN
  I:=0; NEG:=GO=OSUB2; IF GL=L4 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:=GM.I[PI^ SHR 1].AT END END ELSE FAIL(EMIS);
  IF NEG THEN NUMB:=-I ELSE NUMB:=I END;

FUNCTION ONOT(O:OPR):BOOLEAN; BEGIN IF GO=O THEN BEGIN ONOT:=FALSE; NEXT END ELSE ONOT:=TRUE END;

PROCEDURE EXPR; FORWARD; PROCEDURE LOAD; FORWARD;

PROCEDURE ELEM(L:LEV;IS1:BOOLEAN); VAR I:INTEGER; PI:PINTEGER; O:OPR; STEP:BOOLEAN;
LABEL 0; BEGIN IF L>L2 THEN BEGIN ELEM(PRED(L),TRUE); WHILE L=GL DO BEGIN
    O:=GO; NEXT; WO(OSET1); ELEM(PRED(L),TRUE); WO(O) END END
  ELSE BEGIN CASE GO OF OTEST:BEGIN NEXT; ELEM(L0,IS1); WO(OTEST) END;
    OSET1:BEGIN NEXT; EXPR; IF GO=OSET2 THEN NEXT ELSE FAIL(EMIS) END;
    OSET4:BEGIN NEXT; EXPR; WO(OLEAV) END;
    OJUMP:BEGIN I:=GP; NEXT; EXPR; WOI(OJPNE,I) END;
    OLIM2:BEGIN WLIM(GI); NEXT END; OLIM3:BEGIN WO(OLIM3); WS; NEXT END;
    OLD11,OLD12:BEGIN IS1:=GO=OLD11; NEXT; ELEM(L0,IS1); IF(L=GL)AND(L=L2)THEN
      BEGIN IF GO=OLEAD THEN FAIL(ESYN); WO(OSET1); O:=GO; NEXT; EXPR;
        IF IS1 THEN WO(PRED(O)) ELSE WO(O) END ELSE WOB(OLD12,IS1) END
    ELSE BEGIN O:=GO; IF GL IN [L3,L4,L5,L6] THEN BEGIN
      NEXT; ELEM(L1,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 FAIL(ESYN); WLIM(PI^); NEXT END
        ELSE BEGIN IF PI^<0 THEN BEGIN WLIM(-PI^); WO(OLEAD) END ELSE WLIM(PI^);
          NEXT; IF STEP THEN WOB(O,IS1) ELSE IF(L=GL)AND(L=L2)THEN BEGIN
            IF GO=OLEAD THEN NEXT ELSE BEGIN WO(OSET1); O:=GO; NEXT; EXPR; WO(O)
          END END ELSE IF GO IN [OAD2A,OSU2A] THEN BEGIN WOB(SUCC(SUCC(GO)),IS1);
            NEXT END ELSE WO(OLOAD) END ELSE FAIL(EMIS) END END END;
  IF L>L0 THEN BEGIN 0:CASE GO OF
    OLD11,OLD12:BEGIN WO(OSET1); IS1:=GO=OLD11; NEXT; ELEM(L0,TRUE);
      IF(L=GL)AND(L=L2)THEN BEGIN WOB(OIDX2,IS1); O:=GO; NEXT; IF O=OLEAD THEN
        WO(OSET2) ELSE BEGIN EXPR; IF IS1 THEN WO(PRED(O)) ELSE WO(O) END END
      ELSE WOB(OLD22,IS1); GOTO 0 END;
    OSET1:BEGIN WO(OSET1); I:=1; NEXT; IF GO<>OSET2 THEN
      REPEAT EXPR; WO(OSET1); I:=SUCC(I) UNTIL ONOT(OIDX1);
      WLIM(I); WO(OCALL); IF GO=OSET2 THEN NEXT ELSE FAIL(EMIS); GOTO 0 END END
END END END;

PROCEDURE EXPR; VAR PEXPR,PJPEQ,PJPNE:INTEGER; BEGIN PEXPR:=GP;
  IF GO=OENTR THEN BEGIN REPEAT NEXT; EXPR UNTIL GO<>OIDX2;
    IF GO=OLEAV THEN NEXT ELSE FAIL(EMIS) END ELSE ELEM(L8,TRUE);
  CASE GO OF
    OJUMP:BEGIN NEXT; PJPEQ:=GP; WOI(OJPEQ,0); EXPR; WOI(OJUMP,PEXPR); WOIP(OJPEQ,GP,PJPEQ) END;
    OTEST:BEGIN NEXT; IF GO=OJPNE THEN BEGIN NEXT; PJPNE:=GP; WOI(OJPNE,0); EXPR; WOIP(OJPNE,GP,PJPNE)
      END ELSE BEGIN PJPEQ:=GP; WOI(OJPEQ,0); EXPR; IF GO<>OJPNE THEN WOIP(OJPEQ,GP,PJPEQ) ELSE
      BEGIN PJPNE:=GP; WOI(OJUMP,0); WOIP(OJPEQ,GP,PJPEQ); NEXT; EXPR; WOIP(OJUMP,GP,PJPNE) END END
END END END;

PROCEDURE ENTR; VAR AIMP,AVAR:BOOLEAN; PI:PINTEGER; I,LZ:INTEGER; LR:REF; BEGIN
  WHILE GE=0 DO CASE GO OF OLOAD:REPEAT NEXT; LOAD; NEXT UNTIL GO<>OIDX1;
  OABRT,OLEAV:EXIT; OENTR:BEGIN LR:=GR; LZ:=GZ; NEXT; ENTR; GR:=LR; GZ:=LZ;
    IF GO=OLEAV THEN NEXT ELSE FAIL(EMIS) END
  ELSE BEGIN IF ODD(GP) THEN WO(OADD1); AIMP:=GO=OCALL;IF AIMP THEN NEXT;
    WRITE(CHR(13),GP:5,': ',GS); CLREOL;
    IF GO<>OLIM1 THEN FAIL(ESYN) ELSE BEGIN AVAR:=GS[1]<>'.';
      IF AIMP THEN IF LOC(PI) THEN IF AVAR THEN GM.I[PI^ SHR 1].AT:=GP
        ELSE FAIL(ESYN) ELSE FAIL(EMIS) ELSE BEGIN ADD(PI); PI^:=GP END;
      IF GE=0 THEN BEGIN NEXT; CASE GO OF OJPNE: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<>OIDX1;
        OSET1:BEGIN 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<>OIDX2 THEN IF(GO<>OLIM1)OR(GS[1]='.')THEN FAIL(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 ONOT(OIDX1) UNTIL ONOT(OIDX2);
          IF GO=OSET2 THEN NEXT ELSE FAIL(EMIS); WLIM(I); WO(OENTR); EXPR; WO(OLEAV);
          GR:=LR; GZ:=LZ END ELSE IF AVAR THEN FAIL(ESYN) END END END END END END;

PROCEDURE LOAD; VAR F:TEXT; LF:^TEXT; LC:CHAR; PI:PINTEGER; BEGIN GO:=OLIM1;
  IF NOT LOC(PI) THEN BEGIN ADD(PI); LF:=GF; LC:=GC; GF:=PTR(ADDR(F)); GC:=CHR(32);
    IF OPEN THEN BEGIN NEXT; ENTR; SHUT END ELSE FAIL(EMIS); GF:=LF; GC:=LC END END;

PROCEDURE SAVE; VAR F:FILE OF RCHAR128; I:INTEGER; BEGIN
  ASSIGN(F,'@'); REWRITE(F); IF IORESULT=0 THEN BEGIN
    FOR I:=0 TO PRED(GM.V[VTOM]+SIZEOF(RCHAR128)) DIV SIZEOF(RCHAR128) DO
    BEGIN WRITE(F,GM.B[I]) END; CLOSE(F) END END;

PROCEDURE MAIN; VAR PI:PINTEGER; 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.PS:=PTR(ADDR(GM.I[TOM]));
    FOR GI:=0 TO TOM DO GM.I[GI].AT:=0; GE:=0; GZ:=0; GP:=ORD(VPRG)SHL 1;
    WRITELN; WRITELN('COMPILING'); WRITELN; LOAD;
    IF GE=0 THEN BEGIN GS:='.'; GO:=OLIM1; IF LOC(PI) THEN BEGIN
        GM.V[VAUX]:=GP; WLIM(PI^); WO(OSET1); WLIM(1); WO(OCALL); WO(OABRT);
        GM.V[VNIL]:=1234; GM.V[VTOM]:=GP END
      ELSE FAIL(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.