ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/SIMTEL/CPMUG/CPMUG050.ARK/PFET.PAS

Pascal/Delphi Source File | 1984-04-29 | 11KB | 487 lines

(*
  TITLE        PASCAL FAST EXECUTION TRANSLATOR
  FILENAME    PFET.PAS
  AUTHOR    Robert A. Van Valzah  10/06/79
  LAST REVISOR    R.A.V.  01/14/80
  REASON    repaired bug in astoi code
*)

const
    vhu    = 0;    (* version number hundreds *)
    vtn    = 0;    (* tens *)
    vun    = 8;    (* units *)
    devrel    = 'r';    (* development or release version *)
    nlab    = 500;    (* max number of p-labels *)
    codemax    = 5000;    (* max number of p-instructions *)
    ocode    = 1536;    (* object code base address *)
    rtporg    = 256;    (* run time package base address *)

    (* runtime package entry points *)
    base    = rtporg+3;    cmpr    = base+3;
    cspbase    = cmpr+3;    spalit    = cspbase+30;
    spalod    = spalit+3;    spasto    = spalod+3;
    acmpr    = spasto+3;    opr3    = acmpr+3;
    opr4    = opr3+3;    opr5    = opr4+3;
    opr14    = opr5+3;    opr15    = opr14+3;
    spcal0    = opr15+3;    spcal    = spcal0+3;
    spret    = spcal+3;    br    = spret+3;

    (* 8080 instructions *)
    lhld    = 42;    shld    = 34;
    pushh    = 229;    pushd    = 213;
    pushb    = 197;    pushpsw    = 245;
    poph    = 225;    popd    = 209;
    popb    = 193;

    sphl    = 249;    pchl    = 233;
    xchg    = 235;    xthl    = 227;

    dadh    = 41;    dadsp    = 57;
    dadd    = 25;    dadb    = 9;

    call    = 205;    jmp    = 195;
    jz    = 202;    jnz    = 194;
    jnc    = 210;    jc    = 218;

    mvia    = 62;    adi    = 198;
    mvid    = 22;

    lxih    = 33;    lxid    = 17;
    lxib    = 1;

    movem    = 94;    movdm    = 86;
    movme    = 115;    movmd    = 114;
    movbh    = 68;    movcl    = 77;
    movam    = 126;    movhm    = 102;
    movla    = 111;    movae    = 123;
    cmc    = 63;    sbba    = 159;
    dcra    = 61;    orad    = 178;
    anad    = 162;

    inxsp    = 51;    dcxsp    = 59;
    dcxh    = 43;    inxh    = 35;
type
    pops    = ( (* p-op codes *)
        cal, jpc, jump, lit, opr, lod, sto, int,
        csp, lodx, stox, alit, alod, asto,
        alodx, astox, pshf, clod, csto,
        clodx, cstox, halt, lab,
        peof, (* end of p-code file *)
        laa, lodi, stoi, clodi, cstoi, alodi, astoi,
        indx, aindx, cindx
        );
    fflags    = ( (* flags set when condition is false *)
        ifnz, ifz, ifcz, ifznc, ifnc, ifc
        );
    labtyp    = array[0..nlab] of word;
    codtyp    = array[0..codemax] of word;

var
    label    : labtyp;    (* label p-addresses *)
    adr    : labtyp;    (* label 8080 addresses *)
    fla    : codtyp;    (* p-code function & level *)
    aa    : codtyp;    (* p-code address *)
    f    : word;        (* current instruction function *)
    l    : word;        (* current instruction level *)
    a    : word;        (* current instruction address *)
    coa    : word;        (* code out address *)
    cx    : word;        (* p-code array index *)
    cix    : word;        (* number of p-codes read *)
    glram    : word;        (* base address of global ram *)
    pass    : word;        (* pass number *)
    lfl    : fflags;    (* flags set when last
                translated conditional is
                false *)

    (* global variables for procedure getpcd for speed *)
    adlo, adhi    : word;

    (* global variables for function eieiadr for speed *)
    eii, eij, eik    : word;

    (* global variables for procedure trans for speed *)
    transi    : word;

