view release on metacpan or  search on metacpan

misc/old_pugs_perl5_backend/pilrun2-leftovers/api.pl  view on Meta::CPAN

}


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";