untpasscriptcompile.~pas

delphi编写的pascal解释器

  private
    FVarList: TUserVarList;

  public
    constructor Create;
    destructor Destroy; override;

    procedure LoadMethodVar(aMethod: TUserMethod);
    procedure UnLoadVar(aVarNum: integer);
    procedure Clear;
    function getTopValue: variant;

    function GetVarByPos(aPos: integer): TUserVar;
  end;

  TAnalyProgram = class;

  TVMCPU = class
  private
    FVarList: TUserVarList;
    FConstVarList: TUserVarList;
    FMethodList: TUserMethodList;

    FDynaVarStack: TDynaVarStack;
    FCallStack: TCallStack;
    FStack: TStack;

    FVMPCodeList: TVMPCodeList;

    function GetVarList: TUserVarList;
    function GetConstVarList: TUserVarList;
    function GetMethodList: TUserMethodList;

    function GetVMPCodeList: TVMPCodeList;
    procedure Clear;

  public
    constructor Create(aProgram: TAnalyProgram);
    destructor Destroy; override;  

    procedure Run;

    property VarList: TUserVarList read GetVarList;
    property ConstVarList: TUserVarList read GetConstVarList;
    property MethodList: TUserMethodList read GetMethodList;
    property VMPCodeList: TVMPCodeList read GetVMPCodeList; 

  end;

 
  TAnalyDeclare = class
  private
    FCodeMaker: TCodeMaker;
    FTokenReader: TTokenReader;

    procedure Variables;
    procedure Methods;
  public
    constructor Create(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader);
    destructor Destroy; override;
    procedure Analy; overload;

    class procedure Analy(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader); overload;
  end;

  TAnalyExpression = class
  private
    FCodeMaker: TCodeMaker;
    FTokenReader: TTokenReader;

    procedure Expression;
    procedure Term;
    procedure Factor;

  public
    constructor Create(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader);
    destructor Destroy; override;

    procedure Analy; overload;

    class procedure Analy(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader); overload;
  end;

  TAnalyCondition = class
  private
    FCodeMaker: TCodeMaker;
    FTokenReader: TTokenReader;

    procedure Condition;
    
  public
    constructor Create(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader);
    destructor Destroy; override;
    
    procedure Analy;  
  end;

  TAnalyStatement = class
  private
    FCodeMaker: TCodeMaker;
    FTokenReader: TTokenReader;

    procedure Statement;

  public
    constructor Create(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader);
    destructor Destroy; override;

    procedure Analy; overload;

    class procedure Analy(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader); overload;
  end;

  TAnalyCallMethod = class
  private
    FCodeMaker: TCodeMaker;
    FTokenReader: TTokenReader;

  public
    constructor Create(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader);
    destructor Destroy; override;

    procedure Analy; overload;
    class procedure Analy(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader); overload;
  end;

  TAnalyUnit = class(TCodeMaker)
  public
    constructor Create(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader); override;
    destructor Destroy; override;

    procedure Analy; overload;

    procedure AddSysMethod;

    class procedure Analy(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader); overload;
  end;


  TAnalyMethod = class(TCodeMaker)
  private
    FThisMethod: TUserMethod;

    function AddResultVar: TUserVar;

    procedure ProcDef;
    procedure ProcParam;
    procedure ProcBody;

  public
    function RegisterParamVar(aName: string): TUserVar;
    function RegisterVar(aName: string; aAnalyDepth: integer = -1): TUserVar; override;

    constructor Create(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader); override;
    destructor Destroy; override;

    procedure Analy; overload;

    class procedure Analy(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader); overload;

  end;

  TAnalySysMethod = class(TCodeMaker)
  private
    FCustomTokenReader: TTokenReader;
    FSysMethod: TSysProcMethod;

  public
    constructor Create(aCodeMaker: TCodeMaker; aProcDef: string; aSysMethod: TSysProcMethod);  reintroduce;  
    destructor Destroy; override;

    procedure Analy; overload;

    class procedure Analy(aCodeMaker: TCodeMaker; aProcDef: string; aSysMethod: TSysProcMethod); overload;
  end;


  TAnalyProgram = class(TCodeMaker)
  private
    FTokenReader: TTokenReader;

    FVMPCodeList: TVMPCodeList;

    procedure SetSourceCode(aCode: string);
    function GetSourceCode: string;

  public
    function GetVMPCodeList: TVMPCodeList;
    function GetLastVMPCode: TVMPCode; override;
    function PutCode(aCmd, aP1, aP2: integer): TVMPCode; override;
      
    constructor Create; reintroduce; overload;
    destructor Destroy; override;

    function Analy: TVMCPU; overload;

    class function Analy(aCode: string): TVMCPU; overload;

    property SourceCode: string read GetSourceCode write SetSourceCode;
  end;


  function getDataType(astr: string): TDataType;
  procedure myShowMessage(v: TUserVarList);


