/* 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

MODULE = Poly::Ext		PACKAGE = Poly

PROTOTYPES: DISABLE

void
dump_sub(gv)
   SV *gv;
CODE:
{
#ifdef DEBUGGING
   Perl_dump_sub(aTHX_ (GV*)gv);
#else
   croak("this perl is compiled without DEBUGGING");
   gv=0;
#endif
}

BOOT:
{
#ifdef not_PERL_5_8
   PL_check[OP_METHOD]=&intercept_ck_method;
   PL_ppaddr[OP_DOFILE]=&fix_pp_dofile;
#endif
}