untcomile.pas

运用delphi编写的小型解释器

          end;

        end;

end;

function TCompile.NextByte: byte;
var
  i: integer;
begin
  i := FCurPos;
  Result := ReadByte;
  FCurPos := i;
end;

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

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

procedure TCompile.RaiseError(aErrStr: string);
begin
  raise Exception.Create(aErrStr);
end;

function TCompile.ReadByte: byte;
begin
  If FCurPos > FSrcLen then
  Begin
    Result := idEndOfFile;
    exit;
  End;

  Result := byte(FSrcCode[FCurPos]);

  Inc(FCurPos);
end;

procedure TCompile.ReadToken;
Var
  aByte: byte;
  str: String;
Begin
  aByte := ReadByte;

  while aByte <> idEndOfFile do
    begin

    if char(aByte) in BlackSpaces then
        begin
        while char(aByte) in BlackSpaces do aByte := ReadByte;

        aByte := ReadByte;
        continue;
        end;

    if (aByte = idSlash) and (NextByte = idSlash) then
        begin
        ReadByte;

        aByte := ReadByte;
        while (aByte <> idEndOfFile) and (aByte <> idEndOfLine) do
            begin
            aByte := ReadByte;
            end;

        aByte := ReadByte;
        
        continue;
        end;

    if (aByte = idOpenBracket) and (NextByte = idStar) then
        begin
        ReadByte;

        repeat
          aByte := ReadByte;
          until ((aByte = idStar) and (NextByte = idCloseBracket)) or (aByte = idEndOfFile);

        ReadByte;
        aByte := ReadByte;
        
        continue;
        end;

    if aByte = idOpenComment then
        begin
        aByte := ReadByte;

        while (aByte <> idCloseComment) and (aByte <> idEndOfFile) do aByte := ReadByte;

        aByte := ReadByte;
        continue;
        end;

    if aByte = IdStringChar then
        begin
        str := '';
        aByte := ReadByte;

        while (aByte <> idStringChar) and (aByte <> idEndOfFile) and (aByte <> idEndOfLine)do
            begin
            str := str + char(aByte);
            aByte := ReadByte;
            end;

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

        FCurToken := SetToken(idStringConst, str);
        exit;
        end;

    if aByte = idEndOfFile then
        begin
        FCurToken := SetToken(idEndOfFile, 0);
        exit;
        end;

    if char(aByte) in FirstIdentChar then
        begin
        str := char(aByte);

        aByte := ReadByte;

        while (char(aByte) in IdentBackChars) and (not (char(aByte) in StopChars)) do
            begin
            str := str + char(aByte);
            aByte := ReadByte;  
            end;

        if ResWords.GetWordID(str) >= 0 then
            begin
            FCurToken := SetToken(idResWord, ResWords.GetWordID(str));
            exit;
            end
           else if ResConsts.GetWordID(str) >= 0 then
                    begin
                    FCurToken := SetToken(idResConst, ResConsts.GetWordID(str));
                    exit;
                    end
                   else begin
                        FCurToken := SetToken(idIdentifier, str);
                        exit;
                        end;

        end;

    if char(aByte) in Digit then
        begin
        str := char(aByte);

        aByte := ReadByte;

        while char(aByte) in Digit do
            begin
            str := str + char(aByte);
            aByte := ReadByte;
            end;

        if (aByte = idPoint) and (char(NextByte) in Digit) then
            begin
            str := str + '.';

            aByte := ReadByte;
            while char(aByte) in Digit do
                begin
                str := str + char(aByte);
                aByte := ReadByte;
                end;
            end;

        BackByte(1);

        FCurToken := SetToken(idNumberConst, str);
        try
          FCurToken.Data := StrToFloat(str);
        except
          raiseError('数字常量不正确！');
        end;

        exit;
        end; 
    end;


  FCurToken := SetToken(idEndOfFile, 0);

end;

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

procedure TCompile.Condition;
begin
  Expression;

  Case NextToken.id of
      idEqual: begin
               ReadToken;
               Expression;
               FProgList.PutCode(ocEqual, 0, 0);
               end;

      idGreater: begin
                 ReadToken;

                 if NextToken.id = idEqual then
                     begin
                     ReadToken;
                     Expression;
                     FProgList.PutCode(ocGreaterEqual, 0, 0);
                     end
                    else begin
                         Expression;
                         FProgList.PutCode(ocGreater, 0, 0);
                         end;
                 end;

      idLess: begin
              ReadToken;

              case NextToken.id of
                  idEqual: begin
                           ReadToken;
                           Expression;
                           FProgList.PutCode(ocLessEqual, 0, 0);
                           end;

                  idGreater: begin
                             ReadToken;
                             Expression;
                             FProgList.PutCode(ocNotEqual, 0, 0);
                             end;

                     else begin
                          Expression;

                          FProgList.PutCode(ocLess, 0, 0);
                          end;
                  end;
              end;
        
  End;

end;

procedure TCompile.Statement;
var
  tmp: TToken;
  loc1, loc2, loc3: integer;
Begin
  tmp := NextToken;

  Case tmp.ID of
    idBegin: begin
             ReadToken;

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

             if FCurToken.ID <> idEnd then raiseError('期望end!');
             end;

    idIf: begin
          ReadToken;

          Condition;

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

          ReadToken;

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

          Statement;

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

    idWhile: begin
             ReadToken;

             loc3 := FProgList.Count;

             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:
      getrepeatoperator;
    id_for:
      getforoperator;
      id_Goto:
      Begin
        Token := ReadToken;
        Token := ReadToken;
        If Token.ID <> idIdentifier then Error(labname_exp);
        S := Token.Data;
        If Labels.IDByName(s, i) = false
          Then Error(Format(lab_notdef, [s]));
        IDLabels.SetReference(i);
        putcode(ocgoto, i, 0);
      End;
      idIdentifier:
      Begin
        Token := ReadToken;
        s := Token.Data;
        If nexttoken.id = idpoint then
        Begin
          findobject(s);
        End;
        While nexttoken.id = idpoint do
        Begin
          token := readtoken;
          token := readtoken;
          If token.id <> ididentifier then
            Error(id_expected);
          s := s + '.' + token.data;
        End;
        Case nexttoken.id of
        idopenbracket, idsqopenbracket: l23: getuserfunction(s, true, true);
            id2points:
              Begin
                Token := ReadToken;
                Case nexttoken.id of
                idequal:
                  Begin
                    Token := ReadToken;
                    equaldispath(s);
                  End;
                Else
                 labeldispatch(s);
                End;
              End;
        Else
          Goto l23;
        End;
      End;
  Else
    Error(Format(unkn_id, [nexttoken.data]));
  End;

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);
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; aID: integer): TIdent;
begin
  Result := inherited add(aName, aID);
end;

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

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