(* Draak.pas: Please consult the end of this file for copyright information   *)
unit Draak;

interface

uses
  SysUtils, Classes,
  StrUtils,
  Contnrs,
  filedrv,
  gmrdrv,
  cmddrv,
  parser,
  hashs,
  error;

type
  TDraakNotify = procedure(sender: TObject; s: string) of object;

  TDraakFlags = set of (TimeStat, HashTime);

  TDraak = class(TComponent)
  private
    error: TError;
    Grammar: TGmr;
    root: PParseNode;
    FonError: TDraakNotify;
    FonStatus: TDraakNotify;
    FonStream: TdraakNotify;
    FonNodeCreate: TDraakNotify;
    FonNodeChild: TDraakNotify;
    FonNodePop: TDraakNotify;
    FonCompile: TDraakNotify;
    FonAssemble: TDraakNotify;
    FonLink: TDraakNotify;
    Flag: TDraakFlags;
    FSearchPath: string;
    finalSuccess: boolean;
  public
    property rootNode: PParseNode read root;
    property success: boolean read finalSuccess;
  published
    property Flags: TDraakFlags read Flag write Flag;
    property SearchPath: string read FSearchPath write FSearchPath;
    property onError: TDraakNotify read FonError write FonError;
    property onStatus: TDraakNotify read FonStatus write FonStatus;
    property onStream: TDraakNotify read FonStream write FonStream;
    property onNodeCreate: TDraakNotify read FonNodeCreate write FonNodeCreate;
    property onNodeChild: TDraakNotify read FonNodeChild write FonNodeChild;
    property onNodePop: TDraakNotify read FonNodePop write FonNodePop;
    property onCompile: TDraakNotify read FonCompile write FonCompile;
    property onAssemble: TDraakNotify read FonAssemble write FonAssemble;
    property onLink: TDraakNotify read FonLink write FonLink;
    constructor create(AOwner: TComponent); override;
    procedure compile(outStream: TFileStream; inFile: string);
    procedure parse(inFile: string);
    procedure clearGrammer;
    procedure produceCopyright;
    { Published declarations }
  end;

  EDraakNoCompile = class(Exception)

  end;

procedure Register;

implementation

{$ifdef MSWindows} uses windows; {$endif}

function timeCount(var t: int64): double;
var i, f: int64;
begin
  {$ifdef MSWindows}
  if t = 0 then
  begin
    QueryPerformanceCounter(t);
    result := 0;
  end else
  begin
    QueryPerformanceCounter(i);
    QueryPerformanceFrequency(f);
    result := (i-t) / f;
  end; {$endif}
  {$ifdef Linux}
  result := 0;{$Endif}
end;

constructor TDraak.create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  error := TError.create(self);
end;

procedure TDraak.parse(inFile: string);
var loadedFile: string;
    ext, gmrfile: string;
    name: string;
    noext: string;
    lPath: PChar;
    t: int64; tim: double;
    parse: TParser;
begin
  loadedFile := inFile;
  ext := AnsiStrRScan(PChar(loadedFile), '.')+1;
  lPath := AnsiStrRScan(PChar(loadedFile), PathDelim);
  if lPath <> nil then
    name := lPath+1
  else
    name := loadedFile;
  noext := Leftstr(name, AnsiPos('.', name)-1);
  gmrFile := FileSearch({ext+PathDelim+}ext+'.gmr', FSearchPath);

  t := 0; timeCount(t);
  if Grammar = nil then
    Grammar := TGmr.init(TFile.init(gmrFile));
  tim := timeCount(t);
  if HashTime in Flag then error.status(FloatToStrF(tim,ffFixed, 0, 2)+' seconds to hash.');
  t := 0; timeCount(t);
  parse := TParser.Create;
  parse.err := error;
  parse.parse(TFile.init(inFile), Grammar);
  if (parse.rootNode <> nil) AND (root = nil) then
    root := parse.rootNode;
  tim := timeCount(t);
  if TimeStat in Flag then error.status(FloatToStrF(tim, ffFixed, 0, 2)+' seconds.');
end;

procedure TDraak.compile(outStream: TFileStream; inFile: string);
var loadedFile: string;
    ext, gmrFile: string;
    name: string;
    noext: string;
    lPath: PChar;
    t: int64; tim: double;
    macro: TMacro;
    parse: TParser;
begin
  loadedFile := inFile;
  ext := AnsiStrRScan(PChar(loadedFile), '.')+1;
  lPath := AnsiStrRScan(PChar(loadedFile), PathDelim);
  if lPath <> nil then
    name := lPath+1
  else
    name := loadedFile;
  noext := Leftstr(name, AnsiPos('.', name)-1);
  gmrFile := FileSearch({ext+PathDelim+}ext+'.gmr', FSearchPath);

  t := 0; timeCount(t);
  if Grammar = nil then
    Grammar := TGmr.init(TFile.init(gmrFile));
  tim := timeCount(t);
  if HashTime in Flag then error.status(FloatToStrF(tim, ffFixed, 0, 2)+' seconds to hash.');
  t := 0; timeCount(t);
  parse := TParser.Create;
  parse.err := error;
  parse.parse(TFile.init(inFile), Grammar);
  if parse.rootNode <> nil then
  begin
    if root = nil then
      root := parse.rootNode;
    macro := TMacro.create;
    macro.vars := TVars.Create(noext, nil, error);
    macro.err := error;
    macro.gmr := Grammar;
    macro.searchDirs := FSearchPath;
    macro.execute(parse.rootNode);
    if macro.giantError = false then
    begin
      macro.outCode.SaveToStream(outStream);
      macro.outData.SaveToStream(outStream);
      error.status(noext+'.pas: Compiled! ('+intToStr(parse.lines)+' lines)' );
      finalSuccess := true;
    end else begin finalSuccess := false; error.err('Error compiling file.'); end;
//    macro.destroy;
    Grammar.Destroy;
  end;
  tim := timeCount(t);
  if TimeStat in Flag then error.status(FloatToStrF(tim, ffFixed, 0, 2)+' seconds.');
end;

procedure TDraak.clearGrammer;
begin
  Grammar := nil; root := nil;
end;

procedure TDraak.produceCopyright;
begin
  error.status('(* ************************************************************ *)');
  error.status('(* Copyright (c) 1999-2004 Jon Gentle, All right reserved.      *)');
  error.status('(* ************************************************************ *)');
end;

procedure Register;
begin
  RegisterComponents('TOASC', [TDraak]);
end;

(* ************************************************************ *)
(* Copyright (c) 1999-2004 Jon Gentle, All right reserved.      *)
(* ************************************************************ *)
(* This software is given As-Is.  No warranties of any kind,    *)
(* implied or expressed, are given to anyone.  The author(s)    *)
(* shall not be held for any liability under any circumstances. *)
(* Permission is granted to anyone who wishes to alter, use or  *)
(* distribute this software, as long as the following           *)
(* restrictions are met:                                        *)
(*                                                              *)
(* 1) The above copyright and this notice must appear in the    *)
(* software in source code form.  Under no circumstance are     *)
(* these to be removed.                        			            *)
(* 2) The above copyright notice must appear in the software in *)
(* binary form							                                    *)
(* 3) Anyone other then the copyright owner that alters source  *)
(* code must mark the source code and resulting binary form as  *)
(* altered.                                                     *)
(* 4) Original authorship of part or whole must not be          *)
(* misrepresented.                                              *)
(* 5) Any original or modified source code under this licence   *)
(* must be made available upon request.                         *)
(* ************************************************************ *)

begin
end.