untcomile.~pas

delphi编写的pascal解释器

             loc3 := FProgList.Count - 1;

             Condition;

             loc1 := FProgList.PutCode(ocIfFalseGoto, 0, 0);

             ReadToken;

             if FCurToken.ID <> idDo then raiseError('期望Do!');

             Statement;

             loc2 := FProgList.PutCode(ocGoto, 0, loc3);

             FProgList.ProgList[loc1].P2 := loc2 + 1;
             end;

    idRepeat: begin
              ReadToken;

              loc1 := FProgList.Count - 1;

              Statement;

              ReadToken;
              if FCurToken.ID <> idUntil then raiseError('期望until！');

              Statement;

              FProgList.PutCode(ocIfFalseGoto, 0, loc1);
              end;

    idFor: begin
           ReadToken;

           ReadToken;

           if FCurToken.ID <> idIdentifier then raiseError('期望标识符！');

           if FVariables.IndexOf(FCurToken.Data) < 0 then raiseError(FCurToken.Data + '变量未声明！');

           aIdent := FVariables.Idents[FCurToken.Data];

           ReadToken;

           if FCurToken.ID <> id2Points then raiseError('期望冒号！');

           ReadToken;

           if FCurToken.ID <> idEqual then raiseError('期望等号！');

           Expression;

           FProgList.PutCode(ocSto, 0, aIdent.ID);

           ReadToken;

           if FCurToken.ID <> idTo then raiseError('期望To！');

           loc1 := FProgList.Count;   //应该为下一条指令

           Expression;

           loc2 := FProgList.PutCode(ocIfFalseGoto, 0, 0);

           ReadToken;

           if FCurToken.ID <> idDo then raiseError('期望Do！');

           ReadToken;

           if FCurToken.ID <> idBegin then raiseError('期望Begin！');

           Statement;

           while NextToken.ID = idDelimeter do
               begin
               ReadToken;
               Statement;
               end;

           ReadToken;

           if FCurToken.ID <> idEnd then raiseError('期望End！');

           FProgList.PutCode(ocIncVar, 1, aIdent.ID);
           loc3 := FProgList.PutCode(ocGoto, 0, loc1);
           FProgList.ProgList[loc2].P2 := loc3 + 1;

           end;

      idIdentifier: begin
                    ReadToken;

                    if FVariables.IndexOf(FCurToken.Data) < 0 then raiseError(FCurToken.Data + '变量未声明！');

                    aIdent := FVariables.Idents[FVariables.IndexOf(FCurToken.Data)];

                    ReadToken;

                    if FCurToken.ID <> id2Points then raiseError('期望冒号！');

                    ReadToken;

                    if FCurToken.ID <> idEqual then raiseError('期望等号！');

                    Expression;

                    FProgList.PutCode(ocSto, 0, aIdent.ID);

                    end;

  End;

end;

procedure TCompile.Declarations;
begin
  case NextToken.ID of
    idVar: begin
           ReadToken;
           Variables;
           end;
  end;
end;

procedure TCompile.Variables;
var
  i, j: integer;
begin
  while true do
    begin
    ReadToken;

    if FCurToken.ID <> idIdentifier then raiseError('期望变量！');

    if FVariables.IndexOf(FCurToken.Data) >= 0 then raiseError(FCurToken.data + '变量重复声明！');

    i := FVariables.Count;

    FVariables.Add(FCurToken.Data);

    if NextToken.ID = idComma then
        begin
        ReadToken;

        ReadToken;

        if FCurToken.ID <> idIdentifier then raiseError('期望变量！');
        if FVariables.IndexOf(FCurToken.Data) >= 0 then raiseError(FCurToken.data + '变量重复声明！');

        FVariables.Add(FCurToken.Data);
        end;

    if NextToken.ID = id2Points then
        begin
        ReadToken;
        getVarType;

        for j := i to FVariables.Count - 1 do
            begin
            FVariables.Idents[j].FDataType := FCurToken.Data;
            end;

        getDelimeter;
        end;

    if (NextToken.ID <= idReservedEnd) and (NextToken.ID >= idReservedBase) then exit;
    end;
end;

procedure TCompile.Block;
begin
  Declarations;
  Statement;
  
end;

{ TWordList }

procedure TWordList.AddWord(aWordName: String; aWordID: integer);
begin
  FList.AddObject(aWordName, TObject(aWordID));
end;

constructor TWordList.Create;
begin
  FList := TStringList.Create;
  FList.CaseSensitive := false;
end;

