svn/view/io.pas

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

 {$X+}

interface

uses base,listcoll,variabl,struct,express;

function MATREADst(prev,eld:TStatement):TStatement;
function MATINPUTst(prev,eld:TStatement):TStatement;
function MATLINEINPUTst(prev,eld:TStatement):TStatement;
function IORecovery(prev:TStatement):TStatement;
procedure RecordSetterClause(var RecordSetter:tpRecordSetter);

{**********}
{TReadInput}
{**********}
type
  InputFunction=procedure  of object;  //現状，ただの目印


type
  TReadInput=class(TStatement)
         input:inputfunction;           {nilのとき Varilen}
         chn:TPrincipal;
         recovery:TStatement;
         prompt:TPrincipal;
         timeout:TPrincipal;
         elapsed:TVariable;
         vars : TListCollection;      {collection of TVariable}
         option:IOoptions;
         RecordSetter:tpRecordSetter;
         OnlyStringVars:boolean;
         MSAppendQuestionMark:boolean;
       constructor create(prev,eld:TStatement; f:inputfunction; StrOnly:boolean);
       constructor createREAD(prev,eld:TStatement);
       constructor createINPUT(prev,eld:TStatement);
       constructor createLINEINPUT(prev,eld:TStatement);
       constructor createCHARACTERINPUT(prev,eld:TStatement);
       constructor createVariLen(prev,eld:TStatement);
       function item:TObject;virtual;
       function itemVarilen:TObject;virtual;abstract;
       function Code:AnsiString;override;
       destructor destroy;override;
     private
       defaultPrompt:string[2];
       function MsPrompt:TPrincipal;
       function ControlItem1:boolean;
       procedure ControlItem2;
       procedure RegularRead;
       procedure RegularInput;
       procedure LineInput;
       procedure CharacterInput;
       procedure varileninput;
    end;


implementation

uses  Classes, Dialogs,SysUtils,Controls,
      base0,texthand,helpctex,
      mat,control,optina,charinp,graphic,sconsts;


type
     TMatRead=class(TReadInput)
       function item:TObject;override;
       function itemVarilen:TObject;override;
       function Code:AnsiString;override;
     end;


{**************}
{READ statement}
{**************}

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


{*********}
{INPUT statement}
{********}


function TReadInput.MsPrompt:TPrincipal;
begin
     result:=nil  ;{default}
     if (tokenspec=SCon) and ((NextToken=';') or (NextToken=',')) then
       begin
           if permitMicrosoft then
              begin
                  if NextToken=';' then MSAppendQuestionMark:=true;
                  result:=SExpression;
                  gettoken;
              end
           else if AutoCorrect[ac_input] or
                  confirm('INPUT PROMPT '+token+': '+EOL+
                          s_IsCorectAskConvert,
                            IDH_MICROSOFT_IO ) then
             begin
               insertText(' PROMPT');
               result:=SExpression;
               replacetoken(':');
               gettoken;
             end;
       end;
end;


destructor TReadInput.destroy;
begin
    vars.free;
    prompt.free;
    recovery.free;
    chn.free;
    inherited destroy
end;


function TReadInput.ControlItem1:boolean;
var
  CharInput:InputFunction;      // input変数の値を比較するために使用する
begin
    CharInput:=Characterinput;
    result:=true;
    if (token='#')  then
       chn:=channelExpression
    else if (token='IF') and (nexttoken='MISSING') then
         recovery:=IORecovery(self)
    else if (token='PROMPT') and (nextToken<>',')  then
       begin
         gettoken;
         prompt:=SExpression
       end
    else if (token='TIMEOUT') and (nextToken<>',')  then
       begin
         gettoken;
         timeout:=NExpression
       end
    else if (token='ELAPSED') and (nextToken<>',')  then
       begin
         gettoken;
         elapsed:=NVariable;
         if elapsed is TSubstance then
              TSubstance(elapsed).AddQueryInteger(nil); //Integer不適格
       end
    else if (token='CLEAR') and (@input=@charInput) then
       begin
         gettoken;
         Option:=option + [ioClear]
       end
    else if (token='NOWAIT') and (@input=@charInput) then
       begin
         gettoken;
         Option:=option + [ioNoWait]
       end
    else
       result:=false;


end;

procedure TReadInput.ControlItem2;
var
  CharInput:InputFunction;      // input変数の値を比較するために使用する
begin
  CharInput:=Characterinput;

    if (token='IF') and (nexttoken='MISSING') and (recovery=nil) then
       recovery:=IORecovery(self)
    else if (token='PROMPT')  and (prompt=nil) then
       begin
         gettoken;
         prompt:=SExpression
       end
    else if (token='TIMEOUT')  and (timeout=nil) then
       begin
         gettoken;
         timeout:=NExpression
       end
    else if (token='ELAPSED')  and (elapsed=nil) then
       begin
         gettoken;
         elapsed:=NVariable;
         if elapsed is TSubstance then
              TSubstance(elapsed).AddQueryInteger(nil); //Integer不適格
       end
    else if (token='CLEAR') and (@input=@charInput) then
       begin
         gettoken;
         Option:=option + [ioClear]
       end
    else if (token='NOWAIT') and (@input=@charInput) then
       begin
         gettoken;
         Option:=option + [ioNoWait]
       end
    else
       RecordSetterClause(RecordSetter);
end;

procedure RecordSetterClause(var RecordSetter:tpRecordSetter);
begin
    if (token='BEGIN') then
       begin
         gettoken;
         RecordSetter:=rsBegin;
       end
    else if (token='END') then
       begin
         gettoken;
         RecordSetter:=rsEnd;
       end
    else if (token='NEXT') then
       begin
         gettoken;
         RecordSetter:=rsNext;
       end
    else if (token='SAME') then
       begin
         gettoken;
         RecordSetter:=rsSAME;
       end
end;

constructor TReadInput.create(prev,eld:TStatement; f:inputfunction; StrOnly:boolean);
var
   p:TObject;
begin
   inherited create(prev,eld);
   OnlyStringVars:=StrOnly;
   RecordSetter:=rsNone;
   if InsideOfWhen then option:=[ioWhenInside];
   input:=f;
   defaultprompt:='? ';
   prompt:=MsPrompt;
   if prompt=nil then
   begin
      if ControlItem1 then
         begin
            while test(',') do
               ControlItem2;
            check(':',IDH_INPUT_PROMPT);
         end;
   end;
   vars:=TListCollection.create;
   if (self is TMatRead)
        and (@input=@TReadInput.regularinput)
        and (nextnexttoken='?') then
     begin
       input:=nil;
       Vars.insert(itemVarilen);
     end
   else
     repeat
       if (prevtoken=',') and (token='SKIP') and (nexttoken='REST') then
          begin
             gettoken;
             gettoken;
             option:=option+[ioSkipRest];
             break;
          end;
       if StrOnly and (TokenSpec<>SIdf) then
                         seterrexpected(s_StringIdentifier,IDH_MAT_INPUT);
       p:=item;
       vars.insert(p);
     until (@input=@TreadInput.CharacterInput) or (test(',')=false) ;
   if ProgramUnit.CharacterByte then option:=option+[ioCharacterByte];
   //if chn=nil then TextMode:=true;
end;


function TReadInput.item;
begin
   result:=Inputvari(OnlyStringVars)
end;


constructor TReadInput.createREAD(prev,eld:TStatement);
begin
     Create(prev,eld,regularRead,false);
     option:=option+[ioReadWrite];
end;

constructor TReadInput.createINPUT(prev,eld:TStatement);
begin
     Create(prev,eld,regularInput,false);
end;

constructor TReadInput.createLINEINPUT(prev,eld:TStatement);
begin
     Create(prev,eld,LineInput,true);
end;

constructor TReadInput.createCHARACTERINPUT(prev,eld:TStatement);
begin
     Create(prev,eld,CharacterInput,true);
     defaultprompt:='';
     if chn=nil then
        useCharInput:=true;
end;

constructor TReadInput.createVariLen(prev,eld:TStatement);
begin
     Create(prev,eld,nil{VariLenInput},false);
end;

procedure TReadInput.RegularRead;
begin
end;

procedure TReadInput.RegularInput;
begin
end;


procedure TReadInput.LineInput;
begin
end;


procedure TReadInput.CharacterInput;
begin
end;


function INPUTst(prev,eld:TStatement):TStatement;far;
begin
     INPUTst:=TReadInput.createINPUT(prev,eld)
end;

function READst(prev,eld:TStatement):TStatement;far;
begin
        READst:=TReadInput.createREAD(prev,eld)
end;

function LINEst(prev,eld:TStatement):TStatement;far;
begin
   if permitMicrosoft and ((token='(') or (token='-')) then
     LINEst:=MSLINEst(prev,eld)
   else
     begin
       check('INPUT',IDH_LINE_INPUT);
       LINEst:=TREADINPUT.createLINEINPUT(prev,eld)
     end;
end;

function CHARACTERst(prev,eld:TStatement):TStatement;far;
begin
    check('INPUT',IDH_CHARACTER_INPUT);
    CHARACTERst:=TREADINPUT.createCHARACTERINPUT(prev,eld)
end;


{*********}
{Mat Read }
{Mat Input}
{*********}
type  TRedimArray=class
           mat:TMatrix;
           redim:TMatRedim;
         constructor create(mat1:TMatrix);
         destructor destroy;override;
      end;

constructor TRedimArray.create;
begin
   inherited create;
    mat:=mat1;
    redim:=Matredim(mat,false);
end;

destructor TRedimArray.destroy;
begin
   mat.free;
   redim.free;
   inherited destroy;
end;
procedure TReadInput.varileninput;
begin
end;


function TMatRead.item:Tobject;
var
   mat1:TMatrix;
begin
   mat1:=Matrix;
   result:=TRedimArray.create(mat1);
end;

function TMatRead.itemVariLen:Tobject;
var
   mat1:TMatrix;
begin
    mat1:=Matrix;
    if mat1.idr.dim<>1 then
               seterrDimension(IDH_MAT_INPUT);
    check('(',IDH_MAT_INPUT);
    check('?',IDH_MAT_INPUT);
    check(')',IDH_MAT_INPUT);
    result:=TRedimArray.create(mat1);
end;

function MATREADst(prev,eld:TStatement):TStatement;
begin
    result:=TMatRead.createREAD(prev,eld)
end;

function MATINPUTst(prev,eld:TStatement):TStatement;
begin
      result:=TMatRead.createINPUT(prev,eld)
end;

function MATLINEINPUTst(prev,eld:TStatement):TStatement;
begin
    result:=TMatRead.createLINEINPUT(prev,eld)
end;

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

function TReadInput.Code:AnsiString;
var
   kindlist:Ansistring;
   InputFunctionName:Ansistring;
   i:integer;
   optionCode:Ansistring;
   promptCode:Ansistring;
   timelimitCode:Ansistring;
   insideofwhencode:Ansistring;
   ChannelCode:Ansistring;
   ElapsedCode:AnsiString;
   p:TObject;
begin
   proc.HaveMissing:=True;
   result:='';
   optionCode:=IOOptionsCode(option);

   if prompt<>nil then
      promptCode:=Prompt.Code
   else
      promptCode:='''' + DefaultPrompt + '''';

    if timeout<>nil then
       timelimitCode:=timeout.code
    else
       timeLimitCode:='MaxNumberDouble';

    if InsideOfWhen then
       InsideOfWhenCode:='true'
    else
       InsideOfWhenCode:='false' ;

    if elapsed<>nil then
       elapsedCode:='@' + elapsed.code
    else
       elapsedCode:='nil';

