svn/view/print.pas

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


interface
uses variabl,struct;

function MatPrintst(prev,eld:TStatement):TStatement;
function MatWritest(prev,eld:TStatement):TStatement;
function IfThereClause(prev:TStatement):TStatement;
function ImageRef:TPrincipal;

function ChannelCode(chn:TPrincipal):ansistring;

implementation

uses Dialogs,Controls, SysUtils,
     listcoll,base,base0,texthand,textfile,express,control,io,helpctex,
     optina,sconsts;

type
  TAbstractPrintItem=Class(TStatement)
      function  nextitem:TAbstractPrintItem;virtual;abstract;
      procedure execute(ch:TTextDevice);virtual;abstract;
    end;

  TPrint=class(TStatement)
         chn: TPrincipal;
         item:TAbstractPrintItem;
         ifthere:TStatement;
         RecordSetter:tpRecordSetter;
         option:IOoptions;
      constructor create(prev,eld:TStatement; mat:boolean; wri:boolean);
      destructor destroy;override;
      function Code:AnsiString;override;
   end;


function IfThereClause(prev:TStatement):TStatement;
begin
     result:=nil;
     if (token='IF') and (nexttoken='THERE') then
        begin
           gettoken;
           gettoken;
           check('THEN',IDH_FILE);
           if tokenspec=NRep then
              begin
                result:=GOTOst(prev,nil);
                //result.eldest:=result
              end
           else
              begin
                  check('EXIT',IDH_FILE);
                  result:=EXITst(prev,nil);
             end;
       end;
end;


type
  TPrintItem=class(TAbstractPrintItem)
        exp:TPrincipal;
        direction:shortint;   {-1:TAB, 0:no care, 1:new zone, 2:new line}
        TAB:boolean;
      constructor create1;
      function  nextitem:TAbstractPrintItem;override;
      destructor destroy;override;
      function Code:AnsiString;override;
   end;

type
   TPrintItemUsing = class(TAbstractPrintItem)
           image:TPrincipal;
           items:TListCollection;
           direction:shortint;      { 0:no care,  2:new line}
        constructor create2(image1:TPrincipal);
        function initsub(image1:TPrincipal; mat:boolean):boolean;
        destructor destroy;override;
        function Code:AnsiString;override;
   end;

   TMatPrintItemUsing=class(TPrintItemUsing)
        constructor create2(image1:TPrincipal);
        function Code:AnsiString;override;
   end;


function separator(var fin:boolean):integer;
begin
    fin:=false;
    separator:=2;
    if token=';' then
       begin
          separator:=0;
          gettoken
       end
    else if token=',' then
       begin
           separator:=1;
           gettoken
       end
    else
       fin:=true   ;
end;


constructor TPrintItem.create1;
var
  fin:boolean;
begin
    inherited create(nil,nil);
    if (token='TAB') and (IdRecord(false)=nil)
    then
       begin
          TAB:=true;
          gettoken;
          check('(',IDH_PRINT);
          exp:=NExpression;
          check(')',IDH_PRINT)
       end
    else
       if (token=',') or (token=';') then
            exp:=nil
       else
            begin
                exp:=NSExpression;
            end;
    direction:=separator(fin);
    if (not fin) and  (tokenspec<>tail) and (token<>'ELSE') then
            next:=NextItem;
end;

function  TPrintItem.NextItem:TAbstractPrintItem;
begin
    result:=TPrintItem.create1
end;


destructor TPrintItem.destroy;
begin
    exp.free;
    inherited destroy
end;


constructor TPrintItemUsing.create2(image1:TPrincipal);
begin
    initsub(image1,false) ;

end;


function TPrintItemUsing.initsub(image1:TPrincipal; mat:boolean):boolean;
var
    exp:TPrincipal;
begin
    initsub:=false;
    inherited create(nil,nil);
    image:=image1;
    items:=TListCollection.create;
    repeat
        if mat then
             exp:=Matrix
        else
             exp:=NSExpression;
        if exp=nil then exit;
        items.insert(exp);
    until test(',')=false;
    if token=';' then
       begin direction:=0; gettoken end
    else
       direction:=2;
    initsub:=true;
end;

destructor TPrintItemUsing.destroy;
begin
   items.free;
   image.free;
   inherited destroy;
end;


function ImageRef:TPrincipal;
var
    long:longint;
    index:integer;
begin
    result:=nil;
    if tokenspec=Nrep then  {���������}
        begin
             if nonnegativeintegralnumber(long) and (long>0) then
               if pass=2 then
                  with programUnit do
                  begin
                     index:=imagelist.indexofobject(TObject(long));
                     if index>=0 then
                        imageRef:=TStrConstant.create(ImageList.strings[index])
                     else
                        seterr(SysUtils.Format(s_LineNotFound,[strint(long)]),IDH_PRINT_USING);
                  end
               else
             else
                seterrexpected(s_IllegalLineNumber,IDH_PRINT_USING);
        end
    else
        imageRef:=SExpression;
end;


{*********}
{MAT PRINT}
{*********}


constructor TMatPrintItemUsing.create2(image1:TPrincipal);
begin
    initsub(image1,true);
end;


{********}
{ TPRINT }
{********}

destructor  TPrint.destroy;
begin
    item.free ;
    chn.free;
    inherited destroy;
end;


{**********}
{ Mat Print}
{**********}

type
     TMatPrintItem=class(TAbstractPrintItem)
         mat1:TMatrix;
         direction:integer;
      constructor create1;
      function  nextitem:TAbstractPrintItem;override;
      //procedure execute(ch:TTextDevice);override;
      destructor destroy;override;
      function code:ansistring;override;
     end;

constructor TMatPrintItem.create1;
begin
    inherited Create(nil,nil);
    mat1:=matrix;
    if test(';') then
           direction:=0
    else if test(',') then
           direction:=1
    else
          direction :=2;
    if (tokenspec<>tail) and (token<>'ELSE') then
        next:=NextItem;
end;

function  TMatPrintItem.NextItem:TAbstractPrintItem;
begin
    result:=TMatPrintItem.create1
end;

destructor TMATPrintItem.destroy;
begin
    mat1.free;
    inherited destroy
end;


{***************}
{WRITE statement}
{***************}
type
  TWriteItem=class(TPRINTItem)
      constructor create1;
      function  nextitem:TAbstractPrintItem;override;
      //procedure execute(ch:TTextDevice);override;

   end;

constructor TWriteItem.create1;
begin
    inherited create1;
    if tab or (direction=0)  then seterr(WriteSyntaxErrorMes,IDH_Write)
end;

function  TWriteItem.NextItem:TAbstractPrintItem;
begin
    result:=TWriteItem.create1
end;


type
     TMatWriteItem=class(TMatPrintItem)
      constructor create1;
      function  nextitem:TAbstractPrintItem;override;

     end;

constructor TMatWriteItem.create1;
begin
    inherited create1;
    if direction=0 then seterr(WriteSyntaxErrorMes,IDH_Write)
end;

function  TMatWriteItem.NextItem:TAbstractPrintItem;
begin
    result:=TMatWriteItem.create1
end;


{**********}
{Statements}
{**********}


constructor TPrint.create(prev,eld:TStatement; mat:boolean; wri:boolean);
var
  image:TPrincipal;
begin
   inherited create(prev,eld);
   if wri then option:=[ioReadWrite];
   image:=nil;
   textMode:=true;

   if wri or (token='#') then
      begin
         chn:=ChannelExpression;
         if chn=nil then
             SetErrExpected('#',IDH_INTERNAL_FILE);
         while token=',' do
            begin
               gettoken;
               if (token='USING') and not wri then
                   begin
                      gettoken;
                      image:=imageRef
                   end
               else if token='IF' then
                  IfThere:=IfThereClause(prev)
               else
                  RecordSetterClause(RecordSetter);
            end;
         if prevtoken=',' then seterrIllegal(token,IDH_FILE_PRINT);
         if not wri and not mat and ((tokenspec=tail) or (token='ELSE')) then exit;
         if not wri and not mat and (token=':') and
                                ((Nexttokenspec=tail) or (NextToken='ELSE')) then
            begin
               ReplaceToken(' ');
               Raise ERecompile.create('') ;
            end;

         checkToken(':',IDH_FILE_PRINT);
         if wri then
            if mat then
               item:=TMatWriteItem.create1
            else
               item:=TWriteItem.create1
         else if image<>nil then
            if mat then
                  item:=TMatPrintItemUsing.create2(image)
            else
                  item:=TPrintItemUsing.create2(image)
         else
            if mat then
                  item:=TMatPrintItem.create1
            else
                  item:=TPrintItem.create1 ;

      end
   else if (token='USING')
      and ((NextTokenSpec=NREP) or (NextTokenspecWithinParenthesis in [SCon,SIdf]))
      then
      begin
         gettoken;
         image:=ImageRef;
         if not mat and ((tokenspec=tail) or (token='ELSE')) then exit;
         if (token=';') then
             if permitMicrosoft then
                gettoken
             else if (AutoCorrect[ac_using]
                            or confirm(s_ConfirmCorrectPRINT_USING,
                                       IDH_microsoft_IO)) then
                    begin  {MS-syntax}
                      replacetoken(':');
                      gettoken;
                    end
                  else
         else
            checkToken(':',IDH_PRINT_USING);

         if mat then
              item:=TMatPrintItemUsing.create2(image)
         else
              item:=TPrintItemUsing.create2(image);

      end
   else
      begin
        if not mat and ((tokenspec=tail) or (token='ELSE') or (token=':')) then exit;
        if mat then
              item:=TMatPrintItem.create1
        else
              item:=TPrintItem.create1;
      end;

end;

function Printst(prev,eld:tStatement):TStatement;
begin
   result:=TPrint.create(prev,eld,false,false);
end;

function MatPrintst(prev,eld:TStatement):TStatement;
begin
  result:=TPrint.create(prev,eld,true,false)
end;


function  WRITEst(prev,eld:TStatement):TStatement;
begin
  result:=TPrint.create(prev,eld,false,true)
end;

function MatWritest(prev,eld:TStatement):TStatement;
begin
  result:=TPrint.create(prev,eld,true,true)
