MPL Bytecode Compiler Code

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

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

TYPE

  FIDS=(FNIL,FMIN,F002,F003,FMAX,FINP,FOUT);
  REGS=PACKED RECORD PC,BP,LP,SP:SHORT END;

VAR

  GX:CODE; GO:OPER; GA:SHORT; GR:REGS; GPA:PSHORT16;
  GF:PACKED ARRAY[FMIN..FMAX]OF TEXT;
  GK:PACKED ARRAY[OPER]OF (K00,KX2,KX3,KX4,KDI);
  GREF1,GREF2:REF;

{$IFNDEF HASLOWERCASE}
FUNCTION LOWERCASE(A: CHAR): CHAR; BEGIN
  IF A IN [CHR(65)..CHR(90)] THEN LOWERCASE:=CHR(ORD(A)+32) ELSE LOWERCASE:=A;
END;
{$ENDIF}

{$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}

{$IFNDEF HASREADKEY}
FUNCTION READKEY: CHAR; VAR C: CHAR; BEGIN
  READ(KBD,C); READKEY:=C;
END;
{$ENDIF}

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

PROCEDURE MREV(A:POINTER; L:SHORT); VAR T:RCHAR;
BEGIN GREF1.P:=A; GREF2.P:=A; GREF2.A:=PRED(GREF2.A+L);
  WHILE (GREF1.A-GREF2.A)<0 DO BEGIN
    T:=GREF1.B^; GREF1.B^:=GREF2.B^; GREF2.B^:=T;
    GREF1.A:=SUCC(GREF1.A); GREF2.A:=PRED(GREF2.A);
  END;
END;

{$IFDEF HASSHORTINT}
TYPE IEXT = SHORTINT;
{$ELSE}
FUNCTION IEXT(A:SHORT):SHORT; BEGIN
  IF (A AND $80)=0 THEN IEXT:=A AND $00FF ELSE IEXT:=A OR $FF00
END;
{$ENDIF}

FUNCTION ISQRT(A:SHORT):SHORT; VAR N0,N1:SHORT;
BEGIN IF A>0 THEN BEGIN N0:=SUCC(A DIV 2); N1:=(N0+(A DIV N0)) DIV 2;
  WHILE N1<N0 DO BEGIN N0:=N1; N1:=(N0+(A DIV N0)) DIV 2
  END; ISQRT:=N0 END ELSE ISQRT:=0 END;

FUNCTION IPOW(A,B:SHORT):SHORT; VAR OUT:SHORT;
BEGIN OUT:=1; WHILE B>0 DO BEGIN
    IF (B AND 1)<>0 THEN BEGIN OUT:=OUT*A END;
    B:=B SHR 1; A:=A*A END; IPOW:=OUT END;

PROCEDURE SFIX(VAR A:STR127; L:SHORT);
BEGIN IF L<0 THEN L:=0 ELSE IF L>127 THEN L:=127; A[0]:=CHR(L) END;

FUNCTION FRES(VAR A:TEXT):BOOL; BEGIN FRES:=IORESULT=0 END;

FUNCTION FOLD(VAR F:TEXT; VAR FN:STR127):BOOL;
BEGIN ASSIGN(F,FN); RESET(F); FOLD:=FRES(F) END;

FUNCTION FNEW(VAR F:TEXT; VAR FN:STR127):BOOL; BEGIN
  {$IFDEF HPC}ERASE(FN);{$ENDIF}
  ASSIGN(F,FN); REWRITE(F); FNEW:=FRES(F) END;

FUNCTION FEND(VAR F:TEXT):BOOL; BEGIN CLOSE(F); FEND:=FRES(F) END;

FUNCTION FRDC(VAR F:TEXT; VAR C:CHAR):BOOL; BEGIN
  IF EOF(F) THEN FRDC:=FALSE ELSE BEGIN
    IF EOLN(F) THEN BEGIN READLN(F); C:=CHR(10) END ELSE READ(F,C);
    FRDC:=FRES(F)
  END
END;

