program MakeProc;{makes (xxxxproc DLL interface) unit's implementation
part from info in interface part - rewrites completely the implementation
part according to info in interface part, in one of the following forms,
dependint on second command line parametr (0 or 1):

 0: xxx; external xDDL
    or

 1: const                        (default)
    Fxxx:function.. = nil;
    if not Assigned(Fxxx) ...
}
{.$I define.pas}
uses
  SysUtils, Classes, UtlType, WinUtl, ObjList, Fileu;

const
  MakeProcVersion = '2.00';
  { Remade for Windows  }

type
  TSLines = class(TStringList)
  private
    FIndex: integer;
    function Reset: boolean;
    function GetNextLine(var s: string): boolean;
  end;

  TMethodDef = class(TObject)
    name:string;
    pars:TSLines;
    res:string;
    typ:integer;
    constructor Create(AName: string; Apars:TSLines);reintroduce;
    destructor Destroy;override;
  end;
  PMethodDef = ^TMethodDef;


function TSLines.Reset: boolean;
begin
  FIndex := 0;
  Result := FIndex < Count;
end;

function TSLines.GetNextLine(var s: string): boolean;
begin
  Result := false;
  if FIndex >= Count then
    exit;
  s := Strings[FIndex];
  inc(FIndex);
  Result := true;
end;

procedure SysError(s: string);
begin
  writeln(s);
end;

constructor TMethodDef.Create(AName:string; Apars:TSLines);
begin
  inherited Create;
  res := '';
  name := AName;
  if apars = nil then
    pars := TSLines.Create
  else
    pars := apars;
  if (pars = nil) then
    raise Exception.Create('Invalid params.');
end;

destructor TMethodDef.Destroy;
begin
  ClassFree(pars);
  inherited Destroy;
end;

procedure make(infile:string; form:string);
const
  implfile='TMPIMPL.TMP';
  intfile = 'TMPINT.TMP';

  fullForm = '1';

  imNo = 0;
  imFn = 1;
  imProc = 2;
