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 } {*如果读入的字符为空格或者 则跳过*} 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.