FUNCTION FWRC(VAR F:TEXT; C:CHAR):BOOL;
BEGIN IF C=CHR(10) THEN WRITELN(F) ELSE WRITE(F,C); FWRC:=FRES(F) END;

FUNCTION FRDS(VAR F:TEXT; VAR S:STR127):BOOL;
BEGIN READLN(F,S); FRDS:=FRES(F) END;

FUNCTION FWRS(VAR F:TEXT; VAR S:STR127):BOOL; VAR I:SHORT;
BEGIN FWRS:=FALSE;
  FOR I:=1 TO LENGTH(S) DO IF NOT FWRC(F,S[I]) THEN EXIT;
  FWRS:=TRUE END;

PROCEDURE CALL(P:PROC); VAR
  C:CHAR; T:PTEXT; R:PACKED ARRAY[0..4]OF PREAL; S:PACKED ARRAY[0..4]OF PSTR127;

  PROCEDURE UR(I:SHORT); BEGIN GA:=GPA^[I]; R[I]:=PTR(ADDR(GX.I[GA SHR 1])) END;
  PROCEDURE UR2; BEGIN UR(1); UR(0) END;
  PROCEDURE UR3; BEGIN UR(2); UR(1); UR(0) END;
  PROCEDURE US(I:SHORT); BEGIN GA:=GPA^[I]; S[I]:=PTR(ADDR(GX.C[GA])) END;

  FUNCTION UF(I:FIDS):BOOL; BEGIN GA:=-1; T:=NIL;
    IF I IN [FMIN..FMAX] THEN T:=PTR(ADDR(GF[I]))
    ELSE CASE I OF FINP:T:=PTR(ADDR(INPUT)); FOUT:T:=PTR(ADDR(OUTPUT)) END;
    UF:=T<>NIL END;

BEGIN
  GA:=0; GPA:=PTR(ADDR(GX.I[SUCC(GR.SP)]));
  CASE P OF
    PABRT:WRITELN('!!! ABORT !!!');
    PARGC:GA:=PARAMCOUNT;
    PARGV:BEGIN US(0); ARGV(S[0]^,GPA^[1]) END;
    PCTOL:GA:=ORD(LOWERCASE(CHR(GPA^[0])));
    PCTOU:GA:=ORD(UPCASE(CHR(GPA^[0])));
    PFEND:IF UF(FIDS(GPA^[0]))THEN BEGIN GA:=ORD(FEND(T^)) END;
    PFEOF:IF UF(FIDS(GPA^[0]))THEN BEGIN GA:=ORD(EOF(T^))  END;
    PFNEW:IF UF(FIDS(GPA^[0]))THEN BEGIN US(1); GA:=ORD(FNEW(T^,S[1]^)) END;
    PFOLD:IF UF(FIDS(GPA^[0]))THEN BEGIN US(1); GA:=ORD(FOLD(T^,S[1]^)) END;
    PFRDC:IF UF(FIDS(GPA^[0]))THEN BEGIN GA:=ORD(FRDC(T^,C)); GX.C[GPA^[1]].AT:=C END;
    PFRDS:IF UF(FIDS(GPA^[0]))THEN BEGIN US(1); GA:=ORD(FRDS(T^,S[1]^)) END;
    PFWRC:IF UF(FIDS(GPA^[0]))THEN BEGIN GA:=ORD(FWRC(T^,CHR(GPA^[1])))  END;
    PFWRS:IF UF(FIDS(GPA^[0]))THEN BEGIN US(1); GA:=ORD(FWRS(T^,S[1]^)) END;
    PIABS:GA:=ABS(GPA^[0]);
    PIMAX:IF GPA^[0]>GPA^[1] THEN GA:=GPA^[0] ELSE GA:=GPA^[1];
    PIMIN:IF GPA^[0]<GPA^[1] THEN GA:=GPA^[0] ELSE GA:=GPA^[1];
    PIOFR:BEGIN UR(0); GA:=TRUNC(R[0]^) END;
    PIOFS:BEGIN US(0); VAL(S[0]^,GA,GX.I[MPLCASE].AT) END;
    PISQR:GA:=GPA^[0]*GPA^[0];
    PMCPY:BEGIN GA:=GPA^[0]; MOVE(GX.C[GPA^[1]],GX.C[GA],GPA^[2]) END;
    PMREV:BEGIN GA:=GPA^[0]; MREV(ADDR(GX.C[GA]),GPA^[1]) END;
    PMSET:BEGIN GA:=GPA^[0]; FILLCHAR(GX.C[GA],GPA^[2],CHR(GPA^[1])) END;
    PRABS:BEGIN UR2;IF R[1]^<0 THEN R[0]^:=-R[1]^ ELSE R[0]^:=R[1]^ END;
    PRADD:BEGIN UR3;R[0]^:=R[1]^+R[2]^ END;
    PRATN:BEGIN UR2;R[0]^:=ARCTAN(R[1]^) END;
    PRCMP:BEGIN UR2;IF R[0]^<R[1]^ THEN GA:=-1 ELSE IF R[0]^>R[1]^ THEN GA:=1 ELSE GA:=0 END;
    PRCOS:BEGIN UR2;R[0]^:=COS(R[1]^) END;
    PRCPY:BEGIN UR2;R[0]^:=R[1]^ END;
    PRDIV:BEGIN UR3;R[0]^:=R[1]^/R[2]^ END;
    PREXP:BEGIN UR2;R[0]^:=EXP(R[1]^) END;
    PRFRA:BEGIN UR2;R[0]^:=R[1]^-INT(R[1]^) END;
    PRINT:BEGIN UR2;R[0]^:=INT(R[1]^) END;
    PRLOG:BEGIN UR2;R[0]^:=LN(R[1]^) END;
    PRMAX:BEGIN UR3;IF R[1]^>R[2]^ THEN R[0]^:=R[1]^ ELSE R[0]^:=R[2]^ END;
    PRMIN:BEGIN UR3;IF R[1]^<R[2]^ THEN R[0]^:=R[1]^ ELSE R[0]^:=R[2]^ END;
    PRMUL:BEGIN UR3;R[0]^:=R[1]^*R[2]^ END;
    PRNEG:BEGIN UR2;R[0]^:=-R[1]^ END;
    PROFI:BEGIN UR(0);R[0]^:=GPA^[1] END;
    PROFS:BEGIN US(1);UR(0);VAL(S[1]^,R[0]^,GX.I[MPLCASE].AT) END;
    PRROU:BEGIN UR2;R[0]^:=ROUND(R[1]^) END;
    PRSIN:BEGIN UR2;R[0]^:=SIN(R[1]^) END;
    PRSQR:BEGIN UR2;R[0]^:=SQR(R[1]^) END;
    PRSRT:BEGIN UR2;R[0]^:=SQRT(R[1]^) END;
    PRSUB:BEGIN UR3;R[0]^:=R[1]^-R[2]^ END;
    PSADD:BEGIN US(1);US(0);S[0]^:=S[0]^+S[1]^ END;
    PSCHR:BEGIN US(0);GA:=POS(CHR(GPA^[1]),S[0]^) END;
    PSCPY:BEGIN US(1);US(0);S[0]^:=S[1]^ END;
    PSDEL:BEGIN US(0);DELETE(S[0]^,GPA^[1],GPA^[2]) END;
    PSFIX:BEGIN US(0);SFIX(S[0]^,GPA^[1]) END;
    PSINS:BEGIN US(1);US(0);INSERT(S[1]^,S[0]^,GPA^[2]) END;
    PSMID:BEGIN US(1);US(0);S[0]^:=COPY(S[1]^,GPA^[2],GPA^[3]) END;
    PSOFI:BEGIN US(0);STR(GPA^[1]:GPA^[2],S[0]^) END;
    PSOFR:BEGIN UR(1);US(0);STR(R[1]^:GPA^[2]:GPA^[3],S[0]^) END;
    PSSTR:BEGIN US(1);US(0);GA:=POS(S[1]^,S[0]^) END;
    PVCEL:CLREOL;
    PVCSR:CLRSCR;
    PVDLN:DELLINE;
    PVGXY:GOTOXY(GPA^[0],GPA^[1]);
    PVILN:INSLINE;
    PVISK:GA:=ORD(KEYPRESSED);
    PVRDC:BEGIN READ(C);GA:=ORD(C) END;
    PVRDK:BEGIN GA:=ORD(READKEY); IF GA=0 THEN GA:=GA+(ORD(READKEY)SHL 8) END;
    PVRDS:BEGIN US(0);READLN(S[0]^) END;
    PVWRC:BEGIN GA:=GPA^[0]; WRITE(CHR(GA)) END;
    PVWRS:BEGIN US(0);WRITE(S[0]^) END
  END
