mainform.pas

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

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ExtCtrls, StdCtrls, ToolWin, ComCtrls, ImgList,
  RunForm, TableForm, StackForm ,AboutForm;

const
  norw=13;
  txmax=100;
  nmax=14;
  al=10;
  amax=2047;
  levmax=3;
  cxmax=200;
  stacksize=500;  

type
  symbol=(nul,ident,number,plus,minus,times,slash,oddsym,
          eql,neq,lss,leq,gtr,geq,lparen,rparen,comma,
          semicolon,period,becomes,beginsym,endsym,ifsym,
          thensym,whilesym,writesym,readsym,dosym,callsym,
          constsym,varsym,procsym);
  alfa=string[al];
  objects=(constant,variable,procedur);
  symset=set of symbol;
  fct=(lit,opr,lod,sto,cal,int,jmp,jpc);
  instruction=packed record
                       f:fct;
                       l:0..levmax;
                       a:0..amax;
                     end;

  TfrmMain = class(TForm)
    MainMenu: TMainMenu;
    menuFile: TMenuItem;
    menuEdit: TMenuItem;
    menuComplete: TMenuItem;
    menuWindow: TMenuItem;
    menuHelp: TMenuItem;
    menuitemNew: TMenuItem;
    menuitemOpen: TMenuItem;
    N3: TMenuItem;
    menuitemExit: TMenuItem;
    StatusBar: TStatusBar;
    ToolBar: TToolBar;
    Splitter1: TSplitter;
    MsgCode: TListBox;
    MsgError: TListBox;
    Splitter2: TSplitter;
    OpenDialog: TOpenDialog;
    menuitemSaveAs: TMenuItem;
    menuitemSave: TMenuItem;
    SaveDialog: TSaveDialog;
    ImageList: TImageList;
    tbNew: TToolButton;
    tbOpen: TToolButton;
    tbSave: TToolButton;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    MsgEdit: TRichEdit;
    menuitemCut: TMenuItem;
    menuitemCopy: TMenuItem;
    menuitemPaste: TMenuItem;
    menuitemRun: TMenuItem;
    menuitemRunWin: TMenuItem;
    menuitemAbout: TMenuItem;
    menuitemTable: TMenuItem;
    menuitemStack: TMenuItem;
    Timer: TTimer;
    procedure menuitemExitClick(Sender: TObject);
    procedure menuitemOpenClick(Sender: TObject);
    procedure menuitemNewClick(Sender: TObject);
    procedure menuitemSaveAsClick(Sender: TObject);
    procedure menuitemSaveClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure menuitemRunWinClick(Sender: TObject);
    procedure menuitemStackClick(Sender: TObject);
    procedure menuitemTableClick(Sender: TObject);
    procedure menuitemRunClick(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
    procedure MsgEditKeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure MsgEditMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure MsgEditEnter(Sender: TObject);
    procedure menuitemCutClick(Sender: TObject);
    procedure menuitemCopyClick(Sender: TObject);
    procedure menuitemPasteClick(Sender: TObject);
    procedure menuitemAboutClick(Sender: TObject);
  private
    { Private declarations }
    FileName:AnsiString;
    ch:char;
    sym:symbol;
    id:alfa;
    num:integer;
    cc:integer;
    ll:integer;
    kk:integer;
    cx:integer;
    line:AnsiString;
    a:alfa;
    code:array [0..cxmax] of instruction;
    word:array [1..norw] of alfa;
    wsym:array [1..norw] of symbol;
    ssym:array [' '..'^'] of symbol;
    mnemonic:array [fct] of string[5];
    declbegsys,statbegsys,facbegsys:symset;
    table:array [0..txmax] of record
                               name:alfa;
                               case kind:objects of
                                 constant:(val:integer);
                                 variable,procedur:(level,adr,size:integer);
                               end;
    err:integer;
    errstr:array [1..40] of string;
    mLine:integer;
    stop:boolean;
    p,b,t:integer;
    i:instruction;
    s:array [1..stacksize] of integer;
  public
    { Public declarations }
    procedure reset;
    procedure quit;
    procedure error(n:integer);
    procedure getsym;
    procedure gen(x:fct; y,z:integer);
    procedure test(s1,s2:symset; n:integer);
    procedure block(lev,tx:integer; fsys:symset);
    procedure interpret;
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}
{-----------------------------------------------------------}
procedure TfrmMain.reset;
var
 lc:char;
