(* *****************************************************************
** File    : AutoFoldPascal.PAS
** Created : 10.07.00
** Author  :
**
** Macro for FoldMaster
**    AutoFold Funktion für Pascal Dateien
**    einzeln, wie auch fuer ein gesamtes Projekt
**
**
********************************************************************
** Version     Date      Change
** 1.50        10.07.00  Creation
** 1.53        29.10.01  Endlosschleife in skip_param_list durch
**                       zusätzliche Abfrage auf Ende des Textes oder
**                       auf die Schlüsselworte "begin" und "end". In
**                       diesen Fällen wird eine Fehlermeldung ausgegeben
**                       und das Makro abgebrochen.
**                       Im Hauptprogramm wird jetzt setup_menu aufgerufen.
** **************************************************************-**)

PROGRAM AutoFoldPascal;

// Here you can add constants and variables.
// Variables defined in global scope will hold their contents
// until the macro file is unloaded. Functions may use global
// variables to store some information.
(*{{{  const*)
// const
   // global constants
(*}}}*)
(*{{{  var*)
var
   s                 : string;
   interface_section : boolean;
(*}}}*)

// ------------------------------------------------------------------
// FUNCTIONS AND PROCEDURES
// ------------------------------------------------------------------

(*{{{  scan_error*)
{ scan_error
  prints error message in MessageWindow
  and Halts program
}
procedure scan_error(s : string);
begin
   MessageAddMessage('Log', GetModuleName,
                     '(E) Syntax Error found: '+s,
                     GetLineNum, GetX);
   Halt;
end;
(*}}}*)