END;

FUNCTION LPI:SHORT; VAR I:{$IFDEF HPC}SHORT{$ELSE}PSHORT{$ENDIF};
BEGIN
  {$IFDEF HPC}MOVE(GX.C[GR.PC],I,2); LPI:=I;
  {$ELSE}I:=PTR(ADDR(GX.C[GR.PC])); LPI:=I^;
  {$ENDIF}GR.PC:=GR.PC+2; END;

PROCEDURE EXEC; LABEL 0; BEGIN GA:=IORESULT;
0:GO:=OPER(GX.C[GR.PC].AT); GR.PC:=SUCC(GR.PC); IF GO<OOO96 THEN CASE GK[GO] OF
  KX2:BEGIN GR.SP:=PRED(GR.SP); WITH GX.I[GR.SP] DO BEGIN CASE GO OF
      OADD2:GA:=AT+GA      ; OSUB2:GA:=AT -   GA;
      OBAN2:GA:=AT AND GA  ; OMUL2:GA:=AT *   GA;
      ODIV2:GA:=AT DIV GA  ; OMOD2:GA:=AT MOD GA;
      OBXO2:GA:=AT XOR GA  ; OBOR2:GA:=AT OR  GA;
      OSHL2:GA:=AT SHL GA  ; OSHR2:GA:=AT SHR GA;
      OTEQ2:GA:=ORD(AT =GA); OTNE2:GA:=ORD(AT<>GA);
      OTGE2:GA:=ORD(AT>=GA); OTGT2:GA:=ORD(AT> GA);
      OTLE2:GA:=ORD(AT<=GA); OTLT2:GA:=ORD(AT< GA);
      OTAN2:GA:=ORD((AT<>0)AND(GA<>0));
      OTOR2:GA:=ORD((AT<>0)OR (GA<>0));
      OTXO2:GA:=ORD((AT<>0)XOR(GA<>0));
      OLD21:GA:=ORD(GX.C[AT+GA].AT);
      OLD22:GA:=GX.I[AT SHR 1+GA].AT;
      OSET2:GA:=AT END END; GOTO 0 END;
  KX3:BEGIN GR.SP:=PRED(GR.SP); WITH GX.C[GX.I[GR.SP].AT] DO BEGIN CASE GO OF
      OADD3:GA:=ORD(AT)+   GA; OSUB3:GA:=ORD(AT)-   GA;
      OBAN3:GA:=ORD(AT)AND GA; OMUL3:GA:=ORD(AT)*   GA;
      OSHL3:GA:=ORD(AT)SHL GA; OSHR3:GA:=ORD(AT)SHR GA;
      ODIV3:GA:=ORD(AT)DIV GA; OMOD3:GA:=ORD(AT)MOD GA;
      OBXO3:GA:=ORD(AT)XOR GA; OBOR3:GA:=ORD(AT)OR  GA END;
      GA:=GA AND $FF; AT:=CHR(GA) END; GOTO 0 END;
  KX4:BEGIN GR.SP:=PRED(GR.SP); WITH GX.I[GX.I[GR.SP].AT SHR 1] DO BEGIN CASE GO OF
      OADD4:GA:=AT +   GA; OSUB4:GA:=AT -   GA;
      OBAN4:GA:=AT AND GA; OMUL4:GA:=AT *   GA;
      ODIV4:GA:=AT DIV GA; OMOD4:GA:=AT MOD GA;
      OBXO4:GA:=AT XOR GA; OBOR4:GA:=AT OR  GA;
      OSHL4:GA:=AT SHL GA; OSHR4:GA:=AT SHR GA END;
      AT:=GA END; GOTO 0 END;
  KDI:BEGIN WITH GX.I[GA SHR 1] DO BEGIN CASE GO OF
      ODREF:GA:=AT;
      OAD1A:BEGIN AT:=SUCC(AT); GA:=AT; END; OADA1:BEGIN GA:=AT; AT:=SUCC(AT) END;
      OSU1A:BEGIN AT:=PRED(AT); GA:=AT; END; OSUA1:BEGIN GA:=AT; AT:=PRED(AT) END;
      OAD2A:BEGIN AT:=AT+2    ; GA:=AT; END; OADA2:BEGIN GA:=AT; AT:=AT+2     END;
      OSU2A:BEGIN AT:=AT-2    ; GA:=AT; END; OSUA2:BEGIN GA:=AT; AT:=AT-2     END
    END END; GOTO 0 END
  ELSE CASE GO OF
      OADD1:GA:=+GA      ; OSUB1:GA:=-GA;
      OSHL1:GA:=GA SHL 1 ; OSHR1:GA:=GA SHR 1;
      OBAN1:GA:=GA AND 1 ; OMUL1:GA:=GA*GA;
      OBXO1:GA:=GA XOR 1 ; OBOR1:GA:=GA OR 1;
      OCASE:GA:=ORD(GX.I[MPLCASE].AT=GA);
      ODIV1:GA:=ISQRT(GA); OMOD1:GA:=GA AND 1;
      OIDX1:WITH GX.I[PRED(GR.SP)] DO AT:=AT+GA;
      OIDX2:WITH GX.I[PRED(GR.SP)] DO AT:=AT+GA SHL 1;
      OIFEQ:IF GA= 0 THEN GR.PC:=LPI ELSE GR.PC:=GR.PC+2;
      OIFNE:IF GA<>0 THEN GR.PC:=LPI ELSE GR.PC:=GR.PC+2;
      OLD11:GA:=ORD(GX.C[GA].AT); OLD12:GA:=GX.I[GA SHR 1].AT;
      OLIM1:BEGIN GA:=IEXT(ORD(GX.C[GR.PC].AT)); GR.PC:=SUCC(GR.PC) END;
      OLIM2:BEGIN GA:=LPI END;
      OLIM3:BEGIN GA:=GR.PC; GR.PC:=SUCC(GR.PC+ORD(GX.C[GR.PC].AT)) END;
      OJUMP:GR.PC:=LPI; OLEAD:GA:=(GA+GR.LP)SHL 1;
      OSET1:BEGIN GX.I[GR.SP].AT:=GA; GR.SP:=SUCC(GR.SP) END;
      OTEQ1:GA:=ORD(GA =0); OTNE1:GA:=ORD(GA<>0); OTGE1:GA:=ORD(GA>=0);
      OTGT1:GA:=ORD(GA> 0); OTLE1:GA:=ORD(GA<=0); OTLT1:GA:=ORD(GA< 0);
      OCALL:BEGIN GR.SP:=GR.SP-GA; WITH GX.I[GR.SP] DO IF AT<=0 THEN CALL(PROC(-AT))
        ELSE BEGIN MOVE(GR,GX.I[GR.SP+GA],SIZEOF(REGS));
          GR.LP:=GR.SP; GR.SP:=GR.SP+GA+4; GR.PC:=AT END END;
      OENTR:BEGIN GR.BP:=GR.LP+GA; MOVE(GX.I[GR.SP-4],GX.I[GR.BP],SIZEOF(REGS));
        GR.SP:=GR.BP+4 END;
      OEXIT:MOVE(GX.I[GR.BP],GR,SIZEOF(REGS)) ELSE EXIT END END
