Курсовая работа1 / Tokenizer / UCcTokenizer

{
  C-like language compiler v0.1.0.485

  12 november 2007

  Copyright (C) 2006, 2007 Igor Krooshch
  rheo.ikro@gmail.com

  This program is free software; you can redistribute it and/or
  modify it under the terms of the GNU Lesser General Public
  License as published by the Free Software Foundation; either
  version 2.1 of the License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  Lesser General Public License for more details.

  You should have received a copy of the GNU Lesser General Public
  License along with this library; if not, write to the Free Software
  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
}

unit UCcTokenizer;

interface

uses
  SysUtils, Classes,
  UCcBuffer;

type
  TCcTokenSubType = (
    tstNone, tstEof,
    tstIdentifier,
    // константы
    tstIntConst, tstFloatConst, tstStrConst, tstCharConst,
    // ключевые слова
    tstIf, tstElse, tstWhile, tstDo, tstFor, tstBreak, tstContinue,
    tstInt, tstFloat, tstChar, tstVoid, tstStruct, tstEnum, tstTypedef,
    tstConst, tstDefault, tstReturn,

    // операции
    //   assignment-operators
    tstAssignment, tstMulAssign, tstDivAssign, tstRemAssign, tstPlusAssign,
    tstMinusAssign, tstShlAssign, tstShrAssign, tstAndAssign, tstXorAssign,
    tstOrAssign,

    tstLess, tstGreater, tstEqual,
    tstLessEqual, tstGreatEqual, tstNotEqual,
    tstAnd, tstOr, tstXor, tstBitAnd, tstBitOr, tstNot, tstAddition, tstShl,
    tstShr,
    tstPlus, tstMinus, tstDiv, tstMul, tstRemainder, tstInc,
    tstDec, 

    // разделители
    tstOpenParent, tstCloseParent, tstOpenSqParent, tstCloseSqParent,
    tstOpenBraces, tstCloseBraces, tstSemicolon, tstDot, tstComma, tstQuestion,
    tstColon
  );

  TCcTokenSubTypes = set of TCcTokenSubType;

  TCcTokenKeywords = tstIf..tstReturn;

  TCcTokenOperators = tstAssignment..tstDec;
  TCcTokenAssignmentOperators = tstAssignment..tstOrAssign;
  TCcTokenCompareOperators = tstLess..tstNotEqual;
  TCcTokenBinaryOperators = tstAnd..tstRemainder;

  TCcTokenDelimiters = tstOpenParent..tstColon;

  TCcTokenTypeSpecifiers = tstInt..tstEnum;
  TCcTokenTypeQualifier = tstConst..tstConst;

  TCcTokenValue = record
    AsString: string;
    case integer of
      1: (AsInteger: integer);
      2: (AsDouble: double);
      3: (AsBoolean: boolean);
      4: (AsByte: byte);
      5: (AsChar: char);
  end;

  ECcTokenizerException = class(ECcBufferException);


  TCcToken = class
  private
    FSubType: TCcTokenSubType;
    FValue: TCcTokenValue;
    FText: string;
    FPosition: TCcPosition;
  protected
    procedure UpdateInfo(
      ASubType: TCcTokenSubType; const AText: string; AValue: TCcTokenValue);
  public
    constructor Create;
    procedure Assign(AToken: TObject);

    property SubType: TCcTokenSubType read FSubType write FSubType;
    property Text: string read FText write FText;
    property Value: TCcTokenValue read FValue write FValue;
  end;


  TCcTokenizer = class
  private
    FBuffer: TCcBuffer;
    FStream: TFileStream;

    FDebugProgress: boolean;

    FUngot: boolean;

    FToken: TCcToken;

    function IdentifyKeyword: boolean;

    function ReadChar(out AEsc: boolean): char; overload;
    function ReadChar: char; overload;

    procedure ReadIdentifier;
    procedure ReadIntOrFloatConst(const AEscSeq: boolean = false);
    procedure ReadStrConst;
    procedure ReadSymbol;

    procedure SkipWhitespaces;
    function GetPosition: TCcPosition;
  public
    constructor Create(
      const AFileName: string; const ADebugProgress: boolean = false);
    destructor Destroy; override;

    procedure ErrorFmt(const AMsg: string; const AArgs: array of const);
    procedure Error(const AMsg: string);

    function GetToken: TCcToken;
    function NextToken(const ANeedsNext: boolean = false): TCcToken;

    function LookAhead: TCcToken;

    procedure UngetToken;

    procedure RequireToken(
      ATokenType: TCcTokenSubType; const AStr: string = '');

    property Position: TCcPosition read GetPosition;
  end;


