untpasscriptcompile.~pas

delphi编写的pascal解释器

  if aByte <> rcidStringChar then Error('字符串常量应以单引号开头!');

  aByte := ReadByte;

  str := '';

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

  if aByte <> rcidStringChar then Error('字符串常量没有结束！');

  Result := SetToken(udStringConst, str);
end;

function TTokenReader.IsReserveChar(aChar: char): boolean;
var
  aByte: byte;
begin
  aByte := byte(aChar);

  case aByte of
    rcidEndOfFile,                // 0
    rcidEndOfLine,                 // 10
    rcidNewLine,                   // $0a
    rcidPower,                     // ^
    rcidPoint,                     // .
    rcidDelimeter,                 // ;
    rcidGreater,                   // >
    rcidLess,                      // <
    rcidComma,                     // ,
    rcidPlus,                      // +
    rcidMinus,                     // -
    rcidSlash,                     // /
    rcidStar,                      // *
    rcidOpenBracket,               // (
    rcidCloseBracket,              // )
    rcidOpenComment,               // {
    rcidCloseComment,              // }
    rcidEqual,                     // =
    rcidNotEqual,                  // #
    rcid2Points,                   // :
    rcidStringChar,                // '
    rc2idStringChar,               // "
    rcidSqopenBracket,             // [
    rcidSqcloseBracket:            // ]
      Result := True;

   else Result := False; 
  end;
end;

function TTokenReader.Next2Byte: byte;
var
  i: integer;
begin
  i := FCurPos;

  ReadByte;
  Result := ReadByte;

  FCurPos := i;
end;

function TTokenReader.Next2Token: TToken;
var
  tmp: TToken;
  i: integer;
begin
  tmp := FCurToken;
  i := FCurPos;

  ReadToken;
  Result := FCurToken;

  ReadToken;
  Result := FCurToken;
  
  FCurToken := tmp;
  FCurPos := i;

end;

function TTokenReader.NextByte: Byte;
var
  i: integer;
begin
  i := FCurPos;
  Result := ReadByte;
  FCurPos := i;
end;

function TTokenReader.NextToken: TToken;
var
  tmp: TToken;
  i: integer;
begin
  tmp := FCurToken;
  i := FCurPos;

  ReadToken;
  Result := FCurToken;
  
  FCurToken := tmp;
  FCurPos := i;
end;

function TTokenReader.ReadByte: byte;
begin
  if FCurPos > FSourceLen then
    begin
    Result := rcidEndOfFile;
    exit;
    end;

  Result := byte(FSourceCode[FCurPos]);

  Inc(FCurPos);
end;

function TTokenReader.ReadToken: TToken;
var
  aByte: byte;
begin
  FilterBlackAndNote;

  aByte := NextByte;

  while aByte <> rcidEndOfFile do
    begin
    if aByte = rcidStringChar then
        begin
        FCurToken := getStringConst;
        Result := FCurToken;
        exit;
        end;

    if IsReserveChar(char(aByte)) then
        begin
        FCurToken := getReserveChar;
        Result := FCurToken;
        exit;
        end;

    if char(aByte) in FirstIdentChar then
        begin
        FCurToken := getIdentOrReservWord;
        Result := FCurToken;
        exit;
        end;

    if char(aByte) in Digit then
        begin
        FCurToken := getNumberConst;
        Result := FCurToken;
        exit;
        end;

    Error('无法识别的字符' + char(aByte));
    end;


  FCurToken := SetToken(rcidEndOfFile, 0);
  Result := FCurToken;

end;

procedure TTokenReader.SetSourceCode(aSrcCode: string);
begin
  FSourceCode := aSrcCode;
  FSourceLen := Length(FSourceCode);
  FCurPos := 1;
end;

function TTokenReader.SetToken(ID: integer; V: Variant): TToken;
begin
  Result.ID := ID; Result.Data := V;
end;

{ TStack }

procedure TStack.Clear;
begin
  FCount := 0;
  setLength(FDatas, 30);  
end;

constructor TStack.Create;
begin
  setLength(FDatas, 100);
  FCount := 0;
end;

destructor TStack.Destroy;
begin
  setLength(FDatas, 0);
  
  inherited;
end;

function TStack.getData(aIndex: integer): variant;
begin
  if aIndex < 0 then raise Exception.Create('参数不应小于0!');
  if aIndex >= FCount then raise Exception.Create('参数大于堆栈上限!');

  Result := FDatas[aIndex];
end;