implementation

function getDataType(astr: string): TDataType;
begin
  Result := dtUnknown;
end;


{ TTokenReader }

procedure TTokenReader.BackByte(aNum: integer);
begin
  if FCurPos - aNum > 0 then FCurPos := FCurPos - aNum
    else FCurPos := 1;
end;

constructor TTokenReader.Create;
begin
  FCurPos := 1;
  FSourceLen := 0;
  FSourceCode := '';

  FResWords := TStringList.Create;
  FResWords.AddObject('program', TObject(rwidProgram));
  FResWords.AddObject('label', TObject(rwidLabel));
  FResWords.AddObject('goto', TObject(rwidGoto));
  FResWords.AddObject('var', TObject(rwidVar));
  FResWords.AddObject('begin', TObject(rwidBegin));
  FResWords.AddObject('end', TObject(rwidEnd));
  FResWords.AddObject('and', TObject(rwidAnd));
  FResWords.AddObject('or', TObject(rwidOr));
  FResWords.AddObject('xor', TObject(rwidXor));
  FResWords.AddObject('not', TObject(rwidNot));
  FResWords.AddObject('shl', TObject(rwidShl));
  FResWords.AddObject('shr', TObject(rwidShr));
  FResWords.AddObject('div', TObject(rwidDiv));
  FResWords.AddObject('mod', TObject(rwidMod));
  FResWords.AddObject('true', TObject(rwidTrue));
  FResWords.AddObject('false', TObject(rwidFalse));
  FResWords.AddObject('if', TObject(rwidIf));
  FResWords.AddObject('then', TObject(rwidThen));
  FResWords.AddObject('else', TObject(rwidElse));
  FResWords.AddObject('while', TObject(rwidWhile));
  FResWords.AddObject('repeat', TObject(rwidRepeat));
  FResWords.AddObject('until', TObject(rwidUntil));
  FResWords.AddObject('for', TObject(rwidFor));
  FResWords.AddObject('to', TObject(rwidTo));
  FResWords.AddObject('downto', TObject(rwidDownto));
  FResWords.AddObject('do', TObject(rwidDo));
  FResWords.AddObject('nil', TObject(rwidNil));
  FResWords.AddObject('null', TObject(rwidNull));
  FResWords.AddObject('Unitinit', TObject(rwidUnitinit));
  FResWords.AddObject('Unitfinal', TObject(rwidUnitfinal));
  FResWords.AddObject('class', TObject(rwidClass));
  FResWords.AddObject('type', TObject(rwidType));
  FResWords.AddObject('constr', TObject(rwidConstr));
  FResWords.AddObject('destr', TObject(rwidDestr));
  FResWords.AddObject('uses', TObject(rwidUses));
  FResWords.AddObject('unit', TObject(rwidUnit));
  FResWords.AddObject('interface', TObject(rwidInterface));
  FResWords.AddObject('implement', TObject(rwidImplement));
  FResWords.AddObject('procedure', TObject(rwidProcedure));
  FResWords.AddObject('private', TObject(rwidPrivate));
  FResWords.AddObject('public', TObject(rwidPublic));
  FResWords.AddObject('protected', TObject(rwidProtected));
  FResWords.AddObject('published', TObject(rwidPublished));
  FResWords.AddObject('function', TObject(rwidFunction));
  FResWords.AddObject('const', TObject(rwidConst));
  FResWords.AddObject('property', TObject(rwidProperty));
  FResWords.AddObject('virtual', TObject(rwidVirtual));
  FResWords.AddObject('override', TObject(rwidOverride));
  FResWords.AddObject('dynamic', TObject(rwidDynamic));
  FResWords.AddObject('record', TObject(rwidRecord));
  FResWords.AddObject('forward', TObject(rwidForward));
  FResWords.AddObject('index', TObject(rwidIndex));
  FResWords.AddObject('read', TObject(rwidRead));
  FResWords.AddObject('write', TObject(rwidWrite));
  FResWords.AddObject('stored', TObject(rwidStored));
  FResWords.AddObject('default', TObject(rwidDefault));
  FResWords.AddObject('abstract', TObject(rwidAbstract));
  FResWords.AddObject('stdcall', TObject(rwidStdcall));

end;

