turbo2.pas

Turbo Pascal 6.0编译器源码

unit Turbo2;

{$O+,F+,S-,X+,V-}

interface

uses Params, Objects, App, TDos, Utils;

type
  TTurboBase = object(TProgram)
    constructor Init;
    destructor Done; virtual;
    procedure InitDesktop; virtual;
    procedure InitMenuBar; virtual;
    procedure InitScreen; virtual;
    procedure InitStatusLine; virtual;
  end;

  PTurboDestkop = ^TTurboDesktop;
  TTurboDesktop = object(TDesktop)
    procedure TileError; virtual;
  end;

procedure OpenFileDialog(S: PathStr);
procedure NewFile;
procedure GetInfoDialog;
procedure ShellToDos;
procedure FindProcDialog;
procedure FindWindow(S: TResourceName; I: Word);
procedure FindHelpWindow(I: Word);
procedure UpdateMode;
procedure WatchAdd(Edit: Boolean);
procedure WatchRemove(All: Boolean);
procedure CompilerOptionsDialog;
procedure MemorySizesDialog;
procedure LinkerDialog;
procedure DebuggingDialog;
procedure GetCompileName(var S: PathStr);
procedure CallCompiler(I: Word; StopAfter: Boolean);
procedure ResetAll;
procedure SaveOptionsDialog;
procedure RetrieveOptionsDialog;
procedure PreferencesDialog;
procedure MouseOptionsDialog;
procedure EditorOptionsDialog;
procedure StartupOptionsDialog;
procedure UserScreen;
procedure WindowList;
procedure DestinationItem;
procedure MainFileDialog;
procedure ShowError;
procedure ClearError;
procedure SetError(AFileName: PString; ACol, ALine: Integer;
  ANumber, AClass: Word; AParam: Pointer);
procedure ShowFile(Pos: Longint; Msg: Word);
procedure ColorDialog;

implementation

uses Overlay, Drivers, Mem, Memory, HistList, Views, VideoIO, VSwap, TVars,
  VMem, TEdit, CompVars, TStatus, TWindows, FNames, Compiler, Tracer, Editor,
  Reg, TStdDlg, Shell, WatchWin, Help, TMenu, Config, StrNames;

function CalcMask: Byte; near; assembler;
asm
        MOV     BL,AL
        XOR     BH,BH
        MOV     CL,4
        SHR     BL,CL
        MOV     CL,AL
        AND     CL,0FH
        MOV     AL,1
        SHL     AL,CL
end;

procedure Convert(var Src, Dst, Codes; Mode: Byte); assembler;
asm
        PUSH    DS
        LDS     SI,Codes
        CLD
        LODSW
        XCHG    AX,DX
@@1:    LODSW
        MOV     CL,Mode
        ROR     AX,CL
        CALL    CalcMask
        LES     DI,Src
        AND     AL,ES:[BX+DI]
        NEG     AL
        SBB     AL,AL
        NOT     AL
        XCHG    AL,AH
        CALL    CalcMask
        LES     DI,Dst
        XOR     ES:[BX+DI],AH
        OR      ES:[BX+DI],AL
        XOR     ES:[BX+DI],AH
        DEC     DX
        JNZ     @@1
        POP     DS
end;

procedure ShowError;
var
  I: Word;
  P: PEditView;
  L: array[0..2] of Longint;
  Name: PathStr;
  S: string[63];
  ErrStr: string;
begin
  if ErrorPresent then
  begin
    S := Strings^.Get(ErrorNumber + ErrorClass);
    if S = '' then
      S := Strings^.Get(sRuntimeErrorBase);
    L[0] := ErrorNumber;
    L[1] := Longint(@S);
    L[2] := Longint(ErrorParam);
    if ErrorParam = nil then
      I := sError
    else
      I := sErrorParam;
    if ErrorFileName = nil then
      P := nil
    else
    begin
      FExpand(ErrorFileName^, Name);
      P := OpenFile(Name, False);
    end;
    if P = nil then
      MessageBox(I, @L, mfError + mfOkButton)
    else
    begin
      P^.Owner^.Select;
      if ErrorPosition.Y <> 0 then
        if ErrorPosition.X = 0 then
          P^.GotoOldLine(ErrorPosition.Y, False)
        else
          P^.SetPos(ErrorPosition.X, ErrorPosition.Y);
      FormatStr(ErrStr, Strings^.Get(I), L);
      P^.CompilerError(ErrStr);
      ErrorShown := True;
    end;
  end;