begin
 mLine:=0;
 err:=0;
 cc:=0;
 cx:=0;
 ll:=0;
 ch:=' ';
 kk:=al;
 stop:=false;

 for lc:=' ' to '!' do ssym[lc]:=nul;

 word[1]:='begin'; word[2]:='call';
 word[3]:='const'; word[4]:='do';
 word[5]:='end';   word[6]:='if';
 word[7]:='odd';   word[8]:='procedure';
 word[9]:='read';  word[10]:='then';
 word[11]:='var';  word[12]:='while';
 word[13]:='write';

 wsym[1]:=beginsym;     wsym[2]:=callsym;
 wsym[3]:=constsym;     wsym[4]:=dosym;
 wsym[5]:=endsym;       wsym[6]:=ifsym;
 wsym[7]:=oddsym;       wsym[8]:=procsym;
 wsym[9]:=readsym;      wsym[10]:=thensym;
 wsym[11]:=varsym;      wsym[12]:=whilesym;
 wsym[13]:=writesym;

 ssym['+']:=plus;        ssym['-']:=minus;
 ssym['*']:=times;       ssym['/']:=slash;
 ssym['(']:=lparen;      ssym[')']:=rparen;
 ssym['=']:=eql;         ssym[',']:=comma;
 ssym['.']:=period;      ssym['#']:=neq;
 ssym[';']:=semicolon;

 mnemonic[lit]:='lit ';       mnemonic[opr]:='opr ';
 mnemonic[lod]:='lod ';       mnemonic[sto]:='sto ';
 mnemonic[cal]:='cal ';       mnemonic[int]:='int ';
 mnemonic[jmp]:='jmp ';       mnemonic[jpc]:='jpc ';

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

 errstr[1]:='常数说明中的"="写成了":="';
 errstr[2]:='常数说明中的"="后应是数字';
 errstr[3]:='常数说明中的标识符后应是"="';
 errstr[4]:='const,var,procedure后应是标识符';
 errstr[5]:='漏掉了","或";"';
 errstr[6]:='过程说明后的符号不正确(应是语句开始符,或过程定义符)';
 errstr[7]:='应是语句开始符';
 errstr[8]:='程序体内语句部分的后跟符不正确';
 errstr[9]:='语句结尾丢了句号"."';
 errstr[10]:='语句之间漏了";"';
 errstr[11]:='标识符未说明';
 errstr[12]:='赋值语句中,赋值号左部标识符属性应是变量';
 errstr[13]:='赋值语句左部标识符后因是赋值号":="';
 errstr[14]:='call后应为标识符';
 errstr[15]:='call后标识符属性应为过程';
 errstr[16]:='条件语句中丢了"then"';
 errstr[17]:='丢了"end"或";"';
 errstr[18]:='while型循环语句中丢了"do"';
 errstr[19]:='语句后的符号不正确';
 errstr[20]:='应为关系运算符';
 errstr[21]:='表达式内标识符属性不能是过程';
 errstr[22]:='表达式中漏掉右括号")"';
 errstr[23]:='因子后的非法符号';
 errstr[24]:='表达式的开始符不能是此符号';
 errstr[31]:='数越界';
 errstr[32]:='read语句括号中的标识符不是变量';
 errstr[39]:='程序太长';
 errstr[40]:='程序不完整，不能被编译';

 MsgError.Clear;
 MsgCode.Clear;

 frmRun.mView.Lines.Clear;
 frmTable.mView.Items.Clear;

 frmRun.Tag:=0;
 t:=0; b:=1; p:=0;
 s[1]:=0; s[2]:=0; s[3]:=0;

end;

procedure TfrmMain.quit;
begin
 ch:='.';
 stop:=true;
end;

procedure TfrmMain.error(n:integer);
begin
 MsgError.Items.Add('在第'+IntToStr(mLine)+'行发现'+IntToStr(n)+'号错误:'+errstr[n]);
 MsgError.Refresh;
 err:=err+1;
end;

