home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
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
< prev
next >
Wrap
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.