end;

procedure ClearError;
var
  P: PEditView;
begin
  P := FindEditor(nil);
  if P <> nil then
    P^.DrawView;
  ErrorShown := False;
end;

procedure SetError(AFileName: PString; ACol, ALine: Integer;
  ANumber, AClass: Word; AParam: Pointer);
begin
  ErrorPresent := True;
  ErrorFileName := AFileName;
  ErrorPosition.X := ACol;
  ErrorPosition.Y := ALine;
  ErrorNumber := ANumber;
  ErrorClass := AClass;
  ErrorParam := AParam;
  ShowError;
end;

procedure CallInitCompiler;
var
  I: Word;
  InitParams: TInitParams;
  InitResult: TInitResult;
  S: PathStr;
begin
  InitMemPtr := MemPtr;
  InitParams.LibraryName := nil;
  InitParams.MemPtr := MemPtr;
  if LoadTurboTpl then
  begin
    S := Strings^.Get(sTurboTpl);
    SearchSysDir(S);
    InitParams.LibraryName := @S;
  end;
  InitCompiler(InitParams, InitResult);
  InitDebugger;
  if InitResult.ErrorNum <> 0 then
  begin
    I := sInvalidTurboTpl;
    if InitResult.ErrorNum = 1 then
      I := sNoMemoryForTurboTpl;
    if InitResult.ErrorNum = 15 then
      I := sTurboTplNotFound;
    MessageBox(I, nil, mfError + mfOkButton);
    LoadTurboTpl := False;
  end;
  MemPtr := InitResult.MemPtr;
end;

procedure GetCompileName(var S: PathStr);
begin
  if MainFile = '' then
    TopmostName(S)
  else
    S := MainFile;
end;

procedure CallCompiler(I: Word; StopAfter: Boolean);
var
  P: PView;
begin
  ResetAll;
  SourceModified := 0;
  if Use8087 and (CompParams.Flags and cfDisk <> 0) then
  begin
    MemPtr := InitMemPtr;
    CallInitCompiler;
  end;
  if I <> 0 then
    GetCompileName(PrimaryFileStr)
  else
    TopmostName(PrimaryFileStr);
  PrimaryFile := PrimaryFileStr;
  ConvertPath(PrimaryFile, 80);
  CompParams.Flags := CompParams.Flags and not (cfBuild + cfMake) or I;
  CompParams.MemPtr := MemPtr;
  StopAfterCompiling := StopAfter;
  CompResult.ErrorNum := -1;
  P := LoadWindow('CompileWindow');
  if P <> nil then
  begin
    Desktop^.ExecView(P);
    Dispose(P, Done);
    if CompResult.ErrorNum > 0 then
      SetError(CompResult.ErrorFile, CompResult.ErrorCol, CompResult.ErrorLine,
        CompResult.ErrorNum, sErrorBase, CompResult.ErrorPar);
  end;
end;

procedure ResetAll;
begin
  ResetTracer;
  ResetCompiler;
  InitDebugger;
  ErrorPresent := False;
end;

procedure ShellToDos;
begin
  if (ProgramStatus <> psRunning) or (MessageBox(sTerminateDebugging,
    nil, mfWarning + mfOkCancel) <> cmcancel) then
  begin
    AutoSave;
    LibraryUnits := 0;
    ResetAll;
    ShowUserScreen;
    PrintStr(Strings^.Get(sDosShellPrompt));
    RestoreMem;
    DosShell(OvrHeapOrg - PrefixSeg);
    SaveMem;
    ShowTurboScreen;
    Application^.Redraw;
    CallInitCompiler;
    Message(Desktop, evDebugger, cmRefreshInfo, nil);
    Message(Desktop, evEditor, cmDirChanged, nil);
  end;
