mainunit.pas

简单编译器的源代码,是大学课程设计内容,附简单测试用例

unit mainUnit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ExtCtrls, ComCtrls, ToolWin, Menus, ActnList, ImgList,
  ShellApi,
  pcommon,plscan,plparser,plassemb;

type
  TmainForm = class(TForm)
    MainMenu1: TMainMenu;
    StatusBar: TStatusBar;
    F1: TMenuItem;
    N1: TMenuItem;
    O1: TMenuItem;
    S1: TMenuItem;
    K1: TMenuItem;
    N18: TMenuItem;
    N19: TMenuItem;
    N20: TMenuItem;
    N21: TMenuItem;
    N22: TMenuItem;
    N23: TMenuItem;
    PageControl: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    TabSheet3: TTabSheet;
    yuanchengcu: TRichEdit;
    cifafenxishuchu: TRichEdit;
    yufayuyifenxishuchu: TRichEdit;
    OpenDialog: TOpenDialog;
    SaveDialog: TSaveDialog;
    TabSheet4: TTabSheet;
    mubiaodaimashuchu: TRichEdit;
    errpage: TPanel;
    TabSheet5: TTabSheet;
    result: TMemo;
    error: TRichEdit;
    CoolBar1: TCoolBar;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    SpeedButton4: TSpeedButton;
    N2: TMenuItem;
    N3: TMenuItem;
    N5: TMenuItem;
    SpeedButton6: TSpeedButton;
    TabSheet6: TTabSheet;
    help: TRichEdit;
    procedure newButtonClick(Sender: TObject);
    procedure yuanchengcuChange(Sender: TObject);
    procedure SaveButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure X1Click(Sender: TObject);
    procedure OpenButtonClick(Sender: TObject);
    procedure A1Click(Sender: TObject);
    procedure PrintButtonClick(Sender: TObject);
    procedure UndoButtonClick(Sender: TObject);
    procedure CutButtonClick(Sender: TObject);
    procedure CopyButtonClick(Sender: TObject);
    procedure PasteButtonClick(Sender: TObject);
    procedure N11Click(Sender: TObject);
    procedure N13Click(Sender: TObject);
    procedure FindDialogFind(Sender: TObject);
    procedure N12Click(Sender: TObject);
    procedure PL1Click(Sender: TObject);
    procedure yuanchengcuSelectionChange(Sender: TObject);
    procedure runClick(Sender: TObject);
    procedure noerrClick(Sender: TObject);
    procedure PLInterpreter;
    procedure ToolButton1Click(Sender: TObject);
    procedure N16Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure BitBtn3Click(Sender: TObject);
    procedure BitBtn4Click(Sender: TObject);
    procedure init;
    procedure StandardToolBarMouseMove(Sender: TObject; Shift: TShiftState;
      X, Y: Integer);
    procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure yuanchengcuMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure errmsgMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure cifafenxishuchuMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure yufayuyifenxishuchuMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure mubiaodaimashuchuMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure PageControlMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure resultMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure SpeedButton6Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  mainForm: TmainForm;
  maindir,filename:string;  Code0:  text;  runobj:boolean;

implementation



{$R *.DFM}

   {  the PL interpreter  }
procedure tmainform.PLInterpreter;
const
    min=1;
    max=8191;
type
     OperationPart=(Add2,And2,Arrow2,Assign2,Bar2,Call2,constant2,Divide2,
                    EndPro2,EndProg2,Equal2,Fi2,Greater2,Index2,Less2,Minus2,
                    Modulo2,Multiply2,Not2,Or2,Proc2,Prog2,Read2,Subtract2,
                    Value2,Variable2,Write2);
     String1=string[30];
     Store=array[min..max] of integer;
var
     St:Store;
     p,b,s:integer; StackBottom:integer;
     Running:Boolean;
   //  ProgramName:String1;
   //  Code:text;

procedure  Error(LineNo:integer; text1:String1);
begin
    Writeln('LineNo',LineNo:5,' ',Text1); Running:=false
end;

procedure  Allocate(Words:integer);
begin {writeln; writeln(s);}
   s:=s+Words;   {writeln(s); }
   if s>Max then begin Writeln('Stack overflow'); Running:=false end
end;

{variableAccess::="Variable"[Expression"Index"]}
procedure Variable(Level,Displ:integer);
var x:integer;
begin
     Allocate(1); x:=b;
     while Level>0 do begin x:=St[x]; Level:=Level-1 end;
     St[s]:=x+Displ; p:=p+3
end;

