LLVM wrapper generator

wrapper.pl

use strict;

my $file = $ARGV[0];
my @data = ();

my @cast_types = ("AtomicOrdering", "SynchronizationScope", "BinOp", "BinaryOps", "Predicate", "OtherOps");
my @prim_types = ("bool", "unsigned", "unsigned short", "uint8_t", "uint16_t", "uint32_t", "uint64_t", "int8_t", "int16_t", "int32_t", "int64_t", "float", "double");

unlink "$file.h";
unlink "$file.cpp";

my $class = "";
my $base = "";
my @decl = ();
my $public = 0;
open F, $file;
while (<F>)
{
  if (/^class (\w+)(?:\s*:\s*([\w <>,]+))?/)
  {
    $class = $1;
    $base = $2;
  }

  if ($class and /^\};/) {
    &manage_class();
    @data = ();
    $class = 0;
    $public = 0;
  } elsif (/^(\w+):/) {
    $public = ($1 eq "public");
  } elsif ($public) {
    push @data, $_;
  }
}
close F;


my $constr_inhr;
my @private_vars;
sub manage_class
{
  $constr_inhr = "";
  foreach (split /,\s*/, $base)
  {
    if (/public (\w+?[^\s])\s*$/)
    {
      $constr_inhr .= "\t\t, $1(base)\n";
    }
  }

  @private_vars = ();

  my $text = join "", @data;
  $text =~ s/enum (\w+\s*\{[^\}]+\};)/ push @decl, "enum class $1"; "" /mes;
  $text =~ s/\{.*?\}//mgs;
  $text =~ s/\/\/.*//g;
  $text =~ s/,\s*\n\s*/, /mg;
  $text =~ s/\(\s*\n\s*/(/mg;
  $text =~ s/\s*\n\s*\)/)/mg;
  $text =~ s/^\s*\n//mg;

  $text =~ s/(?<=[a-zA-Z])\s+(?=\()//g;
  $text =~ s/(?:\s*;\s*|(?<![;\s])\s*)$/;/mg;
  $text =~ s/ const;$/;/mg;
  $text =~ s/^  /\t/mg;

  my $header = "";
  my $code = "";

  foreach (split /\n+/, $text)
  {
    if (/\t+
         ((?:static\ )?)
         ((?:explicit\ )?(?:virtual\ )?(?:inline\ )?)
         ((?&TYPE))?(?(3)\ )
         ([*&]?)(\w+)
        \(
        ((?&ARG)(?:,\s*(?&ARG))*)?
        ((?(6),\s*)(?&ARG)(?&DEF)(?:,\s*(?&ARG)(?&DEF))*)?
        \)
        (?:\s*:\s*\w+[^;]+)?\s*;

        (?(DEFINE)
         (?<TYPE>(?:\w+::)?[\w ]+(?:<(?:\w+::)?\w+\s*(?:\*\s*)?>)?)
         (?<ARG>(?&TYPE)(?:\ [*&]?\w+)?)
         (?<DEF>\s*=\s*(?:\w+(?:\(\))?|\"\"))
        )
        /x)
    {
      my ($h, $c) = &trans_func($1, $2, $3, $4, $5, $6, $7);
      $header .= $h;
      $code .= $c;
    }
    else
    {
      $header .= "\t//" . (substr $_, 1) . "\n";
    }
  }


  open H, ">> $file.h";
  print H "public ref class $class\n";
  print H "\t: $base\n" if ($base);
  print H "{\n";
  if (@private_vars)
  {
    print H "private:\n";
    foreach (@private_vars)
    {
      print H "\t$_;\n";
    }
    print H "\n";
  }
  print H <<EOF;
internal:
\tllvm::$class *base;
\t$class(llvm::$class *base)
\t\t: base(base)
$constr_inhr\t{
\t}

public:
\t!$class()
\t{
\t}
\tvirtual ~$class()
\t{
\t\tthis->!$class();
\t}
EOF
  foreach (@decl)
  {
    s/  /\t/g;
    s/\s*\/\/.+//g;
    s/ \{/\n\t{/;
    print H "\t$_\n";
  }
  print H $header;
  print H "};\n\n";
  close H;

  open C, ">> $file.cpp";
  print C $code;
  print C "\n";
  close C;
}

sub trans_func
{
  my ($static, $mod, $type, $ptr, $name, $arg, $varg) = @_;
  $arg =~ tr/*/^/;
  my @args = split /,\s*/, $arg;
  $varg =~ tr/*/^/;
  $varg =~ s/\s*=\s*\w+//g;
  my @vargs = split /,\s*/, $varg;
  push @vargs, "" if (@vargs == 0);

  my $constr = "";
  my $pre = "";
  my $post = "";
  my $constructor = ((not $type) and ($name eq $class));
  my $store = 0;
  my $use_ctx = 0;
  my @arg_call = ();

  for (my $i = 0; $i <= $#args; $i++)
  {
    ($args[$i], $arg_call[$i], $constr, $pre, $post, $store, $use_ctx)
      = &manage_arg($args[$i], $constr, $pre, $post, $store, $use_ctx, $constructor);
  }

  my $array = 0;
  if ($type =~ /ArrayRef<((?:\w+::)?\w+)\s*(\*?)>/)
  {
    $store++;
    $post .=
        "\tarray<$1$2> ^s = gcnew array<$1$2>(r.size());\n"
      . "\tfor (int i = 0; i < s->Length; i++)\n"
      . "\t\ts[i] = " . &make_call("$1$2 ^r[i]") . ";\n"
      . "\treturn s;\n";
    $type = "array<$1$2>";
    $ptr = 1;
    $array = 1;
  }
  elsif ($type eq $class)
  {
    $ptr = 1;
  }

  if (($type eq "const char" and $ptr)
      or $type eq "StringRef"
      or $type eq "std::string")
  {
    $type = "System::String";
    $ptr = 1;
  }

  my $call_by;
  if ($constructor)
  {
    $mod = "";
    $call_by = "new llvm::";
  }
  else
  {
    $mod .= "$type " . ($ptr ? "^" : "");
    $mod =~ s/explicit //;
    $call_by = ($static ? "llvm::${class}::" : "base->");
  }

  my $header = "";
  my $code = "";
  foreach (@vargs)
  {
    if ($_)
    {
      my ($a, $c);
      ($a, $c, $constr, $pre, $post, $store, $use_ctx)
        = &manage_arg($_, $constr, $pre, $post, $store, $use_ctx, $constructor);
      push @args, $a;
      push @arg_call, $c;
    }

    my $call = "$call_by$name(" . join(', ', @arg_call) . ")";
    if ($ptr)
    {
      if ($type eq "System::String") {
        $call = "utils::manage_str($call)";
      } elsif (not $array) {
        $call = "gcnew $type($call)";
      }
    }
    if (grep { $_ eq $type } @cast_types)
    {
      $call = "safe_cast<$type>($call)";
    }

    $header .= "\t$static$mod$name(" . join(', ', @args) . ");\n";
    $code .= "$mod${class}::$name(" . join(', ', @args) . ")\n"
        . ($constructor ? "\t: ${constr}base($call)\n" . &reduce_indent($constr_inhr) : "")
        . "{\n"
        . $pre
        . ($constructor ? ""
          : "\t"
          . ($store ? "auto r = " : "return ")
          . $call . ";\n")
        . $post
        . "}\n";
  }

  return ($header, $code);
}

sub manage_arg
{
  my ($arg, $constr, $pre, $post, $store, $use_ctx, $constructor) = @_;
  my ($r, $call);

  if ($arg =~ /ArrayRef<(\w+::)?(\w+)\s*(\^)?> (\w+)/)
  {
    my $hdl = ("$1$2" eq $class ? "^" : $3);
    $r = "array<$1$2$3> ^$4";
    if ($1 or $hdl)
    {
      my $n = chr(97 + $store);
      my $m = $n . "rr";
      $pre .=
          "\tllvm::$1$2 **$n = new llvm::$1$2 *[$4->Length];\n"
        . "\tfor (int i = 0; i < $4->Length; i++)\n"
        . "\t\t${n}[i] = " . &make_call("$1$2 $hdl${4}[i]") . ";\n"
        . "\tllvm::ArrayRef<llvm::$1$2 *> $m($n, $4->Length);\n";
      $call = $m;
      $post = "\tdelete $n;\n" . $post;
      $post .= "\treturn r;\n" if ($store++ == 0);
    }
    else
    {
      $call = "utils::unmanage_array($4)";
    }
  }
  elsif ($arg =~ /(?:const Twine|const char|StringRef)\s*[\^&]?\s*(\w+)/)
  {
    $r = "System::String ^$1";
    if ((grep { $_ == "msclr::interop::marshal_context ^ctx" } @private_vars) == 0)
    {
      push @private_vars, "msclr::interop::marshal_context ^ctx";
    }
    if (not $use_ctx)
    {
      $use_ctx = 1;
      if ($constructor) {
        $constr .= "ctx(gcnew msclr::interop::marshal_context())\n\t, ";
      } else {
        $pre .= "\tauto ctx = gcnew msclr::interop::marshal_context();\n";
      }
      $post .= "\tdelete ctx;\n";
      $post .= "\treturn r;\n" if ($store++ == 0 and not $constructor);
    }
    $call = "ctx->marshal_as<const char *>($1)";
  }
  elsif ($arg =~ /^(\w+)$/)
  {
    $call = $1;
    $r = "$1 ";
    $call =~ s/^([A-Z])/ lc($1) /e;
    $r .= $call;
  }
  else
  {
    $r = $arg;
    $call = &make_call($arg);
  }

  $r =~ tr/&/^/;

  return ($r, $call, $constr, $pre, $post, $store, $use_ctx);
}

sub make_call
{
  $_ = $_[0];
  if (/^(\w+::\w+) (\w+(?:\[\w+\])?)$/)
  {
    return "safe_cast<llvm::$1>($2)";
  }
  elsif (/^([\w ]+) (\w+(?:\[\w+\])?)$/)
  {
    if (grep { $_ eq $1 } @cast_types) {
      return "safe_cast<llvm::$1>($2)";
    } else {
      return "$2";
    }
  }
  elsif (/^[\w ]+ ([\^&])(\w+(?:\[\w+\])?)$/)
  {
    return ($1 eq "&" ? "*" : "") . "$2->base";
  }
  elsif (/^[\w ]+ \^(\w+(?:\[\w+\])?)$/)
  {
    return "$1->base";
  }
  return "?";
}

sub reduce_indent
{
  my $s = $_[0];
  $s =~ s/\t\t/\t/g;
  return $s;
}