*** ACL test ***

global k l m

program teste2
  define x
  for x=1 to 10
    print "["
    print k
    print "]"
    delay 10
  endfor
end

program teste

define x y

set x = 10
set k = x + 1

print "k="
println k

for x=1 to 2
  for y=5 to 4
    print x
    print " "
    println y
    if y = 4
       andif x = 1
      println " y = 4 && x = 1 "
    else
      println " ... "
    endif
    set k = k + 1
    delay 10
  endfor
endfor

stop teste2

goto 1

println "nada"

label 1

end

run teste2
gosub teste
gosub teste

read "type a value" k
println k

stop

run teste2
println "end"

##</code><code>##

#!/usr/bin/perl
use strict;

use threads;
use threads::shared;
$|=1;

use Getopt::Long;

{

my $debug = 0;
my $preprocess = 0;
my $help = 0;
my $result = GetOptions ( 
    "debug" => \$debug, "perl" => \$preprocess, "help" => \$help );
my $source_name = shift;
my $source;
open ( $source, '<', $source_name ) 
    or die "$!";
my $program;

sub _val {  ( $_[0] =~ /^[a-z]/ ) ? "\$@_" : "@_" }
sub _op { local $_ = shift; s/^=$/==/; $_ }

my %_interpreta = (
    '' =>      sub { },
    '*' =>     sub { },
    quiet =>   sub { },
    if =>      sub { "if ( ( " . join( ' ', map { _op(_val($_)) } @_ ) . " )" },
    andif =>   sub { "  && ( " . join( ' ', map { _op(_val($_)) } @_ ) . " )" },
    orif =>    sub { "  || ( " . join( ' ', map { _op(_val($_)) } @_ ) . " )" },
    __fi =>    sub { "   ) {\n" }, 
    else =>    sub { "} else {" },
    endif =>   sub { "}" },
    program => sub { $program = $_[0]; "sub @_ {"; },
    end =>     sub { undef $program; "}"; },
    gosub =>   sub { "undef \$thread{$_[0]}; @_();" },
    run =>     sub { 'undef $thread{' . $_[0] . '}; threads->new(\&' . $_[0] . ');' },
    priority => sub { "" },
    label =>   sub { "L@_: ;" },
    goto =>    sub { "goto L@_;" },
    print =>   sub { 'print ' . _val(@_) . ";" },
    println => sub { 'print ' . _val(@_) . ', "\n"' . ";" },
    define =>  sub { 
        "my (" . join( ",", map { _val($_) } @_ )  . ");\n" .
        join( "\n", map { _val($_) . " = 0;" } @_ ) 
    },
    global =>  sub { 
        "use vars qw(" . join( " ", map { _val($_) } @_ )  . ");\n" .
        join( "\n", map { _val($_) . " = 0;" } @_ ) . "\n" .
        join( "\n", map { "share(" . _val($_) . ");" } @_ )
    },
    set =>     sub { join( ' ', map { _val($_) } @_ ) . ";" },
    delay =>   sub { 'select( undef, undef, undef, ' . _val(@_) . "/100.0 );" },
    for =>     sub {
        my ( $nome, $igual, $ini, $to, $end ) = @_;
        $nome = _val( $nome );
        $ini =  _val( $ini );
        $end =  _val( $end );
        "for ( $nome = $ini; " .
            "( $ini <= $end ? $nome <= $end : $nome >= $end ); " .
            "$nome += ( $ini <= $end ? 1 : -1 ) ) {";
    },
    endfor =>  sub { "}"; },
    read =>    sub { 
        join( "\n", map {
            /^[a-z]/ ?
            'print " > ";' . "\n" . _val($_) . " = <>; chomp "  . _val($_) . ";" :
            'print ' . _val($_) . ";"
        } @_ )
    },
    stop =>    sub {
        return "\$thread{$_[0]} = 1;" if $_[0];
        '$thread{$_} = 1 for keys %thread;'
    }
);

if ( $help )
{
    print "acl - interpreter for the ACL (Advanced Control Language) robot control language\n";
    print "\n";
    print "  ./acl [--perl] [--debug] program.acl\n";
    print "\n";
    print "  ACL commands:\n";
    print "    " . $_ . "\n" for grep { $_ ne '' && $_ !~ /_/ } sort keys %_interpreta;
    exit;
}

my $out = <<'EOT';
#!/usr/bin/perl
use strict; 
use threads;
use threads::shared;
$|=1;
use vars qw( %thread );
share( %thread );
EOT

my $if = 0;
while (<$source>)
{
    chomp;
    my $src = $_;
    lc;
    $_ =~ s/([=\*])/ $1 /;
    s/^\s+|\s+$//g;

    # perlfaq -  How can I split a [character] delimited string ...
    my @t;
    push(@t, defined($1) ? $1:$3) 
	while m/("[^"\\]*(\\.[^"\\]*)*")|([^\s]+)/g;
    my $cmd = shift @t;

    die "Unknown command $cmd" unless exists $_interpreta{$cmd};
    if ( $if && $cmd ne 'andif' && $cmd ne 'orif' ) {
        $if = 0;
        $out .= $_interpreta{__fi}();
    }
    $if = 1 if $cmd eq 'if';
    $out .= $_interpreta{$cmd}(@t);
    $out .= " return if \$thread{$program};" if $program && $cmd && ! $if;
    $out .= "    \t# $src" if $cmd && $debug;
    $out .= "\n";
}
$out .= <<'EOT';
           foreach my $thr (threads->list) {
               # Don't join the main thread or ourselves
               if ($thr->tid && !threads::equal($thr, threads->self)) {
                   $thr->join;
               }
           }
EOT

close ( $source );

print $out if $preprocess;
print STDERR $out if $debug && ! $preprocess;
if ( ! $preprocess )
{
    eval {
        eval $out or die "$!";
    };
    if ( $@ )
    {
        print STDERR "Run time error: $@\n"
            unless $@ =~ /ioctl/;
    }
}

}

__END__

=head1 NAME

acl - interpreter for the ACL (Advanced Control Language) robot control language

=head1 SYNOPSIS

Run a program

  $ ./acl test.acl    

Show how Perl would execute a program

  $ ./acl --perl test.acl

=head1 AUTHOR

Flavio S. Glock <fglock@pucrs.br>

=head1 COPYRIGHT

Copyright (c) 2005 Flavio S. Glock.  All rights reserved.  This
program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut