program makepas;

{$APPTYPE CONSOLE}

uses
  SysUtils;

const
  SEPARATOR = '/*************************************************************/';

var
  f, g: text;
  s, t, r: string;
  i: longint;
  GL: string;
  functype: string;

procedure writeheader;
begin
  writeln(g, '(*************************************************************)');
  writeln(g, '(*                                                           *)');
  writeln(g, '(*   This unit was generated using the following program:    *)');
  writeln(g, '(*                                                           *)');
  writeln(g, '(*  program name : Extension Header to Unit Converter v0.3   *)');
  writeln(g, '(*  part of      : Freestanding                              *)');
  writeln(g, '(*  author       : Danubius / Danube                         *)');
  writeln(g, '(*  date         : 04-16-2005                                *)');
  writeln(g, '(*                                                           *)');
  writeln(g, '(*************************************************************)');
  writeln(g);
  writeln(g, 'unit ', GL, 'ext;');
  writeln(g);
  writeln(g, '(***) interface (***)');
  writeln(g);
  writeln(g, 'uses Windows, GL;');
  writeln(g);
  writeln(g, 'type');
  writeln(g, '  PGLvoid = Pointer;');
  writeln(g, '  PPGLvoid = ^PGLvoid;');
  writeln(g);
  writeln(g, 'function wglGetProcAddress(proc: PChar): Pointer; stdcall; external ''OpenGL32.dll'';');
  writeln(g);
end;

procedure writemiddle;
begin
  writeln(g, '(***) implementation (***)');
  writeln(g);
end;

procedure writefooter;
begin
  writeln(g, 'end.');
end;

function uppercase(s: string): string;
var
  i: byte;
begin
  for i := 1 to length(s) do
    s[i] := upcase(s[i]);
  result := s;
end;

function gettype(s: string): string;
var
  t: string;
begin
  if s[length(s)] = ' ' then Delete(s, length(s), 1);
  t := uppercase(s);
  result := '';
  if t = 'HANDLE'       then result := 'GLuint';
  if t = 'VOID'         then result := 'GLvoid';
  if t = 'BOOL'         then result := 'GLboolean';
  if t = 'CHAR'         then result := 'Char';
  if t = 'SHORT'        then result := 'GLshort';
  if t = 'USHORT'       then result := 'GLushort';
  if t = 'UNSIGNED SHORT' then result := 'GLushort';
  if t = 'INT'          then result := 'GLint';
  if t = 'INT32'        then result := 'GLint';
  if t = 'UINT'         then result := 'GLuint';
  if t = 'UNSIGNED INT' then result := 'GLuint';
  if t = 'FLOAT'        then result := 'GLfloat';
  if t = 'LPVOID'       then result := 'PGLvoid';
  if t = 'GLVOID*'      then result := 'PGLvoid';
  if t = 'PTRDIFF_T'    then result := 'PGLint';
  if t = 'GLCHAR*'      then result := 'PGLchar';
  if result = '' then result := s;
end;

function converttype(s: string): string;
begin
  if uppercase(Copy(s, 1, 6)) = 'CONST ' then Delete(s, 1, 6);
  if Copy(s, length(s) - 8, 9) = '* const *' then
    result := 'P' + gettype(Copy(s, 1, length(s) - 9)) else
  if Copy(s, length(s) - 2, 3) = '* *' then
    result := 'P' + gettype(Copy(s, 1, length(s) - 3)) else
  if s[length(s)] = '*' then result := 'P' + gettype(Copy(s, 1, length(s) - 1))
                        else result := gettype(s);
end;

function splitvar(var t: string): string;
var
  i: byte;
begin
  i := length(t);
  result := '';
  while not (t[i] in [' ', '*']) do
  begin
    result := t[i] + result;
    dec(i);
  end;
  Delete(t, i+1, 255);
  if t[1] = ' ' then Delete(t, 1, 1);
  if t[length(t)] = ' ' then Delete(t, length(t), 1);
end;

function checkname(s: string): string;
var
  t: string;