ELSE GA:=ORD(GO)-128; GOTO 0 END;

FUNCTION LOAD:BOOL; VAR F:FILE OF RCHAR128; FN:STR127; I:SHORT; BEGIN
  LOAD:=FALSE; ARGV(FN,1); FN:=FN+MPXFEXT; ASSIGN(F,FN); RESET(F);
  IF IORESULT=0 THEN BEGIN
    I:=0; WHILE NOT EOF(F) DO BEGIN READ(F,GX.B[I]); I:=SUCC(I); END;
    CLOSE(F); LOAD:=GX.I[MPLNULL].AT=1234 END END;

PROCEDURE INIT; VAR O:OPER; BEGIN
  FOR O:=OABRT TO OOO96 DO CASE O OF
    ODREF,OSU1A,OSUA1,OAD1A,OADA1,OSU2A,OSUA2,OAD2A,OADA2:GK[O]:=KDI;
    OBAN3,OSET3,OSUB3,ODIV3,OADD3,OBOR3,OMOD3,OMUL3,OSHL3,OSHR3,OBXO3:GK[O]:=KX3;
    OBAN4,OSET4,OSUB4,ODIV4,OADD4,OBOR4,OMOD4,OMUL4,OSHL4,OSHR4,OBXO4:GK[O]:=KX4;
    OSET2,OBAN2,OBOR2,OBXO2,OTGE2,OTGT2,OTLE2,OTLT2,ODIV2,OMOD2,OMUL2,
    OTNE2,OTEQ2,OTAN2,OTOR2,OTXO2,OSHL2,OSHR2,OADD2,OSUB2,OLD21,
    OLD22:GK[O]:=KX2 ELSE GK[O]:=K00
  END;
  GX.I[MPLNULL].AT:=0;
  GR.SP:=SUCC(GX.I[MPLHEAP].AT) SHR 1; GR.PC:=GX.I[MPLCASE].AT;
  GX.I[MPLHEAP].AT:=MPLMAXI SHL 1; GX.I[MPLMAXI].AT:=0;
