sanyuanshi.~pas

delphi编的pl0编译器

unit SanYuanShi;

interface
uses
  SysUtils,Defination,Main,YuFaFenXi;

const
  cxmax=2000;
type
  fct=(none,lit,opr,lod,sto,cal,int,jmp,jpc);
  instruction=record
              f:fct;
              l:0..3;
              a:0..2047;
            end;

var
  code:array[0..2000]of instruction;
  mnemonic:array[fct]of array[1..5]of char;
  cx:integer;
  sym:symbol;



procedure final;


implementation



procedure init;
begin
  mnemonic[lit]:='lit  ';
  mnemonic[opr]:='opr  ';
  mnemonic[lod]:='lod  ';
  mnemonic[sto]:='sto  ';
  mnemonic[cal]:='cal  ';
  mnemonic[int]:='int  ';
  mnemonic[jmp]:='jmp  ';
  mnemonic[jpc]:='jpc  ';
  sym:=wordlist[1].symb;
  id:=wordlist[1].name;
  cx:=0;
end;
procedure listcode;
var
i:integer;

begin
  MainForm.Memo4.Lines.Append(' ');
  for i:=0 to cx-1 do
  begin
    MainForm.Memo4.Lines.Append(inttostr(i)+'    (  '+mnemonic[code[i].f]
              +'  , '+inttostr(code[i].l)+
              '  , '+inttostr(code[i].a)+'  ) ');

  end;
  MainForm.Memo4.Lines.Append(' ');
end;

procedure error(n:integer);
begin
  err:=err+1;
  Mainform.Memo2.Lines.Append('行号:'+
                        inttostr(wordlist[temp_wordlist_index].info));
  mainform.Memo2.Lines.Append('   '+
                              wordlist[temp_wordlist_index].name+
                              '    :'
                              +'             '+errlist[n]);
end;

procedure getsym;
begin
  inc(temp_wordlist_index);
  sym:=wordlist[temp_wordlist_index].symb;
  id:=wordlist[temp_wordlist_index].name;

end;


procedure gen(x:fct;y,z:integer);
begin
  with code[cx] do
  begin
    f:=x;
    l:=y;
    a:=z;
  end;
  cx:=cx+1;
end;



procedure test(s1,s2:symset;n:integer);
begin
  if not(sym in s1) then
  begin
    error(n);
    s1:=s1+s2;
    while not(sym in s1) do getsym;
  end;
end;