end;

function GetFreeDosMem: Word; assembler;
asm
        MOV     AH,48H
        MOV     BX,0FFFFH
        INT     21H
        XCHG    AX,BX
end;

function Para2K(I: Word): Word; assembler;
asm
        MOV     AX,I
        ADD     AX,20H
        MOV     CL,6
        SHR     AX,Cl
end;

procedure GetInfoDialog;
var
  TopMem, ProgramMem: Word;
  TurboEmsPages, FreeEmsPages, TotalEmsPages: Word;
  L: array[0..1] of Longint;
  LL: array[0..14] of Longint;
  S: string[63];
  Prim: PathStr;
begin
  FillChar(LL, SizeOf(LL), 0);
  if ProgramStatus <> 0 then
  begin
    LL[0] := CompResult.TotalLines;
    LL[1] := CompResult.CodeSize;
    LL[2] := CompResult.DataSize;
    LL[3] := CompResult.StackSize;
    LL[4] := Longint(CompResult.MinHeapSize) shl 4;
    LL[5] := Longint(CompResult.MaxHeapSize) shl 4;
  end;
  if ProgramStatus <> 0 then
  begin
    Prim := PrimaryFile;
    ConvertPath(Prim, 24);
    L[0] := Longint(@Prim);
    L[1] := ProgErrorCode;
  end;
  FormatStr(S, Strings^.Get(ProgramStatus + sProgramStatusBase), L);
  LL[6] := Longint(@S);
  if ProgramStatus = 0 then
    CompMemPtr := MemPtr;
  TopMem := MemTop - CompMemPtr;
  if ProgramStatus = psRunning then
    ProgramMem := TopMem - GetFreeDosMem
  else
    ProgramMem := 0;
  LL[7] := Para2K(PrefixSeg);
  LL[8] := Para2K(MemPtr - PrefixSeg);
  LL[9] := Para2K(CompMemPtr - MemPtr);
  LL[10] := Para2K(ProgramMem);
  LL[11] := Para2K(TopMem - ProgramMem);
  if EmsHandle <> 0 then
  begin
    TurboEmsPages := OvrEmsPages + 3;
    if EmsResourceStream <> nil then
      Inc(TurboEmsPages, EmsResourceStream^.PageCount);
    if EmsEditorStream <> nil then
      Inc(TurboEmsPages, EmsEditorStream^.PageCount);
    asm
        MOV     AH,42H
        INT     67H
        MOV     FreeEmsPages,BX
        MOV     TotalEmsPages,DX
    end;
    LL[12] := TurboEmsPages shl 4;
    LL[13] := (TotalEmsPages - TurboEmsPages - FreeEmsPages) shl 4;
    LL[14] := FreeEmsPages shl 4;
  end;
  ExecDialog('GetInfoDialog',@LL);
end;

procedure ShowFile(Pos: Longint; Msg: Word);
var
  P: TSrcPoint absolute Pos;
begin
  if P.Fn = 0 then
    MessageBox(Msg, nil, mfError + mfOkButton)
  else
    GoFileLine(GetSourceName(P.Fn)^, P.ln, gfProgram + gfAlways);
end;

procedure FindProcDialog;
var
  S: string[80];
begin
  S := '';
  if ExecDialog('FindProcDialog', @S) <> cmCancel then
    ShowFile(FindProc(S), sProcNotFound);
end;

procedure CompilerOptionsDialog;
var
  Options: record
    CodeGen: Word;
    RunErrors: Word;
    Syntax: Word;
    NumProc: Word;
    Debugging: Word;
    Defines: string[128];
  end;
  S: Word;
const
  Mask: array[0..14] of Word = (14, { Depends on CompParams layout and }
  $0085, $0193, $0294, $0395,       { coXXX constants! }
  $2081, $2182, $2280,
  $4084, $4186, $4283,
  $8090, $8191,
  $6087, $6192);
