program PASCALS(INPUT,OUTPUT,PRD,PRR);
{ author:N.Wirth, E.T.H. CH-8092 Zurich,1.3.76 }
{ modified by R.E.Berry
Department of computer studies
University of Lancaster
Variants of this program are used on
Data General Nova,Apple,and
Western Digital Microengine machines. }
{ further modified by M.Z.Jin
Department of Computer Science&Engineering BUAA,0ct.1989
}
{常量定义}
const nkw = 27; { no. of key words } {*保留字数目*}
alng = 10; { no. of significant chars in identifiers } {*标识符最大长度*}
llng = 121; { input line length } {*输入一行文件内容长度*}
emax = 322; { max exponent of real numbers } {*最大指数大小*}
emin = -292; { min exponent } {*最小指数大小*}
kmax = 15; { max no. of significant digits } {*数字最大长度*}
tmax = 100; { size of table } {*符号表最大长度*}
bmax = 20; { size of block-talbe } {*分程序表最大长度*}
amax = 30; { size of array-table } {*数组向量表最大长度*}
c2max = 20; { size of real constant table } {*实常量表最大长度*}
csmax = 30; { max no. of cases } {*case语句最大分支数目*}
cmax = 800; { size of code } {*目标代码表最大长度*}
lmax = 7; { maximum level } {*最大嵌套层数*}
smax = 600; { size of string-table } {*字符串表最大长度*}
ermax = 58; { max error no. } {*错误种类最大数目*}
omax = 63; { highest order code } {*最大标识符数目*}
xmax = 32767; { 2**15-1 }
nmax = 32767; { 2**15-1 } {*整型最大值*}
lineleng = 132; { output line length } {*输出文件一行最大长度*}
linelimit = 200; {*输出文件行数限制*}
stacksize = 1450; {*栈大小*}
{类型定义}
type symbol = ( intcon, realcon, charcon, stringcon,
notsy, plus, minus, times, idiv, rdiv, imod, andsy, orsy,
eql, neq, gtr, geq, lss, leq,
lparent, rparent, lbrack, rbrack, comma, semicolon, period,
colon, becomes, constsy, typesy, varsy, funcsy,
procsy, arraysy, recordsy, programsy, ident,
beginsy, ifsy, casesy, repeatsy, whilesy, forsy,
endsy, elsesy, untilsy, ofsy, dosy, tosy, downtosy, thensy); {*所有符号种类枚举编码*}
index = -xmax..+xmax; {*index子界限制*}
alfa = packed array[1..alng]of char; {*字符数组存储标识符*}
objecttyp = (konstant, vvariable, typel, prozedure, funktion ); {*种类枚举变量*}
types = (notyp, ints, reals, bools, chars, arrays, records ); {*类型枚举变量*}
symset = set of symbol; {*符号编码枚举变量组成的集合*}
typset = set of types; {*类型枚举变量组成的集合*}
item = record
typ: types;
ref: index;
end;
order = packed record
f: -omax..+omax;
x: -lmax..+lmax;
y: -nmax..+nmax
end;
{变量定义}
var ch: char; { last character read from source program } {*最近读入字符*}
rnum: real; { real number from insymbol } {*实数实型部分*}
inum: integer; { integer from insymbol } {*实数整型部分*}
sleng: integer; { string length } {*字符串长度*}
cc: integer; { character counter } {*字符指针*}
lc: integer; { program location counter } {*目标码指针*}
ll: integer; { length of current line } {*当前读入行长度*}
errpos: integer;
t,a,b,sx,c1,c2:integer; { indices to tables } {*各个表的指针*}
iflag, oflag, skipflag, stackdump, prtables: boolean; {*各个标志变量*}
sy: symbol; { last symbol read by insymbol } {*当前读入的符号*}
errs: set of 0..ermax; {*错误集合*}
id: alfa; { identifier from insymbol } {*读入的符号的值*}
progname: alfa; {*主程序名*}
stantyps: typset; {*标准类型集合*}
constbegsys, typebegsys, blockbegsys, facbegsys, statbegsys: symset; {*一系列test*}
line: array[1..llng] of char; {*当前读入行临时存储数组*}
key: array[1..nkw] of alfa; {*保留字表*}
ksy: array[1..nkw] of symbol; {*保留字对应编码表*}
sps: array[char]of symbol; { special symbols } {*特殊符号对应编码数组*}
display: array[0..lmax] of integer; {*display表*}
tab: array[0..tmax] of { indentifier lable } {*符号表*}
packed record
name: alfa;
link: index;
obj: objecttyp;
typ: types;
ref: index;
normal: boolean;
lev: 0..lmax;
adr: integer
end;
atab: array[1..amax] of { array-table } {*数组向量表*}
packed record
inxtyp,eltyp: types;
elref,low,high,elsize,size: index
end;
btab: array[1..bmax] of { block-table } {*分程序表*}
packed record
last, lastpar, psize, vsize: index
end;
stab: packed array[0..smax] of char; { string table } {*字符表*}
rconst: array[1..c2max] of real; {*常量表*}
code: array[0..cmax] of order; {*目标指令表*}
psin,psout,prr,prd:text; { default in pascal p } {*代码输入，代码输出,键盘,显示屏文件指针*}
inf, outf, fprr: string; {*代码输入，代码输出，运行结果输出文件路径*}
{*
函数名：errormsg;
功能：打印源程序出错信息的摘要;
*}
procedure errormsg;
var k : integer;
msg: array[0..ermax] of alfa; {*出错信息数组*}
begin {*给数组各项赋值*}
msg[0] := 'undef id '; msg[1] := 'multi def ';
msg[2] := 'identifier'; msg[3] := 'program ';
msg[4] := ') '; msg[5] := ': ';
msg[6] := 'syntax '; msg[7] := 'ident,var ';
msg[8] := 'of '; msg[9] := '( ';
msg[10] := 'id,array '; msg[11] := '( ';
msg[12] := '] '; msg[13] := '.. ';
msg[14] := '; '; msg[15] := 'func. type';
msg[16] := '= '; msg[17] := 'boolean ';
msg[18] := 'convar typ'; msg[19] := 'type ';
msg[20] := 'prog.param'; msg[21] := 'too big ';
msg[22] := '. '; msg[23] := 'type(case)';
msg[24] := 'character '; msg[25] := 'const id ';
msg[26] := 'index type'; msg[27] := 'indexbound';
msg[28] := 'no array '; msg[29] := 'type id ';
msg[30] := 'undef type'; msg[31] := 'no record ';
msg[32] := 'boole type'; msg[33] := 'arith type';
msg[34] := 'integer '; msg[35] := 'types ';
msg[36] := 'param type'; msg[37] := 'variab id ';
msg[38] := 'string '; msg[39] := 'no.of pars';
msg[40] := 'real numbr'; msg[41] := 'type ';
msg[42] := 'real type '; msg[43] := 'integer ';
msg[44] := 'var,const '; msg[45] := 'var,proc ';
msg[46] := 'types(:=) '; msg[47] := 'typ(case) ';
msg[48] := 'type '; msg[49] := 'store ovfl';
msg[50] := 'constant '; msg[51] := ':= ';
msg[52] := 'then '; msg[53] := 'until ';
msg[54] := 'do '; msg[55] := 'to downto ';
msg[56] := 'begin '; msg[57] := 'end ';
msg[58] := 'factor';
writeln(psout); {*向代码输出文件中打印空行并换行*}
writeln(psout,'key words'); {*向代码输出文件打印'key words'并换行*}
k := 0;
while errs <> [] do {*输出错误集合中的全部错误信息摘要*}
begin
while not( k in errs )do k := k + 1; {*变量k不在错误集合中则遍历下一错误序号*}
writeln(psout, k, ' ', msg[k] ); {*打印输出错误序号k,空格,错误信息摘要*}
errs := errs - [k] {*从错误集合中去除已遍历过的错误序号k*}
end { while errs }
end { errormsg } ;
{*
函数名:endskip;
功能:源程序出错后在被跳读的部分下面印出下划线标志;
*}
procedure endskip;
begin { underline skipped part of input }
while errpos < cc do
begin
write( psout, '-');
errpos := errpos + 1
end;
skipflag := false
end { endskip };
{*
函数名:nextch;
功能:读取下一字符,处理行结束符,打印出被编译的源程序;
*}
procedure nextch; { read next character; process line end }
begin
if cc = ll {*如果本行已经读完*}
then begin
if eof( psin ) {*如果到文件末尾*}
then begin
writeln( psout ); {*输出空行*}
writeln( psout, 'program incomplete' ); {*输出'文件已经读完'*}
errormsg; {*打印错误信息*}
exit; {*退出程序*}
end;
if errpos <> 0 {*如果本行跳过的错误字符个数不为零*}
then begin
if skipflag then endskip; {*如果本行错误信息未被输出,则在本行的错误信息下面加下划线并输出*}
writeln( psout ); {*输出空行*}
errpos := 0 {*清空erropos变量*}
end;
write( psout, lc: 5, ' '); {*输出源程序指针值*}
ll := 0; {*更新行指针为0*}
cc := 0; {*更新字符指针为0*}
while not eoln( psin ) do {*只要没有读到本行末尾*}
begin
ll := ll + 1; {*行指针加1*}
read( psin, ch ); {*读取一个字符到ch中*}
write( psout, ch ); {*输出该字符*}
line[ll] := ch {*将该字符补充到文件行内容数组line的末尾*}
end;
ll := ll + 1; {*行指针加1*}
readln( psin ); {*读取下一行*}
line[ll] := ' '; {*文件行内容数组末尾加空格*}
writeln( psout ); {*输出空行*}
end;
cc := cc + 1; {*字符指针加1*}
ch := line[cc]; {*读取本行的当前字符*}
end { nextch };
{*
函数名:error;
功能:打印出错位置和出错编号;
参数:n:错误信息种类;
*}
procedure error( n: integer );
begin
if errpos = 0 {*如果没有跳过的错误信息*}
then write ( psout, '****' ); {*输出'****'*}
if cc > errpos {*如果字符指针大于跳过的错误字符数*}
then begin
write( psout, ' ': cc-errpos, '^', n:2); {*输出空格,'^'指出错误信息*}
errpos := cc + 3; {*跳过的错误信息指针加3*}
errs := errs +[n]; {*将该错误加入到错误信息集合中*}
end
end { error };
{*
函数名:fatal;
功能:打印表格溢出信息;
参数:n:表格编号;
*}
procedure fatal( n: integer );
var msg : array[1..7] of alfa; {*溢出信息数组*}
begin
writeln( psout ); {*输出空行*}
errormsg; {*打印错误信息摘要*}
msg[1] := 'identifier'; msg[2] := 'procedures';
msg[3] := 'reals '; msg[4] := 'arrays ';
msg[5] := 'levels '; msg[6] := 'code ';
msg[7] := 'strings ';
writeln( psout, 'compiler table for ', msg[n], ' is too small'); {*输出表格溢出信息*}
exit; {terminate compilation } {*退出程序*}
end { fatal };
{*
函数名:insymbol;
功能:读取下一单词符号，处理注释行;
*}
procedure insymbol; {reads next symbol}
label 1,2,3; {*定义跳转标签*}
var i,j,k,e: integer;{*k记录整数部分位数,asb(e)记录小数部分位数*}
{*
过程名:readscale;
功能:处理实数的指数部分;
*}
procedure readscale;
var s,sign: integer;
begin
nextch; {*读取下一个字符*}
sign := 1; {*符号变量*}
s := 0; {*存储指数部分数值*}
if ch = '+' {如果指数部分以'+'开头，则不做处理}
then nextch
else if ch = '-' {*如果指数部分以'-’开头，则设置符号为负号*}
then begin
nextch;
sign := -1
end;
if not(( ch >= '0' )and (ch <= '9' )) {*如果符号后读入的字符不是数字，则进行报错err40*}
then error( 40 )
else repeat{*否则，将指数部分字符串转化为整数存储至s中*}
s := 10*s + ord( ord(ch)-ord('0'));
nextch;
until not(( ch >= '0' ) and ( ch <= '9' ));
e := s*sign + e {*e>0:rnum实际向右移动的位数;e<0,rnum实际向左移动的位数*}
end { readscale };
{*
过程名:adjustable;
功能:根据小数位数和指数大小求出实数数值;
*}
procedure adjustscale;
var s : integer;
d, t : real;
begin
if k + e > emax {*如果整数位数加上移动位数位数大于上限则报错*}
then error(21)
else if k + e < emin {*如果小于下限*}
then rnum := 0 {*则无法精确到该小值，记该实数为0*}
else begin
s := abs(e); {*s为e的绝对值*}
t := 1.0;
d := 10.0;
repeat
{*将s表示成2^n的形式进行计算10的次幂*}
while not odd(s) do {*如果s是偶数*}
begin
s := s div 2; {*给s除2，div为整除*}
d := sqr(d) {*给d进行平方*}
end;
s := s - 1; {*如果s是奇数，则给s-1*}
t := d * t {*计算以10为底，s为指数的结果*}
until s = 0;
if e >= 0
then rnum := rnum * t {*如果指数部分大于0，则实数等于小数部分乘求得的10的次幂*}
else rnum := rnum / t {*如果指数部分小于0，则实数等于小数部分除求得的10的次幂*}
end
end { adjustscale };
{*
过程名:options;
功能:处理编译时的可选项;
*}
procedure options;
{*
过程名:swicth;
功能:处理编译可选项中的'+','-'标志;
参数:b:是否打印相关表格的特征变量;
*}
procedure switch( var b: boolean );
begin
b := ch = '+'; {*如果当前字符为'+',b=true;否则,b=false*}
if not b {*如果ch不为'+'*}
then if not( ch = '-' ) {*如果ch不为'-'*}
then begin { print error message }
while( ch <> '*' ) and ( ch <> ',' ) do {*略过所有的'*'和','*}
nextch;
end
else nextch {*如果ch为'-',则读入下一个字符*}
else nextch {*如果ch为'+',则读入下一个字符*}
end { switch };
begin { options }
repeat
nextch;
if ch <> '*' {*如果ch不为'*'*}
then begin
if ch = 't' {*如果ch为't',则读入下一个字符，并将是否打印表格的特征变量prtables根据'+,-'置为true或false}
then begin
nextch;
switch( prtables )
end
else if ch = 's' {*如果ch为's',则读入下一个字符，并将是否打印运行错误信息的特征变量stackdump根据'+,-'置为true或false*}
then begin
nextch;
switch( stackdump )
end;
end
until ch <> ','
end { options };
begin { insymbol }
1: while( ch = ' ' ) or ( ch = chr(9) ) do
nextch; { space & htab } {*如果读入的字符为空格或者\t则跳过*}
case ch of
'a','b','c','d','e','f','g','h','i',
'j','k','l','m','n','o','p','q','r',
's','t','u','v','w','x','y','z':
begin { identifier of wordsymbol } {*如果读入的字符是小写字母*}
k := 0;
id := ' '; {*清空id数组*}
repeat {*一直读入字符并取前10个连接到id字符数组的尾部，直到读入的字符不再是小写字母或者数字为止*}
if k < alng {*限制单词的字母个数最多为10*}
then begin
k := k + 1;
id[k] := ch
end;
nextch
until not((( ch >= 'a' ) and ( ch <= 'z' )) or (( ch >= '0') and (ch <= '9' )));
i := 1;
j := nkw; { binary search } {*二分法查找保留字表,判断当前读入的单词是否为保留字*}
repeat
k := ( i + j ) div 2;
if id <= key[k]
then j := k - 1;
if id >= key[k]
then i := k + 1;
until i > j;
if i - 1 > j {*如果当前单词为保留字,则sy为相应的保留字对应的编码*}
then sy := ksy[k]
else sy := ident {*如果不是保留字，则当前单词为标识符*}
end;
'0','1','2','3','4','5','6','7','8','9': {*如果当前字符为数字*}
begin { number }
k := 0;
inum := 0;
sy := intcon; {*sy被赋值为数字编码*}
repeat {*一直读取字符直到不再是数字为止，并将该数字字符串转化为整型数字并存入inum中*}
inum := inum * 10 + ord(ch) - ord('0');
k := k + 1;
nextch
until not (( ch >= '0' ) and ( ch <= '9' ));
if( k > kmax ) or ( inum > nmax ) {*如果数字的位数超过kmax或者数字的大小超过nmax，则进行报错err21*}
then begin
error(21);
inum := 0; {*将当前读入的数字大小置为0*}
k := 0 {*清空数字位数计数器*}
end;
if ch = '.' {*如果读入的字符为'.'，处理小数*}
then begin
nextch;
if ch = '.'
then ch := ':'
else begin
sy := realcon; {*当前符号为实型*}
rnum := inum; {*实型整数部分为刚刚求得的inum*}
e := 0; {*实型指数部分为0*}
while ( ch >= '0' ) and ( ch <= '9' ) do {*先不算小数点，得到全部整数部分和小数部分*}
begin
e := e - 1; {*e记录需要移动小数点的位数*}
rnum := 10.0 * rnum + (ord(ch) - ord('0'));
nextch
end;
if e = 0 {*如果e为0,则说明小数点后面没有数字，报错err40*}
then error(40);
if ch = 'e' {*如果小数部分后面紧跟着'e',则说明为科学计数法表示的实型，调用指数分析过程*}
then readscale;
if e <> 0 then adjustscale
end
end
else if ch = 'e'{*如果当前字符为'e',处理科学计数法表示的实型*}
then begin
sy := realcon;
rnum := inum; {*实型整数部分即为刚刚得到的整数部分*}
e := 0;
readscale; {*调用处理指数部分过程*}
if e <> 0
then adjustscale
end;
end;
':': {*如果是':'*}
begin
nextch;
if ch = '=' {*如果下一个字符为':',则当前符号为赋值符号，并赋给sy对应的编码*}
then begin
sy := becomes;
nextch
end
else sy := colon {*否则，当前符号为冒号*}
end;
'<': {*如果是'<'*}
begin
nextch;
if ch = '=' {*'如果是'=',则当前符号为<='*}
then begin
sy := leq;
nextch
end
else
if ch = '>' {*如果是'>',则当前符号为<>号*}
then begin
sy := neq;
nextch
end
else sy := lss {*否则当前符号为<*}
end;
'>': {*如果是'>'*}
begin
nextch;
if ch = '=' {*如果是'=',则当前符号为>=*}
then begin
sy := geq;
nextch
end
else sy := gtr {*否则，当前符号为>*}
end;
'.': {*如果是'.'*}
begin
nextch;
if ch = '.' {*如果下一个符号也是'.',则当前符号为..,并赋值sy为冒号对应的编码*}
then begin
sy := colon;
nextch
end
else sy := period {*否则当前符号为.*}
end;
'''': {*如果当前符号是'*}
begin
k := 0;
2: nextch;
if ch = '''' {*如果第二个符号也是'*}
then begin
nextch;
if ch <> '''' {*如果第三个符号不是'，此时输入并不合法，因为引号中没有任何字符串或字符，跳转到label3*}
then goto 3
end;
if sx + k = smax {*如果第二个符号不是'并且字符串表已满*}
then fatal(7); {*则打印字符串表溢出信息*}
stab[sx+k] := ch; {*若字符串表没有溢出，则将当前字符记录到stab中*}
k := k + 1; {*当前字符计数器加1*}
if cc = 1 {*如果一行结束，即当前字符指针指向新一行的第一个字符，则置k为0*}
then begin { end of line }
k := 0;
end
else goto 2; {*如果一行没有结束，则继续读入下一个字符*}
3: if k = 1 {*如果单引号内的字符计数为1*}
then begin
sy := charcon; {*则的引号内内容为字符类型*}
inum := ord( stab[sx] ) {*将inum值赋为该字符对应的ASCII码值*}
end
else if k = 0 {*如果单引号内的字符计数为0*}
then begin
error(38); {*则进行报错err38*}
sy := charcon; {*将sy赋值为字符类型*}
inum := 0 {*inum赋值为0*}
end
else begin {*如果单引号内的字符计数大于1,则说明引号内的内容为一个字符串*}
sy := stringcon; {*sy赋值为字符串类型*}
inum := sx; {inum赋值为字符串起始地址}
sleng := k; {sleng记录字符长度}
sx := sx + k {更新字符串表指针}
end
end;
'(': {*如果当前字符是'('*}
begin
nextch;
if ch <> '*' {*当前字符不为'*'*}
then sy := lparent (*则说明读入的符号为左括号*)
else begin { comment } {*如果当前字符为'*'*}
nextch;
if ch = '$' {*如果当前字符为'$',则说明为编译可选项，调用option函数进行分析,形式为(*$t-,s+*)*}
then options;
repeat {*处理注释*}
while ch <> '*' do nextch;
nextch
until ch = ')';
nextch;
goto 1 {*跳过无用信息，重新进入读取符号函数*}
end
end;
'{': {*如果是大括号*}
begin
nextch;
if ch = '$' {*处理编译可选项，形式为{$t+}*}
then options;
while ch <> '}' do {*处理注释*}
nextch;
nextch;
goto 1
end;
'+', '-', '*', '/', ')', '=', ',', '[', ']', ';': {*如果当前符号为分隔符*}
begin
sy := sps[ch];
nextch
end;
'$','"' ,'@', '?', '&', '^', '!': {*如果当前符号为不合法字符，则报错err24*}
begin
error(24);
nextch;
goto 1
end
end { case }
end { insymbol };
{*
过程名:enter;(分程序外)
功能:把标准类型、过程和函数的名字登录到符号表中;
参数:x0:名字;
x1:种类;
x2:类型;
x3:地址;
*}
procedure enter(x0:alfa; x1:objecttyp; x2:types; x3:integer );
begin
t := t + 1; { enter standard identifier } {*符号表初始指针加1*}
with tab[t] do
begin {*各个域内容的填写*}
name := x0;
link := t - 1;
obj := x1;
typ := x2;
ref := 0; {*规定主程序层次为1，此时为0*}
normal := true;
lev := 0;
adr := x3;
end
end; { enter }
{*
过程名:enterarray;
功能:登陆数组信息向量表;
参数:tp:数组类型;
l:数组下界;
h:数组上届;
*}
procedure enterarray( tp: types; l,h: integer );
begin
if l > h {*下界大于上届*}
then error(27);
if( abs(l) > xmax ) or ( abs(h) > xmax ) {*下界或上界的绝对值超过允许的最大整数值*}
then begin
error(27);
l := 0;
h := 0;
end;
if a = amax {*数组信息向量表溢出,则打印溢出信息*}
then fatal(4)
else begin {*登陆数组信息*}
a := a + 1;
with atab[a] do
begin
inxtyp := tp;
low := l;
high := h
end
end
end { enterarray };
{*
过程名:enterblock;
功能:登录分程序表;
*}
procedure enterblock;
begin
if b = bmax {*分程序表溢出，则打印溢出信息*}
then fatal(2)
else begin {*登录分程序信息*}
b := b + 1;
btab[b].last := 0; {*指向过程或函数最后一个符号在表中的位置,用于建表*}
btab[b].lastpar := 0; {*向过程或者函数的最后一个'参数'符号在tab中的位置,用于退栈*}
end
end { enterblock };
{*
过程名:enterreal;
功能:登录实常数表;
参数:x:实常数常量;
*}
procedure enterreal( x: real );
begin
if c2 = c2max - 1 {*实常数表溢出,打印溢出信息*}
then fatal(3)
else begin
rconst[c2+1] := x; {*登录信息*}
c1 := 1; {*查表*}
while rconst[c1] <> x do
c1 := c1 + 1;
if c1 > c2
then c2 := c1
end
end { enterreal };
{*
过程名:emit;
功能:生成P-code,没有操作数;
参数:fct:助记符编号;
*}
procedure emit( fct: integer );
begin
if lc = cmax {*P-code表溢出，打印溢出信息*}
then fatal(6);
code[lc].f := fct; {*登录助记符信息*}
lc := lc + 1
end { emit };
{*
过程名:emit1;
功能:生成P-code,只有一个操作数;
参数:fct:助记符编号;
b:第二个操作数;
*}
procedure emit1( fct, b: integer );
begin
if lc = cmax
then fatal(6);
with code[lc] do
begin
f := fct;
y := b;
end;
lc := lc + 1
end { emit1 };
{*
过程名:emit2;
功能:生成P-code,有两个操作数;
参数:fct:助记符编号;
a:第一个操作数;
b:第二个操作数;
*}
procedure emit2( fct, a, b: integer );
begin
if lc = cmax then fatal(6);
with code[lc] do
begin
f := fct;
x := a;
y := b
end;
lc := lc + 1;
end { emit2 };
{*
过程名:printtables;
功能:打印编译生成的符号表,分程序表,实常量数表,以及P-code表;
*}
procedure printtables;
var i: integer;
o: order;
mne: array[0..omax] of
packed array[1..5] of char;
begin
mne[0] := 'LDA '; mne[1] := 'LOD '; mne[2] := 'LDI ';
mne[3] := 'DIS '; mne[8] := 'FCT '; mne[9] := 'INT ';
mne[10] := 'JMP '; mne[11] := 'JPC '; mne[12] := 'SWT ';
mne[13] := 'CAS '; mne[14] := 'F1U '; mne[15] := 'F2U ';
mne[16] := 'F1D '; mne[17] := 'F2D '; mne[18] := 'MKS ';
mne[19] := 'CAL '; mne[20] := 'IDX '; mne[21] := 'IXX ';
mne[22] := 'LDB '; mne[23] := 'CPB '; mne[24] := 'LDC ';
mne[25] := 'LDR '; mne[26] := 'FLT '; mne[27] := 'RED ';
mne[28] := 'WRS '; mne[29] := 'WRW '; mne[30] := 'WRU ';
mne[31] := 'HLT '; mne[32] := 'EXP '; mne[33] := 'EXF ';
mne[34] := 'LDT '; mne[35] := 'NOT '; mne[36] := 'MUS ';
mne[37] := 'WRR '; mne[38] := 'STO '; mne[39] := 'EQR ';
mne[40] := 'NER '; mne[41] := 'LSR '; mne[42] := 'LER ';
mne[43] := 'GTR '; mne[44] := 'GER '; mne[45] := 'EQL ';
mne[46] := 'NEQ '; mne[47] := 'LSS '; mne[48] := 'LEQ ';
mne[49] := 'GRT '; mne[50] := 'GEQ '; mne[51] := 'ORR ';
mne[52] := 'ADD '; mne[53] := 'SUB '; mne[54] := 'ADR ';
mne[55] := 'SUR '; mne[56] := 'AND '; mne[57] := 'MUL ';
mne[58] := 'DIV '; mne[59] := 'MOD '; mne[60] := 'MUR ';
mne[61] := 'DIR '; mne[62] := 'RDL '; mne[63] := 'WRL ';
writeln(psout);
writeln(psout);
writeln(psout);
{*打印tab表信息*}
writeln(psout,' identifiers link obj typ ref nrm lev adr');
writeln(psout);
for i := btab[1].last to t do
with tab[i] do {*除去编译初启登录的类型,函数名等信息*}
writeln( psout, i,' ', name, link:5, ord(obj):5, ord(typ):5,ref:5, ord(normal):5,lev:5,adr:5);
writeln( psout );
writeln( psout );
writeln( psout );
{*打印btab信息*}
writeln( psout, 'blocks last lpar psze vsze' );
writeln( psout );
for i := 1 to b do
with btab[i] do
writeln( psout, i:4, last:9, lastpar:5, psize:5, vsize:5 );
writeln( psout );
writeln( psout );
writeln( psout );
{*打印atab信息*}
writeln( psout, 'arrays xtyp etyp eref low high elsz size');
writeln( psout );
for i := 1 to a do
with atab[i] do
writeln( psout, i:4, ord(inxtyp):9, ord(eltyp):5, elref:5, low:5, high:5, elsize:5, size:5);
writeln( psout );
writeln( psout );
writeln( psout );
{*打印P-code表信息*}
writeln( psout, 'code:');
writeln( psout );
for i := 0 to lc-1 do
begin
write( psout, i:5 );
o := code[i];
write( psout, mne[o.f]:8, o.f:5 ); {*打印输出助记符*}
if o.f < 31 {*按照操作数个数输出P-code指令*}
then if o.f < 4
then write( psout, o.x:5, o.y:5 )
else write( psout, o.y:10 )
else write( psout, ' ' );
writeln( psout, ',' )
end;
writeln( psout );
writeln( psout, 'Starting address is ', tab[btab[1].last].adr:5 )
end { printtables };
{*
过程名:block;
功能:分析处理分程序;
参数:fsys:传入的test集合检验符号合法性，容错处理;
isfun:
level:处理的分程序所在层数;
*}
procedure block( fsys: symset; isfun: boolean; level: integer );
type conrec = record {*该记录可以根据不同类型的变量来保存数据*}
case tp: types of
ints, chars, bools : ( i:integer );
reals :( r:real )
end;
var dx : integer ; { data allocation index } {*数据分配索引*}
prt: integer ; { t-index of this procedure } {*本过程tab头索引*}
prb: integer ; { b-index of this procedure } {*本过程btab头索引*}
x : integer ;
{*
过程名:skip;
功能:跳读源程序，直至取来的符号属于给出的符号集为止,并打印出出错标志;
参数:fsys: 给定的符号集;
n:错误编号;
*}
procedure skip( fsys:symset; n:integer);
begin
error(n);
skipflag := true;
while not ( sy in fsys ) do
insymbol;
if skipflag then endskip
end { skip };
{*
过程名:test;
功能:测试当前符号是否为分号;
参数:s1:
s2:
n:
*}
procedure test( s1,s2: symset; n:integer );
begin
if not( sy in s1 )
then skip( s1 + s2, n )
end { test };
{*
过程名:testmicolon;
功能；测试当前符号是否为分号;
*}
procedure testsemicolon;
begin
if sy = semicolon
then insymbol
else begin
error(14);
if sy in [comma, colon]
then insymbol
end;
test( [ident] + blockbegsys, fsys, 6 )
end { testsemicolon };
{*
过程名:enter;
功能:在符号表中登录分程序说明部分出现的名字;
参数:id:名字;
k:种类;
*}
procedure enter( id: alfa; k:objecttyp );
var j,l : integer;
begin
if t = tmax {*tab溢出，打印溢出信息*}
then fatal(1)
else begin
tab[0].name := id;{*每一层过程的在tab中的第一个符号link值为0*}
j := btab[display[level]].last; {*为当前层最后一个 标识符在tab中的位置*}
l := j;
while tab[j].name <> id do
j := tab[j].link;
if j <> 0 {*如果j!=0则说明该符号已被重复定义*}
then error(1)
else begin {*将信息登录到tab表中*}
t := t + 1;
with tab[t] do {*登录符号信息*}
begin
name := id;
link := l;
obj := k;
typ := notyp; {*类型此时不确定，在typ过程中得到*}
ref := 0;
lev := level; {*当前静态层次*}
adr := 0;
normal := false { initial value }
end;
btab[display[level]].last := t {*更新当前过程的最后一个符号在tab中的位置*}
end
end
end { enter };
{*
过程:loc;
功能:查找标识符在符号表中的位置;
参数:id:查找的参数名;
返回值:loc:interger,若找到id，则返回id在tab表中的位置;否则返回0;
*}
function loc( id: alfa ):integer;
var i,j : integer; { locate if in table }
begin
i := level;
tab[0].name := id; { sentinel }
repeat
j := btab[display[i]].last;
while tab[j].name <> id do {*在本层查找*}
j := tab[j].link;
i := i - 1; {*本层为找到在上一层继续查找*}
until ( i < 0 ) or ( j <> 0 );
if j = 0 {*如果j=0,则未找到该符号，报错err0*}
then error(0);
loc := j {*如果找到,则返回该符号的位置*}
end { loc } ;
{*
过程名:entervariable;
功能:将变量名登录到符号表中;
*}
procedure entervariable;
begin
if sy = ident
then begin
enter( id, vvariable ); {*调用enter过程登录变量名*}
insymbol
end
else error(2) {*如果要登录的符号不是一个标识符，则报错err2*}
end { entervariable };
{*
过程名:constant;
功能:处理程序中出现的常量,并由参数(c)返回该常量的类型和数值;
参数:fsys:给定检测符号集合;
c:返回该常量的类型和数值;
*}
procedure constant( fsys: symset; var c: conrec );
var x, sign : integer; {*正负号标志*}
begin
c.tp := notyp;
c.i := 0;
test( constbegsys, fsys, 50 );
if sy in constbegsys {*第一个符号是常量开始的符号才继续进行分析*}
then begin
if sy = charcon {*如果当前符号为字符类型*}
then begin
c.tp := chars; {*在c中记录字符类型*}
c.i := inum; {*在c中记录字符值*}
insymbol
end
else begin {*当前符号为数值或者标识符*}
sign := 1;
if sy in [plus, minus] {*为正负号*}
then begin
if sy = minus
then sign := -1; {*负sign标记为-1*}
insymbol
end;
if sy = ident {*为标识符*}
then begin
x := loc(id); {*在符号表中查找该符号*}
if x <> 0 {*查到*}
then
if tab[x].obj <> konstant {*判断类型标记是否为常量,不是常量则报错err25,常量定义中等号后面必须为常数或常量标识符*}
then error(25)
else begin
c.tp := tab[x].typ; {*c.ty赋值为当前符号的类型*}
if c.tp = reals {*如果当前为real型*}
then c.r := sign*rconst[tab[x].adr] {*tab[x].adr为id在rconst中的索引值，求得当前的实数值后赋给c.r*}
else c.i := sign*tab[x].adr {*如果不为常实数，则tab中的adr即为当前的常量值*}
end;
insymbol
end
else if sy = intcon {*如果当前符号为数字型*}
then begin
c.tp := ints;
c.i := sign*inum;
insymbol
end
else if sy = realcon{*如果当前符号为实数型*}
then begin
c.tp := reals;
c.r := sign*rnum;
insymbol
end
else skip(fsys,50) {*否则略过非法字符*}
end;
test(fsys,[],6) {*对后继符号进行检查*}
end
end { constant };
{*
过程名:typ;
功能:处理类型描述，由参数得到它的类型(tp),指向类型详细信息表的指针(ref)和该类型的大小;
参数:fsys:合法的符号集合，用来检测字符的合法性;
tp:返回参数的类型;
rf:返回参数的详细信息表的指针;
sz:返回该类型的大小;
*}
procedure typ( fsys: symset; var tp: types; var rf,sz:integer );
var eltp : types;
elrf, x : integer;
elsz, offset, t0, t1 : integer;
{*
过程名:arraytyp;
功能:处理数组类型,由参数返回值指向该数组信息向量表的指针(aref)和数组大小(arsz);
参数:aref:返回该数组信息向量表的指针;
arsz:返回该数组大小;
*}
procedure arraytyp( var aref, arsz: integer );
var eltp : types;
low, high : conrec; {*上下界类型*}
elrf, elsz: integer;
begin
constant( [colon, rbrack, rparent, ofsy] + fsys, low ); {*查找该low常量并返回其值和类型*}
if low.tp = reals {*如果下标为实型*}
then begin
error(27); {*报错err27实型上下界违法*}
low.tp := ints;
low.i := 0
end;
if sy = colon {*如果当前符号为..*}
then insymbol
else error(13);
constant( [rbrack, comma, rparent, ofsy ] + fsys, high ); {*查找high常量并返回其值和类型*}
if high.tp <> low.tp {*如果上下界类型不同,报错err27*}
then begin
error(27);
high.i := low.i
end;
enterarray( low.tp, low.i, high.i ); {*上下界类型相同,则将该数组登录到atab中*}
aref := a; {*返回值aref指向当前atab索引值*}
if sy = comma {*如果当前符号为,则说明该数组为多维数组*}
then begin
insymbol;
eltp := arrays; {*该数组元素类型为数组类型，为下面计算size做准备*}
arraytyp( elrf, elsz ) {*递归调用arraytyp，分析多维数组*}
end
else begin
if sy = rbrack {*如果当前符号不是右中括号，则进行报错err12*}
then insymbol
else begin
error(12);
if sy = rparent {*如果数组下标右侧符号为右括号，则进行容错处理*}
then insymbol
end;
if sy = ofsy {*如果当前符号为of*}
then insymbol
else error(8);
typ( fsys, eltp, elrf, elsz ) {*对数组类型符号进行查找，并且将该类型的种类，符号表中的位置，大小记录在对应的参数中*}
end;
with atab[aref] do {*完善atab中的当前数组信息*}
begin
arsz := (high-low+1) * elsz; {*返回值arsz记录数组大小*}
size := arsz;
eltyp := eltp;
elref := elrf;
elsize := elsz
end
end { arraytyp };
begin { typ }
tp := notyp;
rf := 0;
sz := 0;
test( typebegsys, fsys, 10 );
if sy in typebegsys
then begin
if sy = ident {*如果当前符号为标识符*}
then begin
x := loc(id); {*查找ident在tab中的位置*}
if x <> 0
then with tab[x] do
if obj <> typel {*如果不是type类型，则报错err29*}
then error(29)
else begin
tp := typ; {*返回值tp记录该类型描述符的类型*}
rf := ref; {*返回该类型详细信息表指针*}
sz := adr; {*返回类型大小*}
if tp = notyp {*如果未定义类型，报错err30*}
then error(30)
end;
insymbol
end
else if sy = arraysy {*如果是数组类型*}
then begin
insymbol;
if sy = lbrack {*如果array后不为[*}
then insymbol
else begin
error(11); {*报错err11*}
if sy = lparent {*如果是(,则进行容错处理*}
then insymbol
end;
tp := arrays; {*返回类型描述符的类型为array*}
arraytyp(rf,sz) {*调用arrtyp,类型描述符指针信息和大小*}
end
else begin { records } {*如果是记录*}
insymbol;
enterblock; {*登录btab，为当前记录分配一块btab表项*}
tp := records; {*返回typ为记录类型*}
rf := b; {*rf为btab当前索引值*}
if level = lmax {*如果当前嵌套层次超过限制的最大值，则报告溢出错误*}
then fatal(5);
level := level + 1; {*记录的信息登录相当于进入新的一层程序,level+1*}
display[level] := b; {*更新display表，建立分层次索引*}
offset := 0; {*域名偏移初始值为0*}
while not ( sy in fsys - [semicolon,comma,ident]+ [endsy] ) do {*循环处理record中的所有字符*}
begin { field section }
if sy = ident {*如果当前符号为标识符*}
then begin
t0 := t; {*记录该类型第一个标识符在tab中的位置*}
entervariable; {*登录tab表，将该变量信息加入tab中*}
while sy = comma do {*只要遇到,说明还有同一类型的变量需要记录到tab中*}
begin
insymbol;
entervariable
end;
if sy = colon {*如果当前符号为:*}
then insymbol
else error(5); {*不为:,报错err5*}
t1 := t; {*记录该类型最后一个域名在tab表中的位置*}
typ( fsys + [semicolon, endsy, comma,ident], eltp, elrf, elsz ); {*查找该类域名的类型信息*}
while t0 < t1 do {*对同一类型的所有域名在tab中登录其详细信息*}
begin
t0 := t0 + 1;
with tab[t0] do
begin
typ := eltp; {*记录类型*}
ref := elrf;
normal := true;
adr := offset; {*记录该域名相对于起始变量的偏移值*}
offset := offset + elsz
end
end
end; { sy = ident }
if sy <> endsy {*如果是end符号,变量声明结束*}
then begin
if sy = semicolon {*检测end后是否为;*}
then insymbol
else begin
error(14); {*不是;则报错*}
if sy = comma {*如果是逗号则进行容错处理*}
then insymbol
end;
test( [ident,endsy, semicolon],fsys,6 ) {*对后继符号合法性进行检查*}
end
end; { field section }
btab[rf].vsize := offset; {完善btab中record的信息,记录record的大小}
sz := offset; {*返回该类型的大小*}
btab[rf].psize := 0; {*没有参数,记录为0*}
insymbol;
level := level - 1 {*登录信息完毕,退出该层*}
end; { record }
test( fsys, [],6 )
end;
end { typ };
{*
过程名:parameterlist;
功能:处理过程或函数说明中的形参表,将形参及其有关信息登录到符号表中;
*}
procedure parameterlist; { formal parameter list }
var tp : types;
valpar : boolean;
rf, sz, x, t0 : integer;
begin
insymbol;
tp := notyp;
rf := 0;
sz := 0;
test( [ident, varsy], fsys+[rparent], 7 ); {*形参的第一个参数必须是var或者标识符*}
while sy in [ident, varsy] do {*循环处理所有参数*}
begin
if sy <> varsy {*如果当前符号不是var*}
then valpar := true {*标记valpar变量为true*}
else begin
insymbol;
valpar := false {*是var则标记valpar为false,并读入下一个符号*}
end;
t0 := t; {*记录tab表此时的索引位置*}
entervariable;
while sy = comma do {*循环处理同一类型的形式参数*}
begin
insymbol;
entervariable; {*将所有的形参登录到tab表中*}
end;
if sy = colon {*如果当前符号为:,其后的符号为该类形参的类型描述符*}
then begin
insymbol;
if sy <> ident {*如果类型描述符不是标识符,则报错err2*}
then error(2)
else begin
x := loc(id); {*查找该标识符在tab中的位置*}
insymbol;
if x <> 0 {*如果找到了这个标识符*}
then with tab[x] do
if obj <> typel {*如果不是typ类型,则报错err29*}
then error(29)
else begin
tp := typ; {*记录当前类型描述符的类型*}
rf := ref; {*记录当前描述符在符号表中的位置*}
if valpar
then sz := adr {*如果是值形参,则sz为当前参数相应的取值地址*}
else sz := 1 {*如果是引用参数,则使sz为1*}
end;
end;
test( [semicolon, rparent], [comma,ident]+fsys, 14 ) {*检验后继符号是否合法，不合法报错err14*}
end
else error(5); {*如果形参的后继符号不是冒号,则报错err5*}
while t0 < t do {*对同一类型的形参信息进行反填*}
begin
t0 := t0 + 1;
with tab[t0] do
begin
typ := tp;
ref := rf;
adr := dx; {*填入的地址为该形参在运行栈中分配存储单元的相对地址*}
lev := level;
normal := valpar; {*如果是变量形参就置normal为false;如果是值形参就置normal为true*}
dx := dx + sz {*对栈中的存储单元的地址进行更新*}
end
end;
if sy <> rparent {*如果是),则说明形式参数已经全部处理完*}
then begin
if sy = semicolon {*过程或者函数的头部结尾应该为;*}
then insymbol
else begin
error(14); {*如果不是;则报告err14*}
if sy = comma {*如果是逗号,则进行容错处理*}
then insymbol
end;
test( [ident, varsy],[rparent]+fsys,6) {*检测尾部符号是否合法,否则报告err6*}
end
end { while };
if sy = rparent {*如果当前符号是),则说明该过程或者函数没有参数*}
then begin
insymbol;
test( [semicolon, colon],fsys,6 ) {*测试后继符号的合法性*}
end
else error(4) {*缺少右括号,不完整的过程或者函数头部或说明,报告err4*}
end { parameterlist };
{*
过程名:constdec;
功能:处理常量定义,将常量名及其相应信息填入符号表;
*}
procedure constdec;
var c : conrec;
begin
insymbol;
test([ident], blockbegsys, 2 ); {*合法的常量应该以标识符为开头符号*}
while sy = ident do {*循环处理所有的常量标识符*}
begin
enter(id, konstant); {*将该标识符登录到tab中*}
insymbol;
if sy = eql {*如果常量标识符的后继符号是=,则读取下一个符号*}
then insymbol
else begin
error(16); {*如果不是=,则进行报错err16*}
if sy = becomes {*如果是:=,则进行容错处理*}
then insymbol
end;
constant([semicolon,comma,ident]+fsys,c); {*查找:=后的常量值,并将信息赋给返回值c*}
tab[t].typ := c.tp; {*对该常量标识符的相关信息反填以完善，在tab中记录该常量标识符的类型*}
tab[t].ref := 0; {*该常量标识符的相关索引指针记为0*}
if c.tp = reals {*如果这个常量的类型为实型*}
then begin
enterreal(c.r); {*则将该常量登录到rconst中*}
tab[t].adr := c1; {*将tab中该常量的地址记为为rconst中常量对应的索引值*}
end
else tab[t].adr := c.i; {*否则adr为该常量的值*}
testsemicolon
end
end { constdec };
{*
过程名:typedeclaration;
功能:处理类型定义,并将类型名及其信息填入符号表;
*}
procedure typedeclaration;
var tp: types;
rf, sz, t1 : integer;
begin
insymbol;
test([ident], blockbegsys,2 ); {*类型声明符号必须以ident标识符开头*}
while sy = ident do {*循环处理type关键字后的所有类型符号*}
begin
enter(id, typel); {*将该typel符号登录到符号表中*}
t1 := t; {*记录第一个类型声明符号在tab中的位置*}
insymbol;
if sy = eql {*如果标识符的后继符号是=,则读入下一个符号*}
then insymbol
else begin
error(16); {*标识符后继符号不是=,则报告错误err16*}
if sy = becomes {*如果是:=,则进行容错处理*}
then insymbol
end;
typ( [semicolon,comma,ident]+fsys, tp,rf,sz ); {*对该类型声明符号被赋予的类型进行检测*}
with tab[t1] do {*对该类型声明符号的其他信息进行反填以完善*}
begin
typ := tp; {*标记类型*}
ref := rf; {*标记指针*}
adr := sz {*标记地址*}
end;
testsemicolon {*检测类型声明符号尾部符号是否为;*}
end
end { typedeclaration };
{*
过程名:variabledeclaration;
功能:处理变量定义,并将变量名及相应信息填入符号表;
*}
procedure variabledeclaration;
var tp : types;
t0, t1, rf, sz : integer;
begin
insymbol;
while sy = ident do {*循环处理所有变量名*}
begin
t0 := t; {*记录当前符号表的位置,即第一个变量名登录符号表的位置*}
entervariable; {*将该变量名登录符号表*}
while sy = comma do {*循环处理同一类型的变量,同一类型的变量用逗号分隔开*}
begin
insymbol;
entervariable;
end;
if sy = colon {*如果是冒号,则接下来进行类型说明*}
then insymbol
else error(5); {*如果不是冒号则报告错误err5*}
t1 := t; {*记录同一类型最后一个变量名在符号表中的位置*}
typ([semicolon,comma,ident]+fsys, tp,rf,sz ); {*检测该类型的相关信息*}
while t0 < t1 do {*在符号表中对该种类型的所有变量进行反填以完善信息*}
begin
t0 := t0 + 1;
with tab[t0] do
begin
typ := tp; {*记录类型*}
ref := rf; {*记录指针*}
lev := level; {*记录当前分层信息*}
adr := dx; {*变量地址为和运行栈现在的栈指针头部*}
normal := true; {*给normal域赋值*}
dx := dx + sz {*累加运行栈存储空间,更新栈顶指针*}
end
end;
testsemicolon
end
end { variabledeclaration };
{*
过程名:procedclaration;
功能:处理过程或者函数说明,将过程名填入符号表,递归调用block分析处理程序(层次level+1);
*}
procedure procdeclaration;
var isfun : boolean;
begin
isfun := sy = funcsy; {*如果是function,isfun赋值为true;为procedure,isfun赋值为false*}
insymbol;
if sy <> ident {*function和procedure后继符号必须为一标识符作为名字*}
then begin
error(2); {*如果不是标识符则报告错误err2*}
id :=' '
end;
if isfun
then enter(id,funktion) {*如果是function,则将该函数名登录到tab表中,并标记类型为function*}
else enter(id,prozedure); {*如果是procedure,则将该函数名登录到tab表中,并标记类型为procedure*}
tab[t].normal := true;
insymbol;
block([semicolon]+fsys, isfun, level+1 ); {*分析处理该function或者procedure分程序*}
if sy = semicolon {*如果是;,则读入下一符号,否则报告错误err14*}
then insymbol
else error(14);
emit(32+ord(isfun)) {exit} {*生成p-code指令;32:退出过程;31:退出函数*}
end { proceduredeclaration };
{*
过程名:statement;
功能:分析处理各种语句;
*}
procedure statement( fsys:symset );
var i : integer;
{*
过程名:expression;
功能:分析处理表达式,由参数(x)返回求值结果的类型;
*}
procedure expression(fsys:symset; var x:item); forward;
{*
过程名:sector;
功能:处理结构变量;数组下标变量或记录成员变量;
参数:fsys:合法字符集合,检测字符是否合法;
v:一个结构体;
typ:类型,v是一个数组还是一个记录;
index:v在btab或者atab中的索引;
*}
procedure selector(fsys:symset; var v:item);
var x : item;
a,j : integer;
begin { sy in [lparent, lbrack, period] } {*首符号为(,[,.之一*}
repeat
if sy = period {*处理记录成员变量,.xx*}
then begin
insymbol; { field selector }
if sy <> ident {*.后不是标识符,则报错err2*}
then error(2)
else begin
if v.typ <> records {*如果访问的数据不是记录类型,报错err31,即没有这样的记录*}
then error(31)
else begin { search field identifier } {*如果是合法的记录类型,开始查找对应的记录成员变量的值*}
j := btab[v.ref].last; {*该记录最后一个标识符在tab中的位置*}
tab[0].name := id; {*令tab[0]为当前访问的记录成员名*}
while tab[j].name <> id do {*在该记录的所有成员变量里从后往前找需要访问的成员变量在tab中的位置*}
j := tab[j].link;
if j = 0 {*如果没有找到,则说明该成员变量未被声明过,报告错误err0*}
then error(0);
v.typ := tab[j].typ; {*v.typ为成员类型*}
v.ref := tab[j].ref; {*v.ref为成员变量所在分程序在btab中的位置*}
a := tab[j].adr; {*a为成员变量相对于起始变量的位移*}
if a <> 0 {*如果位移不为0*}
then emit1(9,a) {*生成p-code指令,栈顶指针加a,计算该成员变量的地址*}
end;
insymbol
end
end
else begin { array selector } {*处理数组成员变量*}
if sy <> lbrack
then error(11);
repeat {*如果是合法的[*}
insymbol;
expression( fsys+[comma,rbrack],x); {*处理[]内的表达式,并将结果值返回于x中*}
if v.typ <> arrays {*如果需要访问的v不是数组类,报告错误err28*}
then error(28)
else begin
a := v.ref; {*a为数组v在atab中的索引位置*}
if atab[a].inxtyp <> x.typ {*如果数组指定下标与[]内计算得出的下标类型不符,报告错误err26*}
then error(26)
else if atab[a].elsize = 1
then emit1(20,a) {*p-code,取下标变量地址,元素长度为1,即为形参*}
else emit1(21,a); {*p-code,取下标变量地址,为实参*}
v.typ := atab[a].eltyp; {*v-typ为被访问元素的类型*}
v.ref := atab[a].elref {*v-ref为被访问元素在atab或btab中的位置*}
end
until sy <> comma; {*访问多维数组*}
if sy = rbrack {*检查]是否存在*}
then insymbol
else begin
error(12);
if sy = rparent {*)容错处理*}
then insymbol
end
end
until not( sy in[lbrack, lparent, period]); {*循环处理直到所有子结构或数组都被处理完*}
test( fsys,[],6)
end { selector };
{*
过程名:call;
功能：处理非标准的过程或函数调用;
参数:fsys:合法的字符集合,对字符的合法性进行检测;
i:被调用过程或函数在tab表中的位置;
*}
procedure call( fsys: symset; i:integer );
var x : item;
lastp,cp,k : integer;
begin
emit1(18,i); { mark stack } {*生成p-code指令,标记栈,i为被调用的过程或者函数在tab表中的位置,建立新的内务信息区*}
lastp := btab[tab[i].ref].lastpar; {*lastp为该过程或者函数最后一个参数在tab中的位置*}
cp := i; {*cp记录该function或procedure在tab中的位置*}
if sy = lparent {*遇到(,处理过程或函数中的参数*}
then begin { actual parameter list }
repeat {*循环处理所有参数*}
insymbol;
if cp >= lastp {*如果当前符号名在tab中的位置大于其最后一个参数在tab中的位置,则说明报错err39,否则还有参数没有被处理完*}
then error(39)
else begin
cp := cp + 1;
if tab[cp].normal {*如果当前参数是值形参或其他参数*}
then begin { value parameter }
expression( fsys+[comma, colon,rparent],x); {*求得实参值和类型记录在x中*}
if x.typ = tab[cp].typ {*如果实参类型和形参类型相同*}
then begin
if x.ref <> tab[cp].ref {*如果形参和实参的指针不同*}
then error(36) {*则报错err36*}
else if x.typ = arrays {*如果实参为数组类型*}
then emit1(22,atab[x.ref].size) {*生成p-code,装入块,将该数组装入数据栈的预留参数单元中*}
else if x.typ = records {*如果实参为记录类型*}
then emit1(22,btab[x.ref].vsize) {*生成p-code,装入块*}
end
else if ( x.typ = ints ) and ( tab[cp].typ = reals ) {*如果实参为整数而形参为实数型*}
then emit1(26,0) {*生成p-code指令,浮点数转换*}
else if x.typ <> notyp {*如果实参未声明类型,则报错err36*}
then error(36);
end
else begin { variable parameter } {*如果参数为变量形参*}
if sy <> ident {*如果读到的不为标识符,则报错err2*}
then error(2)
else begin
k := loc(id); {*k记录当前标识符在tab中的位置*}
insymbol;
if k <> 0 {*如果ident在tab中有记录*}
then begin
if tab[k].obj <> vvariable {*如果该标识符的类型不是变量,则报错err37*}
then error(37);
x.typ := tab[k].typ;{*x.typ为该实参的类型*}
x.ref := tab[k].ref; {*x.ref为该实参的指针*}
if tab[k].normal {*如果标识符的类型不为变量形参,可能是一个数之类的*}
then emit2(0,tab[k].lev,tab[k].adr) {*生成p-code,将该实参的地址装入栈中*}
else emit2(1,tab[k].lev,tab[k].adr);{*否则将该变量形参的值装入栈中*}
if sy in [lbrack, lparent, period] {*如果该参数为记录或数组或记录成员变量*}
then selector(fsys+[comma,colon,rparent],x); {*调用selector分析*}
if ( x.typ <> tab[cp].typ ) or ( x.ref <> tab[cp].ref ) {*如果数组或记录的类型和形参不符,或其指针不等,则报错err36*}
then error(36)
end
end
end {variable parameter }
end;
test( [comma, rparent],fsys,6) {*检测后继符号的合法性*}
until sy <> comma; {*检测不到逗号为止,则已处理完所有参数*}
if sy = rparent {*如果参数结尾不是)则报告err4*}
then insymbol
else error(4)
end;
if cp < lastp {*如果实参个数小于形参个数,则报错err39,说明实参的个数太少*}
then error(39); { too few actual parameters }
emit1(19,btab[tab[i].ref].psize-1 ); {*生成p-code,调用过程或者函数*}
if tab[i].lev < level {*如果函数或过程名的静态层次小于当前层次,更新[lev,level]为下标的display区;lev>=level不更新是因为level用不到lev的变量值;比lev小的部分不用更新是因为递归更新*}
then emit2(3,tab[i].lev, level )
end { call };
{*
过程名:resulttype;
功能:处理整型或实行两个操作数运算时的类型转换;
参数:a:操作数1;
b: 操作数2;
返回值:返回转换类型结果;
*}
function resulttype( a, b : types) :types;
begin
if ( a > reals ) or ( b > reals ) {*如果操作数a或b为布尔型,字符型,数组或者记录,则报错err33,算术表达式类型不合法*}
then begin
error(33);
resulttype := notyp {*返回未定义类型*}
end
else if ( a = notyp ) or ( b = notyp ) {*如果a或b为未定义类型,则也返回未定义类型*}
then resulttype := notyp
else if a = ints {*如果a是整数*}
then if b = ints {*如果b也是整数*}
then resulttype := ints {*则返回值也为整数*}
else begin
resulttype := reals; {*否则将a转换为实型,返回值也为实型*}
emit1(26,1) {*生成p-code指令,转换浮点数*}
end
else begin
resulttype := reals; {*如果a是实型,则返回值为实型*}
if b = ints {*如果b是整型,则生成p-code指令,转换浮点数*}
then emit1(26,0)
end
end { resulttype } ;
{*
过程名:expression;
功能:分析处理表达式,由参数(x)返回求值结果的类型;
参数:fsys:合法字符集合,检查字符合法性;
x:
*}
procedure expression( fsys: symset; var x: item );
var y : item;
op : symbol;
{*
过程名：simpleexpression;
功能:处理简单表达式,由参数(x)返回求值结果的类型;
参数: fsys:合法字符集合,检查字符合法性;
x:
*}
procedure simpleexpression( fsys: symset; var x: item );
var y : item;
op : symbol;
{*
过程名:term;
功能:处理项,由参数返回结果类型;
*}
procedure term( fsys: symset; var x: item );
var y : item;
op : symbol;
{*
过程名:factor;
功能:处理因子,由参数返回结果类型;
*}
procedure factor( fsys: symset; var x: item );
var i,f : integer;
{*
过程名:standfct;
功能:处理标准函数调用;
参数:n:标准函数编码;
*}
procedure standfct( n: integer );
var ts : typset;
begin { standard function no. n }
if sy = lparent {*如果当前符号不是(,则报错err9,说明(缺省*}
then insymbol
else error(9);
if n < 17 {*如果编号<17,即为合法的编号*}
then begin
expression( fsys+[rparent], x ); {*计算表达式参数的值*}
case n of
{ abs, sqr } 0,2: begin {*如果是求绝对值,求平凡和函数函数*}
ts := [ints, reals]; {*实参类型要求为整数型或者实型*}
tab[i].typ := x.typ; {*定义返回值类型*}
if x.typ = reals {*如果实参类型为实型*}
then n := n + 1 {*则函数标号+1*}
end;
{ odd, chr } 4,5: ts := [ints]; {*如果是判断奇数和数字转换为符号的函数,实参类型要求为整数型*}
{ odr } 6: ts := [ints,bools,chars]; {*如果是符号转换为数字的函数,实参类型要求为整数型,布尔型,或者字符型*}
{ succ,pred } 7,8 : begin {*如果是后继函数和前驱函数*}
ts := [ints, bools,chars]; {*实参类型要求为整数型,布尔型或者字符型*}
tab[i].typ := x.typ {*定义返回值类型*}
end;
{ round,trunc } 9,10,11,12,13,14,15,16: {*如果是9-16号操作,即数学操作*}
{ sin,cos,... } begin
ts := [ints,reals]; {*实参要求类型为整数型或者实型*}
if x.typ = ints {*如果实参为整数型*}
then emit1(26,0) {*p-code指令,用于转化浮点数*}
end;
end; { case }
if x.typ in ts {*如果实参的类型在求得的类型集合中*}
then emit1(8,n) {*p-code指令,调用标准函数*}
else if x.typ <> notyp {*如果实参的类型未定义,则报告err48,即标准函数变元表达式类型不正确*}
then error(48);
end
else begin { n in [17,18] } {*如果n>17*}
if sy <> ident {*如果当前符号不为标识符,报错err2*}
then error(2)
else if id <> 'input ' {*如果标识符内容不为input,则报告错误err0,即该标识符未定义*}
then error(0)
else insymbol;
emit1(8,n); {*p-code指令,调用标准函数*}
end;
x.typ := tab[i].typ;{*x记录返回值类型*}
if sy = rparent {*如果当前符号为),说明调用过程结束*}
then insymbol
else error(4)
end { standfct } ;
begin { factor } {*因子分析程序*}
x.typ := notyp; {*初始化返回值类型*}
x.ref := 0; {*初始化返回值指针*}
test( facbegsys, fsys,58 );
while sy in facbegsys do {*因子的开头符号必须为合法的标识符*}
begin
if sy = ident {*如果是标识符类型*}
then begin
i := loc(id); {*在tab中查找位置*}
insymbol;
with tab[i] do
case obj of {*检查标识符类型*}
konstant: begin {*如果是常量*}
x.typ := typ; {*赋予返回值类型*}
x.ref := 0; {*赋予返回值指针*}
if x.typ = reals {*如果标识符是实型*}
then emit1(25,adr) {*则装入实数*}
else emit1(24,adr) {*否则,装入字面常量*}
end;
vvariable:begin {*如果是变量*}
x.typ := typ;
x.ref := ref;
if sy in [lbrack, lparent,period] {*如果标识符后方为[,(,.,即存在子结构*}
then begin
if normal {*如果不是变量形参,置f为0,否则置f为1*}
then f := 0
else f := 1;
emit2(f,lev,adr);{*将变量装入栈中,装入值或者地址*}
selector(fsys,x); {*处理子结构,可能为数组或者记录等*}
if x.typ in stantyps {*如果是标准类型,则取栈顶单元内容为地址的内容*}
then emit(34)
end
else begin {*变量没有子结构*}
if x.typ in stantyps {*该变量类型为标准类型*}
then if normal {*如果不是变量形参,置f为1,否则置f为2*}
then f := 1 {*取值*}
else f := 2 {*取地址*}
else if normal {*如果不是标准类型但也不为变量形参*}
then f := 0 {*取值*}
else f := 1; {*否则取地址*}
emit2(f,lev,adr) {*将该变量内容加载入栈,可为值或为地址*}
end
end;
typel,prozedure: error(44); {*如果是过程标识符或者是类型描述符,报错err44,即表达式中不能出现过程符号或类型描述符*}
funktion: begin {*如果是函数标识符*}
x.typ := typ;
if lev <> 0 {*如果该函数静态层次不为0,则调用call函数求得该函数值*}
then call(fsys,i)
else standfct(adr) {*否则,调用静态函数求值*}
end
end { case,with }
end
else if sy in [ charcon,intcon,realcon ] {*如果当前标识符为字符,整型,或者实型*}
then begin
if sy = realcon {*如果为实型*}
then begin
x.typ := reals;
enterreal(rnum); {*将该实型登录到tab表中*}
emit1(25,c1) {*在栈中装入实数*}
end
else begin
if sy = charcon {*如果是字符*}
then x.typ := chars
else x.typ := ints; {*如果是整型*}
emit1(24,inum) {*在栈中装入字面常量*}
end;
x.ref := 0;
insymbol
end
else if sy = lparent {*如果是(*}
then begin
insymbol;
expression(fsys + [rparent],x); {*调用表达式分析程序*}
if sy = rparent {*没有)报错err4*}
then insymbol
else error(4)
end
else if sy = notsy {*如果是not符号*}
then begin
insymbol;
factor(fsys,x); {*调用因子函数进行分析*}
if x.typ = bools {*如果因子为布尔型,逻辑非指令*}
then emit(35)
else if x.typ <> notyp {*如果类型未定义,则报错err32*}
then error(32)
end;
test(fsys,facbegsys,6)
end { while }
end { factor };
begin { term }
factor( fsys + [times,rdiv,idiv,imod,andsy],x); {*调用因子处理程序分析项*}
while sy in [times,rdiv,idiv,imod,andsy] do {*只要当前符号是*,/,div,mod,and,循环处理因子由符号连接仍然是项*}
begin
op := sy; {*记录因子前面的符号,便于后续运算*}
insymbol;
factor(fsys+[times,rdiv,idiv,imod,andsy],y );
if op = times {*如果是**}
then begin
x.typ := resulttype(x.typ, y.typ); {*转换上一个因子类型和当前因子类型*}
case x.typ of
notyp: ;
ints : emit(57); {*如果运算结果是整型,整型乘*}
reals: emit(60); {*如果运算结果是整型,实型乘*}
end
end
else if op = rdiv {*如果是div,实型除法*}
then begin
if x.typ = ints {*如果第一个操作数是整数型*}
then begin
emit1(26,1); {*整型转实型*}
x.typ := reals;
end;
if y.typ = ints {*如果第二个操作数是整数型*}
then begin
emit1(26,0); {*整型转实型*}
y.typ := reals;
end;
if (x.typ = reals) and (y.typ = reals) {*二者都为实型*}
then emit(61) {*实型除法*}
else begin
if( x.typ <> notyp ) and (y.typ <> notyp)
then error(33);
x.typ := notyp
end
end
else if op = andsy {*与运算*}
then begin
if( x.typ = bools )and(y.typ = bools) {*两个操作数都必须为布尔型*}
then emit(56) {*与运算*}
else begin
if( x.typ <> notyp ) and (y.typ <> notyp)
then error(32);
x.typ := notyp
end
end
else begin { op in [idiv,imod] } {*如果符号为整除或者取模*}
if (x.typ = ints) and (y.typ = ints) {*操作数都为整型*}
then if op = idiv {*为整除*}
then emit(58) {*整除指令*}
else emit(59) {*否则取模指令*}
else begin
if ( x.typ <> notyp ) and (y.typ <> notyp)
then error(34); {*否则类型出错*}
x.typ := notyp
end
end
end { while }
end { term };
begin { simpleexpression }
if sy in [plus,minus] {获得符号是+，-}
then begin
op := sy;
insymbol;
term( fsys+[plus,minus],x); {*处理因子*}
if x.typ > reals {*如果因子不是数*}
then error(33) {*报错,算术表达式类型不合法*}
else if op = minus {*如果是减号,生成取相反数指令指令*}
then emit(36)
end
else term(fsys+[plus,minus,orsy],x); {*否则是项,调用函数进行项处理*}
while sy in [plus,minus,orsy] do {*如果是+,-,循环处理,依靠+,-连接的项得到的依然是简单表达式*}
begin
op := sy;
insymbol;
term(fsys+[plus,minus,orsy],y);{*处理新读入的项*}
if op = orsy {*如果是或符号*}
then begin
if ( x.typ = bools )and(y.typ = bools) {*两个项的结果都必须为布尔型*}
then emit(51) {*生成or指令*}
else begin
if( x.typ <> notyp) and (y.typ <> notyp) {*否则操作数类型出错*}
then error(32);
x.typ := notyp
end
end
else begin {*否则进行实数加减*}
x.typ := resulttype(x.typ,y.typ); {*类型转换*}
case x.typ of
notyp: ;
ints: if op = plus {*整数加减*}
then emit(52)
else emit(53);
reals:if op = plus {*实数加减*}
then emit(54)
else emit(55)
end { case }
end
end { while }
end { simpleexpression };
begin { expression }
simpleexpression(fsys+[eql,neq,lss,leq,gtr,geq],x);
if sy in [ eql,neq,lss,leq,gtr,geq] {*如果当前符号为=,<,>,<=,>=,!=*}
then begin
op := sy;
insymbol;
simpleexpression(fsys,y);
if(x.typ in [notyp,ints,bools,chars]) and (x.typ = y.typ){*如果两个简单表达式同类型并且为notyp,整型,布尔型或者字符型*}
then case op of
eql: emit(45); {*是否相等比较运算*}
neq: emit(46); {*不相等*}
lss: emit(47); {*小于*}
leq: emit(48); {*小于等于*}
gtr: emit(49); {*大于*}
geq: emit(50); {*大于等于*}
end
else begin
if x.typ = ints {*第一个操作数为整型*}
then begin
x.typ := reals; {*第一个操作数转换为为实型*}
emit1(26,1)
end
else if y.typ = ints {*如果第二个操作数为整型*}
then begin
y.typ := reals; {*第二个操作数为实型*}
emit1(26,0)
end;
if ( x.typ = reals)and(y.typ=reals) {*操作数都为实型,进行运算*}
then case op of
eql: emit(39);
neq: emit(40);
lss: emit(41);
leq: emit(42);
gtr: emit(43);
geq: emit(44);
end
else error(35)
end;
x.typ := bools
end
end { expression };
{*
过程名:assignment;
功能:处理赋值语句;
*}
procedure assignment( lv, ad: integer );
var x,y: item;
f : integer;
begin { tab[i].obj in [variable,prozedure] } {*当前符号类型为变量或者过程*}
x.typ := tab[i].typ;
x.ref := tab[i].ref;
if tab[i].normal
then f := 0
else f := 1;
emit2(f,lv,ad);
if sy in [lbrack,lparent,period]
then selector([becomes,eql]+fsys,x);
if sy = becomes {*如果不为赋值符号,报错err51*}
then insymbol
else begin
error(51);
if sy = eql {*等号容错处理*}
then insymbol
end;
expression(fsys,y); {*得到赋值符号右侧表达式值*}
if x.typ = y.typ {*被赋值变量与赋值结果类型一致*}
then if x.typ in stantyps {*二者都为标准类型*}
then emit(38) {*将栈顶内容存入以次栈顶内容为地址的单元*}
else if x.ref <> y.ref {*二者不都为标准类型但指针不同,即在btab中的位置不同,报错err46*}
then error(46)
else if x.typ = arrays {*如果被赋值者为数组型*}
then emit1(23,atab[x.ref].size) {*复制atab数组块*}
else emit1(23,btab[x.ref].vsize){*复制btab记录块*}
else if(x.typ = reals )and (y.typ = ints) {*被赋值者为实型,赋值数为整型*}
then begin
emit1(26,0); {*类型转换*}
emit(38) {*赋值操作*}
end
else if ( x.typ <> notyp ) and ( y.typ <> notyp )
then error(46) {*类型不符报错*}
end { assignment };
{*
过程名:compoundstatement;
功能:处理复合语句;
*}
procedure compoundstatement;
begin
insymbol;
statement([semicolon,endsy]+fsys); {*调用语句分析函数处理第一个语句*}
while sy in [semicolon]+statbegsys do {*只要当前字符在复合语句的合法字符集内*}
begin
if sy = semicolon {*如果是分号,处理下一个语句如果不是分号,报错err14*}
then insymbol
else error(14);
statement([semicolon,endsy]+fsys)
end;
if sy = endsy {*如果是end,读入下一个字符;不是end,报错*}
then insymbol
else error(57)
end { compoundstatement };
{*
过程名:ifstatement;
功能:处理if语句;
*}
procedure ifstatement;
var x : item;
lc1,lc2: integer;
begin
insymbol;
expression( fsys+[thensy,dosy],x); {*处理条件表达式的值*}
if not ( x.typ in [bools,notyp]) {*如果结果不是布尔型或者未定义类型*}
then error(17); {报错etrr17}
lc1 := lc; {*labe1*}
emit(11); { jmpc }
if sy = thensy
then insymbol
else begin
error(52);
if sy = dosy {*容错处理*}
then insymbol
end;
statement( fsys+[elsesy]); {"then后处理语句"}
if sy = elsesy
then begin
insymbol;
lc2 := lc; {*label2*}
emit(10); {*无条件跳转*}
code[lc1].y := lc; {*填入有条件跳转指令地址,if后条件为假,跳转至else语句对应的指令*}
statement(fsys); {*处理else后的语句*}
code[lc2].y := lc {*如果处理完if-then后的语句,执行无条件跳转,跳转到else-then结束之后的语句*}
end
else code[lc1].y := lc
end { ifstatement };
{*
过程名；casestatement;
功能:处理case语句;
*}
procedure casestatement;
var x : item;
i,j,k,lc1 : integer;
casetab : array[1..csmax]of
packed record
val,lc : index
end;
exittab : array[1..csmax] of integer;
{*
过程名:caselabel;
功能:处理case语句中的标号,将各标号对应的目标代码入口地址填入case表中,并检查标号有无重复定义;
*}
procedure caselabel;
var lab : conrec;
k : integer;
begin
constant( fsys+[comma,colon],lab ); {*查找标号常量的相关信息*}
if lab.tp <> x.typ {*如果lable的类型和case后的变量类型不同,则报错err47*}
then error(47)
else if i = csmax {*如果case表已满,打印表格溢出信息*}
then fatal(6)
else begin {*case表未满*}
i := i+1; {*添加新的case表项*}
k := 0; {*检查是否重复的变量*}
casetab[i].val := lab.i; {*新的表项中填入label的值*}
casetab[i].lc := lc; {*记录生成case分支代码的位置,用于跳转到case分支语句*}
repeat {*查找重复表项*}
k := k+1
until casetab[k].val = lab.i;
if k < i {*如果找到了,报错err1*}
then error(1); { multiple definition }
end
end { caselabel };
{*
过程名:onecase;
功能:处理case语句的一个分支;
*}
procedure onecase;
begin
if sy in constbegsys
then begin
caselabel;
while sy = comma do {*处理一个分支的所有label项*}
begin
insymbol;
caselabel
end;
if sy = colon {*label后的符号必须为:*}
then insymbol
else error(5);
statement([semicolon,endsy]+fsys);{*处理case后执行语句*}
j := j+1; {*记录当前case对应的exittab的位置*}
exittab[j] := lc; {*记录case分支语句结束后的代码位置,之后在这个位置代码的跳转地址填入case执行结束后的地址*}
emit(10) {*无条件跳转结束当前case分支*}
end
end { onecase };
begin { casestatement }
insymbol;
i := 0;
j := 0;
expression( fsys + [ofsy,comma,colon],x ); {*处理case后的表达式值*}
if not( x.typ in [ints,bools,chars,notyp ]) {*case后表达式类型不符报错err23*}
then error(23);
lc1 := lc; {*记录case声明语句结束的位置,用于查找情况表代码*}
emit(12); {jmpx} {*生成一条条件跳转语句*}
if sy = ofsy {*变量后不为of报错err8*}
then insymbol
else error(8);
onecase; {*处理一条case语句*}
while sy = semicolon do {*循环处理所有case分支语句*}
begin
insymbol;
onecase
end;
code[lc1].y := lc; {*case*} {*code[lcl]为case声明语句结束后的代码,进行无条件跳转,lc为情况表的起始地址*}
for k := 1 to i do
begin
emit1( 13,casetab[k].val); {*生成情况表登记项的伪指令,用于查找情况和跳转地址*}
emit1( 13,casetab[k].lc);
end;
emit1(10,0); {*无条件跳转代码,case语句处理完毕*}
for k := 1 to j do
code[exittab[k]].y := lc; {*code[exittab]为所有cse分支执行结束后的无条件跳转语句,lc为case结束后的指令地址*}
if sy = endsy {*检查case语句结束符号是否为end,不是报错err57*}
then insymbol
else error(57)
end { casestatement };
{*
过程名:repeatstatement;
功能:处理repeat语句;
*}
procedure repeatstatement;
var x : item;
lc1: integer;
begin
lc1 := lc;{**}
insymbol;
statement( [semicolon,untilsy]+fsys); {*处理repeat后的语句,及执行语句*}
while sy in [semicolon]+statbegsys do {*只要语句后是分号,则继续处理执行语句*}
begin
if sy = semicolon
then insymbol
else error(14);
statement([semicolon,untilsy]+fsys)
end;
if sy = untilsy {*执行语句处理结束后为until关键字*}
then begin
insymbol;
expression(fsys,x); {*处理until判断条件内的表达式*}
if not(x.typ in [bools,notyp] ) {*如果表达式结果类型不符*}
then error(17); {*报错err17*}
emit1(11,lc1); {*如果栈顶内容为假,则跳转到lcl,即执行语句的开头*}
end
else error(53) {*不是until报错err53*}
end { repeatstatement };
{*
过程名:whilestatement;
功能:处理while语句
*}
procedure whilestatement;
var x : item;
lc1,lc2 : integer;
begin
insymbol;
lc1 := lc;
expression( fsys+[dosy],x); {*处理while后的判断条件表达式*}
if not( x.typ in [bools, notyp] ) {*如果表达式结果类型不正确,则报错err17*}
then error(17);
lc2 := lc; {*记录有条件跳转语句指令位置*}
emit(11); {*判断while后的条件,如果为假,则跳转到while循环体外的指令,跳转地址未填*}
if sy = dosy {*判断条件语句之后为do关键字,不是报错err54*}
then insymbol
else error(54);
statement(fsys); {*处理while内的执行语句*}
emit1(10,lc1); {*无条件转移到条件判断指令*}
code[lc2].y := lc {*如果条件为假,则跳转至while循环体外,填入跳转地址*}
end { whilestatement };
{*
过程名:forstatement;
功能:处理for语句;
*}
procedure forstatement;
var cvt : types;
x : item;
i,f,lc1,lc2 : integer;
begin
insymbol;
if sy = ident {*for开头语句第一个字符为标识符*}
then begin
i := loc(id); {*查找标识符即计数变量在tab中的位置*}
insymbol;
if i = 0 {*位置为0,即没有找到*}
then cvt := ints {*默认该计数变量的类型为整数型*}
else if tab[i].obj = vvariable {*如果找到了,并且该计数变量的种类为变量*}
then begin
cvt := tab[i].typ; {*记录计数变量类型*}
if not tab[i].normal {*如果是变量形参,报错err37,此处应为变量*}
then error(37)
else emit2(0,tab[i].lev, tab[i].adr ); {*将该计数变量的地址加载到栈顶*}
if not ( cvt in [notyp, ints, bools, chars]) {*如果该变量类型不符,报错err18,即for之后的变量必须是整型,布尔型,或者字符型*}
then error(18)
end
else begin
error(37); {*如果for后标识符不是变量则报错*}
cvt := ints
end
end
else skip([becomes,tosy,downtosy,dosy]+fsys,2); {*跳过无用符号*}
if sy = becomes {*如果是:=*}
then begin
insymbol;
expression( [tosy, downtosy,dosy]+fsys,x); {*处理:=后的表达式值*}
if x.typ <> cvt {*表达式的值类型与变量类型不符,报错err19*}
then error(19);
end
else skip([tosy, downtosy,dosy]+fsys,51); {*否则,跳过无用符号*}
f := 14; {*操作码先置为F1U*}
if sy in [tosy,downtosy] {*如果接下来是to或者downto*}
then begin
if sy = downtosy {*如果是downto,置操作码为F1D*}
then f := 16;
insymbol;
expression([dosy]+fsys,x); {*处理终值表达式*}
if x.typ <> cvt {*如果终值表达式和计数变量类型不符,报错err19*}
then error(19)
end
else skip([dosy]+fsys,55); {*跳过无用符号*}
lc1 := lc; {*记录循环体开头语句的位置*}
emit(f); {*比较变量初值和终值的大小,满足则将初值赋给循环变量并顺序执行指令,不满足则跳转出for循环体*}
if sy = dosy {*如果是do关键字,读取下一个符号,否则报错err54*}
then insymbol
else error(54);
lc2 := lc; {*记录循环体内语句开头位置*}
statement(fsys); {*处理循环体内语句*}
emit1(f+1,lc2); {*循环变量+1,,判断是否超过终值,未超过则跳转至lc2即循环体执行语句开头,超过则顺序执行下条指令,跳出for循环体*}
code[lc1].y := lc {*code[lcl]F1U或F1D类指令,初始值和终值条件关系不满足,则跳出for循环体外*}
end { forstatement };
{*
过程名:standproc;
功能:处理标准(输入/输出)过程调用;
*}
procedure standproc( n: integer );
var i,f : integer;
x,y : item;
begin
case n of
1,2 : begin { read } {*函数编号为1或2,则为read函数*}
if not iflag
then begin
error(20);
iflag := true
end;
if sy = lparent {*如果是(*}
then begin
repeat {*循环处理read括号内的所有参数,读取所有参数的值*}
insymbol;
if sy <> ident {*如果read函数内部参数不是标识符*}
then error(2)
else begin
i := loc(id); {*查找该标识符*}
insymbol;
if i <> 0
then if tab[i].obj <> vvariable
then error(37)
else begin
x.typ := tab[i].typ; {*记录标识符的种类和指针*}
x.ref := tab[i].ref;
if tab[i].normal
then f := 0
else f := 1;
emit2(f,tab[i].lev,tab[i].adr); {*加载标识符地址或值于栈顶*}
if sy in [lbrack,lparent,period] {*处理子结构*}
then selector( fsys+[comma,rparent],x);
if x.typ in [ints,reals,chars,notyp] {*如果参数类型符合输出条件,调用read指令读取该标识符内容*}
then emit1(27,ord(x.typ))
else error(41) {*否则报错err41,read或write参数不正确*}
end
end;
test([comma,rparent],fsys,6);
until sy <> comma;
if sy = rparent {*检测)*}
then insymbol
else error(4)
end;
if n = 2 {*如果n=2,则为readln函数,读完一行换行*}
then emit(62)
end;
3,4 : begin { write } {*如果是写指令*}
if sy = lparent
then begin
repeat {*循环处理输出函数的所有参数*}
insymbol;
if sy = stringcon {*如果输出的是字符串类型*}
then begin
emit1(24,sleng); {*装入字面常量,sleng为字符串长度*}
emit1(28,inum); {*否则写字符,inum为字符串在stab的起始位置*}
insymbol
end
else begin {*如果输出内容不是字符串*}
expression(fsys+[comma,colon,rparent],x); {*计算要输出的表达式的值*}
if not( x.typ in stantyps ) {*如果表达式不是标准类型,则报错err41*}
then error(41);
if sy = colon {*如果是冒号,处理输出场宽*}
then begin
insymbol;
expression( fsys+[comma,colon,rparent],y); {*计算输出场宽表达式的值*}
if y.typ <> ints {*如果输出格式不是整数,报错err43*}
then error(43);
if sy = colon {*如果还是冒号,处理输出指定实数的小数位数*}
then begin
if x.typ <> reals {*如果被输出内容不是实数,则报错err42*}
then error(42);
insymbol;
expression(fsys+[comma,rparent],y); {*处理指定小数位数的表达式*}
if y.typ <> ints {*如果场宽格式不是整数型,则报错err43*}
then error(43);
emit(37) {*否则按照给定场宽输出实数值*}
end
else emit1(30,ord(x.typ)) {*如果只有单场宽,则按照给定场宽输出数值*}
end
else emit1(29,ord(x.typ)) {*如果输出数值没有场宽限制,则隐含场宽输出数值*}
end
until sy <> comma;
if sy = rparent {*检查输出函数的右括号*}
then insymbol
else error(4)
end;
if n = 4 {*如果n=4,则是writeln函数,则换行继续进行写操作*}
then emit(63)
end; { write }
end { case };
end { standproc } ;
begin { statement }
if sy in statbegsys+[ident] {*检查开头字符是否属于合法的语句字符集合*}
then case sy of
ident : begin {*如果是标识符*}
i := loc(id); {*查找该标识符*}
insymbol;
if i <> 0
then case tab[i].obj of {*查找到对标识符的类型进行分析*}
konstant,typel : error(45); {*如果是常量或者类型描述符则报错err45*}
vvariable: assignment( tab[i].lev,tab[i].adr); {*如果是变量,处理赋值语句*}
prozedure: if tab[i].lev <> 0 {*如果是过程类型,如果被调用过程不为标准过程,则处理该过程*}
then call(fsys,i)
else standproc(tab[i].adr); {*否则处理标准过程*}
funktion: if tab[i].ref = display[level] {*如果该函数在btab中的位置等于当前层在栈中的地址,调用赋值语句,否则报错err45*}
then assignment(tab[i].lev+1,0)
else error(45)
end { case }
end;
beginsy : compoundstatement; {*如果是begin,则调用处理复合语句函数*}
ifsy : ifstatement; {*如果是if,则调用处理if语句函数*}
casesy : casestatement; {*如果是case,则调用处理case语句函数*}
whilesy : whilestatement; {*如果是while,则调用处理while语句函数*}
repeatsy: repeatstatement; {*如果是repeat,则调用处理repeat函数*}
forsy : forstatement; {*如果是for,则调用处理for语句函数*}
end; { case }
test( fsys, [],14);
end { statement };
begin { block }
dx := 5; {*dx为变量存储分配索引,初值为5,即每个分程序在运行栈s中的数据开头应留出5个单元作为内务信息区*}
prt := t; {*prt用来存储该过程进入tab表的位置*}
if level > lmax {*如果该过程静态层次大于嵌套最大值,则报告溢出错误*}
then fatal(5);
test([lparent,colon,semicolon],fsys,14);{检查块开始字符的合法性}
enterblock; {*登录该块的信息于btab表*}
prb := b; {*prb记录该块在btab中的起始位置*}
display[level] := b; {*更新display表,display表指向该过程在btab的位置*}
tab[prt].typ := notyp; {*过程没有类型,这里填入notyp*}
tab[prt].ref := prb; {*记录该块的指针,指向btab中的位置*}
if ( sy = lparent ) and ( level > 1 ) {*如果过程或函数后为(并且不为主函数*}
then parameterlist; {*处理该过程或函数的参数列表*}
btab[prb].lastpar := t; {*记录该过程的最后一个标识符在tab中的位置,有可能该过程或函数没有声明变量或者常量*}
btab[prb].psize := dx; {*记录内务信息区和参数占用的空间大小*}
if isfun {*如果是函数*}
then if sy = colon {*检测返回值类型前的冒号*}
then begin
insymbol; { function type }
if sy = ident {*如果返回值类型是标识符*}
then begin
x := loc(id); {*查找在tab中的位置*}
insymbol;
if x <> 0 {*如果找到了*}
then if tab[x].typ in stantyps {*如果是标准类型*}
then tab[prt].typ := tab[x].typ {将该函数的类型记为返回值类型,否则报错err15}
else error(15)
end
else skip( [semicolon]+fsys,2 ){*跳过无用符号*}
end
else error(5); {*函数括号之后没有冒号报错err5*}
if sy = semicolon {*如果括号之后不是分号报错err14*}
then insymbol
else error(14);
repeat{*循环处理block声明内容*}
if sy = constsy {*处理常量声明语句*}
then constdec;
if sy = typesy {*处理类型描述符*}
then typedeclaration;
if sy = varsy {*处理变量说明语句*}
then variabledeclaration;
btab[prb].vsize := dx; {*记录该block局部变量参数和内务信息区的大小*}
while sy in [procsy,funcsy] do {*循环处理该块内的所有过程声明*}
procdeclaration;
test([beginsy],blockbegsys+statbegsys,56)
until sy in statbegsys;
tab[prt].adr := lc; {*该块的地址为相应目标代码的入口地址*}
insymbol;
statement([semicolon,endsy]+fsys); {*处理block内的语句*}
while sy in [semicolon]+statbegsys do {*循环处理block内的所有语句*}
begin
if sy = semicolon {*如果语句没有以分号结束,则报错err14*}
then insymbol
else error(14);
statement([semicolon,endsy]+fsys); {*接着处理下一个语句*}
end;
if sy = endsy {*该块处理结束*}
then insymbol
else error(57); {*没有end,报错err57*}
test( fsys+[period],[],6 ) {*检测后继符号的合法性*}
end { block };
{*
过程名:interpret;
功能：p-code解释执行程序;
*}
procedure interpret;
var ir : order ; { instruction buffer }
pc : integer; { program counter }
t : integer; { top stack index }
b : integer; { base index } {*基址索引*}
h1,h2,h3: integer; {*临时变量*}
lncnt,ocnt,blkcnt,chrcnt: integer; { counters }
ps : ( run,fin,caschk,divchk,inxchk,stkchk,linchk,lngchk,redchk );
fld: array [1..4] of integer; { default field widths }
display : array[0..lmax] of integer;
s : array[1..stacksize] of { blockmark: }
record
case cn : types of { s[b+0] = fct result }
ints : (i: integer ); { s[b+1] = return adr }
reals :(r: real ); { s[b+2] = static link }
bools :(b: boolean ); { s[b+3] = dynamic link }
chars :(c: char ) { s[b+4] = table index }
end;
{*
过程名:dump;
功能:程序运行时.卸出打印现场剖析信息(display,t,b以及运行栈s的内容,满足编译预选项的要求)
*}
procedure dump;
var p,h3 : integer;
begin
h3 := tab[h2].lev; {*该函数在call指令被调用,h2此时代表当前分程序名字在tab表的位置,则h3代表该分程序的层次*}
writeln(psout);
writeln(psout);
writeln(psout,' calling ', tab[h2].name ); {*打印分程序名字*}
writeln(psout,' level ',h3:4); {*打印分程序层次*}
writeln(psout,' start of code ',pc:4); {*打印分程序语句部分的入口指令地址*}
writeln(psout);
writeln(psout);
writeln(psout,' contents of display ');
writeln(psout);
for p := h3 downto 0 do {*打印display表内容*}
writeln(psout,p:4,display[p]:6);
writeln(psout);
writeln(psout);
writeln(psout,' top of stack ',t:4,' frame base ':14,b:4); {*打印栈指针值和基址*}
writeln(psout);
writeln(psout);
writeln(psout,' stack contents ':20);
writeln(psout);
for p := t downto 1 do {*打印运行栈内容*}
writeln( psout, p:14, s[p].i:8);
writeln(psout,'< = = = >':22)
end; {dump }
{*
过程名:inter0;
功能:处理具体的指令;
*}
procedure inter0;
begin
case ir.f of
0 : begin { load addrss } {*把变量地址装入栈顶*}
t := t + 1; {*栈指针+1*}
if t > stacksize {*栈溢出*}
then ps := stkchk {*报告错误信息*}
else s[t].i := display[ir.x]+ir.y {*取x层相对地址为y的数据地址到当期栈顶*}
end;
1 : begin { load value } {*加载相应的值到栈顶*}
t := t + 1;
if t > stacksize
then ps := stkchk
else s[t] := s[display[ir.x]+ir.y]
end;
2 : begin { load indirect } {*间接装入数据,即以x层y为相对地址的数据为基址的数据*}
t := t + 1;
if t > stacksize
then ps := stkchk
else s[t] := s[s[display[ir.x]+ir.y].i]
end;
3 : begin { update display } {*更新display表*}
h1 := ir.y; {*调用过程或函数所在层次*}
h2 := ir.x; {*被调用过程或函数所在层次*}
h3 := b; {*h3为调用过程基址*}
repeat {*循环更新调用过程到被调用过程之间的层次的display表,h2<h1,这个在生成display这条指令的时候就确定了*}
display[h1] := h3; {*记录当前层次的display为当前过程的基址*}
h1 := h1-1; {*层次-1*}
h3 := s[h3+2].i {*下一个层次为下标的display数组记录值为当前过程SL值*}
until h1 = h2 {**}
end;
8 : case ir.y of {*标准函数处理*}
0 : s[t].i := abs(s[t].i); {*绝对值*}
1 : s[t].r := abs(s[t].r); {*实数求绝对值*}
2 : s[t].i := sqr(s[t].i); {*求平方*}
3 : s[t].r := sqr(s[t].r); {*实求平方*}
4 : s[t].b := odd(s[t].i); {*判断是否为奇数*}
5 : s[t].c := chr(s[t].i); {*将数字转化为符号*}
6 : s[t].i := ord(s[t].c); {*将符号转化为数字*}
7 : s[t].c := succ(s[t].c); {*求符号后继*}
8 : s[t].c := pred(s[t].c); {*求符号前驱*}
9 : s[t].i := round(s[t].r); {*求x的四舍五入*}
10 : s[t].i := trunc(s[t].r); {*求实数的整数部分*}
11 : s[t].r := sin(s[t].r); {*求sin值*}
12 : s[t].r := cos(s[t].r); {*求cos值*}
13 : s[t].r := exp(s[t].r); {*求开方*}
14 : s[t].r := ln(s[t].r); {*求对数*}
15 : s[t].r := sqrt(s[t].r); {*开方*}
16 : s[t].r := arcTan(s[t].r); {*求反三角函数*}
17 : begin {*判断是否为文件结尾并将结果入栈顶*}
t := t+1;
if t > stacksize
then ps := stkchk
else s[t].b := eof(prd)
end;
18 : begin {判断文件本行是否到结尾}
t := t+1;
if t > stacksize
then ps := stkchk
else s[t].b := eoln(prd)
end;
end;
9 : s[t].i := s[t].i + ir.y; { offset } {*栈顶元素加上y*}
end { case ir.y }
end; { inter0 }
procedure inter1;
var h3, h4: integer;
begin
case ir.f of
10 : pc := ir.y ; { jump }
11 : begin { conditional jump } {*栈顶元素条件为假,跳转至y指令处,栈指针回退1*}
if not s[t].b
then pc := ir.y;
t := t - 1
end;
12 : begin { switch } {*转移到y,查找case表*}
h1 := s[t].i; {*case后需要查找值的变量,即case x*}
t := t-1;
h2 := ir.y; {*情况表起始地址*}
h3 := 0; {*标志变量,情况表结束或情况表起始位置不正确,则置为0*}
repeat
if code[h2].f <> 13 {*情况表查找结束*}
then begin
h3 := 1;
ps := caschk {*没有查找到x的值*}
end
else if code[h2].y = h1 {*情况表的label=变量x*}
then begin
h3 := 1; {*置标志位*}
pc := code[h2+1].y {*pc跳转至case对应label的执行语句*}
end
else h2 := h2 + 2
until h3 <> 0
end;
14 : begin { for1up } {*比较for循环to情况的初值和终值*}
h1 := s[t-1].i; {*h1即次栈顶为初值*}
if h1 <= s[t].i {栈顶为终值}
then s[s[t-2].i].i := h1 {*如果初值<=终值,则将初值的值赋给计数变量*}
else begin
t := t - 3; {*初值>终值,栈指针回退,跳转至循环体外*}
pc := ir.y
end
end;
15 : begin { for2up } {*循环变量+1,判断是否超过终值并跳转或顺序执行*}
h2 := s[t-2].i; {*次栈顶存储变量地址*}
h1 := s[h2].i+1; {*计数变量值+1*}
if h1 <= s[t].i {*栈顶为终值,计数变量<=终值*}
then begin
s[h2].i := h1; {*计数变量更新值为旧值+1*}
pc := ir.y {*跳转地址,继续循环*}
end
else t := t-3; {*否则顺序执行并退回栈顶,跳出for循环体*}
end;
16 : begin { for1down } {*与14同理*}
h1 := s[t-1].i;
if h1 >= s[t].i
then s[s[t-2].i].i := h1
else begin
pc := ir.y;
t := t - 3
end
end;
17 : begin { for2down } {*与15同理*}
h2 := s[t-2].i;
h1 := s[h2].i-1;
if h1 >= s[t].i
then begin
s[h2].i := h1;
pc := ir.y
end
else t := t-3;
end;
18 : begin { mark stack } {*标记栈*}
h1 := btab[tab[ir.y].ref].vsize; {*找到被调过程在btab中的位置,进而求得该过程的vsize*}
if t+h1 > stacksize {*如果栈溢出*}
then ps := stkchk {*报错*}
else begin
t := t+5; {*栈指针+5,留出内务信息区空间*}
s[t-1].i := h1-1; {*内务信息区的第四个单元记录vsize-1*}
s[t].i := ir.y {*内务信息区第五个单元记录被调用过程在tab表中的位置*}
end
end;
19 : begin { call } {*调用用户过程或函数*}
h1 := t-ir.y; { h1 points to base } {*t位栈顶,此时指向被调用过程或函数新分配栈的参数区,ir.y为该过程或函数的p.size,即参数区和内务信息区的大小,因此h1即为该过程或函数的基址*}
h2 := s[h1+4].i; { h2 points to tab } {*h2为该过程名在tab表中的位置*}
h3 := tab[h2].lev; {*h3为该过程名的层次*}
display[h3+1] := h1; {*h3加1为该过程块的层次,因为过程名总比过程块层数小1,更新display表*}
h4 := s[h1+3].i+h1; {*s[h1+3]记录的是vsize-1,即局部变量,参数区和内务区的大小,所以h4为该过程分配完所需存储单元后的栈顶指针*}
s[h1+1].i := pc; {*记录RA*}
s[h1+2].i := display[h3]; {*记录SL*}
s[h1+3].i := b; {*记录DL*}
for h3 := t+1 to h4 do {*局部变量区数据清零*}
s[h3].i := 0;
b := h1; {*更新b为当前被调用过程的基址*}
t := h4; {*更新栈顶指针*}
pc := tab[h2].adr; {*pc为该过程的目标代码的入口地址*}
if stackdump
then dump
end;
end { case }
end; { inter1 }
procedure inter2;
begin
case ir.f of
20 : begin { index1 } {*取下标变量地址,元素长度为1*}
h1 := ir.y; { h1 points to atab }
h2 := atab[h1].low; {*数组下界*}
h3 := s[t].i; {*数组下标*}
if h3 < h2 {*所求数组下标小于数组下界,则记录错误错*}
then ps := inxchk
else if h3 > atab[h1].high {*所求数组下标大于数组上界,则记录错误*}
then ps := inxchk
else begin
t := t-1;
s[t].i := s[t].i+(h3-h2) {*当期栈顶存储数组起始基址*}
end
end;
21 : begin { index } {*取下标变量地址,元素长度不为1*}
h1 := ir.y ; { h1 points to atab }
h2 := atab[h1].low;
h3 := s[t].i;
if h3 < h2
then ps := inxchk
else if h3 > atab[h1].high
then ps := inxchk
else begin
t := t-1;
s[t].i := s[t].i + (h3-h2)*atab[h1].elsize
end
end;
22 : begin { load block } {*装入块*}
h1 := s[t].i; {*h1记录块起始地址*}
t := t-1; {*栈退1*}
h2 := ir.y+t; {*块装完栈指针*}
if h2 > stacksize {*栈溢出*}
then ps := stkchk
else while t < h2 do {*循环装入块*}
begin
t := t+1;
s[t] := s[h1];
h1 := h1+1
end
end;
23 : begin { copy block } {*复制块*}
h1 := s[t-1].i; {*将要被复制数据区起始地址*}
h2 := s[t].i; {*复制的数据区起始地址*}
h3 := h1+ir.y;
while h1 < h3 do
begin
s[h1] := s[h2];
h1 := h1+1;
h2 := h2+1
end;
t := t-2
end;
24 : begin { literal } {*装入字面常量*}
t := t+1;
if t > stacksize
then ps := stkchk
else s[t].i := ir.y {*y为被装入的字面常量*}
end;
25 : begin { load real } {*装入实数*}
t := t+1;
if t > stacksize
then ps := stkchk
else s[t].r := rconst[ir.y] {*y为实数在实数表中的位置*}
end;
26 : begin { float } {*转换浮点数*}
h1 := t-ir.y; {*被转换数的地址*}
s[h1].r := s[h1].i
end;
27 : begin { read } {*读内容*}
if eof(prd) {*文件内容读完*}
then ps := redchk {*报错*}
else case ir.y of {*栈顶为被读内容的地址*}
1 : read(prd, s[s[t].i].i); {*读整型*}
2 : read(prd, s[s[t].i].r); {*读实数*}
4 : read(prd, s[s[t].i].c); {*读字符*}
end;
t := t-1 {*栈退1*}
end;
28 : begin { write string } {*写字符*}
h1 := s[t].i; {*栈顶为字符长度*}
h2 := ir.y; {*被写字符起始地址*}
t := t-1;
chrcnt := chrcnt+h1;
if chrcnt > lineleng {*超出可输出最大字符数限制*}
then ps := lngchk;
repeat
write(prr,stab[h2]);
h1 := h1-1;
h2 := h2+1
until h1 = 0
end;
29 : begin { write1 } {*写隐含场宽*}
chrcnt := chrcnt + fld[ir.y]; {*fld[ir.y]场宽*}
if chrcnt > lineleng
then ps := lngchk
else case ir.y of
1 : write(prr,s[t].i:fld[1]); {*输出整数*}
2 : write(prr,s[t].r:fld[2]); {*输出实数*}
3 : if s[t].b {*输出布尔值*}
then write('true')
else write('false');
4 : write(prr,chr(s[t].i)); {*输出字符*}
end;
t := t-1
end;
end { case }
end; { inter2 }
procedure inter3;
begin
case ir.f of
30 : begin { write2 } {*写给定场宽*}
chrcnt := chrcnt+s[t].i;
if chrcnt > lineleng
then ps := lngchk
else case ir.y of
1 : write(prr,s[t-1].i:s[t].i);
2 : write(prr,s[t-1].r:s[t].i);
3 : if s[t-1].b
then write('true')
else write('false');
end;
t := t-2
end;
31 : ps := fin;{*停止*}
32 : begin { exit procedure } {*退出过程*}
t := b-1; {*栈顶为原来过程基址-1*}
pc := s[b+1].i;{*pc转为RA即过程指令返回地址基址*}
b := s[b+3].i {*b转为动态链存储的基址,即调用该过程的基址*}
end;
33 : begin { exit function } {*退出函数*}
t := b; {*t不-1,是因为存储函数返回结果*}
pc := s[b+1].i;
b := s[b+3].i
end;
34 : s[t] := s[s[t].i]; {*取栈顶内容为基址的单元内容*}
35 : s[t].b := not s[t].b; {*逻辑非*}
36 : s[t].i := -s[t].i; {*求负*}
37 : begin {*写实数,给定场宽*}
chrcnt := chrcnt + s[t-1].i;
if chrcnt > lineleng
then ps := lngchk
else write(prr,s[t-2].r:s[t-1].i:s[t].i);
t := t-3
end;
38 : begin { store } {*将栈顶内容存入以栈顶次高元为地址的单元*}
s[s[t-1].i] := s[t];
t := t-2
end;
39 : begin {**实型等于比较}
t := t-1;
s[t].b := s[t].r=s[t+1].r
end;
end { case }
end; { inter3 }
procedure inter4;
begin
case ir.f of
40 : begin {*实型不等比较*}
t := t-1;
s[t].b := s[t].r <> s[t+1].r
end;
41 : begin {*实型小于比较*}
t := t-1;
s[t].b := s[t].r < s[t+1].r
end;
42 : begin {*实型小于等于比较*}
t := t-1;
s[t].b := s[t].r <= s[t+1].r
end;
43 : begin {*实型大于比较*}
t := t-1;
s[t].b := s[t].r > s[t+1].r
end;
44 : begin {*实型大于等于比较*}
t := t-1;
s[t].b := s[t].r >= s[t+1].r
end;
45 : begin {*整型相等比较*}
t := t-1;
s[t].b := s[t].i = s[t+1].i
end;
46 : begin {*整型不等比较*}
t := t-1;
s[t].b := s[t].i <> s[t+1].i
end;
47 : begin {*整型小于比较*}
t := t-1;
s[t].b := s[t].i < s[t+1].i
end;
48 : begin {*整型小于等于比较*}
t := t-1;
s[t].b := s[t].i <= s[t+1].i
end;
49 : begin {*整型大于等于比较*}
t := t-1;
s[t].b := s[t].i > s[t+1].i
end;
end { case }
end; { inter4 }
procedure inter5;
begin
case ir.f of
50 : begin {*整型大于等于比较*}
t := t-1;
s[t].b := s[t].i >= s[t+1].i
end;
51 : begin {*逻辑或*}
t := t-1;
s[t].b := s[t].b or s[t+1].b
end;
52 : begin {*整型加*}
t := t-1;
s[t].i := s[t].i+s[t+1].i
end;
53 : begin {*整型减*}
t := t-1;
s[t].i := s[t].i-s[t+1].i
end;
54 : begin {*实型加*}
t := t-1;
s[t].r := s[t].r+s[t+1].r;
end;
55 : begin {*实型减*}
t := t-1;
s[t].r := s[t].r-s[t+1].r;
end;
56 : begin {*逻辑与*}
t := t-1;
s[t].b := s[t].b and s[t+1].b
end;
57 : begin {*整型乘*}
t := t-1;
s[t].i := s[t].i*s[t+1].i
end;
58 : begin {*整型除*}
t := t-1;
if s[t+1].i = 0 {*除数为0*}
then ps := divchk
else s[t].i := s[t].i div s[t+1].i
end;
59 : begin {*取模*}
t := t-1;
if s[t+1].i = 0
then ps := divchk
else s[t].i := s[t].i mod s[t+1].i
end;
end { case }
end; { inter5 }
procedure inter6;
begin
case ir.f of
60 : begin {*实型乘*}
t := t-1;
s[t].r := s[t].r*s[t+1].r;
end;
61 : begin {*实型除*}
t := t-1;
s[t].r := s[t].r/s[t+1].r;
end;
62 : if eof(prd) {*readln*}
then ps := redchk
else readln;
63 : begin {*writeln*}
writeln(prr);
lncnt := lncnt+1;
chrcnt := 0;
if lncnt > linelimit
then ps := linchk
end
end { case };
end; { inter6 }
begin { interpret }
s[1].i := 0; {初始化运行栈}
s[2].i := 0;
s[3].i := -1;
s[4].i := btab[1].last;
display[0] := 0; {*初始化display表*}
display[1] := 0;
t := btab[2].vsize-1; {*栈指针为栈指针为全程变量区的最后一个单元*}
b := 0;
pc := tab[s[4].i].adr; {*初始化pc运行指令地址*}
lncnt := 0; {*初始化各种计数变量*}
ocnt := 0;
chrcnt := 0;
ps := run; {*运行标志记为run*}
fld[1] := 10; {*初始化场宽相关信息*}
fld[2] := 22;
fld[3] := 10;
fld[4] := 1;
repeat {*取指令,出现错误即ps不为run,则停止运行*}
ir := code[pc];
pc := pc+1;
ocnt := ocnt+1;
case ir.f div 10 of {*运行指令*}
0 : inter0;
1 : inter1;
2 : inter2;
3 : inter3;
4 : inter4;
5 : inter5;
6 : inter6;
end; { case }
until ps <> run;
if ps <> fin {*处理错误情况*}
then begin
writeln(prr);
write(prr, ' halt at', pc :5, ' because of '); {*打印出错指令信息*}
case ps of
caschk : writeln(prr,'undefined case');
divchk : writeln(prr,'division by 0');
inxchk : writeln(prr,'invalid index');
stkchk : writeln(prr,'storage overflow');
linchk : writeln(prr,'too much output');
lngchk : writeln(prr,'line too long');
redchk : writeln(prr,'reading past end or file');
end;
{*进行事后卸出打印*}
h1 := b; {*当前运行分程序基址*}
blkcnt := 10; {*已打印分程序计数器,回溯打印最多不超过10个分程序*} { post mortem dump }
repeat {*循环打印分程序内容,直到分程序基址<0*}
writeln( prr );
blkcnt := blkcnt-1;
if blkcnt = 0 {*打印超过10个分程序,置h1为0,则开始打印主程序内容*}
then h1 := 0;
h2 := s[h1+4].i; {*h2为当前分程序名字在tab表中的位置*}
if h1 <> 0
then writeln( prr, '',tab[h2].name, 'called at', s[h1+1].i:5); {*打印分程序名字和该程序被调用地址*}
h2 := btab[tab[h2].ref].last; {*h2为该程序最后一个标识符在tab中的位置*}
while h2 <> 0 do {*打印该分程序的每一个标识符信息*}
with tab[h2] do
begin
if obj = vvariable {*如果该标识符为变量*}
then if typ in stantyps {*如果该标识符的类型是标准类型*}
then begin
write(prr,'',name,'='); {*打印名字*}
if normal {*如果不是变量形参*}
then h3 := h1+adr {*h3为该变量相对于基址的偏移+基址,即该变量在栈中的基址*}
else h3 := s[h1+adr].i; {*如果是变量形参,求得该过程+offset为基址单元的内容为该变量基址*}
case typ of {*判断变量类型并输出值*}
ints : writeln(prr,s[h3].i);
reals: writeln(prr,s[h3].r);
bools: if s[h3].b
then writeln(prr,'true')
else writeln(prr,'false');
chars: writeln(prr,chr(s[h3].i mod 64 ))
end
end;
h2 := link {*h2记录该过程下一个变量在tab中的位置*}
end;
h1 := s[h1+3].i {*h1为调用该分程序的分程序在栈中的基址*}
until h1 < 0
end;
writeln(prr);
writeln(prr,ocnt,' steps');
end; { interpret }
{*
过程名:setup;
功能:建立初始信息;
*}
procedure setup;
begin
{*初始化保留字表*}
key[1] := 'and ';
key[2] := 'array ';
key[3] := 'begin ';
key[4] := 'case ';
key[5] := 'const ';
key[6] := 'div ';
key[7] := 'do ';
key[8] := 'downto ';
key[9] := 'else ';
key[10] := 'end ';
key[11] := 'for ';
key[12] := 'function ';
key[13] := 'if ';
key[14] := 'mod ';
key[15] := 'not ';
key[16] := 'of ';
key[17] := 'or ';
key[18] := 'procedure ';
key[19] := 'program ';
key[20] := 'record ';
key[21] := 'repeat ';
key[22] := 'then ';
key[23] := 'to ';
key[24] := 'type ';
key[25] := 'until ';
key[26] := 'var ';
key[27] := 'while ';
{*初始化保留字编码表*}
ksy[1] := andsy;
ksy[2] := arraysy;
ksy[3] := beginsy;
ksy[4] := casesy;
ksy[5] := constsy;
ksy[6] := idiv;
ksy[7] := dosy;
ksy[8] := downtosy;
ksy[9] := elsesy;
ksy[10] := endsy;
ksy[11] := forsy;
ksy[12] := funcsy;
ksy[13] := ifsy;
ksy[14] := imod;
ksy[15] := notsy;
ksy[16] := ofsy;
ksy[17] := orsy;
ksy[18] := procsy;
ksy[19] := programsy;
ksy[20] := recordsy;
ksy[21] := repeatsy;
ksy[22] := thensy;
ksy[23] := tosy;
ksy[24] := typesy;
ksy[25] := untilsy;
ksy[26] := varsy;
ksy[27] := whilesy;
{*初始化特殊字符编码表*}
sps['+'] := plus;
sps['-'] := minus;
sps['*'] := times;
sps['/'] := rdiv;
sps['('] := lparent;
sps[')'] := rparent;
sps['='] := eql;
sps[','] := comma;
sps['['] := lbrack;
sps[']'] := rbrack;
sps[''''] := neq;
sps['!'] := andsy;
sps[';'] := semicolon;
end { setup };
{*
过程名:enterids;
功能:在符号表中登录标准的类型(基本类型),函数和过程的名字,以及它们的相应信息;
*}
procedure enterids;
begin
enter(' ',vvariable,notyp,0); { sentinel }
enter('false ',konstant,bools,0);
enter('true ',konstant,bools,1);
enter('real ',typel,reals,1);
enter('char ',typel,chars,1);
enter('boolean ',typel,bools,1);
enter('integer ',typel,ints,1);
enter('abs ',funktion,reals,0);
enter('sqr ',funktion,reals,2);
enter('odd ',funktion,bools,4);
enter('chr ',funktion,chars,5);
enter('ord ',funktion,ints,6);
enter('succ ',funktion,chars,7);
enter('pred ',funktion,chars,8);
enter('round ',funktion,ints,9);
enter('trunc ',funktion,ints,10);
enter('sin ',funktion,reals,11);
enter('cos ',funktion,reals,12);
enter('exp ',funktion,reals,13);
enter('ln ',funktion,reals,14);
enter('sqrt ',funktion,reals,15);
enter('arctan ',funktion,reals,16);
enter('eof ',funktion,bools,17);
enter('eoln ',funktion,bools,18);
enter('read ',prozedure,notyp,1);
enter('readln ',prozedure,notyp,2);
enter('write ',prozedure,notyp,3);
enter('writeln ',prozedure,notyp,4);
enter(' ',prozedure,notyp,0);
end;
begin { main } {*主函数*}
setup; {*初始化所有初始信息*}
{*初始化所有合法字符集合*}
constbegsys := [ plus, minus, intcon, realcon, charcon, ident ];
typebegsys := [ ident, arraysy, recordsy ];
blockbegsys := [ constsy, typesy, varsy, procsy, funcsy, beginsy ];
facbegsys := [ intcon, realcon, charcon, ident, lparent, notsy ];
statbegsys := [ beginsy, ifsy, whilesy, repeatsy, forsy, casesy ];
stantyps := [ notyp, ints, reals, bools, chars ];
lc := 0; {*代码地址索引为0*}
ll := 0; {*行内容长度置为0*}
cc := 0; {*字符指针置为0*}
ch := ' '; {*当前字符为' '*}
errpos := 0; {*错误位置记为0*}
errs := []; {*错误编号集合初始化为空*}
writeln( 'NOTE input/output for users program is console : ' ); {*输出提示语句*}
writeln;
write( 'Source input file ?');
readln( inf ); {*读入源码文件路径*}
assign( psin, inf );
reset( psin );
write( 'Source listing file ?');
readln( outf ); {*读入输出文件路径*}
assign( psout, outf );
rewrite( psout );
assign ( prd, 'con' ); {**}
write( 'result file : ' );
readln( fprr ); {*读入输出结果文件路径*}
assign( prr, fprr );
reset ( prd );
rewrite( prr );
t := -1; {*符号表初始指针置为-1*}
a := 0; {*atab初始指针置为0*}
b := 1; {*btab初始指针置为1*}
sx := 0; {*stab初始指针置为0*}
c2 := 0; {*rconst初始指针置为0*}
display[0] := 1; {*初始化display表*}
iflag := false; {*初始化一系列flag值*}
oflag := false;
skipflag := false;
prtables := false;
stackdump := false;
insymbol;
if sy <> programsy {*程序第一个关键字必须为program,否则报错err3*}
then error(3)
else begin
insymbol;
if sy <> ident {*如果当前符号为标识符*}
then error(2)
else begin
progname := id; {*记录program的名字*}
insymbol;
if sy <> lparent {*如果不为(,则报错*}
then error(9)
else repeat {*循环处理主程序参数,通常为标准输入或者标准输出文件名,一般对应键盘,显示器,代表程序与外界的联系,与具体运行环境有关*}
insymbol;
if sy <> ident {*如果不是标识符,则报错*}
then error(2)
else begin
if id = 'input ' {*如果是input*}
then iflag := true
else if id = 'output ' {*如果是output*}
then oflag := true
else error(0); {*否则报错该标识符未定义*}
insymbol
end
until sy <> comma;
if sy = rparent {*检查)合法性*}
then insymbol
else error(4);
if not oflag then error(20){*程序头部未包含参数output或者input*}
end
end;
enterids; {*登录标准信息到tab中*}
with btab[1] do {*登录初始信息到btab中*}
begin
last := t;
lastpar := 1;
psize := 0;
vsize := 0;
end;
block( blockbegsys + statbegsys, false, 1 ); {*分析程序块*}
if sy <> period {*如果程序不以.结尾,则报错*}
then error(2);
emit(31); { halt } {*31号指令停止程序*}
if prtables {*如果需要打印相关编译信息表格*}
then printtables; {*则打印信息表格*}
if errs = [] {*如果错误集合为空集*}
then interpret {*则开始执行解释程序*}
else begin
writeln( psout ); {*如果有错误则输出编译错误提示信息于输出文件中*}
writeln( psout, 'compiled with errors' );
writeln( psout );
errormsg;
end;
writeln( psout );
close( psout );
close( prr )
end.
浙公网安备 33010602011771号