svn/view/debug.pas

unit debug;
{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}
(***************************************)
(* Copyright (C) 2003, SHIRAISHI Kazuo *)
(***************************************)


interface
uses struct;
//function inspectBox(statement:TStatement):boolean;
procedure ShowCurrentLine(lineNumb:integer);
procedure DeshowCurrentLine;
var
   CurrentLineNumb:integer;

implementation

uses  StdCtrls, Graphics, Forms, ComCtrls, SysUtils, Dialogs,
      myutils, express,base,texthand,variabl,textfile,helpctex,tracefrm,
      compiler,base0;


var
   prevline:integer;

procedure ShowCurrentLine(lineNumb:integer);
begin
   CurrentLineNumb:=LineNumb;
   SelectLine(TextHand.memo,LineNumb);
(*
       with TextHand.memo do
             begin
                Lines.BeginUpdate;
                HideSelection:=true;
                SelStart:=SendMessage(Handle,EM_LINEINDEX,LineNumb,0);
                SelLength:=Length(Lines[LineNumb]);
                SelAttributes.Color:=clGreen;
                SelAttributes.Style:=SelAttributes.Style+[fsBold];

                SelLength:=0;
                SelAttributes.Color:=DefAttributes.Color;
                SelAttributes.Style:=DefAttributes.Style;
                SendMessage(Handle,EM_SCROLLCARET,0,0) ;
                Lines.EndUpdate;
                (owner as TForm).BringToFront;
             end;
 *)
end;

procedure DeshowCurrentLine;
begin
    with Texthand.memo do SelEnd:=SelStart; //Texthand.memo.SelLength:=0;
(*
       with Texthand.memo do
           begin
              Lines.BeginUpdate;
              SelStart:=SendMessage(Handle,EM_LINEINDEX,CurrentLineNumb,0);
              SelStart:=LineIndex(lines.Text,CurrentLineNumb);
              SelLength:=Length(Lines[CurrentLineNumb]);
              if fsUnderLine in SelAttributes.Style then
                 SelAttributes.Color:=BreakPointColor
              else
                 SelAttributes.Color:=DefAttributes.color;
              SelAttributes.Style:=SelAttributes.Style-[fsBold];
              SelLength:=0;
              HideSelection:=false;
              Lines.EndUpdate;
           end;
*)
end;
(*
function inspectBox(statement:TStatement):boolean;far;
begin
  inspectBox:=true;
  if (extype<0) or (statement.ClassType=TStatement) then exit;
  with statement do
    begin
       if (bkdirective=bkstep) and (prevline=linenumb)
            and (previous<>nil) and (previous.linenumb=linenumb) then exit;    {1998.9.24������}

       prevline:=linenumb;
       showCurrentLine(linenumb);
       setDebugDlg(statement);

      // FrameForm.StatusBar1.Panels[3].text:=ProgramOnRunning;
       FrameForm.StatusBar1.update;

       with DebugDlg do
          begin
              RadioGroup1.visible:=true;
              RadioGroup1.ItemIndex:=Ord(bkDirective);
              CheckBox1.Checked:=BreakFlags.TraceMode;

              Execute;;
              //  showModal ;      //CLX������Execute������hang������


              BreakFlags.TraceMode:=CheckBox1.Checked;
              BkDirective:=RadioGroup1.ItemIndex;
              if sr=srCancel then
                                 BkDirective:=BkCancel;
          end;
       case bkdirective of
           bkcontinue:
               ctrlBreakHit:=false;
           bkstep:
               ctrlBreakHit:=true;
           bkcancel:
               begin
                 ctrlBreakHit:=true;
                 raise EStop.create;
                 inspectbox:=false
               end;
       end;
       if BreakFlags.TraceMode then
         with TraceForm do
           begin
             visible:=true;
             if WindowState=wsMinimized then WindowState:=wsNormal;
           end;

       DeshowCurrentLine;

   end;
end;
*)


type
    TBreak=class(TStatement)
       //procedure exec;override;
       function Code:Ansistring;override;
    end;
(*
procedure TBreak.exec;
begin
  if not Punit.debug then exit;
  if InsideOfWhen then
       setexception(10007)
  else
       inspectbox(self);
end;
*)