begin
  Convert(CompParams, Options, Mask, 0);
  Options.Defines := DefinesStr;
  S := ExecDialog('CompilerOptionsDialog', @Options);
  if S <> cmCancel then
  begin
    DefinesStr := Options.Defines;
    Convert(Options, CompParams, Mask, 8);
  end;
end;

procedure MemorySizesDialog;
var
  L: array[0..2] of Longint;
  I: Word;
begin
  L[0] := CompParams.StackSize;
  L[1] := Longint(CompParams.LowHeapLimit) shl 4;
  L[2] := Longint(CompParams.HighHeapLimit) shl 4;
  I := ExecDialog('MemorySizesDialog', @L);
  if I <> cmCancel then
  begin
    CompParams.StackSize := L[0];
    CompParams.LowHeapLimit := (L[1] + 15) shr 4;
    CompParams.HighHeapLimit := (L[2] + 15) shr 4;
  end;
end;

procedure LinkerDialog;
var
  L: array[0..1] of Word;
  I: Word;
begin
  L[0] := (CompParams.Flags and cfLinkMap) shr cfbLinkMap;
  L[1] := (CompParams.Flags and cfDiskBuffer) shr cfbDiskBuffer;
  I := ExecDialog('LinkerDialog', @L);
  if I <> cmCancel then
    CompParams.Flags := (CompParams.Flags and not (cfLinkMap + cfDiskBuffer ))
      or (L[0] shl cfbLinkMap) or (L[1] shl cfbDiskBuffer);
end;

procedure DebuggingDialog;
var
  L: array[0..1] of Word;
  I: Word;
begin
  L[0] := 0;
  if CompParams.Flags and cfIntDebugger <> 0 then
    Inc(L[0]);
  if CompParams.Flags and cfExtDebugger <> 0 then
    Inc(L[0], 2);
  L[1] := ScreenSwapping;
  I := ExecDialog('DebuggingDialog', @L);
  if I <> cmCancel then
  begin
    CompParams.Flags := CompParams.Flags and
      not (cfExtDebugger + cfIntDebugger);
    if L[0] and 1 <> 0 then
      Inc(CompParams.Flags, cfIntDebugger);
    if L[0] and 2 <> 0 then
      Inc(CompParams.Flags, cfExtDebugger);
    ScreenSwapping := L[1];
  end;
end;

procedure EditorOptionsDialog;
var
  Options, Dummy: record
    Options: Word;
    TabSize: Longint
  end;
  I: Word;
const
  Mask: array[0..6] of Word = (6, { Depends on eoXXX constants! }
    $0100, $0201, $0302, $0410, $0505, $0611);
begin
  Options.Options := 0;
  Options.TabSize := DefTabSize;
  Convert(DefOptions, Options.Options, Mask, 0);
  Options.Options := Options.Options xor 2;
  Options.Options := Options.Options or Word(BackupFiles);
  I := ExecDialog('EditorOptionsDialog', @Options);
  if I <> cmCancel then
  begin
    Options.Options := Options.Options xor 2;
    Convert(Options, DefOptions, Mask, 8);
    BackupFiles := Options.Options and 1 <> 0;
    DefTabSize := Options.TabSize;
    SetOptions;
  end;
end;

procedure PreferencesDialog;
var
  I: Word;
begin
  Preferences.ScreenSize := Integer(ScreenMode and smFont8x8 <> 0);
  if ExecDialog('PreferencesDialog', @Preferences) <> cmCancel then
    SetEgaLInes(Preferences.ScreenSize <> 0);
end;

procedure MouseOptionsDialog;
var
  L: array[0..2] of Word;
begin
  L[2] := DoubleDelay;
  L[0] := RBAction;
  L[1] := Integer(MouseReverse);
  if ExecDialog('MouseOptionsDialog', @L) <> cmCancel then
  begin
    RBAction := L[0];
    MouseReverse := Boolean(L[1]);
  end else
    DoubleDelay := L[2];
end;

procedure StartupOptionsDialog;
var
  Written: Boolean;
  H: Integer;
  Header: array[0..4] of Word;
begin