destructor TWordList.Destroy;
begin
  FreeAndNil(FList);
end;

function TWordList.GetWordID(aWordName: string): integer;
var
  i: integer;
begin
  Result := -1;

  for i := 0 to FList.Count do
    begin
    if SameText(FList.Names[i], aWordName) then
        begin
        Result := Integer(FList.Objects[i]);
        exit;
        end;
    end;

  inherited;
end;

function TWordList.GetWordName(aWordID: integer): string;
var
  i: integer;
begin
  Result := '';

  for i := 0 to FList.Count do
    begin
    if Integer(FList.Objects[i]) = aWordID then
        begin
        Result := FList.Names[i];
        exit;
        end;
    end;

end;

{ TConsts }

function TDynaWords.AddWord(aWordName: String): integer;
begin
  Inc(FConstID);

  inherited AddWord(aWordName, FConstID);

  Result := FConstID; 
end;

constructor TDynaWords.Create;
begin
  inherited;
  FConstID := 0;
end;

{ TResWords }

procedure TResWords.AddWord(aWordName: String; aWordID: integer);
begin
  inherited;
end;

{ TResConsts }

procedure TResConsts.AddWord(aWordName: String; aWordID: integer);
begin
  inherited;
end;


{ TProgList }

constructor TProgList.Create;
begin
  setLength(FProgList, 100);
  FCount := 0;
end;

destructor TProgList.Destroy;
begin
  setLength(FProgList, 0);
  
  inherited;
end;

function TProgList.PutCode(aCmd, aP1, aP2: integer): integer;
begin
  if FCount >= Length(FProgList) then
    begin
    setLength(FProgList, FCount + 100);
    end;

  FProgList[FCount].Cmd := aCmd;
  FProgList[FCount].P1 := aP1;
  FProgList[FCount].P2 := aP2;

  Result := FCount;
  
  Inc(FCount);
end;

{ TIdent }

constructor TIdent.Create;
begin
  FParamNames := TStringList.Create;
end;

destructor TIdent.Destroy;
begin
  FreeAndNil(FParamNames);

  inherited;
end;

{ TIdentList }

function TIdentList.Add(aName: string; aID: Integer): TIdent;
begin
  if FCount >= Length(FIdents) then
      begin
      setLength(FIdents, FCount + 30);
      end;

  FIdents[FCount] := TIdent.Create;
  FIdents[FCount].Name := aName;
  FIdents[FCount].ID := aID;

  Result := FIdents[FCount];
  
  Inc(FCount);
end;

constructor TIdentList.Create;
begin
  FCount := 0;
  setLength(FIdents, 30);
end;

destructor TIdentList.Destroy;
begin
  FCount := 0;
  setLength(FIdents, 0);
  
  inherited;
end;

function TIdentList.getIdentByID(aID: integer): TIdent;
var
  i: integer;
begin
  for i := 0 to FCount - 1 do
    begin
    if FIdents[i].ID = aID then
         begin
         Result := FIdents[i];
         exit;
         end;
    end;

  raise Exception.Create('没有ID为' + IntToStr(aID) + '的变量！');

end;

function TIdentList.getIdentByIndex(aIndex: integer): TIdent;
begin

  if (aIndex < 0) or (aIndex >= FCount) then raise Exception.Create('索引超出范围！');

  Result := FIdents[aIndex];

end;

function TIdentList.getIdentByName(aName: String): TIdent;
var
  i: integer;
begin
  i := IndexOf(aName);

  if i < 0 then raise Exception.Create('没有名为' + aName + '的标识符！');

  Result := FIdents[i];
end;

function TIdentList.IndexOf(aName: string): integer;
var
  i: integer;
begin
  Result := -1;
  
  for i := 0 to FCount - 1 do
    begin
    if SameText(FIdents[i].Name, aName) then
         begin
         Result := i;
         exit;
         end;
    end;

end;

{ TConstList }

function TConstList.Add(aName: string): TIdent;
begin
  Inc(FConstID);

  Result := inherited Add(aName, FConstID);
end;

constructor TConstList.Create;
begin
  inherited;

  FConstID := 0;
end;

{ TVariableList }

function TVariableList.Add(aName: string): TIdent;
begin
  Inc(FID);
  
  Result := inherited add(aName, FID);
end;

constructor TVariableList.Create;
begin
  FID := 0;
end;

{ TStack }

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;

initialization
  ResWords := TResWords.Create;
  ResConsts := TResConsts.Create;

finalization
  FreeAndNil(ResWords);
  FreeAndNil(ResConsts);
  
end.