compwind.pas

Turbo Pascal 6.0编译器源码

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.