procedure block(lev,table_index:integer;fsys:symset);
var
  data_index:integer;
  tx0:integer;
  cx0:integer;
  procedure enter(n:integer);
  
  begin
    inc(table_index);

      table[table_index].name:=wordlist[n].name;
      if ident_kind=7 then
      begin
        table[table_index].kind:=7;
        table[table_index].level:=lev;
      end;
      if ident_kind=5 then
      begin
        table[table_index].kind:=5;
        table[table_index].level:=lev;
        table[table_index].adr:=data_index;
        inc(data_index);
      end;
      if ident_kind=6 then
      begin
        table[table_index].name:=wordlist[n-2].name;
        table[table_index].kind:=6;
        table[table_index].value:=wordlist[n].value;
      end;
    
  end;//enter

  function position(id:alfa):integer;
  var
    i:integer;
  begin
    table[0].name:=id;
    i:=table_index;
    while table[i].name<>id do dec(i);
    position:=i;
  end;

  procedure constdeclaretion;
  begin
    if sym=ident then
    begin
      ident_kind:=6;
      getsym;
      if sym in[eql,becomes] then
      begin
        if sym=becomes then error(1);
        getsym;
        if sym=number then
        begin
          enter(temp_wordlist_index);
          getsym;
        end
        else error(2);
      end
      else error(3);
    end
    else error(4);
  end;

  procedure vardeclaration;
  begin
    if sym=ident then
    begin
      ident_kind:=5;
      enter(temp_wordlist_index);
      getsym;
    end
    else error(4);
  end;



  procedure statement(fsys:symset);
  var
    i,cx1,cx2:integer;

    procedure expression(fsys:symset);
    var
      addop:symbol;

      procedure term(fsys:symset);
      var
        mulop:symbol;

        procedure factor(fsys:symset);
        var
          i:integer;
        begin
          test(facbegsys,fsys,24);
          while sym in facbegsys do
          begin
            if sym=ident then
            begin
              i:=position(id);
              if i=0 then error(11)
              else with table[i] do
                case kind of
                  
                  5:gen(lod,lev-level,adr);
                  6:gen(lit,0,value);
                  7:error(21);
                end;
              getsym;
            end
            else
              if sym=number then
              begin
                num:=wordlist[temp_wordlist_index].value;
                gen(lit,0,num);
                getsym;
              end
              else
                if sym=lparen then
                begin
                  getsym;
                  expression([rparen]+fsys);
                  if sym=rparen then getsym
                  else error(22);
                end;
              test(fsys,facbegsys,23);
            end;
          end;  {factor}

      begin{term}
        factor([times,slash]+fsys);
        while sym in [times,slash] do
        begin
          mulop:=sym;
          getsym;
          factor(fsys+[times,slash]);
          if mulop=times then gen(opr,0,4)
          else gen(opr,0,5);
        end;
      end;

    begin{expression}
      if sym in[plus,minus] then
      begin
        addop:=sym;
        getsym;
        term(fsys+[plus,minus]);
        if addop=minus then gen(opr,0,1)
      end
      else term(fsys+[plus,minus]);
      while sym in [plus,minus] do
      begin
        addop:=sym;
        getsym;
        term(fsys+[plus,minus]);
        if addop=plus then gen(opr,0,2)
        else gen(opr,0,3);
      end;
    end;

    procedure condition(fsys:symset);
    var
      relop:symbol;
    begin
      if sym=oddsym then
      begin
        getsym;
        expression(fsys);
        gen(opr,0,6);
      end
      else
      begin
        expression([eql,neq,lss,leq,gtr,geq]+fsys);
        if not(sym in[eql,neq,lss,leq,gtr,geq]) then error(20)
        else
        begin
          relop:=sym;
          getsym;
          expression(fsys);
          case relop of
            eql:gen(opr,0,8);
            neq:gen(opr,0,9);
            lss:gen(opr,0,10);
            geq:gen(opr,0,11);
            gtr:gen(opr,0,12);
            leq:gen(opr,0,13);
          end;
        end;
      end;
    end;{condition}

  begin{statement}
    if sym=ident then
    begin
      i:=position(id);
      if i=0 then error(11)
      else
        if table[i].kind<>5 then//variable then
        begin
          error(12);
          i:=0;
        end;
      getsym;
      if sym=becomes then getsym
      else error(13);
      expression(fsys);
      if i<>0 then
      with table[i] do gen(sto,lev-level,adr);
    end
    else
      if sym=readsym then
      begin
        getsym;
        if sym<>lparen then error(34)
        else
          repeat
            getsym;
            if sym=ident then i:=position(id)
            else i:=0;
            if i=0 then error(35)
            else
            with table[i] do
            begin
              gen(opr,0,16);
              gen(sto,lev-level,adr);
            end;
            getsym
          until sym<>comma;
        if sym<>rparen then
        begin
          error(33);
          while not(sym in fsys) do getsym;
        end
        else getsym;
      end
      else
        if sym=writesym then
        begin
          getsym;
          if sym=lparen then
          begin
            repeat
              getsym;
              expression([rparen,comma]+fsys);
              gen(opr,0,14)
            until sym<>comma;
            if sym<>rparen then error(33)
            else getsym;
          end;
          gen(opr,0,15);
        end
        else
          if sym=callsym then
          begin
            getsym;
            if sym<>ident then error(14)
            else
            begin
              i:=position(id);
              if i=0 then error(11)
              else
              with table[i] do
                if kind=7 then gen(cal,lev-level,adr)
                else error(15);
              getsym;
            end;
          end
          else
            if sym=ifsym then
            begin
              getsym;
              condition([thensym,dosym]+fsys);
              if sym=thensym then getsym
              else error(16);
              cx1:=cx;
              gen(jpc,0,0);
              statement(fsys);
              code[cx1].a:=cx;
            end
            else
              if sym=beginsym then
              begin
                getsym;
                statement([semicolon,endsym]+fsys);
                while sym in [semicolon]+statbegsys do
                begin
                  if sym=semicolon then getsym
                  else error(10);
                  statement([semicolon,endsym]+fsys);
                end;
                if sym=endsym then getsym
                else error(17);
              end
              else
                if sym=whilesym then
                begin
                  cx1:=cx;
                  getsym;
                  condition([dosym]+fsys);
                  cx2:=cx;
                  gen(jpc,0,0);
                  if sym=dosym then getsym
                  else error(18);
                  statement(fsys);
                  gen(jmp,0,cx1);
                  code[cx2].a:=cx;
                end;
    test(fsys,[],19);
  end;{statement}