begin
  result := '';
  t := uppercase(s);
  if t = 'START' then result := 'aStart';
  if t = 'END' then result := 'aEnd';
  if t = 'TYPE' then result := 'eType';
  if t = 'PROGRAM' then result := 'eProgram';
  if t = 'STRING' then result := 'eString';
  if t = 'PACKED' then result := 'ePacked';
  if t = 'ARRAY' then result := 'eArray';
  if t = 'IN' then result := 'eIn';
  if t = 'UNIT' then result := 'eUnit';
  if t = 'OBJECT' then result := 'eObject';
  if result = '' then result := s;
end;

begin
  if ParamCount = 0 then
  begin
    writeln;
    writeln('program name : Extension Header to Unit Converter v0.3');
    writeln('part of      : Freestanding');
    writeln('author       : Danubius / Danube');
    writeln('date         : 04-16-2005');
    writeln;
    writeln('syntax       : makepas [type]');
    writeln;
    writeln('example      : makepas GL');
    writeln('               makepas WGL');
    readln;
    halt;
  end;
  GL := ParamStr(1);
  write('converting ', GL, 'ext.h to ', GL, 'ext.pas ... ');
  assign(f, GL + 'ext.h');
  assign(g, GL + 'ext.pas');
  reset(f);
  rewrite(g);
  writeheader;

  while not eof(f) do
  begin
    readln(f, s);
    if s = SEPARATOR
      then break;
  end;

  writeln(g, '(*************************************************************)');
  writeln(g, '(*                  T   O   K   E   N   S                    *)');
  writeln(g, '(*************************************************************)');
  writeln(g);
  writeln(g, 'const');
  writeln(g);
  while not eof(f) do
  begin
    readln(f, s);
    if s = SEPARATOR
      then break;
    if Copy(s, 1, 9 + length(GL)) = '#ifndef ' + GL + '_' then
    begin
      writeln(g, '(*** ' + Copy(s, 9, 255) + ' ***)');
      readln(f, s);
        while s <> '#endif' do
        begin
          if Copy(s, 1, 8) = '#define ' then
          begin
            Delete(s, 1, 8);
            t := '  '; i := 1;
            while s[i] <> ' ' do
            begin
              t := t + s[i]; inc(i);
            end;
            while s[i] = ' ' do
            begin
              t := t + s[i]; inc(i);
            end;
            t := t + '= ';
            if Copy(s, i, 2) = '0x' then
            begin
              i := i + 2;
              t := t + '$';
            end;
            t := t + copy(s, i, 255) + ';';
            writeln(g, t);
          end;
          readln(f, s);
        end;
      writeln(g);
    end;
  end;

  writeln(g, '(*************************************************************)');
  writeln(g, '(*                    T   Y   P   E   S                      *)');
  writeln(g, '(*************************************************************)');
  writeln(g);
  writeln(g, 'type');
  writeln(g);
  while not eof(f) do
  begin
    readln(f, s);
    if s = SEPARATOR
      then break;
    if Copy(s, 1, 9 + length(GL)) = '#ifndef ' + GL + '_' then
    begin
      writeln(g, '(*** ' + Copy(s, 9, 255) + ' ***)');
      readln(f, s);
        while s <> '#endif' do
        begin
          if Copy(s, 1, 14) = 'DECLARE_HANDLE' then
          begin
            s := Copy(s, 16, length(s) - 17);
            writeln(g, '  ' + s + ' = cardinal;');
          end;
          if Copy(s, 1, 8) = 'typedef ' then
          begin
            Delete(s, 1, 8);
            t := Copy(s, 1, Pos(';', s) - 1);
            r := splitvar(t);
            r := checkname(r);
            t := converttype(t);
            writeln(g, '  ', r, ' = ', t, ';');
            writeln(g, '  P', r, ' = ^', r, ';');
            writeln(g, '  PP', r, ' = ^P', r, ';');  
          end;
          readln(f, s);
        end;
      writeln(g);
    end;
  end;

  writeln(g, '(*************************************************************)');
  writeln(g, '(*            F   U   N   C   T   I   O   N   S              *)');
  writeln(g, '(*************************************************************)');
  writeln(g);
  writeln(g, 'var');
  writeln(g);
  while not eof(f) do
  begin
    readln(f, s);
    if s = SEPARATOR
      then break;
    if Copy(s, 1, 9 + length(GL)) = '#ifndef ' + GL + '_' then
    begin
      writeln(g, '(*** ' + Copy(s, 9, 255) + ' ***)');
      readln(f, s);
        while s <> '#endif' do
        begin
          if Copy(s, 1, 8) = 'typedef ' then
          begin
            Delete(s, 1, 8);
            functype := Copy(s, 1, Pos('(', s) - 1);
            Delete(s, 1, length(functype));
            if functype[length(functype)] = ' ' then
              delete(functype, length(functype), 1);
            if functype = 'void*' then
            begin
              functype := 'void*';
            end;
            functype := converttype(functype);
            t := Copy(s, 1, Pos(')', s) - 1);
            while Pos(' ', t) <> 0 do Delete(t, 1, 1);
            Delete(t, 1, 3);
            Delete(t, length(t) - 3, 4);
            write(g, '  ' + t + ': ');
            if functype = 'GLvoid' then write(g, 'procedure')
                                   else write(g, 'function');
            Delete(s, 1, Pos(')', s));
            Delete(s, 1, Pos('(', s));
            Delete(s, Pos(')', s), 2);
            if uppercase(s) <> 'VOID' then
            begin
              s := s + ',';
              write(g, '(');
              while s <> '' do
              begin
                t := Copy(s, 1, Pos(',', s) - 1);
                r := splitvar(t);
                r := checkname(r);
                t := converttype(t);
                Delete(s, 1, Pos(',', s));
                write(g, r, ': ', t);
                if s <> '' then write(g, '; ');
              end;
              write(g, ')');
            end;
            if functype = 'GLvoid' then write(g, ';')
                                   else write(g, ': ' + functype + ';');
            writeln(g, ' stdcall;');
          end;
          readln(f, s);
        end;
      writeln(g);
    end;
  end;
  close(f);

  reset(f);
  repeat
    readln(f, s);
  until s = SEPARATOR; { skip header }
  repeat
    readln(f, s);
  until s = SEPARATOR; { skip tokens }
  repeat
    readln(f, s);
  until s = SEPARATOR; { skip types }
  while not eof(f) do
  begin
    readln(f, s);
    if s = SEPARATOR
      then break;
    if Copy(s, 1, 9 + length(GL)) = '#ifndef ' + GL + '_' then
    begin
      t := Copy(s, 9, 255);
      readln(f, s);
        while s <> '#endif' do
          readln(f, s);
      writeln(g, 'function Load_' + t + ': boolean;');
    end;
  end;
  writeln(g);
  close(f);

  writemiddle;

  reset(f);
  repeat
    readln(f, s);
  until s = SEPARATOR; { skip header }
  repeat
    readln(f, s);
  until s = SEPARATOR; { skip tokens }
  repeat
    readln(f, s);
  until s = SEPARATOR; { skip types }
  while not eof(f) do
  begin
    readln(f, s);
    if s = SEPARATOR
      then break;
    if Copy(s, 1, 9 + length(GL)) = '#ifndef ' + GL + '_' then
    begin
      writeln(g, '(*** ' + Copy(s, 9, 255) + ' ***)');
      writeln(g, 'function Load_' + Copy(s, 9, 255) + ': boolean;');
      writeln(g, 'begin');
      writeln(g, '  result := false;');
      readln(f, s);
        while s <> '#endif' do
        begin
          if Copy(s, 1, 7) = 'extern ' then
          begin
            Delete(s, 1, Pos('WINAPI ', s) + 6);
            Delete(s, Pos(' ', s), 255);
            writeln(g, '  ' + s + ' := wglGetProcAddress(''' + s + ''');');
            writeln(g, '  if not Assigned(' + s + ') then exit;');
          end;
          if Copy(s, 1, 6) = 'GLAPI ' then
          begin
            Delete(s, 1, Pos('APIENTRY ', s) + 8);
            Delete(s, Pos(' ', s), 255);
            writeln(g, '  ' + s + ' := wglGetProcAddress(''' + s + ''');');
            writeln(g, '  if not Assigned(' + s + ') then exit;');
          end;
          readln(f, s);
        end;
      writeln(g, '  result := true;');
      writeln(g, 'end;');
      writeln(g);
    end;
  end;

  writefooter;
  close(f);
  close(g);
  writeln('done!');
  readln;
end.