end;

function PRINTQst(prev,eld:TStatement):TStatement;
begin
   SelectPrevToken;   {SelectLine(TextHand.memo,linenumber);}
   if AutoCorrect[ac_using] or
     ( MessageDlg(s_QuestionMark,mtConfirmation,
                               [mbYes,mbNo],IDH_MICROSOFT_IO)=mrYes) then
      begin
      replaceprevToken('PRINT ');
      PRINTQst:=PRINTst(prev,eld)
      end
   else
      seterrIllegal(prevToken,IDH_MICROSOFT_IO)   ;
  end;

{******}
{LPRINT}
{******}

type
  TLPRINT=class(TPRINT)
    //procedure exec;override;
  end;
(*
procedure  TLPrint.exec;
begin
    IdleImmediately;

    if item=nil then
       LocalPrinter.newline
    else
      begin
       try
          item.execute(LocalPrinter);
          LocalPrinter.flush
       except
          LocalPrinter.WBuffClear;
          raise
       end;
      end

end;
*)


function LPRINTst(prev,eld:TStatement):TStatement;
begin
   if permitMicrosoft then
        result:=TLPRINT.create(prev,eld,false,false)
   else
        seterr(s_LPRINT,IDH_MICROSOFT_IO)   ;
end;


{**************}
{ Generate Code}
{**************}

function TPrintItem.Code:AnsiString;
begin
  if TAB then
     result:='TTAB.create('+exp.Code+')'
  else if exp<>nil then
     if (exp.kind='n') and (PUnit.Arithmetic=precisionComplex) then
       result := 'TComplex.create('+exp.Code+')'
     else
       result := exp.Code
  else
     result:='''''';

  case direction of
   1: Result:= Result + ', TNewZone.create '  ;
   2: Result:= Result + ', TNewLine.create '  ;
   else
  end;

  if next <>nil then
     result:=result+','+next.code;

end;


function ChannelCode(chn:TPrincipal):ansistring;
begin
  if chn=nil then
     ChannelCode:='console'
  else
     ChannelCode:='ChannelList.channel('+ chn.code + ')' ;
end;

function TPrint.Code:Ansistring;
begin


  if item=nil then
     result:=ChannelCode(chn)+'.PRINT(' + IOOptionsCode(option) +','
                               + RecordSetterCode[RecordSetter] +','
                               + TruthLiteral(insideofWhen)+','
                               +'[TNewLine.create]);'
  else if item is TMatprintitemUsing then
     result:=ChannelCode(chn)+'.MATPRINTUSING('+item.code+');'
  else if item is TprintitemUsing then
     result:=ChannelCode(chn)+'.PRINTUSING('+item.code+');'
  else if item is TMatprintitem then
     result:=ChannelCode(chn)+'.MATPRINT(' + IOOptionsCode(option) +','
                               + RecordSetterCode[RecordSetter] +','
                               + TruthLiteral(insideofWhen)+','
                               +'['+item.code+']);'
  else if item is TPrintItem then
     result:=ChannelCode(chn)+'.PRINT(' + IOOptionsCode(option) +','
                               + RecordSetterCode[RecordSetter] +','
                               + TruthLiteral(insideofWhen)+','
                               +'['+item.code+']);'
  else
  ;


   if IfThere<>nil then
     result := 'try' +EOL
            +   result
            +  'except' + EOL
            +  ' on EExtype do if extype=7308 then'+EOL
            +  '                 begin extype:=0; ' + IfThere.Code +' end' +EOL
            +  '                 else  raise;' +EOL
            +  'end;'+EOL
end;


function TPrintItemUsing.Code:ansistring;
var
   c:integer;
   s:ansistring;
begin
   result:=image.code +',[';
   for c:=0 to items.count-1 do
     begin
       if c>0 then result:=result+',';
       s:=TPrincipal(items.items[c]).code;
       if (TPrincipal(items.items[c]).kind='n') and (PUnit.Arithmetic=precisionComplex) then
          s:='testreal('+s+')';
       result:=result+s;
     end;
   result:=result+'],'+ TruthLiteral(direction=2) + ','
                      + TruthLiteral(insideofWhen) ;


end;

function TmatPrintItem.code:ansistring;
begin
   result:=mat1.code +',' + inttostr(direction);
   if next<>nil then
     result:=result+','+next.code
end;

function TMatPrintItemUsing.Code:ansistring;
var
   c:integer;
begin
   result:=image.code +',[';
   for c:=0 to items.count-1 do
     begin
       if c>0 then result:=result+',';
       result:=result+TPrincipal(items.items[c]).code;
     end;
   result:=result+'],'+ TruthLiteral(direction=2) + ','
                      + TruthLiteral(insideofWhen) ;


end;


procedure statementTableinit;far;
begin
       statementTableinitImperative('PRINT',PRINTst);
       statementTableinitImperative('WRITE',WRITEst);
       statementTableinitImperative('?',PRINTQst);
       //statementTableinitImperative('LPRINT',LPRINTst);
end;

begin
   tableInitProcs.accept(statementTableinit);
end.
