mainform.pas

用delphi实现的PL/0的编译器

   end;{term}

  begin
   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;{expression}

  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
  if sym=ident then
   begin
    i:=position(id);
    if i=0 then error(11)
    else
     if table[i].kind<>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=procedur 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
 dx:=3;
 tx0:=tx;
 table[tx].adr:=cx;
 gen(jmp,0,0);
 if lev>levmax then error(32);
 repeat
  if sym=constsym then
   begin
    getsym;
    repeat
     constdeclaration;
     while sym=comma do
      begin
       getsym;
       constdeclaration;
      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
      enter(procedur);
      getsym;
     end
    else error(4);
    if sym=semicolon then getsym
    else error(5);
    block(lev+1,tx,[semicolon]+fsys);
    if sym=semicolon then
     begin
      getsym;
      test(statbegsys+[ident,procsym],fsys,6);
     end
    else error(5);
   end;
  test(statbegsys+[ident],declbegsys,7);
 until not(sym in declbegsys);
 code[table[tx0].adr].a:=cx;
 with table[tx0] do
  begin
   adr:=cx;
   size:=dx;
  end;
 cx0:=cx;
 gen(int,0,dx);
 statement([semicolon,endsym]+fsys);
 gen(opr,0,0);
 test(fsys,[],8);
 listcode;
end;{block}

procedure TfrmMain.interpret;

 function base(l:integer):integer;
  var
   b1:integer;
  begin
   b1:=b;
   while l>0 do
    begin
     b1:=s[b1];
     l:=l-1;
    end;
   base:=b1;
  end;{base}

begin
 repeat
  i:=code[p];
  p:=p+1;
  with i do
   case f of
    lit:begin
         t:=t+1;
         s[t]:=a;
        end;
    opr:case a of
         0:begin
            t:=b-1;
            p:=s[t+3];
            b:=s[t+2];
           end;
         1:s[t]:=-s[t];
         2:begin
            t:=t-1;
            s[t]:=s[t]+s[t+1];
           end;
         3:begin
            t:=t-1;
            s[t]:=s[t]-s[t+1];
           end;
         4:begin
            t:=t-1;
            s[t]:=s[t]*s[t+1];
           end;
         5:begin
            t:=t-1;
            s[t]:=s[t] div s[t+1];
           end;
         6:s[t]:=ord(odd(s[t]));
         8:begin
            t:=t-1;
            s[t]:=ord(s[t]=s[t+1]);
           end;
         9:begin
            t:=t-1;
            s[t]:=ord(s[t]<>s[t+1]);
           end;
         10:begin
             t:=t-1;
             s[t]:=ord(s[t]<s[t+1]);
            end;
         11:begin
             t:=t-1;
             s[t]:=ord(s[t]>=s[t+1]);
            end;
         12:begin
             t:=t-1;
             s[t]:=ord(s[t]>s[t+1]);
            end;
         13:begin
             t:=t-1;
             s[t]:=ord(s[t]<=s[t+1]);
            end;
         14:begin
             frmRun.mView.Lines.Text:=frmRun.mView.Lines.Text+'   '+IntToStr(s[t]);
             t:=t-1;
            end;
         15:begin
             frmRun.mView.Lines.Add('');
            end;
         16:begin
             if frmRun.readed=true then
              begin
               frmRun.readed:=false;
               t:=t+1;
               s[t]:=frmRun.WantVal;
              end
             else
              begin
               frmRun.mView.Lines.Add('请输入数值：');
               p:=p-1;
               frmRun.readed:=false;
               Timer.Enabled:=true;
               exit;
              end;
            end;
        end;
    lod:begin
         t:=t+1;
         s[t]:=s[base(l)+a];
        end;
    sto:begin
         s[base(l)+a]:=s[t];
         t:=t-1;
        end;
    cal:begin
         s[t+1]:=base(l);
         s[t+2]:=b;
         s[t+3]:=p;
         b:=t+1;
         p:=a;
        end;
    int:t:=t+a;
    jmp:p:=a;
    jpc:begin
         if s[t]=0 then p:=a;
         t:=t-1;
        end;
   end;
 until p=0;
 MsgError.Items.Add('程序执行完毕！');
 frmRun.mView.Lines.Add('程序执行完毕！');
 frmRun.mView.Lines.Add('按Enter键返回主界面...');
 frmRun.Tag:=1;
end;{interpret}
{-----------------------------------------------------------}

procedure TfrmMain.menuitemExitClick(Sender: TObject);
begin
 Close();
end;

