/*
* This file was generated automatically by ExtUtils::ParseXS version 2.18 from the
* contents of Struct.xs. Do not edit this file, edit Struct.xs instead.
*
* ANY CHANGES MADE HERE WILL BE LOST!
*
*/
#line 1 "Struct.xs"
/* Copyright (c) 1997-2006 -*- C -*-
Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
http://www.math.tu-berlin.de/polymake, mailto:polymake@math.tu-berlin.de
This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version: http://www.gnu.org/licenses/gpl.txt.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
*/
#ident "$Project: polymake $$Id: Struct.xs 7533 2006-12-20 23:55:58Z gawrilow $"
#include "Ext.h"
#include <stdio.h>
static HV *secret_pkg;
typedef struct method_info {
OP *next_op;
SV *filter, *fallback;
I32 field_index, filter_is_method;
CV *accessor;
} method_info;
#ifndef NewOp
#define NewOp Newz
#endif
static
OP* pp_hide_orig_object(pTHX)
{
OP *next=(PL_ppaddr[OP_ENTERSUB])(aTHX);
AV *args=GvAV(PL_defgv);
/* imitate shift(@_) without cleaning out the 0-th slot */
SvPVX(args) = (char*)(AvARRAY(args) + 1);
AvMAX(args)--;
AvFILLp(args)--;
PL_op->op_ppaddr=PL_ppaddr[OP_ENTERSUB];
return next;
}
static
OP* pp_hide_orig_object_first(pTHX)
{
PL_stack_sp+=2;
return pp_hide_orig_object(aTHX);
}
static
SV* find_method(pTHX_ I32 index, method_info *info)
{
dSP; dTOPss;
SV *obj=SvRV(sv),
*field=*av_fetch((AV*)obj, index, 1);
SV *method_cv;
for (;;) {
if (SvROK(field)) {
method_cv=SvRV(field);
if (SvTYPE(method_cv)==SVt_PVCV)
break;
if (SvOBJECT(method_cv)) {
sv=field;
obj=method_cv;
field=*av_fetch((AV*)obj, index, 1);
} else {
croak("The method field contains a reference of a wrong type");
}
} else if (SvIOK(field)) {
field=*av_fetch((AV*)obj, SvIVX(field), 1);
} else if (SvPOK(field)) {
if (SvCUR(field)) {
GV *method_gv=gv_fetchmethod(SvSTASH(obj), SvPVX(field));
method_cv= method_gv && isGV(method_gv)
? (SV*)GvCV(method_gv)
: try_namespace_lookup(aTHX_ SvSTASH(obj), field, SVt_PVCV);
if (method_cv) {
sv_setsv(field, newRV(method_cv));
break;
} else {
sv_setsv(field, &PL_sv_no);
}
}
if (info)
croak("Undefined method called");
return field;
} else if (SvOK(field)) {
croak("The method field contains a value of a wrong type");
} else if (info) {
if ((method_cv=info->fallback)) {
sv=TOPs; break;
} else {
croak("Undefined method called");
}
} else {
return field;
}
}
if (info) {
if (CvMETHOD((CV*)method_cv)) {
SV **stack, **bottom, *orig=TOPs;
int push_orig= sv!=orig;
EXTEND(SP,push_orig+1);
for (stack=SP, bottom=PL_stack_base+TOPMARK+1; stack>bottom; --stack)
stack[push_orig]=stack[-1];
*stack=orig;
if (push_orig) {
*++stack=sv;
info->next_op->op_next->op_ppaddr=&pp_hide_orig_object;
}
*(PL_stack_sp=SP+push_orig+1)=method_cv;
return method_cv;
} else {
SETs(method_cv);
return 0;
}
} else {
return sv_2mortal(newRV(method_cv));
}
}
static
OP* pp_access(pTHX)
{
dSP; dTOPss;
SV *obj=SvRV(sv), *method_name=cSVOP_sv;
HV *class=SvSTASH(obj);
MAGIC *mg=SvMAGIC(method_name);
do {
if (class == (HV*)mg->mg_obj) {
method_info *info=(method_info*)mg->mg_ptr;
SV *field=*av_fetch((AV*)obj, info->field_index, 1);
if (info->filter) {
SV *rhs=SP[-1]; /* rhs value */
SP[-1]=field; /* preserve it below the mark */
if (info->filter_is_method)
XPUSHs(method_name); /* preserve ref(obj) on the stack */
else
SP[0]=method_name;
XPUSHs(rhs);
XPUSHs(info->filter);
PUTBACK;
return info->next_op;
} else {
SETs(field); /* replace ref(obj) on the stack top by the requested field */
POPMARK; /* skip pp_entersub */
return info->next_op->op_next;
}
}
} while ((mg=mg->mg_moremagic));
return pp_method_named();
}
/* better to repeat some code than to put extra tests in the heavily used pp_access */
static
OP* pp_method_access(pTHX)
{
dSP; dTOPss;
SV *obj=SvRV(sv), *method_name=cSVOP_sv;
HV *class=SvSTASH(obj);
MAGIC *mg=SvMAGIC(method_name);
do {
if (class == (HV*)mg->mg_obj) {
method_info *info=(method_info*)mg->mg_ptr;
SV *method=find_method(aTHX_ info->field_index, 0);
SETs(method);
POPMARK;
return info->next_op->op_next;
}
} while ((mg=mg->mg_moremagic));
return pp_method_named();
}
static
OP* pp_method_call(pTHX)
{
dSP; dTOPss;
SV *obj=SvRV(sv), *method_name=cSVOP_sv;
HV *class=SvSTASH(obj);
MAGIC *mg=SvMAGIC(method_name);
do {
if (class == (HV*)mg->mg_obj) {
method_info *info=(method_info*)mg->mg_ptr;
POPMARK;
(void)find_method(aTHX_ info->field_index, info);
return info->next_op->op_next;
}
} while ((mg=mg->mg_moremagic));
return pp_method_named();
}
static
OP* method_named_op(OP *o)
{
return ((o->op_flags & OPf_KIDS) &&
(o=cUNOP->op_first->op_sibling) && (o=o->op_sibling) && o->op_type == OP_METHOD_NAMED) ? o : 0;
}
static
OP* pp_quick_anonlist(pTHX)
{
dSP; dMARK; dORIGMARK;
I32 items = SP - MARK;
AV *av=newAV();
SV **ary, **src=MARK+1, **src_last=SP;
New(0,ary,items,SV*);
AvALLOC(av) = ary;
SvPVX(av) = (char*)ary;
AvFILLp(av) = items - 1;
AvMAX(av) = items - 1;
for (; src <= src_last; ++src, ++ary) {
SV *sv=*src;
if (SvTEMP(sv)) {
SvTEMP_off(sv);
SvREFCNT_inc(sv);
*ary = sv;
} else {
SV *copy_sv=NEWSV(0,0);
sv_setsv(copy_sv, sv);
*ary = copy_sv;
}
}
SP = ORIGMARK;
PUSHs((SV*)av);
RETURN;
}
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(var) if (0) var = var
#endif
#line 255 "Struct.c"
XS(XS_Struct_access); /* prototype to pass -Wmissing-prototypes */
XS(XS_Struct_access)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items < 1)
Perl_croak(aTHX_ "Usage: %s(%s)", "Struct::access", "obj, ...");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
SV * obj =SvRV(ST(0));
#line 249 "Struct.xs"
{
I32 index=SvIVX(cv);
OP *o=method_named_op(PL_op);
if (o) {
OP *next_op=PL_op->op_next;
SV *filter=0;
SV *method_name=cSVOPo_sv;
HV *class=SvSTASH(obj);
MAGIC *mg=0;
if (SvTYPE(method_name) == SVt_PVMG) {
/* maybe the first object of some derived class? */
mg=SvMAGIC(method_name);
do {
if (((method_info*)mg->mg_ptr)->accessor == cv) break;
} while ((mg=mg->mg_moremagic));
}
if (mg==0) {
method_info info;
if (next_op->op_type == OP_SASSIGN) {
filter=GvSV(CvGV(cv));
if (SvROK(filter) || (SvPOK(filter) && SvCUR(filter))) {
OP *sub_op;
NewOp(0, sub_op, 1, OP);
Copy(PL_op, sub_op, 1, OP);
sub_op->op_private &= ~OPpLVAL_INTRO;
sub_op->op_next=next_op;
next_op->op_private ^= OPpASSIGN_BACKWARDS;
next_op=sub_op;
if (SvROK(filter)) {
filter=SvRV(filter);
} else {
GV *method_gv=gv_fetchmethod(SvSTASH(obj), SvPVX(filter));
CV *filter_cv= method_gv && isGV(method_gv)
? GvCV(method_gv)
: (CV*)try_namespace_lookup(aTHX_ SvSTASH(obj), filter, SVt_PVCV);
if (!filter_cv) croak("access filter method %.*s not found", SvCUR(filter), SvPVX(filter));
filter=(SV*)filter_cv;
}
} else {
next_op=PL_op;
filter=0;
}
} else {
next_op=PL_op;
}
info.field_index=index;
info.filter=filter;
info.filter_is_method=filter && CvMETHOD((CV*)filter);
info.next_op=next_op;
info.fallback=0;
info.accessor=cv;
if (SvTYPE(method_name) < SVt_PVMG) {
/* first use of this operation */
U32 flags=SvFLAGS(method_name) & (SVf_FAKE | SVf_READONLY);
U32 hash=SvUVX(method_name);
SvFLAGS(method_name) &= ~(SVf_FAKE | SVf_READONLY);
sv_magicext(method_name, (SV*)class, PERL_MAGIC_ext, 0, (char*)&info, sizeof(info));
SvFLAGS(method_name) |= flags;
SvUVX(method_name)=hash;
o->op_ppaddr=&pp_access;
} else {
sv_magicext(method_name, (SV*)class, PERL_MAGIC_ext, 0, (char*)&info, sizeof(info));
}
} else {
/* first object of some derived class */
sv_magicext(method_name, (SV*)class, PERL_MAGIC_ext, 0, mg->mg_ptr, 0);
filter=((method_info*)mg->mg_ptr)->filter;
}
if (filter) {
OP *prev=cUNOP->op_first->op_sibling;
while (prev->op_next != o) prev=prev->op_next;
PL_op=prev;
PUSHMARK(SP); /* restore the mark */
return; /* avoid PUTBACK */
}
}
PUSHs(*av_fetch((AV*)obj, index, 1));
}
#line 360 "Struct.c"
PUTBACK;
return;
}
}
XS(XS_Struct_method_call); /* prototype to pass -Wmissing-prototypes */
XS(XS_Struct_method_call)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 1)
Perl_croak(aTHX_ "Usage: %s(%s)", "Struct::method_call", "obj");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
SV * obj =SvRV(ST(0));
#line 342 "Struct.xs"
{
method_info info, *infop=&info;
I32 index=SvIVX(cv);
OP *o=method_named_op(PL_op),
*next_op=PL_op->op_next;
SV *fallback=GvSV(CvGV(cv));
if (SvROK(fallback)) fallback=SvRV(fallback);
if (SvTYPE(fallback)!=SVt_PVCV) fallback=0;
if (o) {
SV *method_name=cSVOPo_sv;
HV *class=SvSTASH(obj);
MAGIC *mg=0;
if (SvTYPE(method_name) == SVt_PVMG) {
/* maybe the first object of some derived class? */
mg=SvMAGIC(method_name);
do {
if (((method_info*)mg->mg_ptr)->accessor == cv) break;
} while ((mg=mg->mg_moremagic));
}
if (mg==0) {
info.field_index=index;
info.filter=0;
info.next_op=PL_op;
info.fallback=fallback;
info.accessor=cv;
if (SvTYPE(method_name) < SVt_PVMG) {
/* first use of this operation */
U32 flags=SvFLAGS(method_name) & (SVf_FAKE | SVf_READONLY);
U32 hash=SvUVX(method_name);
SvFLAGS(method_name) &= ~(SVf_FAKE | SVf_READONLY);
sv_magicext(method_name, (SV*)class, PERL_MAGIC_ext, 0, (char*)&info, sizeof(info));
SvFLAGS(method_name) |= flags;
SvUVX(method_name)=hash;
switch (next_op->op_type) {
case OP_SASSIGN:
o->op_ppaddr=&pp_access; break;
case OP_ENTERSUB:
o->op_ppaddr=&pp_method_call; break;
default:
o->op_ppaddr=&pp_method_access; break;
}
} else {
sv_magicext(method_name, (SV*)class, PERL_MAGIC_ext, 0, (char*)&info, sizeof(info));
}
} else {
/* first object of some derived class */
sv_magicext(method_name, (SV*)class, PERL_MAGIC_ext, 0, mg->mg_ptr, 0);
infop=(method_info*)mg->mg_ptr;
}
}
switch (next_op->op_type) {
default:
PUSHs(find_method(aTHX_ index, 0));
break;
case OP_SASSIGN:
PUSHs(*av_fetch((AV*)obj, index, 1));
break;
case OP_ENTERSUB:
if (!o) {
info.fallback=fallback;
info.next_op=PL_op;
}
if (find_method(aTHX_ index, infop)) {
if (next_op->op_ppaddr==&pp_hide_orig_object)
next_op->op_ppaddr=&pp_hide_orig_object_first;
else
next_op->op_ppaddr=&select_method_helper_op;
}
++SP;
/* TRICK: even if find_method pushed two or more items on the stack (object, hidden object, method), this XSUB may push only one
(due to scalar context imposed on this op). Thus we pretend here to push just one item, and the helper
op unveils the rest. */
}
}
#line 465 "Struct.c"
PUTBACK;
return;
}
}
XS(XS_Struct_get_field_index); /* prototype to pass -Wmissing-prototypes */
XS(XS_Struct_get_field_index)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 1)
Perl_croak(aTHX_ "Usage: %s(%s)", "Struct::get_field_index", "sub");
PERL_UNUSED_VAR(cv); /* -W */
{
SV * sub = ST(0);
I32 RETVAL;
dXSTARG;
#line 430 "Struct.xs"
RETVAL=SvROK(sub) && (sub=SvRV(sub), CvSTASH((CV*)sub)==secret_pkg) ? SvIVX(sub) : -1;
#line 489 "Struct.c"
XSprePUSH; PUSHi((IV)RETVAL);
}
XSRETURN(1);
}
XS(XS_Struct_get_field_filter); /* prototype to pass -Wmissing-prototypes */
XS(XS_Struct_get_field_filter)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 1)
Perl_croak(aTHX_ "Usage: %s(%s)", "Struct::get_field_filter", "sub");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
SV * sub = ST(0);
#line 439 "Struct.xs"
{
SV *filter=&PL_sv_undef;
if (SvROK(sub) && (sub=SvRV(sub), CvSTASH((CV*)sub)==secret_pkg)) {
filter=GvSV(CvGV(sub));
if (SvROK(filter) && SvTYPE(SvRV(filter))==SVt_PVCV)
filter=sv_mortalcopy(filter);
else
filter=&PL_sv_undef;
}
PUSHs(filter);
}
#line 523 "Struct.c"
PUTBACK;
return;
}
}
XS(XS_Struct_create_accessor); /* prototype to pass -Wmissing-prototypes */
XS(XS_Struct_create_accessor)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 2)
Perl_croak(aTHX_ "Usage: %s(%s)", "Struct::create_accessor", "index, method_field");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
I32 index = (I32)SvIV(ST(0));
SV * method_field = ST(1);
#line 457 "Struct.xs"
{
SV *sub=newSV(0);
sv_upgrade(sub, SVt_PVCV);
SvIVX(sub)=index;
SvFLAGS(sub) |= SVf_IOK | SVp_IOK;
CvXSUB(sub)=SvTRUE(method_field) ? &XS_Struct_method_call : &XS_Struct_access;
CvFLAGS(sub)=CvFLAGS(cv) | CVf_ANON | CVf_LVALUE | CVf_METHOD | CVf_NODEBUG; /* the standard flags should be the same by all XSUBs */
CvSTASH(sub)=secret_pkg;
PUSHs(sv_2mortal(newRV_noinc(sub)));
}
#line 557 "Struct.c"
PUTBACK;
return;
}
}
XS(XS_Struct_original_object); /* prototype to pass -Wmissing-prototypes */
XS(XS_Struct_original_object)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 0)
Perl_croak(aTHX_ "Usage: %s(%s)", "Struct::original_object", "");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
#line 472 "Struct.xs"
{
XPUSHs(AvALLOC(GvAV(PL_defgv))[0]);
}
#line 582 "Struct.c"
PUTBACK;
return;
}
}
XS(XS_Struct_mark_as_default); /* prototype to pass -Wmissing-prototypes */
XS(XS_Struct_mark_as_default)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 1)
Perl_croak(aTHX_ "Usage: %s(%s)", "Struct::mark_as_default", "sv");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
SV * sv = ST(0);
#line 481 "Struct.xs"
{
if (!SvTEMP(sv))
sv=sv_mortalcopy(sv);
PUSHs(sv);
sv_magicext(sv, 0, PERL_MAGIC_ext, 0, (const char*)&secret_pkg, 0);
}
#line 611 "Struct.c"
PUTBACK;
return;
}
}
XS(XS_Struct_start_compile_constructor); /* prototype to pass -Wmissing-prototypes */
XS(XS_Struct_start_compile_constructor)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 0)
Perl_croak(aTHX_ "Usage: %s(%s)", "Struct::start_compile_constructor", "");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
#line 492 "Struct.xs"
{
OP *o_srefgen;
OP *o=PL_op->op_sibling;
if (o->op_type != OP_SREFGEN)
croak("call in wrong context (1)");
o_srefgen=o;
o=cUNOPo->op_first;
if (o->op_type == OP_NULL)
o=cUNOPo->op_first;
if (o->op_type != OP_ANONLIST)
croak("call in wrong context (2)");
o->op_ppaddr=&pp_quick_anonlist;
o=o_srefgen;
while (o->op_sibling) o=o->op_sibling;
if (o->op_type == OP_NULL)
o=cUNOPo->op_first; // OP_GV(inherit_const)
o=o->op_next;
if (o->op_type != OP_ENTERSUB)
croak("call in wrong context (3)");
o=cUNOPo->op_first;
if (o->op_type == OP_NULL)
o=cUNOPo->op_first;
if (o->op_type != OP_PUSHMARK)
croak("call in wrong context (4)");
o->op_next=PL_op->op_next;
}
#line 659 "Struct.c"
PUTBACK;
return;
}
}
XS(XS_Struct_is_default); /* prototype to pass -Wmissing-prototypes */
XS(XS_Struct_is_default)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 1)
Perl_croak(aTHX_ "Usage: %s(%s)", "Struct::is_default", "sv");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
SV * sv = ST(0);
#line 524 "Struct.xs"
{
if (SvTYPE(sv) == SVt_PVMG) {
MAGIC *mg=SvMAGIC(sv);
if (mg && mg->mg_type==PERL_MAGIC_ext && mg->mg_ptr==(const char*)&secret_pkg)
XSRETURN_YES;
}
XSRETURN_NO;
}
#line 690 "Struct.c"
PUTBACK;
return;
}
}
#ifdef __cplusplus
extern "C"
#endif
XS(boot_Struct); /* prototype to pass -Wmissing-prototypes */
XS(boot_Struct)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
char* file = __FILE__;
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(items); /* -W */
XS_VERSION_BOOTCHECK ;
newXS("Struct::access", XS_Struct_access, file);
newXS("Struct::method_call", XS_Struct_method_call, file);
newXS("Struct::get_field_index", XS_Struct_get_field_index, file);
newXS("Struct::get_field_filter", XS_Struct_get_field_filter, file);
newXS("Struct::create_accessor", XS_Struct_create_accessor, file);
newXS("Struct::original_object", XS_Struct_original_object, file);
newXS("Struct::mark_as_default", XS_Struct_mark_as_default, file);
newXS("Struct::start_compile_constructor", XS_Struct_start_compile_constructor, file);
newXS("Struct::is_default", XS_Struct_is_default, file);
/* Initialisation Section */
#line 534 "Struct.xs"
secret_pkg=gv_stashpv("Struct::.secret", TRUE);
#line 728 "Struct.c"
/* End of Initialisation Section */
XSRETURN_YES;
}
syntax highlighted by Code2HTML, v. 0.9.1