unit untCompile;

interface

Uses
  classes, sysutils, forms, windows, dialogs,controls,
  stdctrls, variants, StrUtils;

Type TCharSet = Set of char;

Const
  WhiteSpaces: TCharSet = ['+', '-', '/', '*', '(', ')', ':', '=', ',', ';', '>', '<',
                           '$', '.', '#', '[', ']', '^', '@', '&', '~', '|', '%'];

  BlackSpaces: TCharSet = [#1..#32];

  StopChars: TCharSet = [#0..#32, '+', '-', '/', '*', '(', ')', ':', '=', ',', '''',
                         '{', '}', ';', '>', '<', '$', '.', '#', '[', ']', '"', '^',
                         '@', '&', '~', '|', '%'];

  FirstIdentChar: TCharSet = ['A'..'Z', 'a'..'z', '_'];

  IdentBackChars: TCharSet = ['A'..'Z', 'a'..'z', '_', '0'..'9'];

  Digit: TCharSet = ['0'..'9'];
  
  HexDigit: TCharSet = ['0'..'9', 'A'..'F'];


Const
  wInteger = 1;
  wDouble = 2;
  wString = 3;
  WBoolean = 4;

Const
  ocAdd = 0;
  ocSub = 1;
  ocMul = 2;
  ocDiv = 3;
  ocMod = 4;
  ocSlash = 5;
  ocShl = 6;
  ocShr = 7;
  ocNot = 8;
  ocOr = 9;
  ocXor = 10;
  ocAnd = 11;
  ocGreaterEqual = 12;
  ocEqual = 13;
  ocLessEqual = 14;
  ocNotEqual = 15;
  ocGreater = 16;
  ocLess = 17;
  ocNeg = 18;
  ocGoto = 19;
  ocIF = 20;
  ocIfFalseGoto = 21;
  ocLoadConst = 23;
  ocHalt = 26;
  ocIncVar = 29;
  ocDecVar = 30;
  ocBackDode = 34;
  ocExtFun = 42;
  ocExtProc = 43;
  ocSetSelf = 44;
  ocloadextvar = 45;
  ocstoreextvar = 46;
  ocselffromvar = 47;
  ocmov = 48;
  occall = 49;
  ocreturn = 50;
  ocvarraycreate = 51;
  ocsetvarray = 52;
  ocSto = 53;


{ Character IDs}

  idEndOfFile = 0;
  idEndOfLine = 10;
  idNewLine = $0a;
  idpower = Integer('^');
  idPoint = Integer('.');
  idDelimeter = Integer(';');
  idGreater = Integer('>');
  idLess = Integer('<');
  idComma = Integer(',');
  idPlus = Integer('+');
  idMinus = Integer('-');
  idSlash = Integer('/');
  idStar = Integer('*');
  idOpenBracket = Integer('(');
  idCloseBracket = Integer(')');
  idOpenComment = Integer('{');
  idCloseComment = Integer('}');
  idEqual = Integer('=');
  idNotEqual = integer('#');
  id2Points = Integer(':');
  idStringChar = Integer('''');
  id2StringChar = Integer('"');
  idSqopenBracket = integer('[');
  idSqcloseBracket = integer(']');

 { ID Bases and ID ends }
  idBase = 256;
  idReservedBase = 1000;
  idReservedEnd = 1999;

 { Other IDs }
  idIdentifier = idBase + 0;
  idStringConst = idBase + 1;
  idNumberConst = idBase + 2;
  
  idResWord = idBase + 4;
  idResConst = idBase + 5;
  idHexConst = idBase + 6;

 { Reserverd Words [idReservedBase,idReservedEnd] }
  idProgram = idReservedBase + 0;
  idLabel = idReservedBase + 1;
  idGoto = idReservedBase + 2;
  idVar = idReservedBase + 3;
  idBegin = idReservedBase + 4;
  idEnd = idReservedBase + 5;
  idAnd = idReservedBase + 6;
  idOr = idReservedBase + 7;
  idXor = idReservedBase + 8;
  idNot = idReservedBase + 9;
  idShl = idReservedBase + 10;
  idShr = idReservedBase + 11;
  idDiv = idReservedBase + 12;
  idMod = idReservedBase + 13;
  idTrue = idReservedBase + 14;
  idFalse = idReservedBase + 15;
  idIf = idReservedBase + 16;
  idThen = idReservedBase + 17;
  IdElse = idReservedBase + 18;
  idWhile = idReservedBase + 19;
  idRepeat = idReservedBase + 20;
  idUntil = idReservedBase + 21;
  idFor = idReservedBase + 22;
  idTo = idReservedBase + 23;
  idDownto = idReservedBase + 24;
  idDo = idReservedBase + 25;
  idNil = idReservedBase + 27;
  idNull = idReservedBase + 28;
  idUnitinit = idReservedBase + 31;
  idUnitfinal = idReservedBase + 32;
  idClass = idReservedBase + 33;
  idType = idReservedBase + 34;
  idConstr = idReservedBase + 35;
  idDestr = idReservedBase + 36;
  idUses = idReservedBase + 37;
  idUnit = idReservedBase + 38;
  idInterface = idReservedBase + 39;
  idImplement = idReservedBase + 40;
  idProcedure = idReservedBase + 41;
  idPrivate = idReservedBase + 42;
  idPublic = idReservedBase + 43;
  idProtected = idReservedBase + 44;
  idPublished = idReservedBase + 45;
  idFunction = idReservedBase + 46;
  idConst = idReservedBase + 47;
  idProperty = idReservedBase + 48;
  idVirtual = idReservedBase + 49;
  idOverride = idReservedBase + 50;
  idDynamic = idReservedBase + 51;
  idRecord = idReservedBase + 52;
  idForward = idReservedBase + 53;
  idIndex = idReservedBase + 54;
  idRead = idReservedBase + 55;
  idWrite = idReservedBase + 56;
  idStored = idReservedBase + 57;
  idDefault = idReservedBase + 58;
  idAbstract = idReservedBase + 59;
  idStdcall = idReservedBase + 69;


Type
  TWordList = class
  private
    FList: TStringList;
    FCount: integer;

  protected
    procedure AddWord(aWordName: String; aWordID: integer); virtual;

  public
    constructor Create;
    destructor Destroy; override;


    function GetWordID(aWordName: string): integer;
    function GetWordName(aWordID: integer): string;

    property Count: integer read FCount;
  end;

  TResWords = class(TWordList)
  public
    procedure AddWord(aWordName: String; aWordID: integer); override;
  end;

  TResConsts = class(TWordList)
  public
    procedure AddWord(aWordName: String; aWordID: integer); override;
  end;

  TDynaWords = class(TWordList)
  private
    FConstID: integer;

  public
    constructor Create;
    function AddWord(aWordName: String): integer; reintroduce;
  end;

  TProgItem = record
    Cmd, P1, P2: integer;
  end;

  TIdentType = (itVariable, itProcedure, itFunction);
  TDataType = (dtUnknown, dtInt, dtFloat, dtBool, dtStr, dtDateTime, dtOther);

  TIdent = class
  private
    FName: string;
    FID: Integer;
    FIdentType: TIdentType; {0-Variable 1-procedure 2-function}

    FDataType: TDataType;

    FValue: variant;

    FParCount: Integer;

    FParams: TStringList;

    FDynaFlag: boolean;

    FOffPos: integer;

  public
    constructor Create;
    destructor Destroy; override;
    procedure AddParam(aIdent: TIdent);

    property Name: string read FName write FName;
    property ID: integer read FID write FID;
    property IdentType: TIdentType read FIdentType write FIdentType;
    property Params: TStringList read FParams write FParams;
    property Value: variant read FValue write FValue;
    property DataType: TDataType read FDataType write FDataType;
    property DynaFlag: boolean read FDynaFlag write FDynaFlag;
    property OffPos: integer read FOffPos write FOffPos;
  end;

  TIdentList = class
  private
    FIdents: array of TIdent;
    FCount: integer;

    function getIdentByIndex(aIndex: integer): TIdent;
    function Add(aName: string; aID: Integer): TIdent; virtual;

  public
    function IndexOf(aName: string): integer;

    function getIdentByName(aName: String): TIdent;
    function getIdentByID(aID: integer): TIdent;

    constructor Create;
    destructor Destroy; override;

    function getText: string;
    procedure SetValue(aID: integer; aValue: variant);

    property Idents[aIndex: integer]: TIdent read getIdentByIndex;
    property Count: integer read FCount;
  end;

  TConstList = class(TIdentList)
  private
    FConstID: integer;

  public
    function Add(aName: string): TIdent; reintroduce;
    constructor Create;
  end;

  TVariableList = class(TIdentList)
  private
    FID: integer;

  public
    function Add(aName: string): TIdent; reintroduce;
    constructor Create;

  end;

  TArrayOfTProgItem = array of TProgItem;

  TProgList = class
  private
    FCount: integer;
    FProgList: TArrayOfTProgItem;

  public
    constructor Create;
    function PutCode(aCmd, aP1, aP2: integer): integer;
    destructor Destroy; override;

    function getText: string;

    property ProgList: TArrayOfTProgItem read FProgList;
    property Count: integer read FCount;
    
  end;

  TToken = Record
    ID: Integer;
    Data: Variant;
  End;

  TCompile = class
  private
    FSrcCode: string;
    FCurPos: integer;
    FSrcLen: integer;

    FCurToken: TToken;

    FConsts: TConstList;
    FVariables: TVariableList;

    FLastVarID: integer;

    FProgList: TProgList;

    function ReadByte: Byte;
    function NextByte: Byte;
    procedure BackByte(aNum: integer);

    procedure ReadToken;
    function NextToken: TToken;
    function SetToken(ID: integer; V: Variant): TToken;

    procedure GetVarType;
    function GetVar: integer;
    procedure getComa;
    procedure getIdentifier;
    procedure getdelimeter;
    procedure getOpenBracket;
    procedure getCloseBracket;

    procedure Block;

    procedure Declarations(aPreFix: string = '');
    procedure Variables(aPreFix: string = '');

    function genVarName(aPreFix, aName: string): string;

    procedure Statement(aPreFix: string = '');
    procedure Condition;
    procedure Expression;
    procedure Term;
    procedure Factor;

    function ProcDef: integer;
    procedure ProcParam(aProcName: string);
    procedure ProcBody(aID: integer);

    procedure RaiseError(aErrStr: string);

    function getDataType(aStr: string): TDataType;

    function getVariableByName(aName: string): TIdent; overload;
    function getVariableByName(aPreFix, aName: string): TIdent; overload;

  public
    constructor Create;
    destructor Destroy; override;

    procedure Compile;

    function getVariables: string;
    function getConsts: string;
    function getPCode: string;

    procedure Run;

    property SrcCode: string read FSrcCode write FSrcCode;

  end;


  TStack = class
  private
    FDatas: array of variant;
    FCount: integer;

  public
    constructor Create;
    destructor Destroy; override;

    procedure Put(v: Variant);
    function Pop: variant;
    function getData(aIndex: integer): variant;

    procedure Clear;
  end;

var
  ResWords: TResWords;
  ResConsts: TResConsts;
  Stack: TStack;
  
  function getPCodeName(aCmd: integer): string;
implementation

function getPCodeName(aCmd: integer): string;
begin
  Result := 'unknown';

  if aCmd = ocMov then Result := 'Mov';
  if aCmd = ocLoadConst then Result := 'LoadConst';
  if aCmd = ocSto then Result := 'STO';
  if aCmd = ocAdd then Result := 'Add';
  if aCmd = ocSub then Result := 'Sub';
  if aCmd = ocMul then Result := 'Mul';
  if aCmd = ocDiv then Result := 'Div';
  if aCmd = ocGreater then Result := '>';
  if aCmd = ocGreaterEqual then Result := '>=';
  if aCmd = ocLess then Result := '<';
  if aCmd = ocLessEqual then Result := '<=';
  if aCmd = ocNotEqual then Result := '<>';
  if aCmd = ocIfFalseGoto then Result := 'IfFalseGoto';
  if aCmd = ocGoto then Result := 'Goto';
end;

{ TCompile }

procedure TCompile.BackByte(aNum: integer);
begin
  if FCurPos - aNum > 0 then FCurPos := FCurPos - aNum
    else FCurPos := 1;
end;

constructor TCompile.Create;
begin
  FSrcCode := '';
  FCurPos := 1;
  FSrcLen := 0;

  FConsts := TConstList.Create;
  FVariables := TVariableList.Create;

  FProgList := TProgList.Create;

  FConsts.Add('null');  //id = 1;
  FConsts.Add('nil');  //id = 2;
end;

destructor TCompile.Destroy;
begin
  FreeAndNil(FConsts);
  FreeAndNil(FVariables);
  FreeAndNil(FProgList);
  
  inherited;
end;

procedure TCompile.Expression;
var
  tmp: TToken;
begin
  tmp := NextToken;

  if tmp.ID = idMinus then
      begin
      ReadToken;
      Term;

      FProgList.PutCode(ocNeg, 0, 0);
      end
     else Term;

  tmp := NextToken;
  
  while (tmp.ID = idPlus) or (tmp.ID = idMinus) or (tmp.ID = idOr) or (tmp.ID = idXor) do
    begin
    ReadToken;
    
    Case tmp.ID of
        idPlus:
          Begin
          Term; 
          FProgList.PutCode(ocAdd, 0, 0);
          End;

        idMinus:
          Begin
          Term;
          FProgList.PutCode(ocSub, 0, 0);
          End;

        idOr:
          Begin
          Term;
          FProgList.PutCode(ocOr, 0, 0);
          End;

        idXor:
          Begin    
          Term;
          FProgList.PutCode(ocXor, 0, 0);
          End;
    end;

    tmp := NextToken;
  end;
end;

procedure TCompile.Factor;
var
  str: string;
  aIdent: TIdent;
begin
  ReadToken;

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

                    if FVariables.IndexOf(str) < 0 then raiseError('變量' + str + '沒(méi)有定義');

                    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('期望逗號(hào)！');
end;

procedure TCompile.getdelimeter;
begin
  ReadToken;

  If (FCurToken.ID <> idDelimeter) then raiseError('期望分號(hào)！');
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('期望標(biāo)識(shí)符!');

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

  If Result < 0 then raiseError('沒(méi)有定義變量' + 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