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


interface

uses SysUtils,
     variabl,struct;

function  SETst(prev,eld:TStatement):TStatement;
//function  ASKst(prev,eld:TStatement):TStatement;

type TSetF=class(TStatement)
         chn:TPrincipal;
        constructor create(prev,eld:TStatement; ch:TPrincipal);
        destructor destroy;override;
      end;

     TSetFE=class(TSetF)
          exp:TPrincipal;
        constructor create(prev,eld:TStatement; c:TPrincipal);
        destructor destroy;override;
      end;

     TsetFS=class(TSetF)
          exp:TPrincipal;
        constructor create(prev,eld:TStatement; c:TPrincipal);
        destructor destroy;override;
      end;

function  DefaultAnotherSETst(prev,eld:TStatement; chn:TPrincipal):TStatement;
var
   AnotherSetSt:function(prev,eld:TStatement; chn:TPrincipal):TStatement=DefaultAnotherSETst;

implementation

uses
     base,base0,sconsts,texthand,express,io,graphic,print,helpctex;

constructor TSetF.create(prev,eld:TStatement; ch:TPrincipal);
begin
    inherited create(prev,eld);
    chn:=ch;
end;

destructor TSetF.destroy;
begin
     chn.free;
     inherited destroy;
end;

type
   TSetPointer=class(TsetF)
         rs:tpRecordSetter;
         IfThere:TStatement;
         Recovery:TStatement;
       constructor create(prev,eld:TStatement; ch:TPrincipal);
       //procedure exec;override;
       destructor destroy;override;
       function Code:ansistring;override;
    end;

constructor TSetPointer.create(prev,eld:TStatement; ch:TPrincipal);
begin
    inherited create(prev,eld,ch);
    rs:=rsNone;
    RecordSetterClause(rs);
    if (rs<>rsNone) and (token=',') and (Nexttoken='IF') then
       gettoken;
    if token='IF' then
       if nextToken='THERE' then
          IfThere:=IfThereClause(self)
       else if nexttoken='MISSING' then
          recovery:=IORecovery(self);
end;

destructor TSetPointer.destroy;
begin
   IfThere.free;
   Recovery.free;
end;

function TSetPointer.Code:ansistring;
begin
  result:='with '+ChannelCode(chn)+ ' do'+EOL
          +'begin'+EOL
          +' setpointer('+RecordSetterCode[rs]+','+truthLiteral(insideofwhen)+');'+EOL;
  if ifthere<>nil then
     result:=result
          +'if DaTaFoundForWrite=7308 then'+EOL
          +'  begin '+ifthere.Code + ' end;'+EOL;
  if recovery<>nil then
      result:=result
          +'if DaTaFoundForRead=7305 then'+EOL
          +'  begin  '+recovery.Code +' end;'+EOL;
  result:=result+'end;'
end;


constructor TSetFE.create(prev,eld:TStatement; c:TPrincipal);
begin
   inherited create(prev,eld,c);
   exp :=nexpression;
end;

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


type
    TsetMargin=class(TSetFE)
       //procedure exec;override;
       function Code:ansistring;override;
    end;

type
    TsetZoneWidth=class(TSetFE)
       //procedure exec;override;
       function Code:ansistring;override;
    end;
(*
procedure TSetMargin.exec;
var
   ch:TTextDevice;
begin
    ch:=channel(chn,proc,Punit);
    if ch<>nil then
      ch.setmargin(exp.evalInteger)
    else
      setexception(7004)
end;
*)
function TSetMargin.Code:ansistring;
begin
   result:=ChannelCode(chn) + '.setmargin(LongintRound('+exp.code+'));'
end;
(*
procedure TSetZoneWidth.exec;
var
   ch:TTextDevice;
begin
   ch:=channel(chn,Proc,Punit);
   if ch<>nil then
      ch.setzonewidth(exp.evalInteger)
   else
      setexception(7004);
end;
*)
function TSetZoneWidth.Code:ansistring;
begin
   result:=ChannelCode(chn) + '.SetZoneWidth(LongintRound('+exp.code+'));'
end;


constructor TSetFS.create(prev,eld:TStatement; c:TPrincipal);
begin
   inherited create(prev,eld,c);
   exp :=SExpression;
end;

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

type
  TSetEndOfLIne=class(TSetFS)
       //procedure exec;override;
       function Code:ansistring;override;
  end;

function TSetEndOfLine.Code:ansistring;
begin
   result:=ChannelCode(chn) + '.SetEndOfLine('+exp.code+');'
end;

type
  TSetEcho=class(TSetFS)
       //procedure exec;override;
       function Code:ansistring;override;
  end;

function TSetEcho.Code:ansistring;
begin
   result:=ChannelCode(chn) + '.SetEcho('+exp.code+');'
end;

