d0p1/ack
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

This is the result of the merging of 2.5 with 2.4.1.1, with some

Browse source 
minor fixes.
This commit is contained in:
ceriel 1986-07-21 09:30:11 +00:00
parent 5fd9c608ed
commit d0fdcb18db
1 changed files with 131 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

178
lang/pc/pem/pem.p
View file

@ -1,9 +1,9 @@
#include <em_spec.h> #include <em_spec.h>
#include <em_pseu.h> #include <em_pseu.h>
#include <em_mnem.h> #include <em_mnem.h>
#include <em_mes.h> #include <em_mes.h>
#include <em_reg.h> #include <em_reg.h>
#include <pc_size.h> #include <pc_size.h>
{ {
(c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands. (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
@ -26,7 +26,7 @@
{#define STANDARD 1} {#define STANDARD 1}
{if next line is included, the compiler won't generate static exchanges} {if next line is included, the compiler won't generate static exchanges}
#define NO_EXC 1 {#define NO_EXC 1}
{Author: Johan Stevenson Version: 32} {Author: Johan Stevenson Version: 32}
{$l- : no source line numbers} {$l- : no source line numbers}
@ -43,8 +43,17 @@ program pem(input,output,em,errors);
"Description of a machine architecture for use with "Description of a machine architecture for use with
block structured languages" Informatika rapport 81. block structured languages" Informatika rapport 81.
NOTE: this version is modified to produce the modified EM code of NOTE: this version is modified to produce the modified EM code of
januari 1981. it is not possible, using this compiler, to generate januari 1981. it is not possible, using this compiler, to
code for machines with 1 or 4 byte wordsize. generate code for machines with 1 byte wordsize.
NOTE: this version is modified by Kees Visser in such a way that
the compiler can now run on 2 and 4 byte machines. It is also
able to generate em-code for a 2 bytes machine while running
on a 4-bytes machine. Cross-compilation from a 2 bytes to a
four bytes machine is also possible with the following
exception: large integers that don't fit in an integer of
the compiler are treated like longs and are thus not allowed
in types.
A description of Pascal is given in A description of Pascal is given in
- K.Jensen & N.Wirth, "PASCAL user manual and report", Springer-Verlag. - K.Jensen & N.Wirth, "PASCAL user manual and report", Springer-Verlag.
Several options may be given in the normal pascal way. Moreover, Several options may be given in the normal pascal way. Moreover,
@ -52,7 +61,8 @@ program pem(input,output,em,errors);
a: interpret assertions (+) a: interpret assertions (+)
c: C-type strings allowed (-) c: C-type strings allowed (-)
d: type long may be used (-) d: type long may be used (-)
i: controls the number of bits in integer sets (16) i: controls the number of elements in integer sets
default: (wordsize in bits)
l: insert code to keep track of source lines (+) l: insert code to keep track of source lines (+)
o: optimize (+) o: optimize (+)
r: check subranges (+) r: check subranges (+)
@ -67,14 +77,38 @@ label 9999;
const const
{fundamental constants} {fundamental constants}
MB1 = 7; MB2 = 15; {MB4 = 31} MB1 = 7;
NB1 = 8; NB2 = 16; {NB4 = 32} NB1 = 8;
MI2 = 32767;
MU1 = 255;
NU1 = 256;
MI1 = 127; MI2 = 32767; {MI4 = 2147483647} {string constants}
NI1 = 128; {NI2 = 32768} {NI4 = 2147483648} imax = 10;
max2bytes = '0000032767';
max4bytes = '2147483647';
wordsize = EM_WSIZE;
MU1 = 255; {MU2 = 65535} {MU4 = 4294967295} #if EM_WSIZE == 4
NU1 = 256; {NU2 = 65536} {NU4 = 4294967296} {this can only be compiled with a compiler that has integer size 4}
MU2 = 65535;
NU2 = 65536;
{characteristics of the machine on which the compiler will run}
{wordsize and integer size are 4}
MI = 2147483647;
maxcompintstring = max4bytes;
#endif
#if EM_WSIZE == 2
MU2 = 0; {not used}
NU2 = 0; {not used}
MI = MI2;
maxcompintstring = max2bytes;
#endif
#if EM_WSIZE != 2 && EM_WSIZE != 4
Something wrong here!
#endif
{maximal indices} {maximal indices}
idmax = 8; idmax = 8;
@ -361,6 +395,7 @@ var {the most frequent used externals are declared first}
fa:attr; {attr for current file name} fa:attr; {attr for current file name}
{arrays} {arrays}
sizes:array[0 .. sz_last] of integer; sizes:array[0 .. sz_last] of integer;
maxintstring,maxlongstring:packed array[1..imax] of char;
strbuf:array[1..smax] of char; strbuf:array[1..smax] of char;
rw:array[rwrange] of idarr; rw:array[rwrange] of idarr;
{reserved words} {reserved words}
@ -506,15 +541,27 @@ begin
put1(i1); put1(i2) put1(i1); put1(i2)
end; end;
procedure put4(i:integer);
var i1,i2:integer;
begin
if i<0 then
begin i:=-(i+1); i1:=MU2 - i mod NU2; i2:=MU2 - i div NU2 end
else
begin i1:=i mod NU2; i2:=i div NU2 end;
put1(i1 mod NU1); put1(i1 div NU1);
put1(i2 mod NU1); put1(i2 div NU1)
end;
procedure argend; procedure argend;
begin put1(sp_cend) end; begin put1(sp_cend) end;
procedure argcst(i:integer); procedure argcst(i:integer);
begin begin
if (i >= -sp_zcst0) and (i < sp_ncst0-sp_zcst0) then if (i >= -sp_zcst0) and (i < sp_ncst0-sp_zcst0) then
put1(i + sp_zcst0 + sp_fcst0) put1(i + sp_zcst0 + sp_fcst0)
else else if (i >= -MI2-1) and (i <= MI2) then
begin put1(sp_cst2); put2(i) end begin put1(sp_cst2); put2(i) end
else begin put1(sp_cst4); put4(i) end
end; end;
procedure argnil; procedure argnil;
@ -850,7 +897,8 @@ begin if formof(a.asp,[arrays..records]) then loadaddr else load end;
procedure nextch; procedure nextch;
begin begin
eol:=eoln(input); read(input,ch); srcchno:=srcchno+1; chsy:=cs[ch]; eol:=eoln(input); read(input,ch); chsy:=cs[ch];
if chsy <> tabch then srcchno:=srcchno+1
end; end;
procedure nextln; procedure nextln;
@ -934,9 +982,6 @@ end;
procedure innumber; procedure innumber;
label 1; label 1;
const imax = 10;
maxintstring = '0000032767';
maxlongstring = '2147483647';
var i,j:integer; var i,j:integer;
is:packed array[1..imax] of char; is:packed array[1..imax] of char;
begin ix:=0; sy:=intcst; val:=0; begin ix:=0; sy:=intcst; val:=0;
@ -964,7 +1009,7 @@ begin ix:=0; sy:=intcst; val:=0;
if ix>imax then error(+08) else if ix>imax then error(+08) else
begin is:='0000000000'; i:=ix; j:=imax; begin is:='0000000000'; i:=ix; j:=imax;
repeat is[j]:=strbuf[i]; j:=j-1; i:=i-1 until i=0; repeat is[j]:=strbuf[i]; j:=j-1; i:=i-1 until i=0;
if is<=maxintstring then if (is<=maxintstring) and (is<=maxcompintstring) then
repeat j:=j+1; val:=val*10 - ord('0') + ord(is[j]) until j=imax repeat j:=j+1; val:=val*10 - ord('0') + ord(is[j]) until j=imax
else if (is<=maxlongstring) and (dopt<>off) then else if (is<=maxlongstring) and (dopt<>off) then
begin sy:=longcst; val:=romstr(sp_icon,sz_long) end begin sy:=longcst; val:=romstr(sp_icon,sz_long) end
@ -1307,7 +1352,8 @@ end;
function posaddr(var lb:integer; fsp:sp; partword:boolean):integer; function posaddr(var lb:integer; fsp:sp; partword:boolean):integer;
var sz:integer; var sz:integer;
begin sz:=sizeof(fsp,partword); begin sz:=sizeof(fsp,partword);
if lb >= MI2-sz then begin error(+016); lb:=0 end; if sz_int = 2 then
if lb >= MI2-sz-sz_word then begin error(+016); lb:=0 end;
if not partword or (sz>=sz_word) then if not partword or (sz>=sz_word) then
while lb mod sz_word <> 0 do lb:=lb+1; while lb mod sz_word <> 0 do lb:=lb+1;
posaddr:=lb; posaddr:=lb;
@ -1318,7 +1364,8 @@ function negaddr(fsp:sp):integer;
var sz:integer; var sz:integer;
begin with b do begin begin with b do begin
sz:=sizeof(fsp,wordmult); sz:=sizeof(fsp,wordmult);
if reglb <= -MI2+sz then begin error(+017); reglb:=0 end; if sz_int = 2 then
if reglb <= -MI2+sz+sz_word then begin error(+017); reglb:=0 end;
reglb:=reglb-sz; reglb:=reglb-sz;
while reglb mod sz_word <> 0 do reglb:=reglb-1; while reglb mod sz_word <> 0 do reglb:=reglb-1;
if reglb < minlb then minlb:=reglb; if reglb < minlb then minlb:=reglb;
@ -1332,7 +1379,10 @@ end;
procedure genhol; procedure genhol;
begin gencst(ps_hol,posaddr(holeb,nil,false)); begin gencst(ps_hol,posaddr(holeb,nil,false));
argcst(-MI2-1); argcst(0); level:=1 if sz_word = 4 then begin put1(sp_cst4); put1(0); put1(0); end
else put1(sp_cst2);
put1(0); put1(128); { 1000000000000000 pattern}
argcst(0); level:=1
end; end;
function arraysize(fsp:sp; pack:boolean):integer; function arraysize(fsp:sp; pack:boolean):integer;
@ -1715,8 +1765,9 @@ begin fwptr:=nil; intypedec:=true;
nextif(semicolon,+093); enterid(lip); nextif(semicolon,+093); enterid(lip);
end; end;
until not find2([ident],fsys,+094); until not find2([ident],fsys,+094);
assert sy<>ident;
while fwptr<>nil do while fwptr<>nil do
begin assert sy<>ident; begin
id:=fwptr^.name; lip:=searchid([types]); id:=fwptr^.name; lip:=searchid([types]);
fwptr^.idtype^.eltype:=lip^.idtype; fwptr:=fwptr^.next fwptr^.idtype^.eltype:=lip^.idtype; fwptr:=fwptr^.next
end; end;
@ -1725,7 +1776,7 @@ end;
procedure vardeclaration(fsys:sos); procedure vardeclaration(fsys:sos);
var lip,hip,vip:ip; lsp:sp; var lip,hip,vip:ip; lsp:sp;
begin with b do begin begin
repeat hip:=nil; lip:=nil; repeat hip:=nil; lip:=nil;
repeat vip:=newident(vars,nil,nil,+095); repeat vip:=newident(vars,nil,nil,+095);
if vip<>nil then if vip<>nil then
@ -1745,7 +1796,7 @@ begin with b do begin
end; end;
nextif(semicolon,+099); nextif(semicolon,+099);
until not find2([ident],fsys,+0100); until not find2([ident],fsys,+0100);
end end; end;
procedure pfhead(fsys:sos;var fip:ip;var again:boolean;param:boolean); procedure pfhead(fsys:sos;var fip:ip;var again:boolean;param:boolean);
forward; forward;
@ -2361,21 +2412,41 @@ procedure buildset(fsys:sos);
- expr..expr very difficult to implement on most machines - expr..expr very difficult to implement on most machines
- this construct makes it hard to implement sets of different size - this construct makes it hard to implement sets of different size
} }
const ncsw = 16; {tunable} const ncsb = 32; {tunable}
type wordset = set of 0..MB2; type byteset = set of 0..MB1;
var i,j,val1,val2,ncst,l1,l2,sz:integer; var i,j,val1,val2,ncst,l1,l2,sz:integer;
cst1,cst2,cst12,varpart:boolean; cst1,cst2,cst12,varpart:boolean;
cstpart:array[1..ncsw] of wordset; cstpart:array[1..ncsb] of byteset;
procedure genwordset(s:wordset); procedure genconstset(sz:integer);
{level 2: << buildset} {level 2: << buildset}
var b,i,w:integer; var i,j:integer;
begin i:=0; w:=0; b:=-1;
function setcode(s:byteset):byte;
{level 3: << buildset}
var b,i,w:byte;
begin i:=0; w:=0; b:=1;
for i:=0 to MB1 do
begin if i in s then w:=w+b; b:=b+b end;
setcode := w;
end;
begin
i:=sz;
repeat repeat
if i in s then w:=w-b; b:=b+b; i:=i+1 genop(op_loc); j:=i; i:=i-sz_word;
until i=MB2;
if i in s then w:=w+b; {the bytes of the next word to be loaded on the stack}
gencst(op_loc,w) {are in cstpart[i+1] .. cstpart[j]}
while (cstpart[j] = []) and (j > i+1) do j:=j-1;
if j = i+1 then argcst(setcode(cstpart[j]))
else
begin
if j = i+2 then put1(sp_cst2)
else begin j:=i+4; put1(sp_cst4) end;
for j:=i+1 to j do put1(setcode(cstpart[j]))
end;
until i = 0;
end; end;
procedure setexpr(fsys:sos; var c:boolean; var v:integer); procedure setexpr(fsys:sos; var c:boolean; var v:integer);
@ -2396,14 +2467,14 @@ begin with a do begin c:=false; v:=0; lsp:=asp;
if asp<>nil then if ak=cst then if asp<>nil then if ak=cst then
if (pos.ad<0) or (pos.ad div NB1>=sizeof(lsp,wordmult)) then if (pos.ad<0) or (pos.ad div NB1>=sizeof(lsp,wordmult)) then
error(+0188) error(+0188)
else if sz<=ncsw*sz_word then else if sz<=ncsb*sz_byte then
begin c:=true; v:=pos.ad end; begin c:=true; v:=pos.ad end;
if not c then load; asp:=lsp if not c then load; asp:=lsp
end end; end end;
begin with a do begin {buildset} begin with a do begin {buildset}
varpart:=false; ncst:=0; asp:=nullset; varpart:=false; ncst:=0; asp:=nullset;
for i:=1 to ncsw do cstpart[i]:=[]; for i:=1 to ncsb do cstpart[i]:=[];
if find2([notsy..lparent],fsys,+0189) then if find2([notsy..lparent],fsys,+0189) then
repeat l1:=newmark; repeat l1:=newmark;
setexpr(fsys+[colon2,comma],cst1,val1); cst12:=cst1; setexpr(fsys+[colon2,comma],cst1,val1); cst12:=cst1;
@ -2426,8 +2497,8 @@ begin with a do begin {buildset}
if cst12 then val2:=val1 else genasp(op_set); if cst12 then val2:=val1 else genasp(op_set);
if cst12 then if cst12 then
for i:=val1 to val2 do for i:=val1 to val2 do
begin j:=i div NB2 + 1; ncst:=ncst+1; begin j:=i div NB1 + 1; ncst:=ncst+1;
cstpart[j]:=cstpart[j] + [i mod NB2] cstpart[j]:=cstpart[j] + [i mod NB1]
end end
else else
if varpart then genasp(op_ior) else varpart:=true; if varpart then genasp(op_ior) else varpart:=true;
@ -2436,8 +2507,7 @@ begin with a do begin {buildset}
ak:=loaded; ak:=loaded;
if ncst>0 then if ncst>0 then
begin begin
for i:=sizeof(asp,wordmult) div sz_word downto 1 do genconstset(sizeof(asp,wordmult));
genwordset(cstpart[i]);
if varpart then genasp(op_ior); if varpart then genasp(op_ior);
end end
else else
@ -2655,7 +2725,7 @@ begin
if not formof(la.asp,[arrays..records]) then store else if not formof(la.asp,[arrays..records]) then store else
begin loadaddr; begin loadaddr;
if la.asp^.form<>carray then genasp(op_blm) else if la.asp^.form<>carray then genasp(op_blm) else
begin descraddr(la.asp^.arpos); gensp(ASZ,2*sz_addr); begin descraddr(la.asp^.arpos); gensp(ASZ,sz_addr);
gencst(op_lfr,sz_word); gencst(op_bls,sz_word) gencst(op_lfr,sz_word); gencst(op_bls,sz_word)
end; end;
end; end;
@ -2724,7 +2794,7 @@ begin with b do begin
expression(fsys+[ofsy,semicolon,ident..plussy]); lsp:=a.asp; load; expression(fsys+[ofsy,semicolon,ident..plussy]); lsp:=a.asp; load;
if not nicescalar(desub(lsp)) then begin error(+0223); lsp:=nil end; if not nicescalar(desub(lsp)) then begin error(+0223); lsp:=nil end;
l0:=newmark; ilbno:=ilbno+1; ilb1:=ilbno; l0:=newmark; ilbno:=ilbno+1; ilb1:=ilbno;
nextif(ofsy,+0224); head:=nil; max:=-MI2; min:=MI2; n:=0; nextif(ofsy,+0224); head:=nil; max:=-MI; min:=MI; n:=0;
repeat ilbno:=ilbno+1; ilb2:=ilbno; {label of current case} repeat ilbno:=ilbno+1; ilb2:=ilbno; {label of current case}
repeat i:=cstinteger(fsys+[comma,colon1,semicolon],lsp,+0225); repeat i:=cstinteger(fsys+[comma,colon1,semicolon],lsp,+0225);
if i>max then max:=i; if i<min then min:=i; n:=n+1; if i>max then max:=i; if i<min then min:=i; n:=n+1;
@ -3201,8 +3271,13 @@ end;
procedure init3; procedure init3;
var n:np; p,q:ip; i:integer; c:char; var n:np; p,q:ip; i:integer; c:char;
is:packed array[1..imax] of char;
begin begin
for i:=0 to sz_last do readln(errors,sizes[i]); for i:=0 to sz_last do readln(errors,sizes[i]);
if sz_int = 2 then maxintstring := max2bytes
else maxintstring := max4bytes;
if sz_long = 2 then maxlongstring := max2bytes
else maxlongstring := max4bytes;
gencst(ps_mes,ms_emx); argcst(sz_word); argcst(sz_addr); argend; gencst(ps_mes,ms_emx); argcst(sz_word); argcst(sz_addr); argend;
ix:=1; ix:=1;
while not eoln(errors) do while not eoln(errors) do
@ -3234,7 +3309,16 @@ begin
q:=nil; p:=newip(konst,'false ',boolptr,q); enterid(p); q:=nil; p:=newip(konst,'false ',boolptr,q); enterid(p);
q:=p; p:=newip(konst,'true ',boolptr,q); p^.value:=1; enterid(p); q:=p; p:=newip(konst,'true ',boolptr,q); p^.value:=1; enterid(p);
boolptr^.fconst:=p; boolptr^.fconst:=p;
p:=newip(konst,'maxint ',intptr,nil); p^.value:=MI2; enterid(p); {maxint of the target machine}
p:=newip(konst,'maxint ',intptr,nil);
if sz_int = 2 then p^.value:=MI2
else if wordsize = 4 then p^.value := MI
else {wordsize = 2, sz_int = 4}
begin p^.idtype:=longptr; ix:=imax; is:=max4bytes;
for i:=1 to ix do strbuf[i]:=is[i];
p^.value:=romstr(sp_icon,sz_int);
end;
enterid(p);
p:=newip(konst,spaces,charptr,nil); p^.value:=maxcharord; p:=newip(konst,spaces,charptr,nil); p^.value:=maxcharord;
charptr^.fconst:=p; charptr^.fconst:=p;
{new name space for user externals} {new name space for user externals}
@ -3252,7 +3336,7 @@ end;
procedure init4; procedure init4;
begin begin
copt:=opt['c']; copt:=opt['c'];
dopt:=opt['d']; dopt:=opt['d']; if wordsize < sz_int then dopt:=on;
iopt:=opt['i']; iopt:=opt['i'];
sopt:=opt['s']; sopt:=opt['s'];
if sopt<>off then begin copt:=off; dopt:=off end if sopt<>off then begin copt:=off; dopt:=off end