www.pudn.com > tp60src.zip > COMPWIND.PAS

unit CompWind; 
 
{$O+,F+,S-,V-} 
 
interface 
 
uses Objects, Views, TDos, TWindows, CompVars; 
 
const 
  CCompileView = #6#7; 
 
type 
 
  PCompileView = ^TCompileView; 
  TCompileView = object(TView) 
    Texts: array[0..14] of PString; 
    Params: array[0..5] of Longint; 
    Status: PString; 
    MainFile: PathStr; 
    CurrentFile: PathStr; 
    constructor Init(var Bounds: TRect); 
    constructor Load(var S: TStream); 
    destructor Done; virtual; 
    procedure Draw; virtual; 
    function GetPalette: PPalette; virtual; 
    procedure Store(var S: TStream); 
  private 
    procedure SetInfo(AInfo: PCompInfo); 
    procedure Stop; 
  end; 
 
  PCompileWindow = ^TCompileWindow; 
  TCompileWindow = object(TTurboWindow) 
    constructor Init; 
    function Execute: Word; virtual; 
  end; 
 
function SetCompInfo(AInfo: PCompInfo): Integer; 
 
const 
 
  RCompileView: TStreamRec = ( 
    ObjType: 3100; 
    VmtLink: Ofs(TypeOf(TCompileView)^); 
    Load:    @TCompileView.Load; 
    Store:   @TCompileView.Store 
  ); 
  RCompileWindow: TStreamRec = ( 
    ObjType: 3101; 
    VmtLink: Ofs(TypeOf(TCompileWindow)^); 
    Load:    @TCompileWindow.Load; 
    Store:   @TCompileWindow.Store 
  ); 
 
implementation 
 
uses Drivers, FNames, Compiler, Utils; 
 
var 
  CurCompView: PCompileView; 
 
constructor TCompileView.Init(var Bounds: TRect); 
var 
  I: Integer; 
begin 
  TView.Init(Bounds); 
  Texts[0]  := NewStr(''); 
  Texts[1]  := NewStr('  Main file: %1#%-30s'); 
  Texts[2]  := NewStr('  Compiling: %2#%-30s'); 
  Texts[3]  := NewStr(''); 
  Texts[4]  := NewStr('  Destination: %0#%s   Line number: %3#%6d'); 
  Texts[5]  := NewStr('  Free memory: %5#%4dK    Total lines: %4#%6d'); 
  Texts[6]  := NewStr(''); 
  Texts[7]  := NewStr(''); 
  Texts[8]  := NewStr(''); 
  Texts[9]  := NewStr(''); 
  Texts[10] := NewStr('         Press Ctrl-Break to cancel'); 
  Texts[11] := NewStr('          Cancelled: ~Press any key~'); 
  Texts[12] := NewStr('      Compile successful: ~Press any key~'); 
  Texts[13] := NewStr('Memory'); 
  Texts[14] := NewStr(' Disk '); 
  CurCompView := @Self; 
  if CompParams.Flags and cfDisk = 0 then 
    I := 13 
  else 
    I := 14; 
  Params[0] := Longint(Texts[I]); 
  Params[1] := Longint(@MainFile); 
  Params[2] := Longint(@CurrentFile); 
  Status := Texts[10]; 
  MainFile := PrimaryFile; 
  ShortenPath(MainFile, 30); 
end; 
 
constructor TCompileView.Load(var S: TStream); 
var 
  I: Integer; 
begin 
  CurCompView := @Self; 
  TView.Load(S); 
  for I := 0 to 14 do 
    Texts[I] := S.ReadStr; 
  if CompParams.Flags and cfDisk = 0 then 
    I := 13 
  else 
    I := 14; 
  Params[0] := Longint(Texts[I]); 
  Params[1] := Longint(@MainFile); 
  Params[2] := Longint(@CurrentFile); 
  Status := Texts[10]; 
  MainFile := PrimaryFile; 
  ShortenPath(MainFile, 30); 
end; 
 
destructor TCompileView.Done; 
var 
  I: Integer; 
begin 
  for I := 0 to 14 do 
    DisposeStr(Texts[I]); 
  CurCompView := nil; 
  TView.Done; 
end; 
 
procedure TCompileView.Draw; 
var 
  Color: Word; 
  I: Integer; 
  S: string[63]; 
  B: TDrawBuffer; 
begin 
  Color := GetColor(1); 
  for I := 0 to Size.Y - 2 do 
  begin 
    MoveChar(B, ' ', Color, Size.X); 
    if Texts[I] <> nil then 
    begin 
      FormatStr(S, Texts[I]^, Params); 
      MoveStr(B, S, Color); 
    end; 
    WriteBuf(0, I, Size.X, 1, B); 
  end; 
  Color := GetColor(2); 
  WordRec(Color).Hi := WordRec(Color).Lo or $80; 
  MoveChar(B, ' ', Color, Size.X); 
  MoveCStr(B, Status^, Color); 
  WriteBuf(0, Size.Y - 1, Size.X, 1, B); 
end; 
 
function TCompileView.GetPalette: PPalette; 
const 
  P: string[Length(CCompileView)] = CCompileView; 
begin 
  GetPalette := @P; 
end; 
 
procedure TCompileView.Store(var S: TStream); 
var 
  I: Integer; 
begin 
  TView.Store(S); 
  for I := 0 to 14 do 
    S.WriteStr(Texts[I]); 
end; 
 
procedure TCompileView.SetInfo(AInfo: PCompInfo); 
begin 
  Params[3] := AInfo^.LineNumber; 
  Params[4] := AInfo^.TotalLines; 
  Params[5]:= (AInfo^.FreeMemory + 512) shr 10; 
  if AInfo^.CurrentFile = nil then 
    CurrentFile := '' 
  else 
  begin 
    CurrentFile := AInfo^.CurrentFile^; 
    ShortenPath(CurrentFile, 30); 
  end; 
  DrawView; 
end; 
 
procedure TCompileView.Stop; 
var 
  Event: TEvent; 
begin 
  if (CompResult.ErrorNum < 0) or (CompResult.ErrorNum = 0) and StopAfterCompiling then 
  begin 
    Params[5] := (CompResult.FreeMemory + 512) shr 10; 
    if CompResult.ErrorNum = 0 then 
      Status := Texts[12] 
    else 
      Status := Texts[11]; 
    DrawView; 
    Event.What := evKeyDown; 
    Event.KeyCode := WaitEvent; 
    if Event.KeyCode = 0 then 
      GetMouseEvent(Event) 
    else if Event.CharCode = #0 then 
      PutEvent(Event); 
  end; 
end; 
 
constructor TCompileWindow.Init; 
var 
  R: TRect; 
begin 
  R.Assign(0, 0, 47, 11); 
  TTurboWindow.Init(R, 'Compiling', wnNoNumber, wpCompileWindow); 
  DragMode := dmLimitLoY; 
  Options := Options or ofCentered; 
  Flags := 0; 
  R.Grow(-1, -1); 
  Insert(New(PCompileView, Init(R))); 
end; 
 
function TCompileWindow.Execute: Word; 
begin 
  CtrlBreakHit := False; 
  Compile(CompParams, CompResult); 
  InitDebugger; 
  CurCompView^.Stop; 
end; 
 
function SetCompInfo(AInfo: PCompInfo): Integer; 
begin 
  CurCompView^.SetInfo(AInfo); 
  if CtrlBreakHit then 
    SetCompInfo := -1 
  else 
    SetCompInfo := 0; 
end; 
 
end.