package Perl6::Run::OnPerl5::X1::Api;
use strict;
use vars qw($VERSION @ISA @EXPORT);
require Exporter;
$VERSION = '0.01';
@ISA = qw(Exporter);
@EXPORT =
qw(
p6_is_object
p6_is_perl6_object
p6_is_native
p6_ref
p6_isa
p6_undef
p6_bool
p6_bit
p6_int
p6_num
p6_str
p6_Undef
p6_Bool
p6_Bit
p6_Int
p6_Num
p6_Rat
p6_Str
p6_Pair
p6_Array
p6_Hash
p6_Ref
p6_List
p6_Scalar
p6_new
p6_new_code_CODE
p6_code_mk_CODE
p6_as_bool
p6_as_num
p6_as_str
p6_as_array
p6_as_hash
p6_as_perl5_whatever
p6_perl6_objects_from_whatever
p6_meta
p6_meta_CODE
p6_initialize_package
p6_wrap_code_with_package
p6_eval
p6_eval_file
p6_macrop5
p6_def_macrop5
p6_container_for_var_CODE
p6_var_CODE
p6_var
p6_assign
p6_setq
p6_bind
p6_mangle
p6_apply
p6_applym
p6_return_CODE
p6_catch_return_CODE
p6_loop_CODE
p6_last_CODE
p6_next_CODE
p6_redo_CODE
p6_die
p6_to_perl
p6_defined
p6_declare_package
);
#cat other/api06.pl |perl -wne '/^sub (p6_\S+)/ and print(" " x 7,$1,"\n");'
our @CARP_NOT = (__PACKAGE__);
my $ROOT = "Perl6::Run::OnPerl5::X1::Root";
=pod
https://svn.perl.org/perl6/doc/trunk/design/syn/S06.pod
bit single native bit
int native integer
str native string (sequence of integers, no Unicode)
num native floating point
ref native pointer
bool native boolean
Bit Perl single bit (allows traits, aliasing, etc.)
Int Perl integer (allows traits, aliasing, etc.)
Str Perl string (Unicode semantics)
Num Perl number
Complex Perl complex number
Ref Perl reference
Bool Perl boolean
Array Perl array
Hash Perl hash
IO Perl filehandle
Code Base class for all executable objects
Routine Base class for all nameable executable objects
Sub Perl subroutine
Method Perl method
Submethod Perl subroutine acting like a method
Macro Perl compile-time subroutine
Rule Perl pattern
Block Base class for all unnameable executable objects
Bare Basic Perl block
Parametric Basic Perl block with placeholder parameters
Package Perl 5 compatible namespace
Module Perl 6 standard namespace
Class Perl 6 standard class namespace
Object Perl 6 object
Grammar Perl 6 pattern matching namespace
List Perl list
Lazy Lazily evaluated Perl list
Eager Non-lazily evaluated Perl list
=cut
sub p6_is_object {!p6_is_native(@_)}
sub p6_is_perl6_object {
my $ref = ref($_[0]);
$ref eq 'Dispatchable';
}
sub p6_is_native {
my $ref = ref($_[0]);
!$ref || $ref ne 'Dispatchable';
}
sub ref_flavor {
my $x = shift;
return 'undef' if !defined $x;
my $ref = ref($x);
if(!$ref) {
return 'non_numeric' if !((~$x & $x) eq 0);
return 'numeric';
}
if($ref eq 'SCALAR') {
return 'scalar_non_numeric' if !((~$$x & $$x) eq 0);
return 'scalar_numeric';
}
return lc($ref) if $ref =~ /\A(?:ARRAY|HASH|CODE|REF|GLOB|LVALUE)\z/;
return 'perl5_object' if $ref ne 'Dispatchable';
return 'perl6_object';
}
sub p6_ref {
my $x = shift;
return 'undef' if !defined $x;
my $ref = ref($x);
if(!$ref) {
return 'str' if !((~$x & $x) eq 0);
return 'int' if int($x) == $x;
return 'num';
}
return lc($ref) if $ref =~ /\A(?:SCALAR|ARRAY|HASH|CODE|REF|GLOB|LVALUE)\z/;
return 'perl5:$ref' if $ref ne 'Dispatchable';
return $ref->ref();
}
sub p6_isa {
my($x,$cls)=@_;
my $ref = ref($x);
if($ref) {
return $x->isa($cls) if $ref eq 'Dispatchable';
$cls =~ s/^perl5:(?=\w)//s;
return if $ref eq $cls;
return if lc($ref) eq $cls;
return UNIVERSAL::isa($x,$cls);
}
return ($cls eq 'undef') if !defined $x;
return ($cls eq 'str') if !((~$x & $x) eq 0);
return ($cls eq 'num' || $cls eq 'int') if int($x) == $x;
return ($cls eq 'num');
}
sub p6_undef {undef}
sub p6_bool {$_[0]?1:undef}
sub p6_bit {$_[0]?1:0}
sub p6_int {int($_[0])}
sub p6_num {0+$_[0]}
sub p6_str {"".$_[0]}
#sub p6_ref {ref($_[0])?$_[0]:die "bug"} # XXX - name conflict. sigh.
# some abbreviations for p6_new('Foo')
sub p6_Undef {p6_new('Undef',@_)}
sub p6_Bool {p6_new('Bool',@_)}
sub p6_Bit {p6_new('Bit',@_)}
sub p6_Int {p6_new('Int',@_)}
sub p6_Num {p6_new('Num',@_)}
sub p6_Rat {p6_new('Rat',@_)}
sub p6_Str {p6_new('Str',@_)}
sub p6_Ref {p6_new('Ref',@_)}
sub p6_Pair {p6_new('Pair',@_)}
sub p6_Array {p6_new('Array',@_)}
sub p6_Hash {p6_new('Hash',@_)}
sub p6_List {p6_new('List',@_)}
sub p6_Scalar {p6_new('Scalar',@_)}
# XXX - Using field names here is a major abstraction violation.
# Need to figure out positional constructors. At least it's isolated here. :(
sub new_box {get_meta($_[0])->new('$.unboxed'=>$_[1])}
sub p6_new {
my $cls = shift;
return new_box('Undef',@_) if $cls eq 'Undef';
return new_box('Bool',(shift()?1:undef),@_) if $cls eq 'Bool';
return new_box('Bit',(shift()?1:0),@_) if $cls eq 'Bit';
return new_box('Int',@_) if $cls eq 'Int';
return new_box('Num',@_) if $cls eq 'Num';
return get_meta('Rat')->new('$.a' => $_[0], '$.b' => $_[1]) if $cls eq 'Rat';
return get_meta('Complex')->new('$.real'=>$_[0],'$.imag'=>$_[1]) if $cls eq 'Complex';
return new_box('Str',@_) if $cls eq 'Str';
return get_meta('Ref')->new('$.referred',@_) if $cls eq 'Ref';
return get_meta('Pair')->new('$.key' => $_[0], '$.value' => $_[1]) if $cls eq 'Pair';
if($cls eq 'Scalar') {
my $o = get_meta('Scalar')->new();
$o->ASSIGN($_[0]);
return $o;
}
if($cls eq 'Array') {
my $a = get_meta('Array')->new;
$a->push( @_ );
return $a;
}
if($cls eq 'Hash') {
die "unimplemented";
}
if($cls eq 'IO') {
die "unimplemented";
}
if($cls =~ /\A(?:Code|Routine|Sub|Method|Submethod|Macro|Rule|Block|Bare|Parametric)\z/) {
my($name,$argl,$f,$lval)=@_;
my $body = $f;
$body = '$f->(@_)' if ref($f);
my $code = code_for_code_CODE(name=>$name,kind=>$cls,params=>$argl,
body=>$body,lvalue=>$lval);
my $ret = eval($code);
Carp::confess("p6_new($cls,$name,...):\n$@\n") if $@;
return $ret;
}
if($cls =~ /\A(?:Package|Module|Class|Object|Grammar)\z/) {
my @args;
push(@args,'$.name',$_[0]) if @_;
return get_meta($cls)->new(@args);
}
if($cls =~ /\A(?:List|Lazy|Eager)\z/) {
return get_meta($cls)->new_from_single(@_);
}
my $meta = get_meta($cls);
return $meta->new(@_) if defined $meta;
Carp::confess("p6_new: unknown class $cls\n");
}
sub p6_code_mk_CODE {
my($name,$kind,$pams,$lval,$body)=@_;
code_for_code_CODE(name=>$name, kind=>$kind, params=>$pams,
lvalue=>$lval, body=>$body);
}
sub code_for_code_CODE {
my(%c)=@_;
my($name,$kind,$params,$body,$lvalue,$class) =
@c{qw(name kind params body lvalue class)};
# XXX - lvalue is ignored - use proxy?
my $hybrid_kludge;
if(!ref($params)) { # a string
$params =~ s/\A\s*\(?\s*//;
$params =~ s/\s*\)?\s*\z//;
my @pn = split(/\s*[,:]\s*|(?<=:)\s*/,$params);
$params = \@pn;
$hybrid_kludge = 1;
}
if(@$params && !ref($params->[0])) { # an array of strings
my @p = map{
my %h;
s/\s+/ /; s/\A\s+//; s/\s+\Z//;
$h{'isOptional'}=1 if s/\?//;
$h{'slurpy'}=1 if s/\*//;
$h{'isNamed'}=1 if s/\+//;
$h{'isInvocant'}=1 if s/\s*:\s*$//;
$h{'isLValue'}=1 if s/\s+is lvalue//;
$h{'isLazy'}=1 if s/\s+is lazy//;
$h{'isWritable'}=1 if s/\s+is rw//;
$h{'type'}=$1 if s/\A(\S+)\s+(\S+)\z/$2/;
$h{'paramName'}=$_;
\%h;
} @$params;
$params = \@p;
$hybrid_kludge = 1;
}
my $stringify = sub {
my($s)=@_;
$s =~ s/\\/\\\\/g; $s =~ s/\'/\\\'/g;
$s = "'$s'";
};
return "" if $kind eq 'SubPrim' && $name =~ /END/;#XXX
$kind = 'Sub' if $kind eq 'SubRoutine';
$kind = 'Sub' if $kind eq 'SubPrim';
$kind =~ s/^Sub(\w+)$/$1/;
my $code_body = $body;
if($kind eq 'Macro') {
warn "Macro is not implemented. And is unexpected.\n";
return "";
}
if($kind eq 'Coroutine') {
warn "Coroutine not implemented.\n";
return "";
}
if($kind eq 'Method') {
$code_body = p6_catch_return_CODE($code_body);
if(!defined $class) {
$class = $params->[0]{'type'};
}
}
if($kind eq 'Sub') {
$code_body = p6_catch_return_CODE($code_body);
}
if($kind eq 'Pointy') {
}
if($kind eq 'Block') {
}
my(@names5,@names6,@param_info);
for my $p (@$params) {
my %op = %$p;
my @args;
my $default = $op{'paramDefault'};
push(@args,"default=>sub{$default}") if defined $default;
my $slurpy = ref($op{'paramContext'}) =~ /Slurpy/ #XXX
|| $op{'slurpy'};
my $pname = $op{'paramName'};
push(@names6,$pname);
if($hybrid_kludge) {
my $pn = $pname;
$pn =~ s/[\@\%]/\$/;
push(@names5,$pn);
} else {
push(@names5,'$'.p6_mangle($pname));
}
my $aname = $pname;
$aname = '?'.$aname if $op{'isOptional'};
$aname = '*'.$aname if $slurpy;
$aname = '+'.$aname if $op{'isNamed'};
push(@args,"name=>".$stringify->($aname));
push(@args,"invocant=>1") if $op{'isInvocant'};
push(@args,"lvalue=>1") if $op{'isLValue'};
push(@args,"lazy=>1") if $op{'isLazy'};
push(@args,"named=>1") if $op{'isNamed'};
push(@args,"writable=>1") if $op{'isWritable'};
if(!$class && $op{'isInvocant'}) {
$class = $op{'type'}; # for calls via Api.
}
if(!$class && $op{'isInvocant'}) {
my @parts = split(/::/,$name); pop(@parts);
$class = join("::",@parts) if @parts;
}
my $args = "[".join(",",@args)."]";
push(@param_info,$args);
}
my $code_param_info = join(",",@param_info);
my $my_args = "";
if(@$params) {
my $sig = @names6 > 1 ? '@' : '$';
$my_args = ('my('
.join(",",@names5)
.")=(${sig}_param{"
.join(",",map{$stringify->($_)}@names6)
.'});');
}
$code_body = ('sub{ my $_sub = shift; my %_param = $_sub->bind_params(@_); '
.$my_args.$code_body.'}');
my $code_params = '[map{Perl6::Param->new(@$_)}('.$code_param_info.')]';
my $namestr = $stringify->($name);
my $code_args = "";
$code_args .= "'\$.name'=>$namestr," if $name;
$code_args .= "'\$.params'=>$code_params,";
$code_args .= "'\$.body'=>$code_body";
my $code_val = "p6_meta('$kind')->new($code_args)";
my $code = $code_val;
if($kind eq 'Method') {
my $k = lc $kind;
my $meth = "";
Carp::confess("class undefined") if !defined $class;
$code = ("(p6_meta('$class')".
"->add_method($namestr".
"=> ::make_${k}(do{my \$__f".
"= $code_val; sub{\$__f->(\@_)}})));");
} elsif($name) {
$code = "(p6_setq(__PACKAGE__,$namestr,$code_val));";
}
$code;
}
my %as_bool_handlers =
( undef => sub { undef },
numeric => sub { $_[0] ? 1 : undef },
non_numeric => sub { $_[0] ? 1 : undef },
scalar_numeric => sub { ${$_[0]} ? 1 : undef },
scalar_non_numeric => sub { ${$_[0]} ? 1 : undef },
array => sub { @{$_[0]} ? 1 : undef },
hash => sub { %{$_[0]} ? 1 : undef },
code => sub { 1 },
ref => sub { ${$_[0]} ? 1 : undef }, # p6_as_bool(${$_[0]}) ?
glob => sub { ${$_[0]} ? 1 : undef },
lvalue => sub { p6_as_bool(${$_[0]}) },
perl5_object => sub { $_[0] ? 1 : undef },
perl6_object => sub { $_[0]->as_perl5_bool },
);
sub p6_as_bool {
my($x)=@_;
my $reftyp = ref_flavor($x);
my $handler = $as_bool_handlers{$reftyp};
die "bug $reftyp" if !defined $handler;
$handler->($x);
}
my $nan = 100**100**100 / 100**100**100;
my %as_num_handlers =
( undef => sub { Carp::carp("p6_as_num called on undef"); $nan },
numeric => sub { $_[0] },
non_numeric => sub { 0+ $_[0] },
scalar_numeric => sub { ${$_[0]} },
scalar_non_numeric => sub { 0+ ${$_[0]} },
array => sub { 0+ @{$_[0]} },
hash => sub { 0+ %{$_[0]} },
code => sub { Carp::carp("p6_as_num called on code"); $nan },
ref => sub { 0+ ${$_[0]} },
glob => sub { 0+ ${$_[0]} },
lvalue => sub { p6_as_num(${$_[0]}) },
perl5_object => sub { 0+ $_[0] },
perl6_object => sub { $_[0]->as_perl5_num },
);
sub p6_as_num {
my($x)=@_;
my $reftyp = ref_flavor($x);
my $handler = $as_num_handlers{$reftyp};
die "bug $reftyp" if !defined $handler;
$handler->($x);
}
my %as_str_handlers =
( undef => sub { Carp::carp("p6_as_str called on undef"); "" },
numeric => sub { "". $_[0] },
non_numeric => sub { "". $_[0] },
scalar_numeric => sub { "". ${$_[0]} },
scalar_non_numeric => sub { "". ${$_[0]} },
array => sub { "". @{$_[0]} },
hash => sub { "". %{$_[0]} },
code => sub { "". $_[0] },
ref => sub { "". $_[0] },
glob => sub { "". ${$_[0]} },
lvalue => sub { p6_as_str(${$_[0]}) },
perl5_object => sub { "". $_[0] },
perl6_object => sub { $_[0]->as_perl5_str },
);
sub p6_as_str {
my($x)=@_;
my $reftyp = ref_flavor($x);
my $handler = $as_str_handlers{$reftyp};
die "bug $reftyp" if !defined $handler;
$handler->($x);
}
my $as_array_complain = sub { Carp::carp("p6_as_array called on $_[0]"); undef };
my %as_array_handlers =
( undef => sub { $as_array_complain->("undef"); [] },
numeric => sub { $as_array_complain->("numeric") },
non_numeric => sub { $as_array_complain->("non_numeric") },
scalar_numeric => sub { $as_array_complain->("scalar_numeric") },
scalar_non_numeric => sub { $as_array_complain->("scalar_non_numeric") },
array => sub { $_[0] },
hash => sub { [%{$_[0]}] },
code => sub { $as_array_complain->("code") },
ref => sub { $as_array_complain->("ref") },
glob => sub { $as_array_complain->("glob") },
lvalue => sub { p6_as_array(${$_[0]}) },
perl5_object => sub { [@{$_[0]}] },
perl6_object => sub { $_[0]->as_perl5_array },
);
sub p6_as_array {
my($x)=@_;
my $reftyp = ref_flavor($x);
my $handler = $as_array_handlers{$reftyp};
die "bug $reftyp" if !defined $handler;
$handler->($x);
}
my $as_hash_complain = sub { Carp::carp("p6_as_hash called on $_[0]"); undef };
my %as_hash_handlers =
( undef => sub { $as_hash_complain->("undef"); [] },
numeric => sub { $as_hash_complain->("numeric") },
non_numeric => sub { $as_hash_complain->("non_numeric") },
scalar_numeric => sub { $as_hash_complain->("scalar_numeric") },
scalar_non_numeric => sub { $as_hash_complain->("scalar_non_numeric") },
array => sub { {@{$_[0]}} },
hash => sub { $_[0] },
code => sub { $as_hash_complain->("code") },
ref => sub { $as_hash_complain->("ref") },
glob => sub { $as_hash_complain->("glob") },
lvalue => sub { p6_as_hash(${$_[0]}) },
perl5_object => sub { \%{$_[0]} },
perl6_object => sub { $_[0]->as_perl5_hash },
);
sub p6_as_hash {
my($x)=@_;
my $reftyp = ref_flavor($x);
my $handler = $as_hash_handlers{$reftyp};
die "bug $reftyp" if !defined $handler;
$handler->($x);
}
sub p6_as_perl5_whatever {
my($x)=@_;
return $x if !p6_is_perl6_object($x);
$x->as_perl5_whatever();
}
my $as_p6obj_complain = sub { Carp::carp("p6_perl6_objects_from_whatever called on $_[0]"); undef };
my %as_p6obj_handlers =
( undef => sub { p6_Undef() },
numeric => sub { p6_Num($_[0]) },
non_numeric => sub { p6_Str($_[0]) },
scalar_numeric => sub { p6_Num(${$_[0]}) },
scalar_non_numeric => sub { p6_Str(${$_[0]}) },
array => sub { p6_Array(@{$_[0]}) },
hash => sub { p6_Hash(%{$_[0]}) },
code => sub { $as_p6obj_complain->("code") }, # XXX - unimplemented.
ref => sub { $as_p6obj_complain->("ref") },
glob => sub { $as_p6obj_complain->("glob") },
lvalue => sub { p6_perl6_objects_from_whatever(${$_[0]}) },
perl5_object => sub { $as_p6obj_complain->("perl5_object"); $_[0] }, # XXX - what's right?
perl6_object => sub { $_[0] },
);
sub p6_perl6_objects_from_whatever {
return (map{p6_perl6_objects_from_whatever($_)}@_) if @_ > 1;
return () if @_ < 1;
my($x)=@_;
my $reftyp = ref_flavor($x);
my $handler = $as_p6obj_handlers{$reftyp};
die "bug $reftyp" if !defined $handler;
$handler->($x);
}
sub p6_meta_CODE {
my($pkg)=@_;
"\$${ROOT}::${pkg}::META";
}
sub p6_meta {
my $m = get_meta($_[0]);
die("p6_meta: undefined package '$_[0]'.\n") if !$m;
$m;
}
sub get_meta {
my($pkg)=@_;
my $meta = "${ROOT}::${pkg}::META";
no strict;
$$meta;
}
sub set_meta { # will hopefully remain unused.
my($pkg,$meta_object)=@_;
my $meta = "${ROOT}::${pkg}::META";
$$meta = $meta_object;
}
sub p6_initialize_package {
my($pkg,$kind)=@_;
$kind = "" if !defined $kind;
my $Kind = ucfirst $kind;
my @path = split(/::/,$pkg);
my $tmp = "";
my @classes = map{my $c = $tmp.$_;$tmp=$c.'::';$c} @path;
@classes = reverse map{$_=$ROOT.$_} @classes;
shift(@classes); # dont want current class;
push(@classes,$ROOT);
my $code = "";
$code .= "package $ROOT".($pkg eq "" ? "" : "::$pkg").";\n";
$code .= "use utf8;\n";
$code .= "use Perl6::MetaModel;\n";
$code .= "our \$META;\n";
$code .= "\$META = \$::${Kind}->new('\$:name' => '$pkg');\n" if $kind;
$code .= "use Perl6::Run::OnPerl5::X1::Api;\n";
$code .= "use Error qw(:try);\n";
my $hlp = sub{my $cls=$_[0];
my $symtab = '$'.$cls.'::{$_[0]}';
" exists $symtab\n ? \${$symtab} : \n";};
$code .= "sub p6__lookup {\n";
$code .= $hlp->(shift @classes);
$code .= ' exists($META->FETCH("{}")->{$_[1]}) ? $META->FETCH($_[1]) :'."\n";
for my $cls (@classes) {
$code .= $hlp->($cls);
}
my $where = $pkg; $where = "root namespace" if $where eq "";
my $tell = 0 ? "confess" : "croak";
$code .= ' $_[2] ? 0 : Carp::'.$tell.'("Undefined variable $_[1] in '.$where.'\n") '.";\n";
$code .= "}\n";
eval_p5_code($code);
}
sub p6_wrap_code_with_package {
my($code,$pkg)=@_;
"package ${ROOT}::$pkg; $code";
}
sub eval_wa {
my($code,$wa)=@_;
my(@a,$s);
if($wa) {
@a = eval($code);
} elsif(defined $wa) {
$s = eval($code);
} else {
eval($code);
}
$wa ? @a : $s;
}
BEGIN{unlink("deleteme_code.pl") if -e "deleteme_code.pl";}
my $eval_log_file;
sub eval_p5_log_code {
my($code)=@_;
if($Perl6::Run::OnPerl5::X1::BB::debug && !$eval_log_file) {
open($eval_log_file,">>deleteme_code.pl") or die $!;
}
print $eval_log_file $code,"\n" if $eval_log_file;
print $code if 0;
}
sub eval_p5_log_error {
my($code,$err)=@_;
Carp::confess("$@\n".number_the_lines($code)."\n");
}
sub eval_p5_code {
my($code)=@_;
eval_p5_log_code($code);
my @res = eval_wa($code,wantarray);
eval_p5_log_error($code,$@) if $@;
return(@res);
}
sub number_the_lines {
my($s)=@_;
my $cnt = 1;
$s =~ s/^/$cnt++."\t"/mge;
$s;
}
sub p6_eval {
my($p6,$pkg)=@_;
$pkg = (caller())[0] if !defined $pkg;
$pkg = 'main' if $pkg !~ /\A$ROOT/;
$pkg = "${ROOT}::main" if $pkg eq 'main';
$pkg = "${ROOT}" if $pkg eq '';
my $cc = Perl6::Run::OnPerl5::X1::CodeCompile->new(p6=>$p6)->compile;
print STDERR $cc->warnings;
my $p5 = "package $pkg;".$cc->as_p5;
eval_p5_code($p5);
}
sub p6_eval_file {
my($fn)=@_;
my $cc = Perl6::Run::OnPerl5::X1::CodeCompile->new(p6_file=>$fn)->get_p6_file;
p6_eval($cc->as_p6);
}
my %macros;
sub p6_macrop5 {
my($name)=@_;
$macros{$name};
}
sub p6_def_macrop5 {
my($kind,$name,$param,$fun)=@_;
my $mfun = $fun;
if($param =~ /\*/) {
my $modifyargs ="";
my $argl = $param;
while($argl =~ s/\*([\@\%])(\w+)/$1$2/) {
$modifyargs .= "my \$$2 = \\$1$2;";
}
my $argl2 = $argl;
$argl2 =~ s/[\@\%]/\$/g;
my $code = "# macrop5 $name\n sub{my$argl=\@_; $modifyargs \$fun->$argl2}\n";
eval_p5_log_code($code);
$mfun = eval($code);
eval_p5_log_error($code,$@) if $@;
}
$macros{$name}=$mfun;
}
sub p6_container_for_var_CODE {
my($name)=@_;
return "\$${ROOT}::Scalar::META->new()" if $name =~ /\$|\&/;
return "\$${ROOT}::Array::META->new()" if $name =~ /\@/;
return "\$${ROOT}::Hash::META->new()" if $name =~ /\%/;
Carp::confess "bug >$name<";
}
sub p6_var_CODE {
my($name)=@_;
my $mn = p6_mangle($name);
"(do{no strict;defined(\$$mn)?\$$mn:p6__lookup('$mn','$name')})";
}
sub p6_var { # XXX - not quite the right thing
my($name)=@_;
my $mn = p6_mangle($name);
my $pkg = (caller)[0];
#my $ret = eval "package $pkg;".<<' END';
# no strict;defined($$mn)?$$mn:p6__lookup('$mn','$name')
#END
#die "p6_var: bug: $@" if $@;
#$ret;
my $look = "${pkg}::p6__lookup";
no strict 'refs';
&$look($mn,$name);
}
sub p6_setq {
my($pkg,$n,$v)=@_;
my $mn = p6_mangle($n,$pkg);
# print STDERR $mn,"\n";
no strict 'refs';
$$mn = p6_meta('Scalar')->new();
$$mn->ASSIGN($v);
}
sub p6_assign {my($o,$v)=@_; $o->ASSIGN($v);}
sub p6_bind {my($o,$v)=@_; $o->BIND($v);}
my %space_from_sigil;
my %sigil_from_space;
BEGIN{
%space_from_sigil = ( '$' => 'scalar', '@' => 'array', '%' => 'hash',
'&' => 'code', ':' => 'type');
%sigil_from_space = map {$space_from_sigil{$_},$_} keys(%space_from_sigil);
}
sub p6_mangle {
my($n,$pkg)=@_;
my $sigil = substr($n,0,1);
my $mn = substr($n,1);
my $is_absolute_name = $mn =~ /::|^\*/;
$mn =~ s/^(::)?(\*)?(::)?//;
$mn =~ s/_/__/g;
$mn =~ s/([^a-z0-9_])/"_".ord($1)."x"/ieg;
$mn =~ s/_58x_58x/::/g;
if($sigil eq ':') {
$mn .= "::META";
} else {
my $space = $space_from_sigil{$sigil};
Carp::confess "bogus name?: '$n' with sigil '$sigil'" if !$space;
my @parts = split('::',$mn);
$parts[-1] = $space."_".$parts[-1];
$mn = join('::',@parts);
}
$mn = $ROOT."::".$mn if $is_absolute_name;
$mn = $pkg."::".$mn if !$is_absolute_name && $pkg;
$mn;
}
sub p6_apply {
my($f,@args)=@_;
#print STDERR "\n<$f,",@args,">\n";
return p6_from_b(0) if $f eq 'bit' && ! defined $args[0]; # undef.bit() # XXX eep
if(!ref($f)) { # XXX - see PApp in EvalX.
return $args[0]->$f(splice(@args,1));
}
if(!p6_as_bool($f->defined())) {
Carp::confess "Error: Application of undef.\n";
}
$f->do(@args);
}
sub p6_applym {
my($m,$o,@args)=@_;
$o->$m(@args);
}
no strict 'vars';
package Perl6::Run::OnPerl5::X1::Api::Exception;
@ISA=qw(Error);
package Perl6::Run::OnPerl5::X1::Api::Exception::Return;
@ISA=qw(Perl6::Run::OnPerl5::X1::Api::Exception);
package Perl6::Run::OnPerl5::X1::Api::Exception::LoopControl;
@ISA=qw(Perl6::Run::OnPerl5::X1::Api::Exception);
package Perl6::Run::OnPerl5::X1::Api;
use strict;
sub p6_return_CODE {
my(@args)=@_;
my $argl = join(",",@args);
"(throw Perl6::Run::OnPerl5::X1::Api::Exception::Return(-text =>q{$argl},-value => [$argl]))";
}
sub p6_catch_return_CODE {
my($code)=@_;
'(try { '.$code.' } catch Perl6::Run::OnPerl5::X1::Api::Exception::Return with { @{$_[0]{"-value"}} })'
}
sub p6_loop_CODE {
my($body)=@_;
# the caller is responsible for providing any value capture needed, in $body.
'{ my $__flag;
try { '.$body.' }
catch Perl6::Run::OnPerl5::X1::Api::Exception::LoopControl with { $__flag = $_[0]{"-text"} };
if($__flag) {
last if $__flag eq "last";
next if $__flag eq "next";
redo if $__flag eq "redo";
die "p6_loop_CODE: bug";
}
}'."\n";
}
sub p6_last_CODE {
"(throw Perl6::Run::OnPerl5::X1::Api::Exception::LoopControl('-text' => 'last'))";
}
sub p6_next_CODE {
"(throw Perl6::Run::OnPerl5::X1::Api::Exception::LoopControl('-text' => 'next'))";
}
sub p6_redo_CODE {
"(throw Perl6::Run::OnPerl5::X1::Api::Exception::LoopControl('-text' => 'redo'))";
}
sub p6_die {my(@args)=@_; die @args;}
sub p6_to_perl {
my($x)=@_;
return 'undef' if !defined $x;
my $s = eval {p6_as_str($x->perl)};
defined $s ? $s : p6_as_str($x);
}
sub p6_defined {
my($x)=@_;
return 0 if !defined $x;
return $x->defined if p6_is_perl6_object($x);
return 1;
}
sub p6_declare_package {
my($pkg,$kind)=@_;
p6_initialize_package($pkg,$kind);
}
1;
__END__