procedure TfrmMain.getsym;
 var i,k:integer;

 procedure getch;
  begin
   if cc=ll then
    begin
     ll:=0; cc:=0;
     while ll=0 do
      begin
       if (mLine>MsgEdit.Lines.Count) then
        begin
         error(9);
         error(40);
         quit;
         exit;
        end;
       line:=MsgEdit.Lines[mLine]+' ';
       ll:=length(line);
       mLine:=mLine+1;
      end;
    end;
   cc:=cc+1;
   ch:=line[cc];
  end;

 begin
  while (ch=' ') and (not stop) do getch;
  if ch in ['a'..'z'] then
   begin
    k:=0; a:='';
    repeat
     if k<al then
      begin
       k:=k+1;
       a:=a+ch;
      end;
     getch;
    until not (ch in ['a'..'z','0'..'9']);
    id:=a;
    k:=0;
    for i:=1 to norw do
     begin
      if id=word[i] then k:=i;
     end;
    if k>0 then sym:=wsym[k]
    else sym:=ident;
   end
  else
   if ch in ['0'..'9'] then
    begin
     k:=0;
     num:=0;
     sym:=number;
     repeat
      num:=10*num+(ord(ch)-ord('0'));
      k:=k+1;
      getch;
     until not(ch in ['0'..'9']);
     if k>nmax then error(30);
    end
   else
    if ch=':' then
     begin
      getch;
      if ch='=' then
       begin
        sym:=becomes;
        getch;
       end
      else sym:=nul;
     end
    else
     if ch='<' then
      begin
       getch;
       if ch='=' then
        begin
         sym:=leq;
         getch;
        end
       else sym:=lss
      end
     else
      if ch='>' then
       begin
        getch;
        if ch='=' then
         begin
          sym:=geq;
          getch;
         end
        else sym:=gtr;
       end
      else
       begin
        sym:=ssym[ch];
        if sym<>period then getch
        else quit;
       end;
 end; {getsym}

procedure TfrmMain.gen(x:fct; y,z:integer);
begin
 if cx>cxmax then
  begin
   error(39);
   quit;
   exit;
  end;
 with code[cx] do
  begin
   f:=x;
   l:=y;
   a:=z;
  end;
 cx:=cx+1;
end;

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

procedure TfrmMain.block(lev,tx:integer; fsys:symset);
var
 dx:integer;
 tx0:integer;
 cx0:integer;

 procedure enter(k:objects);
  begin
   tx:=tx+1;
   with table[tx] do
    begin
     name:=id;
     kind:=k;
     case k of
      constant:begin
                if num>amax then
                 begin
                  error(31);
                  num:=0;
                 end;
                val:=num;
                frmTable.mView.Items.Add('常量['+name+'] '+IntToStr(val));
               end;
      variable:begin
                level:=lev;
                adr:=dx;
                dx:=dx+1;
                frmTable.mView.Items.Add('变量['+name+'] '+IntToStr(level)+':'+IntToStr(adr)+':'+IntToStr(dx));
               end;
      procedur:begin
                level:=lev;
                frmTable.mView.Items.Add('过程['+name+'] '+IntToStr(level));
               end;
     end;
    end;
  end;{enter}

 function position(id:alfa):integer;
  var i:integer;
  begin
   table[0].name:=id;
   i:=tx;
   while table[i].name<>id do i:=i-1;
   position:=i;
  end;{position}

 procedure constdeclaration;
  begin
   if sym=ident then
    begin
     getsym;
     if sym in [eql,becomes] then
      begin
       if sym=becomes then error(1);
       getsym;
       if sym=number then
        begin
         enter(constant);
         getsym;
        end
       else error(2);
      end
     else error(3);
    end
   else error(4);
  end; {constdeclaration}

 procedure vardeclaration;
  begin
   if sym=ident then
    begin
     enter(variable);
     getsym;
    end
   else error(4);
  end;{vardeclaration}

 procedure listcode;
  var i:integer;
  begin
   for i:=cx0 to cx-1 do
    with code[i] do
     begin
      MsgCode.Items.Add(mnemonic[f]+IntToStr(l)+','+IntToStr(a));
     end;
  end; {listcode}

 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
             constant:gen(lit,0,val);
             variable:gen(lod,lev-level,adr);
             procedur:error(21);
            end;
          getsym;
         end
        else
         if sym=number then
          begin
           if num>amax then
            begin
             error(31);
             num:=0;
            end;
           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
    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;