type
  TSetCoding=class(TSetFS)
       //procedure exec;override;
       function Code:ansistring;override;
  end;


function TSetCoding.Code:ansistring;
begin
   result:=ChannelCode(chn) + '.SetCoding('+exp.code+');'
end;



Type
    TSetDirectory=class(TStatement)
       exp:TPrincipal;
       constructor create(prev,eld:TStatement);
       //procedure exec;override;
       destructor destroy;override;
       function Code:ansistring;override;
    end;

constructor TSetDirectory.create(prev,eld:TStatement);
begin
  inherited create(prev,eld);
  exp:=SExpression;
end;

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

function TsetDirectory.code:ansistring;
begin
   result:='SetDirectory('+exp.code+');'
end;

function  SETst(prev,eld:TStatement):TStatement;
var
    chn:TPrincipal;
begin
   SETst:=nil;
   if token='DIRECTORY' then
     begin
        gettoken;
        SETst:=TSetDirectory.create(prev,eld);
     end
    else
     begin
        chn:=ChannelExpression;
        if chn<>nil then
                     checktoken(':',IDH_SET_POINTER);
        if (token='POINTER') then
           begin
               gettoken;
               SETst:=TSetPointer.create(prev,eld,chn);
           end
        else if (token='IF') then
           begin
               SETst:=TSetPointer.create(prev,eld,chn);
           end
        else if (token='MARGIN')  then
             begin
                 gettoken;
                 SETst:=TSetmargin.create(prev,eld,chn);
             end
         else if (token='ZONEWIDTH')  then
             begin
                 gettoken;
                 SETst:=TSetZoneWidth.create(prev,eld,chn);
             end
         else if (token='ECHO')  then
             begin
                 gettoken;
                 SETst:=TSetECHO.create(prev,eld,chn);
             end
         else if (token='ENDOFLINE')  then
             begin
                 gettoken;
                 SETst:=TSetEndOfLine.create(prev,eld,chn);
             end
          else if (token='CODING')  then
             begin
                 gettoken;
                 SETst:=TSetCoding.create(prev,eld,chn);
             end
        else
             SetSt:=AnotherSetSt(prev,eld,chn)
     end;
end;

function  DefaultAnotherSETst(prev,eld:TStatement; chn:TPrincipal):TStatement;
begin
    result:=nil;
    seterrIllegal(token,0)
end;

{***}
{ASK}
{***}
(*
function AskMargin(ch:TTextDevice):integer;
begin
     if  (ch.rectype=rcDisplay) then
        AskMargin:=ch.Margin
     else
        AskMargin:=0;
end;

function AskZoneWidth(ch:TTextDevice):integer;
begin
     if (ch.rectype=rcDisplay)then
        AskZoneWidth:=ch.ZoneWidth
     else
        AskZoneWidth:=0;
end;


function AskFILETYPE(ch:TTextDevice):AnsiString;
begin
    if ch.TrueFile then
          result:='FILE'
    else
          result:='DEVICE'
end;

function AskEcho(ch:TTextDevice):AnsiString;
begin
    if ch.echoOn then
           result:='ON'
    else
           result:='OFF'
end;
*)

type
  TAskDirectory=class(TStatement)
    exp:TStrVari;
    constructor create(prev,eld:TStatement);
    //procedure exec;override;
    destructor destroy;override;
    function Code:Ansistring;override;
   end;

constructor TAskDirectory.create(prev,eld:TStatement);
begin
   inherited create(prev,eld);
   exp:=StrVari;
end;

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

function TAskDirectory.code:ansistring;
begin
  result:='AskDirectory('+exp.code+');'
end;

type
  TAskFile=class(TStatement)
    chn:TPrincipal;
    expAccess,expDatum,expErasable,expFileType,expName,
    expOrganization,expPointer,expRecsize1,expRecType,expSetter,
    expCharin,expTypeahead,expEchoControl,expEcho:TStrVari;
    expMargin,expRecSize2,expZonewidth,expCharacterPending,expFilesize:TVariable;
    constructor create(prev,eld:TStatement; c:TPrincipal);
    //procedure exec;override;
    destructor destroy;override;
    function Code:ansistring;override;
   end;

function  ASKst(prev,eld:TStatement):TStatement;
var
   chn:TPrincipal;
begin
   if token='DIRECTORY' then
     begin
       gettoken;
       ASKst:=TAskDirectory.create(prev,eld);
     end
   else
     begin
        chn:=ChannelExpression;
        if chn<>nil then
                     checktoken(':',IDH_SET_MARGIN);
        if (chn<>nil)
           or (token='MARGIN')
           or (token='ZONEWIDTH')
           or (token='CHARIN')
           or (token='TYPEAHEAD')
           or (token='ECHO')
           or ((token='CHARACTER') and (nexttoken='PENDING')) then
           ASKst:=TAskFile.create(prev,eld,chn)
        else
           ASKst:=Graphic.ASKst(prev,eld);
     end;