END;

{$IFDEF FPC}
CONST XPOSE:SET OF PROC=[
  PARGC,PARGV,PCTOL,PCTOU,PFEND,PFNEW,PFOLD,PFRDC,PFRDS,PFWRC,PFWRS,PIABS,PIMAX,
  PIMIN,PISQR,PSOFI,PMCPY,PMREV,PMSET,PRABS,PRADD,PRATN,PRCMP,PRCOS,PRCPY,PRDIV,
  PREXP,PRFRA,PRINT,PRLOG,PRMAX,PRMIN,PRMUL,PRNEG,PRROU,PRSIN,PRSQR,PRSRT,PRSUB,
  PIOFR,PSOFR,PSADD,PSCPY,PSDEL,PSINS,PSMID,PSCHR,PSSTR,PIOFS,PROFS,PVCEL,PVILN,
  PVRDC,PVRDK,PVRDS,PVWRC,PVWRS,PVCSR,PVDLN,PVGXY,PVISK,PSFIX,PFEOF,PROFI];

PROCEDURE LIBMPX(FN:STR127); VAR T:TEXT; P:PROC;
  PROCEDURE WRV(S:STR127; I:SHORT); BEGIN WRITELN(T,S,':',I) END;
  PROCEDURE WRI(S:STR127; I:SHORT); BEGIN WRV('.'+S,I) END;
BEGIN
  IF FNEW(T,FN) THEN BEGIN
    WRV('HEAP',MPLHEAP*2); WRV('CASE',MPLCASE*2);
    WRI('FMIN',ORD(FMIN)); WRI('FMAX',ORD(FMAX));
    WRI('FINP',ORD(FINP)); WRI('FOUT',ORD(FOUT));
    FOR P:=LOW(PROC) TO HIGH(PROC) DO IF P IN XPOSE THEN BEGIN
      STR(P,FN); DELETE(FN,1,1); WRI(FN,-ORD(P));
    END;
    WRITELN(T);
    FEND(T) END END;
{$ENDIF}

BEGIN
  {$IFDEF FPC}LIBMPX('LIBMPX.MPL');{$ENDIF}
  IF PARAMCOUNT<1 THEN WRITELN('USAGE: MPX <FILE>')
  ELSE IF LOAD THEN BEGIN INIT; EXEC; WRITELN; WRITELN('=',GA) END
  ELSE WRITELN('NO INPUT');
  {$IFDEF FPC}READLN;{$ENDIF}
END.