untcomile.~pas

delphi编写的pascal解释器

  case FCurToken.ID of
      idIdentifier: begin
                    str := FCurToken.data;

                    if FVariables.IndexOf(str) < 0 then raiseError('变量' + str + '没有定义');

                    aIdent := FVariables.getIdentByName(str);

                    case aIdent.IdentType of
                       itVariable: begin
                                   FProgList.PutCode(ocMov, 0, aIdent.ID);
                                   end;

                       end;

                    end;

      idFalse: begin
               aIdent := FConsts.Add('False');
               aIdent.IdentType := itVariable;
               aIdent.DataType := dtBool;
               aIdent.Value := false;

               FProgList.PutCode(ocLoadConst, 0, aIdent.ID);
               end;

      idTrue: begin
               aIdent := FConsts.Add('True');
               aIdent.IdentType := itVariable;
               aIdent.DataType := dtBool;
               aIdent.Value := true;

               FProgList.PutCode(ocLoadConst, 0, aIdent.ID);
             end;

      idNil: begin
             FProgList.PutCode(ocLoadConst, 0, 2);
             end;

      idNull: begin
             FProgList.PutCode(ocLoadConst, 0, 1);
             end;


      idNumberConst: begin
                     aIdent := FConsts.Add('Number');
                     aIdent.Value := FCurToken.Data;
                     aIdent.IdentType := itVariable;
                     aIdent.DataType := dtFloat;

                     FProgList.PutCode(ocLoadConst, 0, aIdent.ID);
                     end;

      idStringConst: begin
                     aIdent := FConsts.Add('str');
                     aIdent.Value := FCurToken.Data;
                     aIdent.IdentType := itVariable;
                     aIdent.DataType := dtStr;

                     FProgList.PutCode(ocLoadConst, 0, aIdent.ID);
                     end;

      idOpenBracket: begin
                     Expression;
                     getCloseBracket; 
                     end;

  end;
end;

procedure TCompile.getCloseBracket;
begin
  ReadToken;
  if FCurToken.id <> idCloseBracket then raiseError('期望右括弧！');
end;

procedure TCompile.getComa;
begin
  ReadToken;
  
  If FCurToken.id <> idComma then raiseError('期望逗号！');
end;

procedure TCompile.getdelimeter;
begin
  ReadToken;

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

procedure TCompile.getIdentifier;
begin
  ReadToken;
  If FCurToken.id <> idIdentifier then raiseError('期望变量！');
end;

procedure TCompile.getOpenBracket;
begin
  ReadToken;
  If FCurToken.id <> idOpenBracket then raiseError('期望左括弧！');
end;

function TCompile.GetVar: integer;
begin
  ReadToken;

  If FCurToken.id <> idIdentifier then raiseError('期望标识符!');

  Result := FVariables.IndexOf(FCurToken.Data);

  If Result < 0 then raiseError('没有定义变量' + FCurToken.Data);

  FLastVarID := FVariables.Idents[Result].ID;
end;

procedure TCompile.GetVarType;
begin
  ReadToken;
end;

procedure TCompile.Term;
var
  tmp: TToken;
begin
  Factor;

  tmp := NextToken;

  while (tmp.ID = idAnd) or (tmp.ID = idStar) or (tmp.ID = idSlash) or
        (tmp.ID = idDiv) or (tmp.ID = idMod) do
        begin
        Case tmp.ID of
          idAnd: begin
                 ReadToken;
                 Factor;
                 FProgList.PutCode(ocAnd, 0, 0);
                 end;

          idStar: begin
                  ReadToken;

                  Factor;

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

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

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

          idMod: begin
                 ReadToken;
                 Factor;

                 FProgList.PutCode(ocMod, 0, 0);
                 end;
          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 aByte = id2Points then
        begin
        FCurToken := SetToken(id2Points, 0);
        exit;
        end;

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

  tmp := NextToken;

  if tmp.ID <> idResWord then raiseError('却缺少关键字！');

  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;
  aIdent: TIdent;
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;
          end;

    idWhile: begin
             ReadToken;