pl0-pas.txt.pas

Pascal语言写的扩充PL0文法编译器

          gen1(addc, ad)
end   end;

procedure addressvar(ref: integer);
begin with itab[ref] do
      begin address(vlevel, vadr); if refpar then gen0(load) end
end;

procedure mustbe(x, y: integer);
begin if x<>y then
      if (ttab[x].kind=arrays) and (ttab[y].kind=arrays) and
         (ttab[x].low=ttab[y].low) and (ttab[x].high=ttab[y].high)
      then mustbe(ttab[x].elemtip, ttab[y].elemtip)
      else error(107)
end;

procedure expression(var x: integer);
  forward;

procedure selector(var t: integer; var ref: integer);
  var j, x: integer;
begin t:= itab[ref].tip; getsym;
      if sym in [period, lbrack] then begin
          addressvar(ref); ref:= 0;
          while sym in [period, lbrack] do
          case sym of
            period : begin if ttab[t].kind<>records then error(108);
                           getsym; check(ident);
                           j:= ttab[t].fields; itab[0].name:= id;
                           while itab[j].name<>id do j:= itab[j].link;
                           if j=0 then error(109);
                           gen1(addc, itab[j].offset);
                           t:= itab[j].tip; getsym
                     end;
            lbrack : begin repeat if ttab[t].kind<>arrays then error(110);
                                  getsym; expression(x); mustbe(intip, x);
                                  gen1(addc, -ttab[t].low);
                                  t:= ttab[t].elemtip;
                                  gen1(mulc, ttab[t].size); gen0(add)
                           until sym<>comma;
                           skip(rbrack)
end   end end        end;

procedure varpar(var t: integer);
  var j: integer;
begin check(ident); j:= position; selector(t, j);
      if j<>0 then addressvar(j)
end;

procedure standfct(n: integer);
  var x, l: integer;
begin case n of
        fabs: begin skip(lparen); expression(x); mustbe(intip, x);
                  gen0(dupl); gen1(ldc, 0); gen0(lssi);
                  l:= codelabel; gen1(jumpz, 0); gen0(neg);
                  code[l].a:= codelabel;
                  skip(rparen)
              end;
        fsqr: begin skip(lparen); expression(x); mustbe(intip, x);
                  gen0(dupl); gen0(mul); skip(rparen)
              end;
        fodd: begin skip(lparen); expression(x); mustbe(intip, x);
                  gen0(rem2); skip(rparen)
              end;
        fchr: begin skip(lparen); expression(x); mustbe(intip, x);
                  skip(rparen)
              end;
        ford: begin skip(lparen); expression(x); mustbe(chartip, x);
                  skip(rparen)
              end;
        fwrite, fwriteln:
              begin if n=fwrite then check(lparen);
                  if sym=lparen then begin
                      repeat getsym;
                          if sym=sstring then begin
                              for x:= 1 to slen do begin
                                  gen1(ldc, ord(str[x]));
                                  gen0(wrc)
                              end;
                              getsym
                          end else begin
                              expression(x);
                              if sym=colon then begin
                                  mustbe(intip, x); getsym;
                                  expression(x); mustbe(intip,x);
                                  gen0(wri)
                              end else if x=intip then begin
                                  gen1(ldc, 8); gen0(wri)
                              end else if x=chartip then
                                  gen0(wrc)
                              else
                                  error(111)
                          end
                      until sym<>comma;
                      skip(rparen)
                  end;
                  if n=fwriteln then gen0(wrl)
              end;
     fread, freadln:
              begin if n=fread then check(lparen);
                  if sym=lparen then begin
                      repeat getsym; varpar(x);
                             if x=intip   then gen0(rdi) else
                             if x=chartip then gen0(rdc)
                                          else error(112)
                      until sym<>comma;
                      skip(rparen)
                  end;
                  if n=freadln then gen0(rdl)
              end;
        feoln: gen0(eol)
end   end;

procedure funcall(i: integer);
  var d, p, x: integer;
begin getsym;
      with itab[i] do
      if flevel<0 then
          standfct(fadr)
      else begin
          if tip<>0 then gen1(ldc, 0); p:= i; d:= dx;
          if sym=lparen then begin
              repeat getsym;
                  if p=lastpar then error(113); p:= p+1;
                  if itab[p].refpar then
                      varpar(x)
                  else begin
                      expression(x);
                      if ttab[x].kind<>simple then gen1(copy, ttab[x].size)
                  end;
                  mustbe(itab[p].tip, x)
              until sym<>comma;
              skip(rparen)
          end;
          if p<>lastpar then error(114);
          if flevel<>0 then address(flevel, 0);
          gen1(call, fadr); dx:= d
end   end;

procedure factor(var t: integer);
   var i: integer;
