use
5.00503;
use
vars
qw( $VERSION @ISA $parrot $DEBUG )
;
@ISA
=
qw( Inline )
;
BEGIN {
$VERSION
=
'0.1201'
;
$DEBUG
= 0;
$parrot
= Inline::Parrot::parrot->new(
parrot_options
=> [],
debug
=> 0,
);
print
__PACKAGE__ .
"::DEBUG is on.\n"
if
$DEBUG
;
}
sub
register {
return
{
language
=>
'Parrot'
,
aliases
=> [
'parrot'
,
'pir'
],
type
=>
'interpreted'
,
suffix
=>
'pir'
,
};
}
sub
usage_config {
}
sub
usage_config_bar {
}
sub
validate {
}
sub
build {
my
$o
=
shift
;
my
$code
=
$o
->{API}{code};
my
$pattern
=
$o
->{ILSM}{PATTERN};
my
$path
= File::Spec->catdir(
$o
->{API}{install_lib},
'auto'
,
$o
->{API}{modpname});
my
$obj
=
$o
->{API}{location};
$o
->mkpath(
$path
)
unless
-d
$path
;
print
"saving preprocessed code snippet [ $code ] into file [ $obj ] \n"
if
$DEBUG
;
open
PARROT_OBJ,
"|-"
,
$parrot
->{parrot_file_name} .
" -E - > $obj"
or croak
"Can't open Parrot preprocessor for file $obj\n$!"
;
print
PARROT_OBJ
$code
;
close
\
*PARROT_OBJ
;
}
my
@sub_name
;
my
%sub_param
;
my
%sub_prototyped
;
sub
load {
my
$o
=
shift
;
my
$obj
=
$o
->{API}{location};
open
PARROT_OBJ,
"< $obj"
or croak
"Can't open $obj for output\n$!"
;
my
@code
= <PARROT_OBJ>;
close
\
*PARROT_OBJ
;
my
$package
=
$o
->{API}{pkg};
my
$sub_name
=
""
;
for
(
@code
)
{
if
( m/^\s*\.pcc_sub\s+(\w+)/ )
{
push
@sub_name
, $1;
$sub_name
= $1;
$sub_prototyped
{
$sub_name
} = m/\bprototyped\b/ ?
"prototyped"
:
"non_prototyped"
;
$sub_param
{
$sub_name
} = [];
}
if
( m/^\s*\.param\s+(\w+)\s+(\w+)/ )
{
push
@{
$sub_param
{
$sub_name
} }, {
type
=> $1,
name
=> $2 };
}
}
my
$status
=
$parrot
->compile(
join
''
=>
@code
);
print
"parrot compiler returned status: \n$status --\n"
if
$DEBUG
;
unless
(
$status
=~ m/\n\$\
$ret
\$\$\n/ )
{
my
(
$error
) =
$status
=~ m/\$\
$start
\$\$\n(.*)/s;
warn
"Error compiling Parrot, near subroutine \"$sub_name\" "
.
" in package $package: $error\n"
;
}
my
$inline_package
= __PACKAGE__;
for
my
$sub_name
(
@sub_name
)
{
my
$perl_accessor
= '
package
'.$package.'
;
sub
'.$sub_name.'
{
print
"start parrot sub '.$sub_name.' \n"
if
$Inline::Parrot::DEBUG
;
my
(
$param
,
$value
) =
'.$inline_package.'
::_setup_parrot_parameters(
"'.$sub_name.'"
,
@_
);
my
$cmd
=
"_start_sub_'.$sub_name.'\n"
.
".pcc_sub _start_sub_'.$sub_name.'\n"
.
" \$P1 = P1\n"
.
" .local pmc sub\n"
.
$param
.
" .pcc_call sub\n"
.
" .pcc_end\n"
.
" P1 = \$P1\n"
.
".end\n"
;
my
$status
=
$Inline::Parrot::parrot
->compile_and_run(
$cmd
,
$value
);
print
"parrot returned status: \n$status --\n"
if
$Inline::Parrot::DEBUG
;
unless
(
$status
=~ m/\n\$\
$ret
\$\$\n/ )
{
my
(
$error
) =
$status
=~ m/\$\
$start
\$\$\n(.*)/s;
warn
"Runtime error calling Parrot subroutine \"'.$sub_name.'\" "
.
"in package '.$package.': $error\n"
;
}
my
(
$stdout
,
$return
) =
$status
=~
m/\$\
$start
\$\$\n(.*)\n\$\
$ret
\$\$\n(.*)\$\
$end
\$\$/s;
print
$stdout
if
$stdout
;
my
@return
=
split
/\n/s ,
$return
;
my
$prototyped
=
shift
@return
;
my
$int_count
=
shift
@return
;
my
$string_count
=
shift
@return
;
my
$pmc_count
=
shift
@return
;
my
$float_count
=
shift
@return
;
my
@ret
;
while
(
@return
)
{
my
$strlen
=
shift
@return
;
my
$str
;
$str
=
shift
@return
;
while
(
length
(
$str
) <
$strlen
)
{
$str
.=
"\n"
;
my
$s
=
shift
@return
;
$str
.=
$s
if
defined
$s
;
}
push
@ret
,
$str
;
}
@return
=
@ret
;
return
$return
[0]
unless
$#return
;
return
@return
;
}
';
eval
$perl_accessor
;
croak
"Unable to load Parrot module $sub_name:\n$@"
if
$@;
}
}
sub
info {
}
sub
_setup_parrot_parameters {
my
$sub_name
=
shift
;
my
@param
= @{
$sub_param
{
$sub_name
} };
my
$param
=
""
;
my
$value
=
""
;
my
$param_count
=
scalar
@_
;
$param
.=
" find_global sub, \"$sub_name\" \n"
;
for
( 0 ..
$#_
)
{
my
$def
=
$param
[
$_
];
my
$val
=
$_
[
$_
];
if
(
$def
)
{
$param
.=
" .local $def->{type} $def->{name}\n"
;
$param
.=
" read \$S12, "
.
length
(
$val
) .
"\n"
;
$param
.=
" set $def->{name}, \$S12\n"
;
$value
.=
$val
;
}
else
{
$param
.=
" .local string var$_\n"
.
" set var$_, \"$val\"\n"
;
}
}
$param
.=
" .pcc_begin $sub_prototyped{ $sub_name } \n"
;
for
( 0 ..
$#_
)
{
my
$def
=
$param
[
$_
];
my
$val
=
$_
[
$_
];
if
(
$def
)
{
$param
.=
" .arg $def->{name}\n"
;
}
else
{
$param
.=
" .arg var$_\n"
;
}
}
return
(
$param
,
$value
);
}
1;