Acme-Perl-VM

 view release on metacpan or  search on metacpan

lib/Acme/Perl/VM.pm  view on Meta::CPAN

        vivify_ref
        sv_newmortal sv_mortalcopy sv_2mortal
        SvPV SvNV SvIV SvTRUE
        av_assign av_store
        hv_store hv_store_ent hv_scalar

        defoutgv
        gv_fullname

        looks_like_number
        sv_defined is_null is_not_null
        mark_list
        not_implemented
        dump_object dump_value dump_stack dump_si

        apvm_extern
        cv_external

        APVM_DEBUG APVM_DUMMY
        APVM_SCOPE APVM_TRACE
    );
    our %EXPORT_TAGS = (
        perl_h => \@EXPORT_OK,

lib/Acme/Perl/VM.pm  view on Meta::CPAN

our $PL_comppad;
our $PL_comppad_name;
our @PL_curpad;

our $PL_last_in_gv;

our @PL_ppaddr;

our $color = 'GREEN BOLD'; # for debugging log

sub not_implemented;

{
    my $i = 0;
    while(my $ppname = B::ppname($i)){
        my $ppaddr = \$Acme::Perl::VM::PP::{$ppname};

        if(ref($ppaddr) eq 'GLOB'){
            $PL_ppaddr[$i] = *{$ppaddr}{CODE};
        }

        $PL_ppaddr[$i] ||= sub{ not_implemented($ppname) };

        $i++;
    }
}

sub runops_standard{ # run.c
    1 while(${ $PL_op = &{$PL_ppaddr[ $PL_op->type ]} });
    return;
}

lib/Acme/Perl/VM.pm  view on Meta::CPAN

sub GIMME_V(){ # op.h
    my $gimme = OP_GIMME($PL_op, -1);
    return $gimme != -1 ? $gimme : block_gimme();
}

sub LVRET(){ # cf. is_lvalue_sub() in pp_ctl.h
    if($PL_op->flags & OPpMAYBE_LVSUB){
        my $cxix = dopoptosub($#PL_cxstack);

        if($PL_cxstack[$cxix]->lval && $PL_cxstack[$cxix]->cv->CvFLAGS & CVf_LVALUE){
            not_implemented 'lvalue';
            return TRUE;
        }
    }
    return FALSE;
}

sub SVOP_sv{
    my($op) = @_;
    return USE_ITHREADS ? PAD_SV($op->padix) : $op->sv;
}
sub GVOP_gv{
    my($op) = @_;
    return USE_ITHREADS ? PAD_SV($op->padix) : $op->gv;
}

sub vivify_ref{
    not_implemented 'vivify_ref';
}

sub sv_newmortal{
    my $sv;
    push @PL_tmps, \$sv;
    return B::svref_2object(\$sv);
}
sub sv_mortalcopy{
    my($sv) = @_;

lib/Acme/Perl/VM.pm  view on Meta::CPAN

}

# Utilities

sub sv_defined{
    my($sv) = @_;

    return $sv && ${$sv} && defined(${ $sv->object_2svref });
}

sub is_not_null{
    my($sv) = @_;
    return ${$sv};
}
sub is_null{
    my($sv) = @_;
    return !${$sv};
}

my %not_a_scalar;
@not_a_scalar{qw(AV HV CV IO)} = ();
sub is_scalar{
    my($sv) = @_;
    return !exists $not_a_scalar{ $sv->class };
}

sub mark_list{
    my($mark) = @_;
    return map{ ${ $_->object_2svref } } splice @PL_stack, $mark+1;
}


our %external;

lib/Acme/Perl/VM.pm  view on Meta::CPAN

        markstack => \@PL_markstack,
        cxstack   => \@PL_cxstack,
        scopstack => \@PL_scopestack,
        savestack => \@PL_savestack,
        tmps      => \@PL_tmps,
    );

    ddx([\%stack_info]);
}

sub not_implemented{
    if(!@_){
        if($PL_op && is_not_null($PL_op)){
            @_ = ($PL_op->name);
        }
        else{
            @_ = (caller 0)[3];
        }
    }

    push @_, ' is not implemented';
    goto &Carp::confess;
}

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

    return $PL_op->next;
}

sub pp_pushmark{
    PUSHMARK;
    return $PL_op->next;
}

sub pp_const{
    my $sv = is_not_null($PL_op->sv) ? $PL_op->sv : PAD_SV($PL_op->targ);
    PUSH($sv);
    return $PL_op->next;
}