function TStack.Pop: variant;
begin
  if FCount = 0 then raise Exception.Create('堆栈下溢出!');

  Result := FDatas[FCount - 1];

  Dec(FCount);
end;

procedure TStack.Put(v: Variant);
begin
  if FCount >= Length(FDatas) then
    begin
    setLength(FDatas, FCount + 100);
    end;

  FDatas[FCount] := v;

  Inc(FCount);
end;


{ TVMCPU }

procedure TVMCPU.Clear;
begin
  FDynaVarStack.Clear;
  FCallStack.Clear;
  FStack.Clear;
end;

constructor TVMCPU.Create(aProgram: TAnalyProgram);
var
  i, j: integer;
  aUserVar, aUserVar2: TUserVar;
  aMethod, aMethod2: TUserMethod;
begin
  //其实是克隆aPrgram中的变量和方法,写得有点冗余
  FVarList := TUserVarList.Create;

  for i := 0 to aProgram.VarList.Count - 1 do
    begin
    aUserVar := TUserVar(aProgram.VarList.Items[i]);
    FVarList.AddVar(aUserVar.ID, aUserVar.Name, aUserVar.Value,
                    aUserVar.DataType, aUserVar.VarType, aUserVar.OffPos);
    end;

  FConstVarList := TUserVarList.Create;
  
  for i := 0 to aProgram.ConstVarList.Count - 1 do
    begin
    aUserVar := TUserVar(aProgram.ConstVarList.Items[i]);
    FConstVarList.AddVar(aUserVar.ID, aUserVar.Name, aUserVar.Value,
                    aUserVar.DataType, aUserVar.VarType, aUserVar.OffPos);
    end;


  FMethodList := TUserMethodList.Create;

  for i := 0 to aProgram.MethodList.Count - 1 do
    begin
    aMethod := TUserMethod(aProgram.MethodList.Items[i]);
    aMethod2 := FMethodList.AddMethod(aMethod.ID, aMethod.Name, aMethod.MethodType, 0, aMethod.Addr);
    
    aMethod2.SysMethodFlag := aMethod.SysMethodFlag;
    aMethod2.SysProcMethod := aMethod.SysProcMethod;

    for j := 0 to aMethod.ParamList.Count - 1 do
      begin
      aUserVar := TUserVar(aMethod.ParamList.Items[j]);
      aUserVar2 := FVarList.getVarByID(aUserVar.ID);
      
      aMethod2.AddParamVar(aUserVar2);
      end;

    for j := 0 to aMethod.DynaVarList.Count - 1 do
      begin
      aUserVar := TUserVar(aMethod.DynaVarList.Items[j]);
      aUserVar2 := FVarList.getVarByID(aUserVar.ID);
      
      aMethod2.AddDynaVar(aUserVar2);
      end;
    end;

  FVMPCodeList := TVMPCodeList.Create;

  for i := 0 to aProgram.FVMPCodeList.Count - 1 do
    begin
    FVMPCodeList.AddVMPCode(aProgram.FVMPCodeList.VMPCodeList[i].Cmd,
                            aProgram.FVMPCodeList.VMPCodeList[i].P1,
                            aProgram.FVMPCodeList.VMPCodeList[i].P2);
    end;

  FCallStack := TCallStack.Create;
  FDynaVarStack := TDynaVarStack.Create;
  FStack := TStack.Create;


end;

destructor TVMCPU.Destroy;
begin
  FreeAndNil(FVarList);
  FreeAndNil(FConstVarList);

  FreeAndNil(FMethodList);

  FreeAndNil(FDynaVarStack);
  FreeAndNil(FStack);
  FreeAndNil(FCallStack);

  FreeAndNil(FVMPCodeList);
  inherited;
end;

{ TAnalyzeDeclare }

procedure TAnalyDeclare.Analy;
begin
  while true do
    begin
    case FTokenReader.NextToken.ID of
      rwidVar: begin
               FTokenReader.ReadToken;
               Variables;
               end;

      rwidProcedure,
      rwidFunction: begin
                    Methods;
                    end;

      else break;
      end;

    end;
end;

class procedure TAnalyDeclare.Analy(aCodeMaker: TCodeMaker;
  aTokenReader: TTokenReader);
var
  aAnaly: TAnalyDeclare;
begin
  aAnaly := TAnalyDeclare.Create(aCodeMaker, aTokenReader);
try
  aAnaly.Analy;

  finally
  FreeAndNil(aAnaly);
  end;
end;

constructor TAnalyDeclare.Create(aCodeMaker: TCodeMaker; aTokenReader: TTokenReader);
begin
  FCodeMaker := aCodeMaker;
  FTokenReader := aTokenReader;