begin
  data_index:=3;
  tx0:=table_index;
  table[table_index].adr:=cx;
  gen(jmp,0,0);

  repeat
    if sym=constsym then
    begin
      getsym;
      repeat
        constdeclaretion;
        while sym=comma do
        begin
          getsym;
          constdeclaretion;
        end;
        if sym=semicolon then getsym
        else error(5)
      until sym<>ident;
    end;
    if sym=varsym then
    begin
      getsym;
      repeat
        vardeclaration;
        while sym=comma do
        begin
          getsym;
          vardeclaration;
        end;

        if sym=semicolon then getsym
        else error(5)
      until sym<>ident;
    end;
    while sym=procsym do
    begin
      getsym;
      if sym=ident then
      begin
        ident_kind:=7;
        enter(temp_wordlist_index);
        getsym;
      end
      else error(4);
      if sym=semicolon then getsym
      else error(5);
      block(lev+1,table_index,[semicolon]+fsys);
      if sym=semicolon then
      begin
        getsym;
        test(statbegsys+[ident,procsym],fsys,6);
      end
      else error(5);
    end;
    test(statbegsys+[ident]+[semicolon],declbegsys,7)
  until not(sym in declbegsys);
  code[table[tx0].adr].a:=cx;
  with table[tx0] do
  begin
    adr:=cx;
    size:=data_index;
  end;
  cx0:=cx;
  gen(int,0,data_index);
  statement([semicolon,endsym]+fsys);
  gen(opr,0,0);
  test(fsys,[],8);

end;{block}

procedure final;          //产生中间代码
label endflag;
begin
  Initialize;
  init;
  err:=0;
  if_end:=false;
  num:=0;
  temp_wordlist_index:=1;
  table_index:=0;

  declbegsys:=[constsym,varsym,procsym];
  statbegsys:=[beginsym,callsym,ifsym,whilesym];
  facbegsys:=[ident,number,lparen];

  if temp_wordlist_index>wordlist_index then
  begin
    error(9);
    exit;
  end;

  /////////////////////////////////////////////////////
  if wordlist[1].symb=period then         //Bug处理
  begin
    code[0].f:=jmp;code[0].l:=0;code[0].a:=1;
    code[1].f:=int;code[1].l:=0;code[1].a:=3;
    code[2].f:=opr;code[2].l:=0;code[2].a:=0;
    cx:=3;
    goto endflag;
  end;

  block(0,0,[period]+declbegsys+statbegsys);


  if if_end then exit;////////////////////////////

  if err=0 then MainForm.Memo2.Lines.Append('  程序无语法错误，可以继续编译!');

endflag:
  listcode;

end;



end.