procedure TfrmMain.menuitemOpenClick(Sender: TObject);
begin
 if MsgEdit.Modified then
  case MessageDlg('你已经修改了'+FileName+'文件内容，是否保存？',mtConfirmation,[mbYes,mbNo,mbAbort],0) of
   mrYes:menuitemSaveClick(Application);
   mrAbort:exit;
  end;
 if OpenDialog.Execute then
  begin
   FileName:=OpenDialog.FileName;
   frmMain.Caption:='PL/0 编译器 - '+FileName;
   MsgEdit.Lines.LoadFromFile(OpenDialog.FileName);
   MsgEdit.Modified:=false;
   MsgError.Items.Clear;
   MsgCode.Items.Clear;
  end;
end;

procedure TfrmMain.menuitemNewClick(Sender: TObject);
begin
 if MsgEdit.Modified then
  case MessageDlg('你已经修改了'+FileName+'文件内容，是否保存？',mtConfirmation,[mbYes,mbNo,mbAbort],0) of
   mrYes:menuitemSaveClick(Application);
   mrAbort:exit;
  end;
 MsgEdit.Lines.Clear;
 MsgError.Items.Clear;
 MsgCode.Items.Clear;
 FileName:='';
 frmMain.Caption:='PL/0 编译器'+FileName;
 MsgEdit.Modified:=false;
end;

procedure TfrmMain.menuitemSaveAsClick(Sender: TObject);
begin
 if SaveDialog.Execute then
  begin
   FileName:=SaveDialog.FileName;
   frmMain.Caption:='PL/0 编译器 - '+FileName;
   MsgEdit.Lines.SaveToFile(SaveDialog.FileName);
   MsgEdit.Modified:=false;
  end;
end;

procedure TfrmMain.menuitemSaveClick(Sender: TObject);
begin
 if FileName<>'' then
  begin
   MsgEdit.Lines.SaveToFile(FileName);
   MsgEdit.Modified:=false;
  end
 else
  begin
   menuitemSaveAsClick(Application);
  end;
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 if MsgEdit.Modified then
  case MessageDlg('你已经修改了'+FileName+'文件内容，是否保存？',mtConfirmation,[mbYes,mbNo],0) of
   mrYes:menuitemSaveClick(Application);
   mrAbort:exit;
  end;
end;

procedure TfrmMain.menuitemRunWinClick(Sender: TObject);
begin
 frmRun.Show;
end;

procedure TfrmMain.menuitemStackClick(Sender: TObject);
begin
 frmStack.Show;
end;

procedure TfrmMain.menuitemTableClick(Sender: TObject);
begin
 frmTable.Show;
end;

procedure TfrmMain.menuitemRunClick(Sender: TObject);
begin
 reset;
 MsgError.Items.Add('开始编译'+FileName+'程序...');
 getsym;
 block(0,0,[period]+declbegsys+statbegsys);
 if sym<>period then error(9);
 if err<>0 then MsgError.Items.Add('程序中有'+IntToStr(err)+'处语法错误，编译失败！')
 else
  begin
   MsgError.Items.Add('程序编译成功！');
   if FileName<>'' then MsgError.Items.Add('开始执行程序:'+FileName)
   else MsgError.Items.Add('开始执行程序...');
   frmRun.Show;
   frmRun.mView.Lines.Add('开始执行PL/0程序...');
   if FileName<>'' then frmRun.mView.Lines.Add('文件名:'+FileName);
   interpret;
  end;
end;

procedure TfrmMain.TimerTimer(Sender: TObject);
begin
 if frmRun.readed=true then
  begin
   Timer.Enabled:=false;
   interpret;
  end;
end;

procedure TfrmMain.MsgEditKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 StatusBar.Panels[1].Text:=IntToStr(MsgEdit.CaretPos.Y+1)+' 行，'+IntToStr(MsgEdit.CaretPos.X+1)+' 列';
end;

procedure TfrmMain.MsgEditMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 StatusBar.Panels[1].Text:=IntToStr(MsgEdit.CaretPos.Y+1)+' 行，'+IntToStr(MsgEdit.CaretPos.X+1)+' 列';
end;

procedure TfrmMain.MsgEditEnter(Sender: TObject);
begin
 StatusBar.Panels[1].Text:=IntToStr(MsgEdit.CaretPos.Y+1)+' 行，'+IntToStr(MsgEdit.CaretPos.X+1)+' 列';
end;

procedure TfrmMain.menuitemCutClick(Sender: TObject);
begin
 MsgEdit.CutToClipboard;
end;

procedure TfrmMain.menuitemCopyClick(Sender: TObject);
begin
 MsgEdit.CopyToClipboard;
end;

procedure TfrmMain.menuitemPasteClick(Sender: TObject);
begin
 MsgEdit.PasteFromClipboard;
end;

procedure TfrmMain.menuitemAboutClick(Sender: TObject);
begin
 frmAbout.ShowModal;
end;

end.