unit fortwrap;

interface

uses SysUtils;

function FortranWrap(filename: String): Integer;
//will wrap all lines that exceed 72 columns,
//except those containing a comment
//returns number of lines wrapped

function Fortran90Wrap(filename: String): Integer;
//will wrap all lines that exceed 90 columns,
//except those containing a comment
//returns number of lines wrapped

function PascalWrap(filename: String): Integer;
//will wrap all lines that exceed 255 columns,
//except those containing a comment
//or those where no place to wrap between will be found
//returns number of lines wrapped

function AddRealSuffixF90(filename: String; RealSuffix: String): Integer;
//With a value given by RealSuffix (e.g. '8'), a suffix (e.g.'_8') will be added to all real values which do not yet contain a suffix.

implementation

function FortranWrap(filename: String): Integer;
var
  Q, Z: TextFile;
  s, s1, comment: String;
  wrappedlines: Integer;
begin
  wrappedlines:=0;
  AssignFile(Q,filename);
  reset(Q);
  AssignFile(Z,filename+'.tmp');
  rewrite(Z);
  while not EOF(Q) do
  begin
    readln(Q,s);
    if (copy(s,1,1)='c') or (copy(s,1,1)='C') or (copy(s,1,1)='!') or (copy(s,1,1)='#') then
      writeln(Z,s)
    else
    begin
      comment:='';
      if pos('!',s)>0 then
      begin
        comment:=copy(s,pos('!',s),length(s));
        s:=copy(s,1,pos('!',s)-1);
      end;
      s1:=copy(s,1,6);
      write(Z,s1);
      s:=copy(s,7,length(s));
      while length(s)>66 do
      begin
        wrappedlines:=wrappedlines+1;
        s1:=copy(s,1,66);
        writeln(Z,s1);
        write(Z,'     &');
        s:=copy(s,67,length(s));
      end;
      write(Z,s);
      writeln(Z,comment);
    end;
  end;
  closefile(Z);
  closefile(Q);
  deletefile(filename);
  renamefile(filename+'.tmp',filename);
  result:=wrappedlines;
end;

function IsStandardChar(c: Char):Boolean;
begin
  if (ord(c)>=ord(char('a'))) and (ord(c)<=ord(char('z'))) then
    result:=true
  else if (ord(c)>=ord(char('A'))) and (ord(c)<=ord(char('Z'))) then
    result:=true
  else if (ord(c)>=ord(char('0'))) and (ord(c)<=ord(char('9'))) then
    result:=true
  else if (ord(c)=ord(char('_'))) or (ord(c)=ord(char('$'))) or (ord(c)=ord(char('.'))) then
    result:=true
  else
    result:=false;
end;

function AddRealSuffix(var s: String; RealSuffix: String): Integer;
var
  state: String;
  i: Integer;
  s1: String;
  c: Char;
  addedSuffixes: Integer;
begin
  addedSuffixes:=0;
  state:='normal';
  s1:='';
  s:=s+' ';
  for i:=1 to length(s) do
  begin
    c:=s[i];
    if state='normal' then
    begin
      if isStandardChar(c) then
      begin
        if (ord(c)=ord(char('.'))) then state:='dot'
        else if pos(c,'0123456789')>0 then state:='integer'
        else state:='other';
      end;
    end
    else if state='other' then
    begin
      if not isStandardChar(c) then state:='normal';
    end
    else if state='integer' then
    begin
      if isStandardChar(c) then
      begin
        if (ord(c)=ord(char('.'))) then
          state:='real'
        else if (ord(c)=ord(char('e'))) then
          state:='realE'
        else if (ord(c)=ord(char('E'))) then
          state:='realE';
      end
      else
        state:='normal';
    end
    else if state='real' then
    begin
      if isStandardChar(c) then
      begin
        if (ord(c)=ord(char('_'))) then state:='other'  // real already has a suffix
        else if (ord(c)=ord(char('e'))) then state:='realE'
        else if (ord(c)=ord(char('E'))) then state:='realE'
        else if pos(c,'0123456789')>0 then state:='real'
        else state:='other'; //especially if a second dot occurs
      end
      else
      begin
        s1:=s1+'_'+RealSuffix;
        addedSuffixes:=addedSuffixes+1;
        state:='normal';
      end;
    end
    else if state='dot' then
    begin
      if isStandardChar(c) then
      begin
        if pos(c,'0123456789')>0 then state:='real'
        else state:='other'; //especially if a second dot occurs
      end
      else
        state:='normal';
    end
    else if state='realE' then
    begin
      if isStandardChar(c) then
      begin
        if pos(c,'0123456789')>0 then state:='real'
        else state:='other';
      end
      else
      begin
        if pos(c,'+-')>0 then state:='real'
        else state:='normal';
      end;
    end;
    s1:=s1+c;
  end;
  s:=copy(s1,1,length(s1)-1);
  result:=addedSuffixes;
end;