procedure co1b(ch: word);

    begin
    coa:=coa+1;
    if pass=2 then put#0(ch)
    end; (* co1b *)

procedure co2b(c1,c2: word);

    begin
    coa:=coa+2;
    if pass=2 then put#0(c1,c2)
    end; (* co2b *)

procedure co3b(c1,c2,c3: word);

    begin
    coa:=coa+3;
    if pass=2 then put#0(c1,c2,c3)
    end; (* co3b *)

procedure co4b(c1,c2,c3,c4: word);

    begin
    coa:=coa+4;
    if pass=2 then put#0(c1,c2,c3,c4)
    end; (* co4b *)

procedure coad(ad: word);

    begin
    co1b(ad); co1b(ad/256)
    end; (* coad *)

procedure coopad(op,ad: word);

    begin
    co1b(op); coad(ad)
    end; (* coopad *)

procedure getpcd; (* get next p-code to f, l, and a *)

    begin
    if pass=1 then begin
        if cix>codemax then put#1('*cd over');
        get#0(f);
        get#0(l);
        fla[cix]:=f+l*256;
        get#0(adlo); get#0(adhi);
        a:=adlo+adhi*256;
        aa[cix]:=a;
        cix:=cix+1
        end
    else begin (* must be pass 2 *)
        a:=fla[cx]; (* use a as a temp *)
        l:=a/256; f:=a-l*256;
        a:=aa[cx];
        cx:=cx+1
        end
    end; (* getpcd *)

procedure wrsym;

    var     i    : word;

    begin
    for i:=0 to nlab do begin
        put#1('P',label[i]#);
        put#1(' ',adr[i]#);
        put#1(13,10)
        end
    end; (* wrsym *)

procedure gencmp;

    begin
    if l=0
        then coopad(call,cmpr)
        else coopad(call,acmpr)
    end; (* gencmp *)

procedure varadr;

    var    lev    : word;

    begin
    lev:=l;
    if lev=0 then begin (* local ref *)
        coopad(lxib,0-a);
        coopad(lhld,br); co1b(dadb)
        end
    else if lev=255 then (* global ref *)
        coopad(lxih,a+glram)
    else begin (* intermediate ref *)
        co2b(mvia,lev);
        coopad(call,base); coopad(lxid,0-a);
        co1b(dadd)
        end
    end; (* varadr *)

function eieiadr(pad: word (* p-code address *) );

    begin
    if pass=2 then
        if adr[pad]<>0 then eieiadr:=adr[pad]
        else put#1('P',pad#,'undefind',13,10)
    end; (* eieiadr *)

procedure dw2;

    begin
    co4b(f, l, a, a/256)
    end; (* dw2 *)

procedure flagtoa;

    begin
    case lfl of
    ifnz:    begin
        co4b(adi, 255, cmc, sbba)
        end; (* ifnz *)
    ifz:    begin
        co3b(adi, 255, sbba)
        end; (* ifz *)
    ifcz:    begin
        co2b(mvia, 0);
        coopad(jc,coa+7); coopad(jz,coa+4); co1b(dcra)
        end; (* ifcz *)
    ifznc:    begin
        co2b(mvia, 0);
        coopad(jz,coa+6); coopad(jnc,coa+4); co1b(dcra)
        end; (* ifznc *)
    ifnc:    co1b(sbba);
    ifc:    begin
        co2b(cmc, sbba)
        end (* ifc *)
    end (* case lfl of *)
    end; (* flagtoa *)

