summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/AspectC/Repo.pm40
-rw-r--r--lib/Kratos/DFADriver.pm17
-rw-r--r--lib/Kratos/DFADriver/Model.pm81
3 files changed, 131 insertions, 7 deletions
diff --git a/lib/AspectC/Repo.pm b/lib/AspectC/Repo.pm
index 6f59117..35bffbe 100644
--- a/lib/AspectC/Repo.pm
+++ b/lib/AspectC/Repo.pm
@@ -46,13 +46,33 @@ sub parse_xml {
my $filename = $node->getAttribute('filename');
my $id = $node->getAttribute('id');
if ( defined $id ) {
- $self->{files}[$id] = $filename;
+ $self->{files}{$id} = $filename;
}
else {
say STDERR "repo.acp: File ${filename} has no ID";
}
}
+ for my $aspect (
+ $xml->findnodes(
+ '/ac-model/root/Namespace[@name="::"]/children/Aspect'
+ . ' | /ac-model/root/Namespace[@name="::"]/children/Namespace'
+ )
+ )
+ {
+ my $aspect_name = $aspect->getAttribute('name');
+ for my $attr_node ( $aspect->findnodes('./children/Attribute') ) {
+ my $attr_name = $attr_node->getAttribute('name');
+ my $attr_id = $attr_node->getAttribute('id');
+ if ( defined $attr_id ) {
+ $self->{attributes}{$attr_id} = {
+ namespace => $aspect_name,
+ name => $attr_name,
+ };
+ }
+ }
+ }
+
for my $node (
$xml->findnodes('/ac-model/root/Namespace[@name="::"]/children/Class') )
{
@@ -70,7 +90,7 @@ sub parse_xml {
push(
@sources,
{
- file => $self->{files}[ $source->getAttribute('file') ],
+ file => $self->{files}{ $source->getAttribute('file') },
kind => $source_loc_kind[ $source->getAttribute('kind') ],
}
);
@@ -84,6 +104,7 @@ sub parse_xml {
my $name = $fnode->getAttribute('name');
my $id = $fnode->getAttribute('id') // q{?};
my $kind = $fnode->getAttribute('kind');
+ my $attributes = $fnode->getAttribute('attributes');
my $result_type = q{?};
my @args;
@@ -92,12 +113,23 @@ sub parse_xml {
$result_type = $typenode->getAttribute('signature');
}
- #print "$id $name $kind $result_type <- ";
for my $argnode ( $fnode->findnodes('./arg_types/Type') ) {
push( @args, $argnode->getAttribute('signature') );
}
- #say join( q{, }, @args );
+ my $fun = {
+ name => $name,
+ returns => $result_type,
+ argtypes => [@args],
+ };
+
+ if ($attributes) {
+ $fun->{attributes} = [
+ map { $self->{attributes}{$_}{name} }
+ split( qr{ \s+ }x, $attributes )
+ ];
+ }
+ $class->{function}{$name} = $fun;
}
$self->{class}{$class_name} = $class;
}
diff --git a/lib/Kratos/DFADriver.pm b/lib/Kratos/DFADriver.pm
index 8c8f780..7ceaa4a 100644
--- a/lib/Kratos/DFADriver.pm
+++ b/lib/Kratos/DFADriver.pm
@@ -35,11 +35,24 @@ sub new {
$self->{dfa} = Kratos::DFADriver::DFA->new(%opt);
$self->{mimosa} = MIMOSA->new(%opt);
- $self->{model} = Kratos::DFADriver::Model->new(%opt);
$self->{repo} = AspectC::Repo->new;
- $self->{class_name} = $self->{model}->class_name;
$self->{lp}{iteration} = 1;
+ if ( -r $opt{xml_file} ) {
+ $self->{model} = Kratos::DFADriver::Model->new(%opt);
+ $self->{class_name} = $self->{model}->class_name;
+ }
+ elsif ( $opt{class_name} ) {
+ $self->{model} = Kratos::DFADriver::Model->new_from_repo(
+ repo => $self->{repo},
+ class_name => $opt{class_name},
+ xml_file => $opt{xml_file},
+ );
+ }
+ else {
+ die('Neither driver.xml nor class name specified, cannot continue');
+ }
+
bless( $self, $class );
$self->set_paths;
diff --git a/lib/Kratos/DFADriver/Model.pm b/lib/Kratos/DFADriver/Model.pm
index 677fd99..f87b81c 100644
--- a/lib/Kratos/DFADriver/Model.pm
+++ b/lib/Kratos/DFADriver/Model.pm
@@ -8,7 +8,7 @@ use parent 'Class::Accessor';
use Carp;
use Carp::Assert::More;
-use List::Util qw(first);
+use List::Util qw(first uniq);
use XML::LibXML;
Kratos::DFADriver::Model->mk_ro_accessors(qw(class_name xml));
@@ -32,6 +32,85 @@ sub new {
return $self;
}
+sub new_from_repo {
+ my ( $class, %opt ) = @_;
+ my $repo = $opt{repo};
+ my $class_name = $opt{class_name};
+
+ my @states;
+ my %transition;
+
+ if ( not exists $repo->{class}{$class_name} ) {
+ die("Unknown class: $class_name\n");
+ }
+ my $class_base = $repo->{class}{$class_name};
+
+ for my $function ( values %{ $class_base->{function} } ) {
+ for my $attrib ( @{ $function->{attributes} // [] } ) {
+ if ( $attrib =~ s{ ^ src _ }{}x ) {
+ push( @states, $attrib );
+ push( @{ $transition{ $function->{name} }{src} }, $attrib );
+ }
+ elsif ( $attrib =~ s{ ^ dst _ }{}x ) {
+ push( @states, $attrib );
+ push( @{ $transition{ $function->{name} }{dst} }, $attrib );
+ }
+ else {
+ say "wat $attrib";
+ }
+ }
+ }
+
+ @states = uniq @states;
+ @states = sort @states;
+
+ my $xml = XML::LibXML::Document->new('1.0');
+
+ my $data_node = $xml->createElement('data');
+ my $driver_node = $xml->createElement('driver');
+ my $states_node = $xml->createElement('states');
+ my $transitions_node = $xml->createElement('transitions');
+
+ $driver_node->setAttribute( name => $class_name );
+
+ $xml->setDocumentElement($data_node);
+ $data_node->appendChild($driver_node);
+ $driver_node->appendChild($states_node);
+ $driver_node->appendChild($transitions_node);
+
+ for my $state (@states) {
+ my $state_node = $xml->createElement('state');
+ $state_node->setAttribute( name => $state );
+ $states_node->appendChild($state_node);
+ }
+ for my $transition ( sort keys %transition ) {
+ my $transition_node = $xml->createElement('transition');
+ my $level = $transition eq 'epilogue' ? 'epilogue' : 'user';
+ $transition_node->setAttribute( name => $transition );
+ for my $src_state ( @{ $transition{$transition}{src} } ) {
+ my $src_node = $xml->createElement('src');
+ my $src_name = $xml->createTextNode($src_state);
+ $src_node->appendChild($src_name);
+ $transition_node->appendChild($src_node);
+ }
+ for my $dst_state ( @{ $transition{$transition}{dst} } ) {
+ my $dst_node = $xml->createElement('dst');
+ my $dst_name = $xml->createTextNode($dst_state);
+ $dst_node->appendChild($dst_name);
+ $transition_node->appendChild($dst_node);
+ }
+ my $level_node = $xml->createElement('level');
+ my $level_name = $xml->createTextNode($level);
+ $level_node->appendChild($level_name);
+ $transition_node->appendChild($level_node);
+ $transitions_node->appendChild($transition_node);
+ }
+
+ $xml->toFile( $opt{xml_file} );
+
+ return $class->new(%opt);
+}
+
sub parse_xml_property {
my ( $self, $node, $property_name ) = @_;
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 03:33:18 +0000