procedure Index(Bound, LineNo:integer);
var i:integer;
begin
      i:=St[s]; s:=s-1; p:=p+3;
      if (i<1) or (i>Bound) then  Error(LineNO,'Range Error')
      else St[s]:=St[s]+i-1
end;

{ Factor::="constant"| VariableAccess"Value"|Expression|Factor"Not"}
procedure Constant(Value:integer);
begin
    Allocate(1);
    St[s]:=Value;
    p:=p+2
end;

procedure Value;
begin
   St[s]:=St[St[s]]; p:=p+1
end;

procedure  Notx;
begin
   St[s]:=1-St[s]; p:=p+1
end;

 {Term::=Factor # Factor MultiplyingOperator #
MultiplyingOperator::="Multiply" | "Divide" | "Modulo" }
procedure Multiply;
begin
   p:=p+1; s:=s-1; St[s]:=St[s]*St[s+1]
end;

procedure Divide;
begin
   p:=p+1; s:=s-1; St[s]:=St[s] div St[s+1]
end;

procedure Modulo;
begin
   P:=p+1;  s:=s-1; St[s]:=St[s] mod St[s+1]
end;

 {SimpleExpression::=Term["Minus"] # Term AddingOperator #
  AddingOperator::="Add" | "subtract"}
procedure Minus;
begin
  St[s]:=-St[s]; p:=p+1
end;

procedure Add;
begin
   p:=p+1; s:=s-1; St[s]:=St[s]+St[s+1]
end;

procedure Subtract;
begin
   p:=p+1; s:=s-1; St[s]:=St[s]-St[s+1]
end;

{ primaryExpression::=SimpleExpression [SimpleExpression RelationOperator]
  RelationlOperator::="Less" | "Equal" | "Greater"}
procedure Less;
begin
   p:=p+1; s:=s-1; St[s]:=ord(St[s]<St[s+1])
end;

procedure Equal;
begin
    p:=p+1; s:=s-1; St[s]:=ord(St[s]=St[s+1])
end;

procedure Greater;
begin
   p:=p+1;  s:=s-1; St[s]:=ord(St[s]>St[s+1])
end;

{Expression::=PrimaryExpression # PrimaryExpression PrimaryOperator #
PrimaryOperator::="And" | "Or" }
procedure Andx;
begin
    p:=p+1; s:=s-1;
    if St[s]=1 then St[s]:=St[s+1]
 end;

procedure Orx;
begin
   p:=p+1; s:=s-1;
   if St[s]=0 then St[s]:=St[s+1]
end;

