yxml-gen.pl

#!/usr/bin/perl

#  Copyright (c) 2013 Yoran Heling
#
#  Permission is hereby granted, free of charge, to any person obtaining
#  a copy of this software and associated documentation files (the
#  "Software"), to deal in the Software without restriction, including
#  without limitation the rights to use, copy, modify, merge, publish,
#  distribute, sublicense, and/or sell copies of the Software, and to
#  permit persons to whom the Software is furnished to do so, subject to
#  the following conditions:
#
#  The above copyright notice and this permission notice shall be included
#  in all copies or substantial portions of the Software.
#
#  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
#  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
#  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
#  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
#  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
#  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
#  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

use strict;
use warnings;

my $machine_fn = 'yxml-states';
my $code_fn = 'yxml.c.in';
my $out_fn = 'yxml.c';


my %states;


sub condtoc {
  local $_ = shift;
  return "yxml_is$1(ch)" if /^([a-zA-Z]+)$/;
  return join ' || ', map "ch == (unsigned char)$_", split /\|/ if /^'/;
  return "x->$1 == ch" if /^\$(.+)$/;
  die "Unknown condition: $_\n";
}


sub acttoc {
  my $next = shift;
  my(@c, @r);
  # XXX: Return values of function calls are or'ed together to create the
  # return value of yxml_parse(). This only works when the function do not
  # return an error code. Functions that may return an error should NOT be
  # called in the same state as other functions.
  for(@_) {
    push @r, "yxml_$1(x, ch)" if /^([a-z0-9_]+)$/;
    push @c, "x->$1 = ch" if /^\$(.+)$/;
    if(/^"/) {
      push @c, (
        "x->nextstate = YXMLS_$$next",
        "x->string = (unsigned char *)$_"
      );
      $$next = 'string';
    }
    push @c, "x->nextstate = YXMLS_$_" if s/^@//;
  }
  (
    map("$_;", @c),
    'return ' . (@r ? join('|', @r) : 'YXML_OK') . ';'
  )
}


sub gencode {
  my($state, @desc) = @_;

  my @code = ("case YXMLS_$state:");
  for(@desc) {
    my($cond, @act) = split / /;
    die "Invalid state description for $state\n" if !@act;
    my $next = pop @act;
    $cond = condtoc $cond;
    @act = acttoc \$next, @act;
    my $needbrack = $next ne $state || @act > 1;
    push @code,
      "\tif($cond)".($needbrack ? ' {':''),
      $next eq '@'    ? "\t\tx->state = x->nextstate;" :
      $next ne $state ? "\t\tx->state = YXMLS_$next;" : (),
      map("\t\t$_", @act),
      ($needbrack ? "\t}" : ());
  }
  push @code, "\tbreak;";
  return join "\n", map "\t$_", @code;
}


sub readmachine {
  local @ARGV = ($machine_fn);
  while(<>) {
    chomp;
    s/[ \t]+/ /g;
    s/^ //;
    s/ $//;
    next if !$_ || /^#/;
    die "Unrecognized line: $_\n" and next if !/^([a-z0-9]+) (.+)$/;
    my($state, @desc) = ($1, split / *; */, $2);
    die "State '$state' specified more than once.\n" if $states{$state};
    $states{$state} = gencode $state, @desc;
  }
}


sub writeout {
  local @ARGV = ($code_fn);
  open my $F, '>', $out_fn or die $!;
  print $F "/* THIS FILE IS AUTOMATICALLY GENERATED, DO NOT EDIT! */\n\n";
  while(<>) {
    s#/\*=STATES=\*/#join ",\n", map "\tYXMLS_$_", sort keys %states#e;
    s#/\*=SWITCH=\*/#join "\n", map $states{$_}, sort keys %states#e;
    print $F $_;
  }
}


readmachine;
writeout;