/*
* This file was generated automatically by ExtUtils::ParseXS version 2.18 from the
* contents of Ext.xs. Do not edit this file, edit Ext.xs instead.
*
* ANY CHANGES MADE HERE WILL BE LOST!
*
*/
#line 1 "Ext.xs"
/* Copyright (c) 1997-2005 -*- 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: Ext.xs 6652 2005-12-21 19:51:48Z gawrilow $"
#include "Ext.h"
#include <stdio.h>
void dump_me(SV *x)
{
if (SvROK(x)) {
fprintf(stderr, "{ REF=%p, sv_any=%p refcnt=%u flags=%x } ", x, SvANY(x),
(unsigned int)SvREFCNT(x), (unsigned int)SvFLAGS(x));
x=SvRV(x);
}
fprintf(stderr, "SV=%p, sv_any=%p refcnt=%u flags=%x", x, SvANY(x),
(unsigned int)SvREFCNT(x), (unsigned int)SvFLAGS(x));
if (SvPOKp(x)) fprintf(stderr, " pv=%.*s", SvCUR(x), SvPVX(x));
if (SvIOKp(x)) fprintf(stderr, " iv=%d", (int)SvIVX(x));
if (SvNOKp(x)) fprintf(stderr, " nv=%f", SvNVX(x));
if (SvTYPE(x) >= SVt_PVMG) {
MAGIC *m;
HV *h=SvSTASH(x);
if (h)
fprintf(stderr, " class=%s", HvNAME(h));
for (m=SvMAGIC(x); m; m=m->mg_moremagic) {
SV *mo=m->mg_obj;
char *moptr="=";
if (mo && SvROK(mo)) {
mo=SvRV(mo);
moptr="->";
}
fprintf(stderr, " magic=%p(%c) { obj%s%p str=%p len=%d }", m, m->mg_type, moptr, mo, m->mg_ptr, (int)m->mg_len);
}
switch (SvTYPE(x)) {
case SVt_PVCV:
if (SvLEN(x)) fprintf(stderr, " pv=%.*s", SvCUR(x), SvPVX(x));
if (CvSTASH(x)) fprintf(stderr, " pkg=%s", HvNAME(CvSTASH(x)));
if (!(CvFLAGS(x) & CVf_ANON))
fprintf(stderr, " name=%s::%.*s", HvNAME(GvSTASH(CvGV(x))), GvNAMELEN(CvGV(x)), GvNAME(CvGV(x)));
else
fprintf(stderr, " refcnt(glob)=%u", (unsigned int)SvREFCNT(CvGV(x)));
break;
case SVt_PVGV:
fprintf(stderr, " gvname=%.*s cv=%p cvgen=%u", GvNAMELEN(x), GvNAME(x), GvCV(x), (unsigned int)GvCVGEN(x));
if (GvEGV(x)) {
fprintf(stderr, " egv=%p:%.*s cv=%p cvgen=%u", GvEGV(x), GvNAMELEN(GvEGV(x)), GvNAME(GvEGV(x)), GvCV(GvEGV(x)), (unsigned int)GvCVGEN(GvEGV(x)));
}
break;
case SVt_PVHV:
fprintf(stderr, " keys=%d name=%s", (int)((XPVHV*)SvANY(x))->xhv_keys, ((XPVHV*)SvANY(x))->xhv_name);
break;
case SVt_PVAV:
fprintf(stderr, " fill=%d max=%d flags=%x", (int)((XPVAV*)SvANY(x))->xav_fill, (int)((XPVAV*)SvANY(x))->xav_max, ((XPVAV*)SvANY(x))->xav_flags);
break;
}
}
}
/******************************************************************************************************/
/* The obsolete stuff is left here only for teaching purposes */
#if 0
void
and_not(s1,s2)
unsigned char *s1;
unsigned char *s2;
PROTOTYPE: $$
CODE:
{
I32 l=min(SvCUR(ST(0)), SvCUR(ST(1)));
for ( ; l>0; --l, ++s1, ++s2) {
*s1 &= ~ *s2;
}
}
void
includes(s1,s2)
unsigned char *s1;
unsigned char *s2;
PROTOTYPE: $$
CODE:
{
I32 l1=SvCUR(ST(0)), l2=SvCUR(ST(1));
for ( ; l1>0 && l2>0; --l1, --l2, ++s1, ++s2) {
if ((*s1 & *s2) != *s2) XSRETURN_NO;
}
for ( ; l2>0; --l2, ++s2) {
if (*s2) XSRETURN_NO;
}
}
XSRETURN_YES;
void
intersect(s1,s2)
unsigned char *s1;
unsigned char *s2;
PROTOTYPE: $$
CODE:
{
I32 l=min(SvCUR(ST(0)), SvCUR(ST(1)));
for ( ; l>0; --l, ++s1, ++s2) {
if (*s1 & *s2) XSRETURN_YES;
}
}
XSRETURN_NO;
void
empty(s)
unsigned char *s;
PROTOTYPE: $
CODE:
{
I32 l=SvCUR(ST(0));
for ( ; l>0; --l, ++s) {
if (*s) XSRETURN_NO;
}
}
XSRETURN_YES;
#endif
#ifdef not_PERL_5_8
#define LvalMethodDebug 0
static
OP *defuse(OP *o)
{
if (o && o->op_type==OP_ENTERSUB) {
OP *kid;
for (kid=cBINOPo->op_first; kid; kid=kid->op_sibling) {
if (kid->op_type==OP_METHOD) {
kid->op_next=0;
#if LvalMethodDebug
fprintf(stderr, "LVALUE COMPLETE: %p\n", kid);
#endif
return o;
}
}
}
return 0;
}
static
OP* intercept_ck_sassign(pTHX_ OP *o)
{
OP *ret=ck_sassign(o);
if (ret==o && (o->op_private & 2) && defuse(cBINOPo->op_first->op_sibling)) {
PL_check[OP_SASSIGN]=&Perl_ck_sassign;
}
return ret;
}
static
OP* intercept_ck_add(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_ADD]=&Perl_ck_null;
}
return o;
}
static
OP* intercept_ck_subtract(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_SUBTRACT]=&Perl_ck_null;
}
return o;
}
static
OP* intercept_ck_multiply(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_MULTIPLY]=&Perl_ck_null;
}
return o;
}
static
OP* intercept_ck_pow(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_POW]=&Perl_ck_null;
}
return o;
}
static
OP* intercept_ck_divide(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_DIVIDE]=&Perl_ck_null;
}
return o;
}
static
OP* intercept_ck_modulo(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_MODULO]=&Perl_ck_null;
}
return o;
}
static
OP* intercept_ck_bit_or(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_BIT_OR]=&Perl_ck_bitop;
}
return ck_bitop(o);
}
static
OP* intercept_ck_bit_and(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_BIT_AND]=&Perl_ck_bitop;
}
return ck_bitop(o);
}
static
OP* intercept_ck_bit_xor(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_BIT_XOR]=&Perl_ck_bitop;
}
return ck_bitop(o);
}
static
OP* intercept_ck_null(pTHX_ OP *o)
{
OP *ret=o;
if ((o=cUNOPo->op_first) && defuse(cUNOPo->op_first)) {
PL_check[OP_NULL]=&Perl_ck_null;
}
return ret;
}
static
OP* intercept_ck_concat(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_CONCAT]=&Perl_ck_concat;
}
return ck_concat(o);
}
static
OP* intercept_ck_repeat(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_REPEAT]=&Perl_ck_repeat;
}
return ck_repeat(o);
}
static
OP* intercept_ck_left_shift(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_LEFT_SHIFT]=&Perl_ck_bitop;
}
return ck_bitop(o);
}
static
OP* intercept_ck_right_shift(pTHX_ OP *o)
{
if (defuse(cBINOPo->op_first)) {
PL_check[OP_RIGHT_SHIFT]=&Perl_ck_bitop;
}
return ck_bitop(o);
}
static
OP* intercept_ck_entersub(pTHX_ OP *o)
{
OP *ret=ck_subr(o);
char *before=PL_oldbufptr;
I32 lval=FALSE;
switch (*before) {
case '=':
if (before[1] != '=' && before[1] != '>') {
lval=TRUE;
PL_check[OP_SASSIGN]=&intercept_ck_sassign;
}
break;
case '+':
if (before[1] == '=' || before[1] == '+') {
lval=TRUE;
PL_check[OP_ADD]=&intercept_ck_add;
}
break;
case '-':
if (before[1] == '=' || before[1] == '-') {
lval=TRUE;
PL_check[OP_SUBTRACT]=&intercept_ck_subtract;
}
break;
case '*':
if (before[1] == '=') {
lval=TRUE;
PL_check[OP_MULTIPLY]=&intercept_ck_multiply;
} else if (before[1] == '*' && before[2] == '=') {
lval=TRUE;
PL_check[OP_POW]=&intercept_ck_pow;
}
break;
case '/':
if (before[1] == '=') {
lval=TRUE;
PL_check[OP_DIVIDE]=&intercept_ck_divide;
}
break;
case '%':
if (before[1] == '=') {
lval=TRUE;
PL_check[OP_MODULO]=&intercept_ck_modulo;
}
break;
case '|':
if (before[1] == '=') {
lval=TRUE;
PL_check[OP_BIT_OR]=&intercept_ck_bit_or;
} else if (before[1] == '|' && before[2] == '=') {
lval=TRUE;
PL_check[OP_NULL]=&intercept_ck_null;
}
break;
case '&':
if (before[1] == '=') {
lval=TRUE;
PL_check[OP_BIT_AND]=&intercept_ck_bit_and;
} else if (before[1] == '&' && before[2] == '=') {
lval=TRUE;
PL_check[OP_NULL]=&intercept_ck_null;
}
break;
case '^':
if (before[1] == '=') {
lval=TRUE;
PL_check[OP_BIT_XOR]=&intercept_ck_bit_xor;
}
break;
case '.':
if (before[1] == '=') {
lval=TRUE;
PL_check[OP_CONCAT]=&intercept_ck_concat;
}
break;
case 'x':
if (before[1] == '=') {
lval=TRUE;
PL_check[OP_REPEAT]=&intercept_ck_repeat;
}
break;
case '<':
if (before[1] == '<' && before[2] == '=') {
lval=TRUE;
PL_check[OP_LEFT_SHIFT]=&intercept_ck_left_shift;
}
break;
case '>':
if (before[1] == '>' && before[2] == '=') {
lval=TRUE;
PL_check[OP_RIGHT_SHIFT]=&intercept_ck_right_shift;
}
break;
}
if (!lval) {
OP *kid=0;
for (kid=cBINOPo->op_first; kid; kid=kid->op_sibling) {
if (kid->op_type==OP_METHOD) {
kid->op_next=0;
#if LvalMethodDebug
fprintf(stderr, "DEFUSE(%c): %p\n", *before, kid);
#endif
break;
}
}
if (!kid)
croak("check_entersub: no OP_METHOD kid found\n");
#if LvalMethodDebug
} else {
fprintf(stderr, "ASSIGNMENT SEEN\n");
#endif
}
PL_check[OP_ENTERSUB]=&Perl_ck_subr;
return ret;
}
static
OP* intercept_ck_method(pTHX_ OP *o)
{
OP *ret=ck_method(o);
if (o==ret && cUNOPo->op_first->op_type != OP_CONST) {
ret=fold_constants(o->op_next=o);
#if LvalMethodDebug
fprintf(stderr, "METHOD: %p\n", ret);
#endif
PL_check[OP_ENTERSUB]=&intercept_ck_entersub;
}
return ret;
}
OP* fix_pp_dofile(pTHX)
{
I32 cix=cxstack_ix;
OP *o=PL_op, *ret=pp_require();
if (cxstack_ix > cix && (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR) {
if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
cxstack[cxstack_ix].blk_gimme=G_VOID;
else
cxstack[cxstack_ix].blk_gimme=G_ARRAY;
for (o=ret; o->op_sibling; o=o->op_sibling) ;
o->op_flags &= ~OPf_WANT;
}
return ret;
}
#endif
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(var) if (0) var = var
#endif
#line 460 "Ext.c"
XS(XS_Poly_dump_sub); /* prototype to pass -Wmissing-prototypes */
XS(XS_Poly_dump_sub)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 1)
Perl_croak(aTHX_ "Usage: %s(%s)", "Poly::dump_sub", "gv");
PERL_UNUSED_VAR(cv); /* -W */
{
SV * gv = ST(0);
#line 454 "Ext.xs"
{
#ifdef DEBUGGING
Perl_dump_sub(aTHX_ (GV*)gv);
#else
croak("this perl is compiled without DEBUGGING");
gv=0;
#endif
}
#line 484 "Ext.c"
}
XSRETURN_EMPTY;
}
#ifdef __cplusplus
extern "C"
#endif
XS(boot_Poly__Ext); /* prototype to pass -Wmissing-prototypes */
XS(boot_Poly__Ext)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
char* file = __FILE__;
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(items); /* -W */
XS_VERSION_BOOTCHECK ;
newXS("Poly::dump_sub", XS_Poly_dump_sub, file);
/* Initialisation Section */
#line 464 "Ext.xs"
{
#ifdef not_PERL_5_8
PL_check[OP_METHOD]=&intercept_ck_method;
PL_ppaddr[OP_DOFILE]=&fix_pp_dofile;
#endif
}
#line 518 "Ext.c"
/* End of Initialisation Section */
XSRETURN_YES;
}
syntax highlighted by Code2HTML, v. 0.9.1