(*{{{  procedure skip_param_list;*)
{ Skips parameter list
  till ; is found.
  Halt if "begin" or "end" is found or if end of file is reached
}
procedure skip_param_list;
var s : string;
   (*{{{  procedure skip_brackets;*)
   procedure skip_brackets;
   begin
      repeat
         SyntaxRight; s := strlwr(GetSyntaxItem);
         if (IsEndOfText) then Halt;
         if (s = 'end')   then scan_error('unexpected "end"');
         if (s = 'begin') then scan_error('unexpected "begin"');
      until (s = ')');
   end;
   (*}}}*)
begin
   repeat
      SyntaxRight; s := strlwr(GetSyntaxItem);
      if (s = '(') then skip_brackets;
      if (IsEndOfText) then Halt;
      if (s = 'end')   then scan_error('unexpected "end"');
      if (s = 'begin') then scan_error('unexpected "begin"');
   until (s = ';');
end;
(*}}}*)
(*{{{  procedure scan_object_record;*)
procedure scan_object_record;
begin
   repeat
      SyntaxRight; s := strlwr(GetSyntaxItem);
      if      (s = 'record') then scan_object_record
      else if (s = 'object') then scan_object_record
      else if (s = 'end')    then break;
   until IsEndOfText;
end;
(*}}}*)
(*{{{  procedure scan_types*)
{ scan_types
  scannes a Types- section
}
procedure scan_types;
var n1, n2, x2 : integer;
begin
   n1 := GetLineNum;  // Zeilennummer mit "type"
   n2 := n1;
   repeat
      if (s <> '') then n2 := GetLineNum; // die vorhergehende Zeile merken
      SyntaxRight; s := strlwr(GetSyntaxItem);
      if      (s = 'function' )      then break
      else if (s = 'procedure')      then break
      else if (s = 'constructor')    then break
      else if (s = 'destructor')     then break
      else if (s = 'implementation') then break
      else if (s = 'object')         then scan_object_record
      else if (s = 'record')         then scan_object_record
      else if (s = 'var')            then break
      else if (s = 'const')          then break
      else if (s = 'type')           then break
      else if (s = 'begin')          then break
   until IsEndOfText;
   GotoXY(1, n1); SelectExtend(1);
   GotoXY(1, n2); EndOfLine;
   FoldMake;      SelectExtend(0);
   FoldHide;      ReplaceLine ('TYPES');
end;
(*}}}*)
(*{{{  procedure scan_const_section( title : string);*)
{ scan_const_section
  Scannt eine const Section
  diese wird eingeleitet durch "const"
  und beendet durch eines der folgenden Schluesselworte
  function, procedure, type, begin, var
  interface
}
procedure scan_const_section( title : string);
var n1, n2, x2 : integer;
begin
   n1 := GetLineNum;
   n2 := n1;
   repeat
      if (s <> '') then n2 := GetLineNum; // die vorhergehende Zeile merken
      SyntaxRight; s := strlwr(GetSyntaxItem);
      if      (s = '')                then continue
      else if (s = 'function')        then break
      else if (s = 'procedure')       then break
      else if (s = 'constructor')     then break
      else if (s = 'destructor')      then break
      else if (s = 'implementation')  then break
      else if (s = 'type')            then break
      else if (s = 'var')             then break
      else if (s = 'const')           then break
      else if (s = 'begin')           then break
   until IsLastLine;
   GotoXY(1, n1);
   SelectExtend(1);
   GotoXY(1, n2); EndOfLine;
   FoldMake;      SelectExtend(0);
   FoldHide;      ReplaceLine(title);
   EndOfLine;
end;
(*}}}*)
(*{{{  procedure scan_block;*)
{ scan_block
  Sucht beginnend bei einem block das zugehoerige end.
  Der Bezeichner fuer start ist meist begin
  kann aber ebenso case asm oder was aehnliches sein.
  Dabei sind Konstrukte innerhalb einer Zeile ebenso
  zu beruecksichtigen wie z.B.:
  if (a=b) then begin c := a; end;
  Die Prozedur erwarten, als Parameter die Position
  hinter dem Bezeichners z.b. begin^
}
function scan_block : boolean;
var p    : integer;
    erg  : boolean;
    e    : boolean;
begin
   erg := false;
   repeat
      SyntaxRight; s := strlwr(GetSyntaxItem);
      if      (s = '')      then continue
      else if (s = 'begin') then e := scan_block
      else if (s = 'case')  then e := scan_block
      else if (s = 'asm')   then e := scan_block
      else if (s = 'end')   then begin
         SyntaxRight; // end noch ueberspringen
         erg := true; break;
      end;
   until IsLastLine;
   scan_block := erg;
end;
(*}}}*)
(*{{{  procedure scan_func_proc;*)
procedure scan_func_proc;
var n1, n2, x2 : integer;
    begin_pos  : integer;
begin
   n1 := GetLineNum;  // Zeilennummer mit "function" oder "procedure"
   // erst Parameterliste ueberspringen
   skip_param_list;
   if (interface_section) then exit;
   repeat
      SyntaxRight; s := strlwr(GetSyntaxItem);
      if      (s = '')         then continue
      else if (s = 'function') then scan_func_proc
      else if (s = 'procedure')then scan_func_proc
      else if (s = 'forward')  then exit
      else if (s = 'type')     then scan_types
      else if (s = 'const')    then scan_const_section('CONST')
      else if (s = 'var')      then scan_const_section('VARS')
      else if (s = 'uses')     then scan_const_section('USES')
      else if ((s = 'begin') OR (s = 'asm')) then begin
         if (Scan_Block) then begin
            x2 := GetLinePos;
            n2 := GetLineNum;
            GotoXY(1, n1);  SelectExtend(1);
            GotoXY(x2, n2); FoldMake; FoldHide;
            SelectExtend(0);EndOfLine;
            break;
         end;
      end;
   until IsEndOfText;
end;
(*}}}*)
(*{{{  procedure auto_fold_pascal;*)
{  auto_fold_pascal
   Makro um eine Datei automatisch zu falten.
   Dabei soll es sich um eine PASCAL Datei handeln.
}
procedure auto_fold_pascal;
var
    begin_pos : integer;
begin
   // 1. alle Funktionen und Prozeduren falten
   StartOfText; interface_section := false;
   repeat
      SyntaxRight; s := strlwr(GetSyntaxItem);
      if      (s = '')               then continue
      else if (s = 'function')       then scan_func_proc
      else if (s = 'procedure')      then scan_func_proc
      else if (s = 'constructor')    then scan_func_proc
      else if (s = 'destructor')     then scan_func_proc
      else if (s = 'type')           then scan_types
      else if (s = 'const')          then scan_const_section('CONST')
      else if (s = 'uses')           then scan_const_section('USES')
      else if (s = 'var')            then scan_const_section('VARS')
      else if (s = 'interface')      then interface_section := true
      else if (s = 'implementation') then interface_section := false
      else if (s = 'begin')          then break;
   until IsEndOfText;
   // 2. KLASSEN falten
   // 3. TYPE Abschnitte falten
   // 3. CONST Abschnitte falten
   // 5. VAR Abschnitte falten
   // 6. Interface falten
   // 7. Implementation falten
end;
(*}}}*)

(*{{{  procedure project_auto_fold_pascal;*)
{ project_auto_fold_pascal
  Das Projekt Modul fuer Modul durchgehen und die AutoFoldFunktion
  auf jede Datei anwenden.
}
procedure project_auto_fold_pascal;
var fn : string;
    i  : integer;
begin
   ProjectShow; StartOfText;
   i := 0;
   repeat
      { kompletten Dateinamen mit Pfad ermitteln }
      fn := IterateProjectModules(false, i);
      if (fn <> '') then begin
         if (FileNameGetExt(fn) = '.PAS') then begin
            writeln ('Working on ', fn);
            FileOpen(fn);
            if (IsModuleOpen(fn)) then begin
               s := '';
               auto_fold_pascal;
            end;
         end;
      end;
      Inc(i);
   until fn = '';
end;
(*}}}*)

(*{{{  procedure setup_menue;*)
{ setup_menue
  setup macro menu entries
}
procedure setup_menue;
begin
   MacroMenuAdd('project_auto_fold_pascal', 'Fold each module in Project');
   MacroMenuAdd('auto_fold_pascal', 'Auto fold current module');
end;
(*}}}*)

// ------------------------------------------------------------------
// MAIN BLOCK
// ------------------------------------------------------------------
BEGIN
   // if the macro file itself is executed this block will be
   // executed. Here you can call other procedures and
   // functions as necessary.
   setup_menue;
END.