type

     TDebug=class(TStatement)
           state:boolean;
       constructor create(prev,eld:TStatement);
       //procedure exec;override;
       function Code:Ansistring;override;
     end;

     TTRace=class(TStatement)
           state:boolean;
           chn:TPrincipal;
       constructor create(prev,eld:TStatement);
       //procedure exec;override;
       function Code:Ansistring;override;
     end;

constructor TDebug.create(prev,eld:TStatement);
begin
   inherited create(prev,eld);
   if token='ON' then
       begin
          gettoken;
          state:=true;
       end
   else if token='OFF' then
       begin
          gettoken;
          state:=false;
       end
   else
       seterrExpected('ON or OFF',IDH_DEBUG);
end;

constructor TTrace.create(prev,eld:TStatement);
begin
   inherited create(prev,eld);
   if token='ON' then
       begin
          gettoken;
          state:=true;
          if Token='TO' then
            begin
               GetToken;
               Check('#',IDH_DEBUG);
               chn:=NExpression;
            end;
          Punit.haveTraceSt:=true;     //2010.9.10 for code gen.
       end
   else if token='OFF' then
       begin
          gettoken;
          state:=false;
       end
   else
       seterrExpected('ON or OFF',IDH_DEBUG);
end;
(*
procedure TDebug.exec;
begin
    Punit.debug:=state;
end;

procedure TTrace.exec;
var
   i:longint;
   ch:TTextDevice;
   traceChannel:integer;
begin
    if PUnit.Debug then
      if state then
        begin
            TraceChannel:=0;
            if chn<>nil then
               begin
                  i:=chn.evalInteger;
                  if i>=0 then
                      begin
                          ch:=PUnit.channel(i);
                          if ch<>nil then
                             with ch do
                                  if isOpen and (AMode in [amOutIn,amOutput])
                                     and (RecType=rcDisplay)  then
                                      TraceChannel:=i
                                  else
                                      setexception(7402)

                          else
                             setexception(7401)
                      end
                  else
                      Setexception(7001) ;
               end
        end
      else
        TraceChannel:=-1;
   BreakFlags.TraceChannelPlus1:=TraceChannel+1
end;
*)
function DEBUGst(prev,eld:TStatement):TStatement;far;
begin
       DEBUGst:=TDebug.create(prev,eld);
end;

function BREAKst(prev,eld:TStatement):TStatement;far;
begin
   BREAKst:=TBreak.create(prev,eld);
end;

function TRACEst(prev,eld:TStatement):TStatement;far;
begin
       TRACEst:=TTRACE.create(prev,eld);
       TextMode:=true;
end;

function TBreak.code:ansistring;
begin
  DebugVariables.add('var Debug'+IntToStr(PUNIT.LineNumb+1)+':boolean=false;');
  result:='if Debug'+IntToStr(PUNIT.LineNumb+1)
        + ' then BreakPr('+QuotedStr(TextHand.memo.lines[linenumb])+');';
end;

function TDebug.code:ansistring;
begin
  DebugVariables.add('var Debug'+IntToStr(PUNIT.LineNumb+1)+':boolean=false;');
  result:='Debug'+IntToStr(PUNIT.LineNumb+1)+':='+TruthLiteral(state)+';'
end;

function TTrace.code:ansistring;
begin
  DebugVariables.add('var Trace'+IntToStr(PUNIT.LineNumb+1)+':TTextDevice=nil;');
  result := 'if Debug'+IntToStr(PUNIT.LineNumb+1)+
            ' then Trace' + IntToStr(PUNIT.LineNumb+1) + ':=';
  if state then
     if chn <>nil then
        result:=result + 'ChannelList.channel(' + chn.code + ');'
     else
        result:=result + 'console;'
  else
    result:=result + 'nil;' ;

end;

{**********}
{initialize}
{**********}
procedure statementTableinit;far;
begin
       statementTableinitImperative('DEBUG',DEBUGst);
       statementTableinitImperative('BREAK',BREAKst);
       statementTableinitImperative('TRACE',TRACEst);
   prevline:=-1;
end;


begin
   if TableInitProcs=nil then
      TableInitProcs:=TProcsCollection.create; //
   tableInitProcs.accept(statementTableinit);
end.