{Readstatement::=VariableList "Read"
 VariableList::=VariableAccess # VariableAccess # }
procedure  Readx(No:integer);
var tmpstr:string; inp,int:boolean;  x,i:integer;
begin
   {  Write('?');
     Readln(St[St[s]]);       }
   p:=p+2; s:=s-No; x:=s;
   while x<s+No do
    begin
     x:=x+1;
     inp:=false;
     result.Lines.Add(' 输 入 ： ');
     while not inp do
       If InputQuery('输入对话框', '请输入一个整数：', TmpStr) then
         begin
           if TmpStr<>'' then
             begin
              int:=true;
              for i:=1 to length(TmpStr) do
                if not (TmpStr[i] in ['0'..'9']) then int:=false;
              if int then
                begin
                  St[St[x]]:=strtoint(TmpStr);
                  result.Lines[result.Lines.Count-1]:=' 输 入 ： '+ TmpStr;
                  inp:=true;
                end
              else showmessage('出错：类型不匹配！请输入整数！');
            end
          else showmessage('出错：输入不能为空值！请输入整数！');
        end
      else showmessage('出错：你必须输入一个整数，否则程序无法运行！');
    end;
end;

 {WriteStatement::=ExpressionList "Write"
  ExpressionList::=Expression # Expression # }
procedure Writex(No:integer);
var  x:integer;
begin
   p:=p+2; s:=s-No; x:=s;
   while x<s+No do 
      begin
        x:=x+1;
        result.Lines.Add(' 输 出 ： '+inttostr(St[x]));
      end
end;

{AssignmentStatement::=VariableList ExpressionList}
procedure AssignValue(No:integer);
var x:integer;
Begin
     p:=p + 2; s:= s - 2 * No; x:=s;
     while x < s + No do
      begin
        x:=x+1;
        St[St[x]] :=St[x + No]
      end;
end;

{ ProcedureStatement ::= "Call" }
procedure Callx( Level ,Addr : integer);
var x:integer;
begin
 Allocate(3); x := b;
 while Level > 0 do
    begin x :=St[x]; Level := Level -1 end;
 St[s-2] :=x; St[s-1] := b; St[s] := p +3; b:= s -2; p := Addr
end;

{ IfStatement ::= GuardedCommandList  "Fi"
 DoStatement ::= GuardedCommandList
 GuardedCommandList ::= GuardedCommand # GuardedCommand #
 GuardedCommand ::= Expression "Arrow" StatementPart "Bar" }

procedure Arrow ( Addr :integer);
begin
   if St[s] = ord (true ) then p:= p+2 else p:= Addr;
   s :=s-1
end;

procedure Bar (Addr :Integer);
begin
   p :=Addr
end;

procedure Fi (LineNo :Integer);
begin
   Error ( LineNo, 'If Statement Fails')
end;

{ ProcedureDefinition ::= "Proc" Block " EndProc"
  Block ::= # ProcedureDefinition # StatementPart
  Statement ::= Empty | ReadStatement | WriteStatement| AssignmentSatemnet
  ProcedureStatement| IfStatement  | DoStatement }
procedure Proc (VarLength, Addr :integer);
begin
   Allocate (VarLength); p:= Addr 
end;

procedure EndProc;
begin
   s:= b-1; p := St[b +2]; b:=St[b+1]
end;

{ Program ::="Prog" Block "EndProg" }
procedure Prog (VarLength, Addr :integer);
begin
    b := StackBottom; s:= b; Allocate(VarLength +2); P :=Addr
end;

procedure EndProg;
begin
    Running := false
end;

procedure LoadProgram;
var x:integer;
begin
   x:=Min;
   While not Eof(Code0 ) do
     begin
       readln(Code0, St[x]);
       x:= x+1
     end;
   StackBottom :=x
end;

procedure RunProgram;
var op, op5:integer;
begin
   Running:=true;
   p :=min;
   while Running do
   begin
     op :=St[p]; op5 :=op div 5;
     case op5 of
     0: case op of
        0 {add2}   :add;
        1 {And2}   :Andx;
        2 {Arrow2} :Arrow(St[p+1]);
        3 {Assign2}:AssignValue(St[p+1]);
        4 {bar2}   :Bar(St[p+1])
       end;
      1: case op of
        5 {Call2}    : Callx(St[p+1],St[p+2]);
        6 {constant2}: Constant (St[p+1]);
        7 {divide2}  :Divide;
        8 {EndProc2} :EndProc;
        9 {EndProg2} :EndProg
      end;
      2: case op of
       10{Equal2}   :Equal;
       11{Fi2}      :Fi(St[p+1]);
       12{Greater2} :Greater;
       13{Index2}   :Index(St[p+1],St[p+2]);
       14{Less2}    :Less
       end;
      3: case op of
        15{Minus2}    :Minus;
        16{Modulo2}   :Modulo;
        17{Multiply2} :Multiply;
        18{not2}      :Notx;
        19{or2}       :Orx
        end;
      4: case op of
        20{Proc2}      :Proc(St[p+1],St[p+2]);
        21{Prog2}      :Prog(St[p+1],St[p +2]);
        22{read2}      :Readx(St[p+1]);
        23{subtract2}  :Subtract;
        24{value2}     :Value
        end;
      5: case op of
        25{variable2}  :Variable(St[p+1],St[p+2]);
        26{write2}     :Writex(St[p+1])
       end
     end { case op5 }
   end {while}
end;

 {  PL Interpreter  }
begin
   result.Lines.Add('  ');
   assignfile(Code0, ChangeFileExt(filename,'.COD'));
   Reset(Code0);
   LoadProgram;
   RunProgram;
   Closefile(Code0);
   result.Lines.Add('  ');
   StatusBar.Panels[4].Text:='程序结束！';
end;


procedure TmainForm.newButtonClick(Sender: TObject);
begin
   yuanchengcu.Lines.Clear ;
   yuanchengcu.Lines.Add('begin');
   yuanchengcu.Lines.add('   ');
   yuanchengcu.Lines.Add('end.');
   filename:=maindir+'kechengshiji.pl';
   init;
   PageControl.ActivePage:=TabSheet1;
   cifafenxishuchu.Lines.Clear ;
   yufayuyifenxishuchu.Lines.Clear ;
   mubiaodaimashuchu.Lines.Clear ;
   result.Lines.Clear ;   
end;

procedure TmainForm.yuanchengcuChange(Sender: TObject);
begin

   s1.Enabled :=true;
end;

procedure TmainForm.SaveButtonClick(Sender: TObject);
begin
   if filename=maindir+'kechengsiji.pl' then
      A1Click(nil)   //save as
   else
     begin
       s1.Enabled :=false;