procedure trans;

    begin
    case f of
    lit:    begin
        coopad(lxih,a); co1b(pushh)
        end;
    opr:    case a of
        0:    (* procedure return *)
            coopad(jmp,spret);
        2:    (* (top)=(top)+(top-1) *)
            begin
            co4b(popd, poph, dadd, pushh)
            end; (* case opr sub *)
        3:    (* (top)=(top)-(top-1) *)
            coopad(call,opr3);
        4:    (* multiply *)
            coopad(call,opr4);
        5:    (* divide *)
            coopad(call,opr5);
        8:    begin (* (top)=(top-1) conditional *)
            gencmp; lfl:=ifnz
            end; (* opr 8 *)
        9:    begin (* (top)<>(top-1) condtional *)
            gencmp; lfl:=ifz
            end; (* opr 9 *)
        10:    begin (* (top)<(top-1) conditinal *)
            gencmp; lfl:=ifcz
            end; (* opr 10 *)
        11:    begin (* (top-1)>=(top) conditonal *)
            gencmp; lfl:=ifznc
            end; (* opr 11 *)
        12:    begin (* (top-1)>(top) conditionla *)
            gencmp; lfl:=ifnc
            end; (* opr 12 *)
        13:    begin (* (top-1)<=(top) conditional *)
            gencmp; lfl:=ifc
            end; (* opr 13 *)
        14:    begin (* (top)=(top-1) or (top) *)
            flagtoa; co2b(popd, orad);
            lfl:=ifz
            end; (* opr 14 *)
        15:    begin (* (top)=(top-1) and (top) *)
            flagtoa; co2b(popd, anad);
            lfl:=ifz
            end; (* opr 15 *)
        19:    begin (* increment (top) *)
            co3b(poph, inxh, pushh);
            lfl:=ifz
            end; (* opr 19 *)
        20:    begin (* decrement (top) *)
            co3b(poph, dcxh, pushh)
            end; (* opr 20 *)
        21:    begin (* copy (top) *)
            co3b(poph, pushh, pushh)
            end (* case opr 21 *)
        else    put#1('bad opr ',a#,13,10)
        end; (* case opr *)
    lod:    begin
        if l=255 then begin (* global lod *)
            coopad(lhld,a+glram);
            co1b(pushh)
            end (* global *)
        else begin (* intermediate to local *)
            varadr; co4b(movem, inxh, movdm, pushd);
            end
        end; (* case lod *)
    sto:    begin
        if l=255 then begin (* global sto *)
            co1b(poph);
            coopad(shld,a+glram)
            end
        else begin (* intermediate to local *)
            varadr; co4b(popd, movme, inxh, movmd)
            end
        end; (* sto *)
    cal:    begin
        coopad(lxid,eieiadr(a));
        if l=0
            then coopad(call,spcal0)
            else begin
                co2b(mvia, l);
                coopad(call,spcal)
                end;
        end; (* cal *)
    int:    begin
        if (a>=0-4) and (a<=4) then begin
            for transi:= 1 to a do
                co1b(dcxsp);
            for transi:= 0-1 downto a do
                co1b(inxsp)
            end
        else begin
            coopad(lxih,0-a);
            co2b(dadsp, sphl)
            end
        end; (* int *)
    jump:    begin
        coopad(jmp,eieiadr(a))
        end; (* jump *)
    jpc:    begin
        case lfl of
        ifnz:    coopad(jnz,eieiadr(a));
        ifz:    coopad(jz,eieiadr(a));
        ifcz:    begin
            coopad(jc,eieiadr(a));
            coopad(jz,eieiadr(a))
            end; (* ifcz *)
        ifznc:    begin
            coopad(jz,coa+6);
            coopad(jnc,eieiadr(a))
            end; (* ifznc *)
        ifnc:    coopad(jnc,eieiadr(a));
        ifc:    coopad(jc,eieiadr(a))
        end (* case lfl of *)
        end; (* jpc *)
    pshf:    begin
        flagtoa; co1b(pushpsw)
        end; (* pushf *)
    csp:    begin
        co2b(mvia, l);
        coopad(call,cspbase+3*a)
        end; (* csp *)
    lodx:    begin
        varadr; co4b(popd, dadd, dadd, movem);
        co3b(inxh, movdm, pushd)
        end; (* lodx *)
    stox:    begin
        varadr; co4b(popd, popb, dadb, dadb);
        co3b(movme, inxh, movmd)
        end; (* stox *)
    indx:    begin (* index word array *)
        co4b(poph, dadh, popd, dadd);
        co1b(pushh)
        end; (* case indx *)
    clod:    begin
        varadr; co3b(movdm, pushd, inxsp);
        end; (* clod *)
    csto:    begin
        varadr; co3b(popd, dcxsp, movme)
        end; (* csto *)
    clodi:    begin (* character load indirect *)
        co4b(poph, movdm, pushd, inxsp)
        end; (* case clodi *)
    cstoi:    begin (* character store indirect *)
        co4b(popd, dcxsp, poph, movme)
        end; (* case cstoi *)
    cindx:    begin (* character array index *)
        co4b(poph, popd, dadd, pushh)
        end; (* case cindx *)
    clodx:    begin
        varadr; co3b(popd, dadd, movem);
        co3b(mvid, 0, pushd)
        end; (* clodx *)
    cstox:    begin
        varadr; co4b(popd, popb, dadb, movme)
        end; (* cstox *)
    alit:    begin
        coopad(call,spalit);
        getpcd; dw2;
        getpcd; dw2
        end;
    alod:    begin
        varadr; coopad(call,spalod)
        end; (* alod *)
    asto:    begin
        varadr; coopad(call,spasto)
        end; (* asto *)
    aindx:    begin
        co4b(poph, dadh, dadh, dadh);
        co3b(popd, dadd, pushh)
        end; (* case aindx *)
    alodi:    begin (* alfa load indirect *)
        co1b(poph); coopad(call,spalod)
        end; (* case alodi *)
    astoi:    begin (* alfa store indirect *)
        coopad(lxih,8);
        co4b(dadsp, movam, inxh, movhm);
        co1b(movla); coopad(call,spasto);
        co1b(poph)
        end; (* case astoi *)
    alodx:    begin
        varadr; co3b(popd, xchg, dadh);
        co3b(dadh, dadh, dadd);
        coopad(call,spalod)
        end; (* alodx *)
    astox:    begin
        varadr; co1b(xchg); coopad(lxih,8);
        co4b(dadsp, movam, inxh, movhm);
        co3b(movla, dadh, dadh);
        co2b(dadh, dadd); coopad(call,spasto);
        co1b(poph)
        end; (* case astox *)
    laa:    begin
        varadr; co1b(pushh)
        end; (* case laa *)
    lodi:    begin (* load word indirect *)
        co4b(poph,movem,inxh,movdm);
        co1b(pushd)
        end; (* case lodi *)
    stoi:    begin (* store word indirect *)
        co4b(popd,poph,movme,inxh);
        co1b(movmd)
        end; (* case stoi *)
    peof:    begin (* do nothing *)
        end (* case peof *)
    else    put#1('bad p-op',f#,13,10)
    end (* case f of *)
    end; (* trans *)

procedure pass12(ps: word);

    begin
    pass:=ps;
    coa:=ocode;
    repeat
        getpcd;
        if f<>lab then trans
        else if pass=1 then
                if a>nlab then put#1('*lb over')
                else adr[a]:=coa
            else (* pass = 2 *)
                if adr[a]<>coa then
                    put#1('Phase er',
                    'ror    P',a#)
    until f=peof;
    if pass=1 then glram:=coa
    end; (* pass12 *)

begin (* main line *)
    (* zero all addresses for undefined label detection *)
    (* use cix as temp index *)
    put#1('pfet rev',' ',vhu#,'.',vtn#,vun#,devrel,13,10);
    for cix:=0 to nlab do adr[cix]:=0;
    cix:=0;
    put#1('Pass 1  ',13,10);
    pass12(1);
    put#1(cix#,' p-codes', ' read   ',13,10);
    cx:=0;
    put#1('Pass 2  ',13,10);
    pass12(2);
    put#1('done!   ',13,10)
end.