// InputFunctionName
  InputFunctionName:='';
  if @input=@TReadInput.RegularInput then
     InputFunctionName:='InputData'
  else if  @input=@TReadInput.RegularRead then
     InputFunctionName:='ReadData'
  else if  @input=@TReadInput.LineInput then
     InputFunctionName:='LineInput'
  else if  @input=@TReadInput.CharacterInput then
     InputFunctionName:='CharacterInput'
  else
   ;

  // kindlist
  kindlist:='';
  for i:=0 to vars.count-1 do
    begin
      p:=TObject(vars.items[i]);
      kindlist:=kindlist+ (p as TInputvari).vari.kind
    end;
  // ch

  if chn=nil then
     if ioReadWrite in option then
        ChannelCode:='DataSeq'
     else
        ChannelCode:='console'
  else
     ChannelCode:='ChannelList.channel('+ chn.code + ')' ;

  // Code 生成
  result:=result
          + 'with TDataList.create do ' +EOL
          + 'try' +EOL
          + ' Missing:=false;'+EOL
          + ' if '+InputFunctionName +'(' + channelCode+ ','''+kindlist+''','
                                  + optionCode +',' + promptCode +','
                                  + timelimitcode + ',' + elapsedcode + ','
                                  + insideofWhenCode + ',' + RecordSetterCode[RecordSetter] + ','
                                  + Strint(LineNumb)+ ') then' +EOL
          + 'begin'+EOL;

  // 代入文の生成
  for i:=0 to vars.count-1 do
       if (TObject(vars.items[i]) is TStrVari)
          and (TStrVari(vars.items[i]).index1<>nil)  then
          begin
             if PUnit.characterbyte then
                result:=result+' SubstSubstringByte('
             else
                result:=result+' SubstSubstring(';
             result:=result
                  +TInputVari(vars.items[i]).vari.code + ','
                  +TStrVari(vars.items[i]).index1.code + ','
                  +TStrVari(vars.items[i]).index2.code + ','
                  +' strings[' + Strint(i) + '] ) ;' +EOL    ;
          end
       else if TObject(vars.items[i]) is TInputvari then
          begin
              result:=result
                +' '+(TObject(vars.items[i]) as TInputvari).vari.code + ' := ' ;
             if (TObject(vars.items[i]) as TInputvari).vari.kind = 'n' then
                result:=result + 'FloatVal( strings[' + Strint(i) + ']) ;' +EOL
             else
                result:=result + ' strings[' + Strint(i) + '] ;' +EOL    ;
          end;


  result:=result
         + 'end'+EOL
         + 'else' +EOL
         + ' Missing:=true;'+EOL
         + 'finally' + EOL
         + ' free;' +EOL
         + 'end;' +EOL;

  if recovery=nil then
     result:=result + 'if Missing then setexception(base.extype);' +EOL
  else
     result:=result + 'if Missing then begin base.extype:=0; ' + recovery.code + 'end;' +EOL;

end;

function TMatRead.Code:AnsiString;
var
   kindlist:Ansistring;
   InputFunctionName:Ansistring;
   i:integer;
   optionCode:Ansistring;
   promptCode:Ansistring;
   timelimitCode:Ansistring;
   insideofwhencode:Ansistring;
   ChannelCode:Ansistring;
   ElapsedCode:AnsiString;
   p:TObject;
begin
   proc.HaveMissing:=True;
   result:='';
   optionCode:=IOOptionsCode(option);

   if prompt<>nil then
      promptCode:=Prompt.Code
   else
      promptCode:='''' + DefaultPrompt + '''';

    if timeout<>nil then
       timelimitCode:=timeout.code
    else
       timeLimitCode:='MaxNumberDouble';

    if InsideOfWhen then
       InsideOfWhenCode:='true'
    else
       InsideOfWhenCode:='false' ;

    if elapsed<>nil then
       elapsedCode:='@' + elapsed.code
    else
       elapsedCode:='nil';

// InputFunctionName
  InputFunctionName:='';
  if @input=@TReadInput.RegularInput then
     InputFunctionName:='InputData'
  else if  @input=@TReadInput.RegularRead then
     InputFunctionName:='ReadData'
  else if  @input=@TReadInput.LineInput then
     InputFunctionName:='LineInput'
  //else if  @input=@TReadInput.CharacterInput then
  //   InputFunctionName:='CharacterInput'
  else if @input=nil then
       InputFunctionName:='InputVarilen';

 // kindlist
  kindlist:='';
  for i:=0 to vars.count-1 do
    begin
      p:=TObject(vars.items[i]);
      if p is TRedimArray then
         begin
           if (p as TRedimArray).redim<>nil then
              result:=result+(p as TRedimArray).redim.Code;
           if i=0 then
              KindList:=(p as TRedimArray).mat.Code+'.KindList'
           else
              KindList:=KindList+'+'+(p as TRedimArray).mat.Code+'.KindList'
         end;
    end;
  // ch

  if chn=nil then
     if ioReadWrite in option then
        ChannelCode:='DataSeq'
     else
        ChannelCode:='console'
  else
     ChannelCode:='ChannelList.channel('+ chn.code + ')' ;

  // Code 生成
  result:=result
          + 'with TDataList.create do ' +EOL
          + 'try' +EOL
          + ' Missing:=false;'+EOL
          + ' if '+InputFunctionName +'(' + channelCode+ ','+kindlist+','
                                  + optionCode +',' + promptCode +','
                                  + timelimitcode + ',' + elapsedcode + ','
                                  + insideofWhenCode + ',' + RecordSetterCode[RecordSetter] + ','
                                  + Strint(LineNumb)+ ') then' +EOL
          + 'begin'+EOL;


  // 代入文の生成
  if @input<>nil then
     begin
       result:=result +' AssignData([';
       for i:=0 to vars.count-1 do
          begin
             if i>0 then result:=result+',';
             result:=result + (TObject(vars.items[i]) as TRedimArray).mat.Code;
          end;
       result:=result+']);'+EOL;
     end
  else
     result:=result +' '
            +'AssignVarilen(' +(TObject(vars.items[0]) as TRedimArray).mat.Code + ');'+EOL;


 result:=result
         + 'end'+EOL
         + 'else' +EOL
         + ' Missing:=true;'+EOL
         + 'finally' + EOL
         + ' free;' +EOL
         + 'end;' +EOL;

  if recovery=nil then
     result:=result + 'if Missing then setexception(base.extype);' +EOL
  else
     result:=result + 'if Missing then begin base.extype:=0; ' + recovery.code + 'end;' +EOL;

end;


procedure statementTableinit;far;
begin
   StatementTableInitImperative('INPUT',INPUTst);
   StatementTableInitImperative('LINE',LINEst);
   StatementTableInitImperative('CHARACTER',CHARACTERst);
   StatementTableInitImperative('READ',READst);
end;

procedure functiontableInit;far;
begin
end;


begin
   tableInitProcs.accept(statementTableinit);
   tableInitProcs.accept(FunctionTableInit);
end.