const
  KW_VALUES: array[TCcTokenKeywords] of string = (
      'if', 'else', 'while', 'do', 'for', 'break', 'continue',
      'int', 'float', 'char', 'void', 'struct', 'enum', 'typedef',
      'const', 'default', 'return'
  );

  OPER_VALUES: array[TCcTokenOperators] of string = (
      '=', '*=', '/=', '%=', '+=', '-=', '<<=', '>>=', '&=', '^=', '|=',
      '<', '>', '==', '<=', '>=', '!=', '&', '|', '^', '&&', '||', '!', '~',
      '<<', '>>', '+', '-', '/', '*', '%', '++', '--'
  );

  DELIM_VALUES: array[TCcTokenDelimiters] of string = (
      '(', ')', '[', ']', '{', '}', ';', '.', ',', '?', ':'
  );


implementation

uses
  UCcTokenizerConsts;

function IsDigit(A: char): boolean;
begin
  Result := A in ['0'..'9'];
end;


function IsOctDigit(A: char): boolean;
begin
  Result := A in ['0'..'7'];
end;


function IsHexDigit(A: char): boolean;
begin
  Result := A in ['0'..'9', 'a'..'f', 'A'..'F'];
end;


function IsOpInList(const S: string): TCcTokenSubType;
var
  t: TCcTokenSubType;
begin
  Result := tstNone;
  for t := Low(TCcTokenOperators) to High(TCcTokenOperators) do
    if OPER_VALUES[t] = S then begin
      Result := t;
      Exit;
    end;
end;


function IsNonDigit(A: char): boolean;
begin
  Result := A in ['_', 'A'..'Z', 'a'..'z'];
end;


function OctToInt(const A: string): integer;
var
  i: integer;
  o: byte;
begin
  o := Ord('0');
  Result := 0;
  for i := 1 to Length(A) do
    Result := Result * 8 + Ord(A[i]) - o;
end;


{ TCcTokenizer }

constructor TCcTokenizer.Create(
  const AFileName: string; const ADebugProgress: boolean);
begin
  FStream := TFileStream.Create(AFileName, fmOpenRead);
  FBuffer := TCcBuffer.Create(FStream);
  FUngot := false;
  FDebugProgress := ADebugProgress;

  FToken := TCcToken.Create;
end;


destructor TCcTokenizer.Destroy;
begin
  FToken.Free;
  FBuffer.Free;
  FStream.Free;
  inherited;
end;


procedure TCcTokenizer.Error(const AMsg: string);
begin
  FBuffer.Error(AMsg, ECcTokenizerException);
end;


procedure TCcTokenizer.ErrorFmt(
  const AMsg: string; const AArgs: array of const);
begin
  Error(Format(AMsg, AArgs));
end;


function TCcTokenizer.GetPosition: TCcPosition;
begin
  Result := FBuffer.Position;
end;


function TCcTokenizer.GetToken: TCcToken;
begin
  if FDebugProgress then
    write('.');
  if (FToken.SubType = tstNone) then
    Result := NextToken
  else
    Result := FToken;
end;


function TCcTokenizer.IdentifyKeyword: boolean;
var
  i: TCcTokenSubType;
begin
  Result := false;
  for i := Low(TCcTokenKeywords) to High(TCcTokenKeywords) do
    if CompareStr(KW_VALUES[i], FToken.Text) = 0 then begin
      FToken.SubType := i;
      Result := true;
      Break;
    end;
end;


function TCcTokenizer.LookAhead: TCcToken;
begin
  Result := NextToken;
  UngetToken;
end;


function TCcTokenizer.NextToken(const ANeedsNext: boolean): TCcToken;
var
  c: char;
