objgen

#!/usr/bin/perl

#   Copyright © 2008 Sam Chapin
#
#   This file is part of Gospel.
#
#   Gospel is free software: you can redistribute it and/or modify
#   it under the terms of version 3 of the GNU General Public License
#   as published by the Free Software Foundation.
#
#   Gospel is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with Gospel.  If not, see <http://www.gnu.org/licenses/>.


# Convert a GoSPeL identifier to a C identifier.
sub cname {
  my $name = ucfirst shift;
  $name =~ s/:/_/g;
  return $name;
}

$id = qr/[[:alnum:]]*[[:alpha:]][[:alnum:]]*/;
$ids = qr/$id(?::(?:$id:)*)?/;
while (<>) {
  if    (/^(\#.*| *)$/          ) {                                                            }
  elsif (/^&((?:$id:?)+)/       ) { push @symbols, $1;                                         }
  elsif (/^@($id) ($id) ?(.*)$/ ) { $parent{$currentObject = $1} = $2;
                                    $objects{$currentObject} = {};
                                    $hidden{$currentObject} = $3;
                                    $currentMethod = 0;                                        }
  elsif (/^~($id) ([^\n]*)$/    ) { $exceptions{$currentObject}{$1} = $2;                      }
  elsif (/^[!?]($ids)/          ) { $methods{$currentMethod = $1} = $1;                        }
  elsif (/^[!?]([^ ]+) ($ids)/  ) { $methods{$currentMethod = $2} = $1;                        }
  elsif (/^\$($id) ([^\n]+)/    ) { push @{$constants{$currentObject}}, [$1, $2];              }
  elsif (/^\$($id)/             ) { push @{$constants{$currentObject}}, [$1, "o" . cname($1)]; }
  else {
    if ($currentMethod) { $objects{$currentObject}{$currentMethod} .= $_; }
    else                { $dispatchMethods{$currentObject} .= $_;         }
  }
}

sub slotCount {
  $_ = shift;
  return (keys %{$objects{$_}})
       + @{$constants{$_}}
       + (keys %{$exceptions{$_}});
}

open HEADER, ">objects.h" or die("ObjGen couldn't write objects.h");
open SOURCE, ">objects.c" or die("ObjGen couldn't write objects.c");

print HEADER "#ifndef OBJECTS_H\n#define OBJECTS_H\n\nobj ",
      (join "\n  , ",
           (map { "o" . cname $_ } keys %objects),
           (map { "s" . cname $_ } @symbols, keys(%methods)),
           (map { join "\n  , ", map { "s" . cname $_->[0] } @$_ } values %constants),
           (map { join "\n  , ", map { "e" . cname $_ } keys %$_ } values %exceptions)),
      ";\n\n#endif\n";

sub emitMethod {
  print SOURCE "int $_[0]() {\n",
               "  obj target = continuationTarget(threadContinuation(currentThread));\n",
               "  $_[1]\n",
               "}\n";
}

foreach $object (keys %objects) {
  emitMethod "m" . cname($object) . cname($_), $objects{$object}{$_} foreach (keys %{$objects{$object}});
  emitMethod "m" . cname($object) . "_", $dispatchMethods{$object} if $dispatchMethods{$object};
}

print SOURCE "void initializeObjects() {\n";
# Objects need to be initialized first, since the symbols and exceptions that come next will refer
# to the values of object identifiers for their prototypes.
print SOURCE "  o", cname($_), " = newObject(NIL, emptyVector, emptyVector, NIL);\n"
 foreach(keys %objects);
print SOURCE "\n";
foreach $objectExceptions (values %exceptions) {
  print SOURCE "  e", cname($_), " = string(\"$objectExceptions->{$_}\");\n"
   foreach(keys %$objectExceptions);
}
foreach (keys %methods) {
  print SOURCE "  s", cname($_), " = symbol(\"$methods{$_}\");\n";
}
foreach (@symbols) {
  print SOURCE "  s", cname($_), " = symbol(\"$_\");\n";
}
foreach $objectConstants (values %constants) {
  print SOURCE "  s", cname($_->[0]), " = symbol(\"$_->[0]\");\n"
   foreach (@$objectConstants);
}

foreach $object (keys %objects) {
  print SOURCE "\n  setHiddenData(o", cname($object), ", ", $hidden{$object}, ");"
   if ($hidden{$object} !~ /^ *$/);
  print SOURCE "\n  setProto(o", cname($object), ", o", cname($parent{$object}), ");";
  print SOURCE "\n  setDispatchMethod(o", cname($object), ", primitive(m", cname($object), "_));"
   if ($dispatchMethods{$object});
  print SOURCE "\n  setSlots(o",
               cname($object),
               ", newVector(",
               (scalar(keys %{$objects{$object}})
                + scalar(@{$constants{$object}})
                + scalar(keys %{$exceptions{$object}})) * 3;
               
  print SOURCE "\n  , s",
               cname($_),
               ", primitive(m",
               cname($object),
               cname($_),
               "), oNamespaceCanon"
   foreach (keys %{$objects{$object}});
  print SOURCE "\n  , s",
                cname($_->[0]),
                ", $_->[1], oNamespaceCanon"
   foreach (@{$constants{$object}});
  print SOURCE "\n  , symbol(\"$_\"), e",
               cname($_),
               ", oNamespaceCanon"
   foreach (keys %{$exceptions{$object}});
  print SOURCE "\n  ));\n";
}
print SOURCE "}\n";