end;

constructor TAskFile.create(prev,eld:TStatement; c:TPrincipal);
begin
   inherited create(prev,eld);
   chn:=c;
   repeat
         if token='MARGIN' then
            begin
                 gettoken;
                 expMargin:=NVariable;
                 if expMargin is TSubstance then
                      TSubstance(expMargin).AddQueryInteger(nil); //Integer不適格
            end
         else if token='ZONEWIDTH' then
            begin
                 gettoken;
                 expZonewidth:=NVariable;
                 if expZonewidth is TSubstance then
                      TSubstance(expZonewidth).AddQueryInteger(nil); //Integer不適格
            end
         else if token='ACCESS' then
            begin
                 gettoken;
                 expACCESS:=StrVari;
            end
         else if token='DATUM' then
            begin
                 gettoken;
                 expDatum:=StrVari;
            end
         else if token='ERASABLE' then
            begin
                 gettoken;
                 expErasable:=StrVari;
            end
         else if token='SETTER' then
            begin
                 gettoken;
                 ExpSetter:=StrVari;
            end
         else if token='FILETYPE' then
            begin
                 gettoken;
                 expFiletype:=StrVari;
            end
         else if token='FILESIZE' then //規格外
            begin
                 gettoken;
                 expFilesize:=NVariable;
                 if expFilesize is TSubstance then
                      TSubstance(expFilesize).AddQueryInteger(nil); //Integer不適格
            end
         else if token='NAME' then
            begin
                 gettoken;
                 expName:=StrVari;
            end
         else if token='ORGANIZATION' then
            begin
                 gettoken;
                 expOrganization:=StrVari;
            end
         else if token='POINTER' then
            begin
                 gettoken;
                 expPointer:=StrVari;
            end
         else if token='RECTYPE' then
            begin
                 gettoken;
                 expRectype:=StrVari;
            end
         else if token='RECSIZE' then
            begin
                 gettoken;
                 expRecsize1:=StrVari;
                 expRecsize2:=NVariable;
                 if expRecsize2 is TSubstance then
                      TSubstance(expRecsize2).AddQueryInteger(nil); //Integer不適格
            end
         else if (token='ECHO') and (NextToken='CONTROL') then
            begin
                 gettoken;gettoken;
                 expEchoControl:=StrVari;
            end
         else if token='ECHO' then
            begin
                 gettoken;
                 expEcho:=StrVari;
            end
         else if token='TYPEAHEAD' then
            begin
                 gettoken;
                 expTypeAhead:=StrVari;
            end
         else if (token='CHARACTER') and (NextToken='PENDING') then
            begin
                 gettoken;gettoken;
                 expCharacterPending:=NVariable;
                 if expCharacterPending is TSubstance then
                      TSubstance(expCharacterPending).AddQueryInteger(nil); //Integer不適格
            end
         else if token='CHARIN' then
            begin
                 gettoken;
                 expCharin:=StrVari;
            end
      until not test(',');
end;

destructor TAskFile.destroy;
begin
    chn.free;
    expAccess.free;
    expDatum.free;
    expErasable.free;
    expFileType.free;
    expName.free;
    expOrganization.free;
    expPointer.free;
    expRecsize1.free;
    expRecType.free;
    expSetter.free;
    expCharin.free;
    expTypeahead.free;
    expEchoControl.free;
    expEcho.free;
    expMargin.free;
    expRecSize2.free;
    expZonewidth.free;
    expCharacterPending.free;
    inherited destroy;
end;




function TAskFile.code:ansistring;
 function s(exp:TStrVari):string;
 begin
   if exp=nil then
      result:='nil'
   else
      result:=exp.code
 end;
 function v(exp:TVariable):string;
 begin
   if exp=nil then
      result:='nil'
   else
      result:='@'+exp.code
 end;


begin
   result:='AskFile(' + ChannelCode(chn)+','
          +s(expAccess)+','
          +s(expDatum)+','
          +s(expErasable)+','
          +s(expFileType)+','
          +s(expName)+','
          +s(expOrganization)+','
          +s(expPointer)+','
          +s(expRecsize1)+','
          +s(expRecType)+','
          +s(expSetter)+','
          +s(expCharin)+','
          +s(expTypeahead)+','
          +s(expEchoControl)+','
          +s(expEcho)+','    // 以上，TStrVari;
          +v(expMargin)+','
          +v(expRecSize2)+','
          +v(expZonewidth)+','
          +v(expCharacterPending)+','
          +v(expFilesize) +');' // 以上，TVariable
end;

procedure statementTableinit;
begin
   StatementTableInitImperative('ASK',ASKst);
end;

begin
    tableInitProcs.accept(statementTableinit) ;
end.