begin
  if FDebugProgress then
    write('-');

  if FUngot and not ANeedsNext then begin
    FUngot := false;
    Result := GetToken;
  end
  else begin
    if ANeedsNext then
      FUngot := false;
    SkipWhitespaces;
    c := FBuffer.GetChar;
    FBuffer.UngetChar;
    if (c = #0) then begin
      FToken.SubType := tstEof;
      FToken.Text := '';
    end
    else if isNonDigit(c) then
      ReadIdentifier
    else if isDigit(c) or (c = '.') then
      if
        (c = '.') and
        (
          (FToken.SubType = tstIdentifier) or
          (FToken.SubType = tstCloseSqParent)
        )
      then begin
        FToken.SubType := tstDot;
        FToken.Text := c;
        FBuffer.GetChar;
      end
      else
        ReadIntOrFloatConst
    else if c = '"' then
      ReadStrConst
    else if c = '''' then begin
      FBuffer.GetChar;
      c := ReadChar;
      FToken.SubType := tstIntConst;
      FToken.Text := c;
      with FToken.Value do
        AsInteger := Ord(c);
      c := FBuffer.GetChar;
      if (c <> '''') then
        Error(SCcTokenUnexpectedSymbolError);
    end
    else
      ReadSymbol;
    Result := FToken;
  end;
end;


function TCcTokenizer.ReadChar(out AEsc: boolean): char;
var
  c: char;
begin
  Result := #0;
  c := FBuffer.GetChar;
  AEsc := c = '\';
  if (c = '\') then begin
    c := FBuffer.GetChar;
    if (c in ['x', 'X']) or IsOctDigit(c) then begin
      FBuffer.UngetChar;
      ReadIntOrFloatConst(true);
      if not (FToken.Value.AsInteger in [0..255]) then
        Error(SCcTokenCharCodeOutOfRange);
      Result := FToken.Value.AsChar;
    end
    else
      case c of
        #0: Error(SCcTokenUnexpectedEOFError);
        '"', '''', '\': Result := c;
        'a', 'A': Result := #7;
        'b', 'B': Result := #8;
        't', 'T': Result := #9;
        'n', 'N': Result := #$A;
        'v', 'V': Result := #$B;
        'r', 'R': Result := #$D;
        'f', 'F': Result := #$C;
        #13:
          begin
            SkipWhitespaces;
            Result := FBuffer.GetChar;
            if Result = #0 then
              Error(SCcTokenUnexpectedEOFError);
          end;
      else
        Result := c;
      end;
  end
  else begin
    if c in [#13, #10] then
      Error(SCcTokenUnexpectedEndOfLine)
    else
      Result := c;
  end;
end;


function TCcTokenizer.ReadChar: char;
var
  b: boolean;
begin
  Result := ReadChar(b);
end;


procedure TCcTokenizer.ReadIdentifier;
var
  c: char;
begin
  c := FBuffer.GetChar;
  FToken.Text := '';
  if not isNonDigit(c) then
    Error(SCcTokenUnexpectedSymbolInIdentifier);
  while (isNonDigit(c) or isDigit(c)) do begin
    FToken.Text := FToken.Text + c;
    c := FBuffer.GetChar;
  end;
  FBuffer.UngetChar;
  if not IdentifyKeyword then
    FToken.SubType := tstIdentifier;
end;


procedure TCcTokenizer.ReadIntOrFloatConst(const AEscSeq: boolean = false);
var
  c: char;
  iv: integer;
  hasValue: boolean;

  procedure readFloatConst;
  var
    s: string;
    ds, c: char;
    hasFloatValue: boolean;
  begin
    hasFloatValue := false;
    ds := DecimalSeparator;
    try
      DecimalSeparator := '.';
      s := IntToStr(iv) + '.';
      c := FBuffer.GetChar;
      if (c = '.') then
        c := FBuffer.GetChar;
      while isDigit(c) do begin
        s := s + c;
        c := FBuffer.GetChar;
        hasFloatValue := true;
      end;
      if (c in ['e', 'E']) then begin
        s := s + c;
        c := FBuffer.GetChar;
        if (c in ['+', '-']) then begin
          s := s + c;
          hasFloatValue := true;
          c := FBuffer.GetChar;
        end;
        if not isDigit(c) then
          Error(SCcTokenUnexpectedEndOfFloatExpConst);
        while isDigit(c) do begin
          s := s + c;
          hasFloatValue := true;
          c := FBuffer.GetChar;
        end;
      end;
      if not (hasFloatValue or hasValue) then
        Error(SCcTokenInFloatRepError);
      FBuffer.UngetChar;
      FToken.Text := s;
      with FToken.Value do
        AsDouble := StrToFloat(s);
      FToken.SubType := tstFloatConst;
    finally
      DecimalSeparator := ds;
    end;
  end;


  procedure readIntConst(const AEsc: boolean = false);
  var
    s: string;
  begin
    s := '';
    if AEsc then
      s := '0';
    iv := 0;
    if (c = '0') or AEsc then begin
      while isOctDigit(c) do begin
        s := s + c;
        c := FBuffer.GetChar;
      end;
      if (c in ['x', 'X']) and (AEsc or (s = '0')) then begin
        s := s + c;
        c := FBuffer.GetChar;
        while isHexDigit(c) do begin
          s := s + c;
          c := FBuffer.GetChar;
        end;
        if AEsc and (LowerCase(s) = '0x') then
          Error(SCcTokenHexValueIsTooShort);

        try
          iv := StrToInt('$' + Copy(s, 3, Length(s) - 2));
        except
          Error(Format(SCcTokenInvalidIntValFmt, [s]));
        end;
        FBuffer.UngetChar;
      end
      else if (c in ['.', 'e', 'E']) then begin
        if AEsc then
          Error(SCcTokenFloatIsNotAllowed);
        if (s <> '0') then
          Error(SCcTokenIntegerPartError);
        hasValue := s <> '';
        FBuffer.UngetChar;
        readFloatConst;
        Exit;
      end
      else begin
        iv := OctToInt(s);
        FBuffer.UngetChar;
      end;
    end
    else begin
      while isDigit(c) do begin
        s := s + c;
        c := FBuffer.GetChar;
      end;
      iv := StrToInt(s);
      if (c in ['.', 'e', 'E']) then begin
        hasValue := s <> '';
        FBuffer.UngetChar;
        readFloatConst;
        Exit;
      end
      else
        FBuffer.UngetChar;
    end;
    FToken.Text := s;
    with FToken.Value do
      AsInteger := iv;
    FToken.SubType := tstIntConst;
  end;


begin
  iv := 0;
  hasValue := false;
  c := FBuffer.GetChar;
  if (c = '.') then
    readFloatConst
  else if AEscSeq or isDigit(c) then
    readIntConst(AEscSeq)
  else
    Error(SCcTokenUndefinedTypeOfConst);
end;


procedure TCcTokenizer.ReadStrConst;
var
  c: char;
  s: string;
  b: boolean;
begin
  c := FBuffer.GetChar;
  if c <> '"' then
    Error(SCcTokenUnexpectedSymbolError);
  s := '';
  repeat
    c := ReadChar(b);
    if b or (c <> '"') then
      s := s + c;
  until (c = '"') and not b;
  FToken.Text := s;
  FToken.SubType := tstStrConst;
end;


procedure TCcTokenizer.ReadSymbol;
var
  c: char;
  s: string;
  t, lt: TCcTokenSubType;
begin
  c := FBuffer.GetChar;
  for t := Low(TCcTokenDelimiters) to High(TCcTokenDelimiters) do
    if DELIM_VALUES[t][1] = c then begin
      FToken.SubType := t;
      FToken.Text := c;
      Exit;
    end;
  s := c;
  t := IsOpInList(s);
  lt := t;
  while (c <> #0) and (t <> tstNone) do begin
    c := FBuffer.GetChar;
    s := s + c;
    lt := t;
    t := IsOpInList(s);
  end;
  Delete(s, Length(s), 1);
  if (c <> #0) then
    FBuffer.UngetChar;
  if (s <> '') then begin
    FToken.SubType := lt;
    FToken.Text := s;
  end
  else
    Error(SCcTokenUnexpectedSymbolError);
end;


procedure TCcTokenizer.RequireToken(
  ATokenType: TCcTokenSubType; const AStr: string);
begin
  if NextToken.SubType <> ATokenType then
    ErrorFmt(SCcTokenExpectedButFoundFmt, [AStr, GetToken.Text]);
end;


procedure TCcTokenizer.SkipWhitespaces;

  procedure skipComment1;
  var
    c: char;
  begin
    with FBuffer do
      while true do begin
        c := GetChar;
        CheckEof(c);
        if (c = '*') then begin
          c := GetChar;
          CheckEof(c);
          if (c = '/') then
            Break;
        end;
      end;
  end;


  procedure skipComment2;
  var
    c: char;
  begin
    with FBuffer do
      while true do begin
        c := GetChar;
        if (c = #0) then begin
          UngetChar;
          Exit;
        end;
        if (c = #13) then begin
          UngetChar;
          Break;
        end;
      end;
  end;

var
  c: char;
begin
  with FBuffer do begin
    while (GetChar in [#32, #13, #10, #9]) do;
    UngetChar;
    if (GetChar = '/') then begin
      c := GetChar;
      if (c = '*') then begin
        skipComment1;
        SkipWhitespaces;
      end
      else if (c = '/') then begin
        skipComment2;
        SkipWhitespaces;
      end
      else begin
        UngetChar;
        UngetChar;
      end;
    end
    else
      UngetChar;
  end;
end;


procedure TCcTokenizer.UngetToken;
begin
  FUngot := true;
end;


{ TCcToken }

procedure TCcToken.Assign(AToken: TObject);
begin
  if (AToken is TCcToken) then
    with AToken as TCcToken do begin
      Self.FSubType := FSubType;
      Self.FValue := FValue;
      Self.FText := FText;
      Self.FPosition := FPosition;
    end;
end;


constructor TCcToken.Create;
begin
  FSubType := tstNone;
end;


procedure TCcToken.UpdateInfo(
  ASubType: TCcTokenSubType; const AText: string; AValue: TCcTokenValue);
begin
  FSubType := ASubType;
  FText := AText;
  FValue := AValue;
end;


end.