begin if sym=ident then begin
          i:= position; t:= itab[i].tip;
          case itab[i].kind of
            konst: begin getsym; gen1(ldc, itab[i].val) end;
            varbl: begin selector(t, i);
                         if i<>0 then addressvar(i);
                         if ttab[t].kind=simple then gen0(load)
                   end;
            funkt: if t=0 then error(115) else funcall(i);
            tipe : error(116)
          end
      end else if sym=number then begin
          gen1(ldc, num); t:= intip; getsym
      end else if (sym=sstring) and (slen=1) then begin
          gen1(ldc, ord(str[1])); t:= chartip; getsym
      end else if sym=lparen then begin
          getsym; expression(t); skip(rparen)
      end else if sym=notsym then begin
          getsym; factor(t); mustbe(booltip, t); gen0(neg); gen1(addc, 1)
      end else
          error(117)
end;

procedure term(var x: integer);
  var y: integer;
begin factor(x);
      while sym in [andsym, star, divsym, modsym] do begin
          if sym=andsym then mustbe(booltip, x) else mustbe(intip, x);
          case sym of
            star  : begin getsym; factor(y); gen0(mul) end;
            divsym: begin getsym; factor(y); gen0(divd) end;
            modsym: begin getsym; factor(y); gen0(remd) end;
            andsym: begin getsym; factor(y); gen0(andb) end
          end;
          mustbe(x, y)
end   end;

procedure simplexpression(var x: integer);
  var y: integer;
begin if sym=plus then begin
          getsym; term(x); mustbe(intip, x)
      end else if sym=minus then begin
          getsym; term(x); mustbe(intip, x); gen0(neg)
      end else
          term(x);
      while sym in [orsym, plus, minus] do begin
          if sym=orsym then mustbe(booltip, x) else mustbe(intip, x);
          case sym of
            plus : begin getsym; term(y); gen0(add) end;
            minus: begin getsym; term(y); gen0(neg); gen0(add) end;
            orsym: begin getsym; term(y); gen0(orb) end
          end;
          mustbe(x, y)
end   end;

procedure expression(var x: integer);
  var op: symbol; y: integer;
begin simplexpression(x);
      if sym in [eql, neq, lss, leq, gtr, geq] then begin
          if ttab[x].kind<>simple then error(118);
          op:= sym; getsym; simplexpression(y); mustbe(x, y);
          case op of
            eql: gen0(eqli);
            neq: gen0(neqi);
            lss: gen0(lssi);
            leq: gen0(leqi);
            gtr: gen0(gtri);
            geq: gen0(geqi)
          end;
          x:= booltip
end   end;

procedure statement;
  var i, j, t, x: integer;
begin if sym=ident then begin
          i:= position;
          with itab[i] do
          case kind of
            varbl: begin selector(t, i); skip(becomes);
                         expression(x); mustbe(t, x);
                         if i=0 then gen0(swap)
                                else addressvar(i);
                         if ttab[t].kind=simple
                         then gen0(stor)
                         else gen1(move, ttab[t].size)
                   end;
            funkt: if tip=0 then
                       funcall(i)
                   else begin
                       if not inside then error(119);
                       getsym; skip(becomes);
                       expression(x); mustbe(tip, x);
                       address(flevel+1, resultadr);
                       gen0(stor)
                   end;
            konst, field, tipe: error(120)
          end
      end else if sym=ifsym then begin
          getsym; expression(t); mustbe(booltip, t); skip(thensym);
          i:= codelabel; gen1(jumpz, 0); statement;
          if sym=elsesym then begin
              getsym; j:= codelabel; gen1(jump, 0);
              code[i].a:= codelabel; i:= j; statement
          end;
          code[i].a:= codelabel
      end else if sym=whilesym then begin
          getsym; i:= codelabel; expression(t); mustbe(booltip, t);
          skip(dosym); j:= codelabel; gen1(jumpz, 0);
          statement; gen1(jump, i);
          code[j].a:= codelabel
      end else if sym=repeatsym then begin
          i:= codelabel;
          repeat getsym; statement until sym<>semicolon;
          skip(untilsym); expression(t); mustbe(booltip, t);
          gen1(jumpz, i)
      end else if sym=beginsym then begin
          repeat getsym; statement until sym<>semicolon;
          skip(endsym)
end   end;

procedure block(l: integer);
  forward;

procedure constant(var c, t: integer);
  var i, s: integer;
begin if (sym=sstring) and (slen=1) then begin
          c:= ord(str[1]); t:= chartip
      end else begin
          if sym=plus  then begin getsym; s:= +1 end else
          if sym=minus then begin getsym; s:= -1 end
                       else s:= 0;
          if sym=ident then begin
              i:= position;
              if itab[i].kind<>konst then error(121);
              c:= itab[i].val; t:= itab[i].tip
          end else if sym=number then begin
              c:= num; t:= intip
          end else
              error(122);
          if s<>0 then begin mustbe(t, intip); c:= c*s end
      end;
      getsym
end;

procedure constdeclaration;
  var a: alfa; t, c: integer;
begin a:= id; getsym; skip(eql); constant(c, t);
      skip(semicolon); enter(a, konst, t); itab[ix].val:= c
end;

procedure typ(var t: integer);
  var i, j, sz, ft: integer;
  procedure arraytyp(var t: integer);
    var x: integer;
  begin with ttab[t] do begin
            kind:= arrays; getsym; constant(low, x); mustbe(intip, x);