destructor TTokenReader.Destroy;
begin
  FreeAndNil(FResWords);
  
  inherited;
end;

procedure TTokenReader.Error(astr: string);
begin
  raise Exception.Create(astr);
end;

procedure TTokenReader.FilterBalckChar;
var
  aByte: byte;
begin
  aByte := NextByte;
  
  if char(aByte) in BlackSpaces then
      begin
      while char(aByte) in BlackSpaces do aByte := ReadByte;
      
      BackByte(1);
      end;
end;

procedure TTokenReader.FilterBlackAndNote;
var
  aPrePos: integer;
begin
  repeat
    aPrePos := FCurPos;
    
    FilterBalckChar;
    FilterNote;
    
  until aPrePos = FCurPos;
end;

procedure TTokenReader.FilterNote;
var
  aByte: byte;
begin
  { 单行注释 }
  if (NextByte = rcidSlash) and (Next2Byte = rcidSlash) then
      begin
      ReadByte;
      ReadByte;

      aByte := ReadByte;
      while (aByte <> rcidEndOfFile) and (aByte <> rcidEndOfLine) do
          begin
          aByte := ReadByte;
          end;

      ReadByte;
      end;

  { 括弧加星号注释 }
  if (NextByte = rcidOpenBracket) and (Next2Byte = rcidStar) then
      begin
      ReadByte;
      ReadByte;

      repeat
        aByte := ReadByte;
        until ((aByte = rcidStar) and (NextByte = rcidCloseBracket)) or (aByte = rcidEndOfFile);

      ReadByte;
      end;

  { 大括弧注释 } 
  if NextByte = rcidOpenComment then
      begin
      ReadByte;
      aByte := ReadByte;

      while (aByte <> rcidCloseComment) and (aByte <> rcidEndOfFile) do aByte := ReadByte;
      end;

end;

procedure TTokenReader.getCloseBracket;
begin
  ReadToken;
  if FCurToken.id <> rcidCloseBracket then Error('期望右括弧！');
end;

procedure TTokenReader.getComma;
begin
  ReadToken;

  If (FCurToken.ID <> rcidComma) then Error('期望逗号！');
end;

function TTokenReader.GetCurToken: TToken;
begin
  Result := FCurToken;
end;

procedure TTokenReader.getDelimeter;
begin
  ReadToken;

  If (FCurToken.ID <> rcidDelimeter) then Error('期望分号！');
end;

function TTokenReader.getIdentOrReservWord: TToken;
var
  aByte: byte;
  str: string;
  i: integer;
begin
  aByte := NextByte;

  if not (char(aByte) in FirstIdentChar) then Error('无法识别的标识符！');

  ReadByte;

  str := char(aByte);

  aByte := NextByte;

  while (char(aByte) in IdentBackChars) and (not (char(aByte) in StopChars)) do
      begin
      ReadByte;

      str := str + char(aByte);
      
      aByte := NextByte;
      end;


  { 是否是保留字 }
  i := FResWords.IndexOf(str);
  if i >= 0 then
      begin
      Result := SetToken(Integer(FResWords.Objects[i]), str);
      exit;
      end;


  { 是用户自定义标识 }     
  Result := SetToken(udIdentifier, str);

end;

function TTokenReader.getNumberConst: TToken;
var
  aByte: byte;
  str: string;
begin
  aByte := NextByte;
  
  if char(aByte) in Digit then
      begin
      ReadByte;
      
      str := char(aByte);

      aByte := NextByte;

      while char(aByte) in Digit do
          begin
          ReadByte;

          str := str + char(aByte);
          
          aByte := NextByte;
          end;

      if (NextByte = rcidPoint) and (char(Next2Byte) in Digit) then
          begin
          ReadByte;
          
          str := str + '.';

          aByte := NextByte;
          while char(aByte) in Digit do
              begin
              ReadByte;

              str := str + char(aByte);

              aByte := NextByte;
              end;
          end;

      Result := SetToken(udNumberConst, str);
      
      try
        Result.Data := StrToFloat(str);
      except
        Error('数字常量[' + str + ']不正确！');
      end;

      end;

end;

function TTokenReader.getReserveChar: TToken;
var
  aByte: byte;
begin
  aByte := NextByte;
  
  if not IsReserveChar(char(aByte)) then Error('不是保留字符!');

  Result := SetToken(aByte, char(aByte));

  ReadByte;   
end;

function TTokenReader.GetSourceCode: string;
begin
  Result := FSourceCode;
end;

function TTokenReader.getStringConst: TToken;
var
  aByte: byte;
  str: string;
begin
  aByte := NextByte;