untcompile.pas

运用delphi编写的小型解释器

                 ReadToken;
                 Factor;
                 FProgList.PutCode(ocAnd, 0, 0);
                 end;

          idStar: begin
                  ReadToken;

                  Factor;

                  FProgList.PutCode(ocMul, 0, 0);
                  end;

          idSlash: begin
                   ReadToken;
                   Factor;
                   FProgList.PutCode(ocDiv, 0, 0);
                   end;

          idMod: begin
                 ReadToken;
                 Factor;

                 FProgList.PutCode(ocMod, 0, 0);
                 end;
          end;

        tmp := NextToken;

        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 > Length(FSrcCode) 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;
        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 aByte = id2Points then
        begin
        FCurToken := SetToken(id2Points, ':');
        exit;
        end;

    if aByte = idEqual then
        begin
        FCurToken := SetToken(idEqual, '=');
        exit;
        end;

    if aByte = idDelimeter then
        begin
        FCurToken := SetToken(idDelimeter, ';');
        exit;
        end;

    if aByte = idComma then
        begin
        FCurToken := SetToken(idComma, ',');
        exit;
        end;

    if aByte = idPlus then
        begin
        FCurToken := SetToken(idPlus, '+');
        exit;
        end;

    if aByte = idMinus then
        begin
        FCurToken := SetToken(idMinus, '-');
        exit;
        end;

    if aByte = idStar then
        begin
        FCurToken := SetToken(idStar, '*');
        exit;
        end;

    if aByte = idSlash then
        begin
        FCurToken := SetToken(idSlash, '/');
        exit;
        end;

    if aByte = idOpenBracket then
        begin
        FCurToken := SetToken(idOpenBracket, '(');
        exit;
        end;

    if aByte = idCloseBracket then
        begin
        FCurToken := SetToken(idCloseBracket, ')');
        exit;
        end;

    if aByte = idGreater then
        begin
        FCurToken := SetToken(idGreater, '>');
        exit;
        end;

    if aByte = idLess then
        begin
        FCurToken := SetToken(idLess, '<');
        exit;
        end;

    if aByte = idPoint then
        begin
        FCurToken := SetToken(idPoint, '.');
        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;

        BackByte(1);

        if ResWords.GetWordID(str) >= 0 then
            begin
            FCurToken := SetToken(ResWords.GetWordID(str), 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;

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

    aByte := ReadByte;
    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;
var
  tmp: TToken;
begin
  Expression;

  tmp := NextToken;

  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;

      else raiseError('缺少比较符！');
        
  End;

end;

procedure TCompile.Statement(aPreFix: string);
var
  tmp: TToken;
  loc1, loc2, loc3: integer;
  aIdent: TIdent;
Begin
  tmp := NextToken;

  Case tmp.ID of
    idBegin: begin
             ReadToken;

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

             ReadToken;
             
             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;
          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: 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('期望标识符！');

           aIdent := getVariableByName(aPreFix, FCurToken.Data);

           if aIdent = nil then raiseError(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(aPreFix);
               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(aPreFix: string);
begin
  case NextToken.ID of
    idVar: begin
           ReadToken;
           Variables(aPreFix);
           end;

    idProcedure, idFunction: begin
                             ReadToken;
                             
                             end;
  end;
end;



procedure TCompile.Variables(aPreFix: string);
var
  i, j: integer;
  vIdent: TIdent;
begin
  while true do
    begin
    ReadToken;

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

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

    i := FVariables.Count;

    vIdent := FVariables.Add(genVarName(aPreFix, FCurToken.Data));
    if aPreFix <> '' then vIdent.DynaFlag := True;

    while NextToken.ID = idComma do
        begin
        ReadToken;

        ReadToken;

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

        vIdent := FVariables.Add(genVarName(aPreFix, FCurToken.Data));
        if aPreFix <> '' then vIdent.DynaFlag := True;
        end;

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

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

        getDelimeter;
        end;

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

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

procedure TCompile.Compile;
begin
  Block;
end;

function TCompile.getVariables: string;
begin
  Result := FVariables.getText;
end;

function TCompile.getDataType(aStr: string): TDataType;
begin
  Result := dtUnknown;
  
  if SameText(aStr, 'integer') then Result := dtInt;
  if SameText(aStr, 'float') then Result := dtFloat;
end;

procedure TCompile.Run;
var
  i: integer;
  cmd, p1, p2: integer;
  aIdent: TIdent;
  v1, v2: variant;
begin
  i := 0;

  while i < FProgList.Count do
    begin
    cmd := FProgList.ProgList[i].Cmd;
    p1 := FProgList.ProgList[i].P1;
    p2 := FProgList.ProgList[i].P2;

    case cmd of
         ocMov: begin
                aIdent := FVariables.getIdentByID(p2);
                Stack.Put(aIdent.Value);
                end;

         ocLoadConst: begin
                      aIdent := FConsts.getIdentByID(p2);
                      Stack.Put(aIdent.Value);
                      end;

         ocSto: begin
                FVariables.SetValue(p2, Stack.Pop);
                end;

         ocAdd: begin
                v1 := Stack.Pop;
                v2 := Stack.Pop;
                Stack.Put(v1 + v2);
                end;

         ocSub: begin
                v1 := Stack.Pop;
                v2 := Stack.Pop;
                Stack.Put(v2 - v1);
                end;