sub pp_gv{
    PUSH( GVOP_gv($PL_op) );
    return $PL_op->next;
}

sub pp_gvsv{

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

    }

    my $gimme = GIMME_V;

    if($gimme == G_VOID){
        return $PL_op->next;
    }
    elsif($gimme == G_SCALAR){

        if($PL_op->flags & OPf_MOD || LVRET){
            not_implemented $PL_op->name . ' for lvalue';
        }

        my $num = keys %{ $hv->object_2svref };
        mPUSH( svref_2object(\$num) );
        return $PL_op->next;
    }


    my($dokeys, $dovalues);
    if($PL_op->name eq 'keys'){

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

    if($sv->ROK){
        $sv = $sv->RV;
    }

    if($sv->class ne 'GV'){
        apvm_die 'Not a GLOB reference';
    }

    if($PL_op->private & OPpLVAL_INTRO){
        not_implemented 'rv2gv for OPpLVAL_INTRO';
    }

    SET($sv);
    return $PL_op->next;
}

sub pp_rv2sv{
    my $sv = TOP;
    my $gv;

    if($sv->ROK){
        if(!is_scalar($sv)){
            apvm_die 'Not a SCALAR reference';
        }
    }
    else{
        if($sv->class ne 'GV'){
            not_implemented 'rv2xv for soft references';
        }
        $gv = $sv;
    }

    if($PL_op->flags & OPf_MOD){
        if($PL_op->private & OPpLVAL_INTRO){
            if($PL_op->first->name eq 'null'){
                $sv = save_scalar(TOP);
            }
            else{

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

        $sv = $sv->RV;

        if($sv->class ne $class){
            apvm_die "Not $name reference";
        }
        if($PL_op->flags & OPf_REF){
            SET($sv);
            return $PL_op->next;
        }
        elsif(LVRET){
            not_implemented 'rv2av for lvalue';
        }
        elsif($PL_op->flags & OPf_MOD
                && $PL_op->private & OPpLVAL_INTRO){
            apvm_die q{Can't localize through a reference};
        }
    }
    else{
        if($sv->class eq $class){
            if($PL_op->flags & OPf_REF){
                SET($sv);
                return $PL_op->next;
            }
            elsif(LVRET){
                not_implemented 'rv2av for lvalue';
            }
        }
        else{
            if($sv->class ne 'GV'){
                not_implemented 'rv2av for symbolic reference';
            }

            if($PL_op->private & OPpLVAL_INTRO){
                $sv = $save->($sv);
            }
            else{
                $sv = $sv->$class();
            }

            if($PL_op->flags & OPf_REF){
                SET($sv);
                return $PL_op->next;
            }
            elsif(LVRET){
                not_implemented 'rv2av for lvalue';
            }
        }
    }

    if($class eq 'AV'){ # rv2av
        if($gimme == G_ARRAY){
            POP;
            PUSH( $sv->ARRAY );
        }
        elsif($gimme == G_SCALAR){

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

    my $targ = GET_TARGET;

    if(($PL_op->private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO){
            SAVECLEARSV($targ);
    }
    if($PL_op->flags & OPf_REF){
        PUSH($targ);
        return $PL_op->next;;
    }
    elsif(LVRET){
        not_implemented 'padav for lvalue';
    }

    my $gimme = GIMME_V;
    if($gimme == G_ARRAY){
        PUSH( $targ->ARRAY );
    }
    elsif($gimme == G_SCALAR){
        my $sv = sv_newmortal();
        $sv->setval($targ->FILL + 1);
        PUSH($sv);

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

    if(($PL_op->private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO){
        SAVECLEARSV($targ);
    }

    PUSH($targ);

    if($PL_op->flags & OPf_REF){
        return $PL_op->next;
    }
    elsif(LVRET){
        not_implemented 'padhv for lvalue';
    }

    my $gimme = GIMME_V;
    if($gimme == G_ARRAY){
        return &_do_kv;
    }
    elsif($gimme == G_SCALAR){
        SET( hv_scalar($targ) );
    }

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

    else{
        mPUSH(svref_2object(\%hash));
    }
    return $PL_op->next;
}

sub _refto{
    my($sv) = @_;

    if($sv->class eq 'PVLV'){
        not_implemented 'ref to PVLV';
    }
    my $rv = $sv->object_2svref;
    return sv_2mortal( svref_2object(\$rv) );
}

sub pp_srefgen{
    $PL_stack[-1] = _refto($PL_stack[-1]);
    return $PL_op->next;
}
sub pp_refgen{

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

        if($sv->RV->class eq 'CV'){
            SET($sv->RV);
            return $PL_op->next;
        }
    }

    SET(_method_common($sv));
    return $PL_op->next;
}
sub pp_method_named{
    my $sv = is_not_null($PL_op->sv) ? $PL_op->sv : PAD_SV($PL_op->targ);

    PUSH(_method_common($sv));
    return $PL_op->next;
}

sub pp_entersub{
    my $sv = POP;
    my $cv = $sv->toCV();

    if(is_null($cv)){

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

    my $cx = POPBLOCK;
    my $popsub2;
    my $retop;

    if($cx->type eq 'SUB'){
        $popsub2 = TRUE;
        $retop   = $cx->retop;
    }
    else{
        not_implemented 'return for ' . $cx->type
    }

    my $newsp = $cx->oldsp;
    my $gimme = $cx->gimme;
    if($gimme == G_SCALAR){
        if($mark < $#PL_stack){
            $PL_stack[++$newsp] = sv_mortalcopy(TOP);
        }
        else{
            $PL_stack[++$newsp] = sv_undef;

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

    return $PL_op->next;
}
sub pp_iter{
    my $cx = $PL_cxstack[-1];

    my $itersv  = $cx->ITERVAR;
    my $iterary = $cx->iterary;

    if(ref($iterary) ne 'ARRAY'){ # iterate range
        if(my $cur = $cx->iterlval){
            not_implemented 'string range in foreach';
        }

        # integer increment
        if($cx->iterix > $cx->itermax){
            PUSH(sv_no);
            return $PL_op->next;
        }

        $itersv->setval($cx->iterix);
        $cx->iterix($cx->iterix+1);

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

    my $nextop;

    if($type eq 'LOOP'){
        $newsp  = $cx->resetsp;
        $nextop = $cx->myop->lastop->next;
    }
    elsif($type eq 'SUB'){
        $nextop = $cx->retop;
    }
    else{
        not_implemented "last($type)";
    }

    my $gimme = $cx->gimme;
    if($gimme == G_SCALAR){
        if($mark < $#PL_stack){
            $PL_stack[++$newsp] = sv_mortalcopy($PL_stack[-1]);
        }
        else{
            $PL_stack[++$newsp] = sv_undef;
        }

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

    else{
        return $PL_op->next;
    }
}

sub pp_flip{
    if(GIMME_V == G_ARRAY){
        return $PL_op->first->other;
    }

    not_implemented 'flip-flop in scalar context';
}
sub pp_flop{
    if(GIMME_V == G_ARRAY){
        my $right = POP;
        my $left  = POP;

        my $i   = ${$left->object_2svref};
        my $max = ${$right->object_2svref};

        if(_range_is_numeric($left, $right) && $i >= $max){

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

        $max++;
        while($i ne $max){
            my $sv = sv_newmortal();
            $sv->setval($i);
            PUSH($sv);
            $i++;
        }
    }
    else{
        not_implemented 'flip-flop in scalar context';
    }

    return $PL_op->next;
}


sub pp_preinc{
    ${ TOP()->object_2svref }++;

    return $PL_op->next;

lib/Acme/Perl/VM/PP.pm  view on Meta::CPAN

    }
    return $PL_op->next;
}

sub pp_undef{
    if(!$PL_op->private){
        PUSH(sv_undef);
        return $PL_op->next;
    }

    not_implemented 'undef(expr)';
}

sub pp_scalar{
    return $PL_op->next;
}

sub pp_not{
    SET( !SvTRUE(TOP) ? sv_yes : sv_no );
    return $PL_op->next;
}

lib/Acme/Perl/VM/Run.pm  view on Meta::CPAN

use strict;
use warnings;
use Acme::Perl::VM    qw(:perl_h);
use B qw(main_start comppadlist);

no warnings 'void';
INIT{
    return if APVM_DUMMY;

    if(is_not_null(main_start)){
        ENTER;
        SAVETMPS;

        $PL_curcop ||= bless \do{ my $addr = 0 }, 'B::COP'; # dummy cop

        $PL_op = main_start;
        PAD_SET_CUR(comppadlist, 1);

        $PL_runops->();