end;

destructor TAnalyDeclare.Destroy;
begin
  FCodeMaker := nil;
  FTokenReader := nil;
  
  inherited;
end;

procedure TAnalyDeclare.Methods;
var
  aMethodAnaly: TAnalyMethod;
begin
  aMethodAnaly := TAnalyMethod.Create(FCodeMaker, FTokenReader);
  
try
  while (FTokenReader.NextToken.ID = rwidProcedure) or (FTokenReader.NextToken.ID = rwidFunction) do
    begin

    aMethodAnaly.FAnalyDepth := FCodeMaker.AnalyDepth + 1;
    aMethodAnaly.Analy;
    end;

  finally
  FreeAndNil(aMethodAnaly);
  end;

end;

procedure TAnalyDeclare.Variables;
var
  i: integer;
  aLevel: integer;
  aUserVar: TUserVar;
  aList: TList;
begin
  aList := TList.Create;

try
  while true do
    begin
    FTokenReader.ReadToken;

    if FTokenReader.CurToken.ID <> udIdentifier then FTokenReader.Error('期望变量！');

    aUserVar := FCodeMaker.FindVarByName(FTokenReader.CurToken.Data, aLevel);
    if (aUserVar <> nil) and (aLevel = 0) then FTokenReader.Error(FTokenReader.CurToken.data + '变量重复声明！');

    aUserVar := FCodeMaker.RegisterVar(FTokenReader.CurToken.Data);
    aList.Add(Pointer(aUserVar));

    while FTokenReader.NextToken.ID = rcidComma do
        begin
        FTokenReader.ReadToken;

        FTokenReader.ReadToken;

        if FTokenReader.CurToken.ID <> udIdentifier then FTokenReader.Error('期望变量！');

        aUserVar := FCodeMaker.FindVarByName(FTokenReader.CurToken.Data, aLevel);
        if (aUserVar <> nil) and (aLevel = 0) then FTokenReader.Error(FTokenReader.CurToken.data + '变量重复声明！');

        aUserVar := FCodeMaker.RegisterVar(FTokenReader.CurToken.Data);
        aList.Add(Pointer(aUserVar));
        end;

    if FTokenReader.NextToken.ID = rcid2Points then
        begin
        FTokenReader.ReadToken;
        FTokenReader.ReadToken;

        for i := 0 to aList.Count - 1 do
            begin
            aUserVar := TUserVar(aList.Items[i]);
            aUserVar.FDataType := getDataType(FTokenReader.CurToken.Data);
            end;

        FTokenReader.getDelimeter;
        end;

    if (FTokenReader.NextToken.ID <= ReserveWordEnd) and (FTokenReader.NextToken.ID >= ReserveWordBase) then exit;
    end;

    finally
    FreeAndNil(aList);
    end;

end;

function TVMCPU.GetConstVarList: TUserVarList;
begin
  Result := FConstVarList;
end;

function TVMCPU.GetMethodList: TUserMethodList;
begin
  Result := FMethodList;
end;

function TVMCPU.GetVarList: TUserVarList;
begin
  Result := FVarList;
end;

function TVMCPU.GetVMPCodeList: TVMPCodeList;
begin
  Result := FVMPCodeList;
end;

procedure TVMCPU.Run;
var
  i, j: integer;
  cmd, p1, p2: integer;
  aUserVar: TUserVar;
  v1, v2: variant;
  aCallInfo: TCallInfo;
  aMethod: TUserMethod;
  aDynaAddr: integer;
  aUserVarList: TUserVarList;
begin
  i := 0;

  Clear;

  aUserVarList := TUserVarList.Create;
   
  while i < FVMPCodeList.Count do
    begin
    cmd := FVMPCodeList.VMPCodeList[i].Cmd;
    p1 := FVMPCodeList.VMPCodeList[i].P1;
    p2 := FVMPCodeList.VMPCodeList[i].P2;

    case cmd of
         ocMov: begin
                aUserVar := FVarList.getVarByID(p2);

                if aUserVar.VarType = vtStatic then FStack.Put(aUserVar.Value)
                    else if (aUserVar.VarType = vtDynamic) or (aUserVar.VarType = vtParam) then
                              begin
                              aCallInfo := FCallStack.GetPreCallInfo(p1);

                              aDynaAddr := aCallInfo.BaseDynaVarAddr + aUserVar.OffPos;
                              
                              FStack.Put(FDynaVarStack.GetVarByPos(aDynaAddr).Value);
                              end;