var
  outfile: string;
  UsingUnit: boolean;(*true if the source is not xxxxproc import unit but
    xxxxu implementation unit; then only methods between {export ..} {/export ..}
    lines considered, xxxxproc file created
  *)
  inexport: boolean;{used if UsingUnit to decide if lines should be parsed}
  usesline: string;(*used if UsingUnit and after {EXPORT clause follows word uses
                   followed by names of units to be included in output file*)
  ConstNameFound: boolean;
    { found in interface section definition for DLLName ? }


  methods: TObjList;{of PMethodDef}

  firstline: boolean;
  inputf, implf, intf: text;
  line: string;
  method: TMethodDef;
  {methodpars:PTextLinesCollection;}
  {methodnames:PTextLinesCollection;}
  methodname: string;
  methodresult: string;
  dllname: string;
  target: string;
  p,i: integer;

  inpar: boolean;
  inmet: byte;
  incom: boolean;
  iscomment: boolean;

  procedure wr(s: string);
  begin
    write(implf, s);
  end;

  procedure w(s: string);
  begin
    writeln(implf, s);
  end;

  function InitMethod:boolean;
  begin
    InitMethod := false;
    method := TMethodDef.Create('', nil);
    if method = nil then
      exit;
    InitMethod := true;
  end;

  function FindDLLName:boolean;
  var
    i:integer;
    d:dirstr;
    n:namestr;
    e:extstr;
  begin
    FindDLLName := false;
    if ExtractFileExt(infile) = '' then
    infile := ChangeFileExt(infile, '.PAS');
    infile := UpperCase(infile);
    i := pos('PROC', infile);
    if i > 0 then begin
      dllname := ExtractFileName(copy(infile, 1, i - 1)) + 'DLL';
      UsingUnit := false;
      outfile := infile;
    end else begin
      d := ExtractFilePath(infile);
      n := ChangeFileExt(ExtractFileName(infile),'');
      e := ExtractFileExt(infile);
      //FSplit(infile,d,n,e);
      if e = '' then
        e := '.PAS';
      if n[length(n)] = 'U' then begin
        outfile := d + copy(n, 1, 3) + 'XPROC' + e;
        dllname := copy(n, 1, length(n) - 1) + 'DLL';
        UsingUnit := true;
      end else begin
        SysError('PROC or U word not found in ' + infile);
        exit;
      end;
    end;
    FindDLLName := true;
  end;

  procedure WriteIntHead;
  begin
    writeln(intf, 'unit ' + ChangeFileExt(ExtractFileName(outfile),'') + ';');
    writeln(intf, 'interface');
    if usesline <> '' then
      writeln(intf, usesline);
    writeln(intf);
  end;

  procedure WriteImplHead;
  begin
    if not ConstNameFound then begin
      w('const');
      w('  ' + dllname + 'Name: shortstring = ' + dllname + ';');
    end;
    w('implementation');
    if form = fullForm then begin
      w('uses DLLUtl;');
      w('');
      w('const');
      w('  DLLHandle:THandle = 0;');
      w('procedure Load;');
      w('begin');
      w('  if DLLHandle = 0 then DLLLoad('+ dllname + 'Name, true, DLLHandle);');
      w('end;');
    end;
    w('');
  end;

  procedure WriteImplEnd;
  begin
    if form = fullForm then begin
      w('procedure Done;');
      w('begin');
      w('  if DLLHandle <> 0 then');
      w('    DLLFree(DLLHandle);');
      w('  DLLHandle := 0;');
      w('end;');
      w('');
      w('const');
      w('  OldExitProc:pointer = nil;');
      w('{$S-}');
      w('procedure Ex;far;');
      w('begin');
      w('  ExitProc := OldExitProc;');
      w('  Done;');
      w('end;');
      w('');
      w('begin');
      w('  OldExitProc := ExitProc;');
      w('  ExitProc := @Ex;');
    end;
    w('end.');
  end;

  function methodType(mt:integer):string;
  begin
    case mt of
      imFn: methodType := 'function';
      imProc: methodType := 'procedure';
    end;
  end;

  procedure FinishMethod;
  begin
    method.Name := methodname;
    method.Res := methodresult;
    method.typ := inMet;
    methods.add(method);
    InitMethod;
    methodname := '';
    methodresult := '';
    inMet := imNo;
  end;

  procedure WriteImplBody;

    procedure WriteMet(item:TMethodDef);far;

      procedure writepars;
      var
        i:integer;
        s:string;
      begin
        i := 0;
        if item.pars.Reset then begin
          wr('(');
          while item.pars.GetNextLine(s) do begin
            if s <> '' then begin
              if i <> 0 then
                w('');
              wr(s);
              inc(i);
            end;
          end;
          wr(')');
        end;
      end;

      procedure Strip(var s:string);
      var
        incol:boolean;
        incom:boolean;
        p:integer;
        len:integer;
      begin
        p := 1;
        incol := false;
        incom := false;
        while p <= length(s) do begin

          if incom then begin
            if s[p] = '}' then
              incom := false;
            inc(p);
          end else begin
            if s[p] = '{' then begin
              incom := true;
              inc(p);
            end;
          end;

          if not incom then begin
            if incol then begin
              if s[p] = ';' then begin
                s[p] := ',';
                incol := false;
                inc(p);
              end else begin
                if incom then
                  inc(p)
                else
                  delete(s, p, 1);
              end;
            end else begin
              if s[p] = ':' then begin
                incol := true;
                delete(s, p, 1);
              end else begin
                if s[p] = ';' then
                  s[p] := ',';
                inc(p);
              end;
            end;
          end;

        end;{while}

        repeat
          p := pos('VAR ', UpperCase(s));
          if p = 0 then begin
            p := pos('CONST ', UpperCase(s));
            if p > 0 then
              len := 6;
          end else
            len := 4;
          if p > 0 then begin
            if (p = 1) or (s[p-1] in [' ',';',',','(']) then
             Delete(s, p, len);
          end;
        until p = 0;

      end;


      procedure writeparvals;
      var
        i:integer;
        s:string;

      begin
        i := 0;
        if item.pars.Reset then begin
          wr('(');
          while item.pars.GetNextLine(s) do begin
            if s <> '' then begin
              if i <> 0 then
                w('');
              Strip(s);
              wr(s);
              inc(i);
            end;
          end;
          wr(')');
        end;
        w(';');
      end;

    begin
      if form = fullForm then begin
        w('const');
        wr('  F' + item.name + ':' + methodType(item.typ));
        writepars;
        w(item.res + ' = nil;');
        w('');
      end;
      wr(methodType(item.typ) + ' ' + item.name);
      writepars;
      w(item.res + ';');
      if item.typ = imFN then begin
        {w('var res' + getString(item^.res) + ';');}
      end;
      if form = fullForm then begin
        w('begin');
        w('  if not Assigned(F' + item.name + ') then begin');
        w('    Load;');
        w('    DLLAssignProc(@F' + item.name + ', DLLHandle, ' + chr(39) + {UpperCase}(item.name)
          +  chr(39) + ', true);');
        w('  end;');
        case item.typ of
          imFN: begin
            wr('  ' + item.name + ' := F' + item.name);
            writeparvals;
          end;
          imProc: begin
            wr('  F' + item.name);
            writeparvals;
          end;
        end;
        w('end;');

      end else begin
        w('  external ' + DLLNAME + ';');
      end;
      w('');
    end;

  var i:integer;
  begin
    for i := 0 to methods.Count - 1 do
      WriteMet(methods[i]);
  end;

  procedure WriteExports;
  var
    s:string;
    i:integer;

    expo:text;
    d:dirstr;
    n:namestr;
    e:extstr;
  begin
    FileNameSplit(infile, d, n, e);//fileu utltype winutl
    i := pos('PROC', n);
    if i > 0 then begin
      n := copy(n, 1, i - 1);
      if n <> '' then begin
        AssignFile(expo, d + n + 'EXPO' + e);
        {$I-}
        rewrite(expo);
        if ioresult <> 0 then
          n := '';
      end;
    end else
      n := '';

    w('(*');
    w('exports');
    for i := 0 to Methods.Count - 1 do begin
      s := TMethodDef(Methods[i]).Name;
      w('  ' + s + ',');
      if n <> '' then begin
        if i < (Methods.Count - 1) then
          writeln(expo, '  ' + s + ',')
        else
          writeln(expo, '  ' + s);
      end;
    end;
    w('*)');

    if n <> '' then
      CloseFile(expo);
  end;

begin
  inexport := false;
  methods := nil;
  usesline := '';
  ConstNameFound := false;
  {methodpars := nil;}

  if form = '' then
    form := fullForm;

  if not FindDLLName then
    exit;
  methods := TObjList.Create;

  AssignFile(inputf, infile);
  {$I-}
  reset(inputf);
  if ioresult<> 0 then begin
    SysError(infile + ' not found.');
    exit;
  end;

  AssignFile(implf, implfile);
  rewrite(implf);
  if ioresult <> 0 then begin
    SysError('Can no create ' + implfile);
  end;

  AssignFile(intf, intfile);
  rewrite(intf);
  if ioresult <> 0 then
  begin
    SysError('Can not create ' + intfile);
  end;

  if not Initmethod then
    exit;

  inmet := imNo;
  inpar := false;
  incom := false;
  line := '';
  methodname := '';
  methodresult := '';

  firstline := true;
  iscomment := false;
  repeat
    if line = '' then begin
      readln(inputf, line);
      if (length(line) > 3) and (trim(copy(line, 1, 3)) = '') then begin
        iscomment := true;
      end else
        iscomment := false;

      if UsingUnit then begin
        if not inexport then begin
          if pos('{EXPORT', UpperCase(line)) = 1 then begin
            i := pos('uses',line);
            if i > 0 then begin
              usesline := copy(line, i, length(line) - i);
            end;
            if UsingUnit then
              WriteIntHead;
            inexport := true;
          end;
          line := '';
          continue;
        end else begin
          if pos('{/EXPORT', UpperCase(line)) = 1 then begin
            break;
          end;
        end;
      end else begin
        if pos('Name: string[12] = ', line) <> 0 then begin {rtmiproc}
          ConstNameFound := true;
        end;
        if eof(inputf) or (pos('IMPLEMENTATION', UpperCase(line)) <> 0) then
          break;
      end;

      if firstline then begin
        if pos('MAKEPROC',line) = 0 then begin
          line := line + '{Made by MAKEPROC program ' + MakeProcVersion + '}';
        end;
        firstline := false;
      end;
      i := pos('{$IFDEF PMODE}', line);
      if i > 0 then begin
        line := copy(line, 1, i - 1);
      end;
      writeln(intf, line);
    end;


    if (inMet = imNo) then begin
      {find and strip function/procedure and its name:}
      if not iscomment then begin
        i := pos('FUNCTION ', UpperCase(line));
        if i = 0 then begin
          i := pos('PROCEDURE ', UpperCase(line));
          if i > 0 then
            inmet := imProc;
        end else begin
          inmet := imFn;
        end;
      end;

      if inmet <> imNo then begin
        method.pars.Clear;//objlist
        line := copy(line, i + 8 + inmet, 255);
        i := pos('(', line);
        if i > 0 then begin
          {has parameters:}
          methodname := trim(copy(line, 1, i - 1));
          line := copy(line, i + 1, 255);
          inpar := true;
        end else begin
          {no pars, strip name:}
          case inMet of
            imFn: begin
              i := pos(':', line);
              methodname := copy(line, 1, i - 1);
              line := copy(line, i, 255);
            end;
            imProc: begin
              i := pos(';', line);
              methodname := copy(line, 1, i - 1);
              line := copy(line, i, 255);
            end;
          end;
        end;
      end else
        line := '';
    end;

    if (inmet <> imNo) then begin
      if not inpar then begin
        i := pos(';', line);
        if i > 0 then begin
          case inmet of
            imFn: methodresult := copy(line, 1, i - 1);
            imProc: methodresult := '';
          end;

          line := copy(line, i + 1, 255);
          Finishmethod;
          if pos('{$IFDEF PMODE}', line) = 1 then
            line := '';
        end else begin
          SysError('";" on end of method missing: ' + line);
          exit;
        end;
      end else begin
        i := pos(')', line);
        if i = 0 then begin
          method.pars.add(line);
          line := '';
        end else begin
          method.pars.add(copy(line, 1, i - 1));
          line := copy(line, i + 1, 255);
          inpar := false;
        end;

      end;
    end;

  until false;
  WriteImplHead;

  WriteImplBody;
  WriteImplEnd;
  WriteExports;

  CloseFile(implf);
  CloseFile(inputf);
  CloseFile(intf);{tmp}
  ClassFree(methods);
  ClassFree(method);

  target := outfile;

  EraseFile(Target);
  AppendFile(intfile, target);
  AppendFile(implfile, target);{fileu}
end;

procedure makeall(infiles:string;form:string);
var
  f:text;
  s:string;
  fn,frm:string;
  i:integer;
begin
  if infiles <> '' then begin
    if infiles[1] = '@' then begin
      infiles := copy(infiles, 2, 255);
      assign(f, infiles);
      reset(f);
      while not eof(f) do begin
        readln(f, s);
        i := pos(' ', s);
        if i > 0 then begin
          fn := trim(copy(s, 1, i - 1));
          frm := trim(copy(s, i, 255));
        end else begin
          fn := s;
          frm := '';
        end;
        if frm = '' then
          frm := form;
        make(fn, form);
      end;
      close(f);
    end else begin
      make(infiles, form);
    end;
  end;
end;

begin
  if paramcount = 0 then begin
    writeln('Usage: MAKEPROC {xxxxproc[.pas] [[1|]0] | @ProcFileNamesListFile [{0|1}] } ');
    writeln('Version: ' + MakeProcVersion + ' for Windows');
    writeln('  creates implementation part of xxxxproc.pas DLL import unit');
    writeln('  in forms: 0 -  XProc;external DLL');
    writeln('            1 - const FXProc:procedure=nil; if not Assigned(FXProc).. (default)');
    writeln;
    writeln('  Creates also list of exported methods in the form usable for');
    writeln('  EXPORTS section of DLL at the end of the file as comment.');
    writeln;
    writeln('  If the input file name does not end with "proc" word but with');
    writeln('  letter "u", then it is expected to be the implementation unit');
    writeln('  and interface unit named xxxXPROC.PAS will be created from those lines');
    writeln('  of the input file, that are between lines that contains {EXPORT} and ');
    writeln('  {/EXPORT} clauses at the beggining of line;');
    writeln('  {EXPORT uses mytype,..;} form can be used to force the output file');
    writeln('  to contain line "uses mytype,..;" after interface clause.');
  end else begin
    makeall(paramstr(1), paramstr(2));
  end;
end.