function AddRealSuffixF90(filename: String; RealSuffix: String): Integer;
var
  Q, Z: TextFile;
  s: String;
  addedSuffixes: Integer;
begin
  addedSuffixes:=0;
  AssignFile(Q,filename);
  reset(Q);
  AssignFile(Z,filename+'.tmp');
  rewrite(Z);
  while not EOF(Q) do
  begin
    readln(Q,s);
    AddedSuffixes:=addedSuffixes+AddRealSuffix(s,RealSuffix);
    writeln(Z,s);
  end;
  closefile(Z);
  closefile(Q);
  deletefile(filename);
  renamefile(filename+'.tmp',filename);
  result:=addedSuffixes;
end;

function Fortran90Wrap(filename: String): Integer;
var
  Q, Z: TextFile;
  s, s1, comment: String;
  wrappedlines: Integer;
  lastpos: Integer;
  lastchar: String;
begin
  wrappedlines:=0;
  AssignFile(Q,filename);
  reset(Q);
  AssignFile(Z,filename+'.tmp');
  rewrite(Z);
  while not EOF(Q) do
  begin
    //read a new line
    readln(Q,s);
      //Step 1: See if a comment exists, this will not be wrapped
      comment:='';
      if pos('!',s)>0 then
      begin
        comment:=copy(s,pos('!',s),length(s));
        s:=copy(s,1,pos('!',s)-1);
      end;
      //Step 2: Remove trailing spaces and add them to the comment
      while copy(s,length(s),1)=' ' do
      begin
        s:=copy(s,1,length(s)-1);
        comment:=' '+comment;
      end;
      //Step 3: While the remaining line is longer than 255 chars, split it and write it line by line
      while length(s)>255 do
      begin
        wrappedlines:=wrappedlines+1;
        lastpos:=254;
        lastchar:='a';
        while (lastchar <> ' ') and (lastchar <> ')') and
              (lastpos > 1) do
        begin
          lastpos:=lastpos-1;
          lastchar:=copy(s,lastpos+1,1);
        end;
        if lastpos>1 then
        begin
          s1:=copy(s,1,lastpos);
          writeln(Z,s1+' &');
          s:=copy(s,lastpos+1,length(s));
        end
        else
        begin
          //wrapping failed, write complete line
          write(Z,s);
          s:='';
        end;
      end;
      write(Z,s);
      //Step 4: write the comment
      writeln(Z,comment);
  end;
  closefile(Z);
  closefile(Q);
  deletefile(filename);
  renamefile(filename+'.tmp',filename);
  result:=wrappedlines;
{  wrappedlines:=0;
  AssignFile(Q,filename);
  reset(Q);
  AssignFile(Z,filename+'.tmp');
  rewrite(Z);
  while not EOF(Q) do
  begin
    readln(Q,s);
      comment:='';
      if pos('!',s)>0 then
      begin
        comment:=copy(s,pos('!',s),length(s));
        s:=copy(s,1,pos('!',s)-1);
      end;
      while length(s)>90 do
      begin
        wrappedlines:=wrappedlines+1;
        s1:=copy(s,1,90);
        write(Z,s1);
        writeln(Z,'&');
        write(Z,'      &');
        s:=copy(s,91,length(s));
      end;
      write(Z,s);
      writeln(Z,comment);
  end;
  closefile(Z);
  closefile(Q);
  deletefile(filename);
  renamefile(filename+'.tmp',filename);
  result:=wrappedlines;}
end;

function PascalWrap(filename: String): Integer;
var
  Q, Z: TextFile;
  s, s1, comment: String;
  wrappedlines: Integer;
  lastpos: Integer;
  lastchar: String;
begin
  wrappedlines:=0;
  AssignFile(Q,filename);
  reset(Q);
  AssignFile(Z,filename+'.tmp');
  rewrite(Z);
  while not EOF(Q) do
  begin
    readln(Q,s);
      comment:='';
      if pos('//',s)>0 then
      begin
        comment:=copy(s,pos('//',s),length(s));
        s:=copy(s,1,pos('//',s)-1);
      end;
      while length(s)>255 do
      begin
        wrappedlines:=wrappedlines+1;
        lastpos:=254;
        lastchar:='a';
        while (lastchar <> ' ') and (lastchar <> '(') and (lastchar <> ')') and
              (lastpos > 1) do
        begin
          lastpos:=lastpos-1;
          lastchar:=copy(s,lastpos+1,1);
        end;
        if lastpos>1 then
        begin
          s1:=copy(s,1,lastpos);
          writeln(Z,s1);
          s:=copy(s,lastpos+1,length(s));
        end
        else
        begin
          //wrapping failed, write complete line
          write(Z,s);
          s:='';
        end;
      end;
      write(Z,s);
      writeln(Z,comment);
  end;
  closefile(Z);
  closefile(Q);
  deletefile(filename);
  renamefile(filename+'.tmp',filename);
  result:=wrappedlines;
end;

end.
