/* Copyright (c) 1997-2004			 -*- 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: Scope.xs,v 1.6 2004/11/01 21:35:09 gawrilow Exp $"

#include "Ext.h"

static
void localize_marker(pTHX_ void *p)
{
   SV *errsv=get_sv("@", FALSE);
   if (SvPOKp(errsv) && SvCUR(errsv)==0) {
      sv_setpv(errsv, "Scope::end missing");
      croak(Nullch);
   }
}

typedef struct local_var_ptrs {
   SV *var;
   void *orig_any;
   SV *temp_owner;
} local_var_ptrs;

static
local_var_ptrs* do_local_var(SV *var, SV *value)
{
   local_var_ptrs *ptrs;
   New(0, ptrs, 1, local_var_ptrs);
   ptrs->var=var;
   ptrs->orig_any=SvANY(var);
   SvANY(var)=SvANY(value);
   ptrs->temp_owner=value;
   SvREFCNT_inc(var);
   SvREFCNT_inc(value);
   return ptrs;
}

static
void undo_local_var(pTHX_ void *p)
{
   local_var_ptrs *ptrs=(local_var_ptrs*)p;
   SvANY(ptrs->var)=ptrs->orig_any;
   SvREFCNT_dec(ptrs->var);
   SvREFCNT_dec(ptrs->temp_owner);
   Safefree(p);
}

typedef struct local_scalar_ptrs {
   SV *var;
   SV orig;
} local_scalar_ptrs;

static
local_scalar_ptrs* do_local_scalar(SV *var, SV *value)
{
   local_scalar_ptrs *ptrs;
   New(0, ptrs, 1, local_scalar_ptrs);
   ptrs->var=var;
   ptrs->orig.sv_any=var->sv_any;
   ptrs->orig.sv_refcnt=var->sv_refcnt;
   ptrs->orig.sv_flags=var->sv_flags;
   var->sv_any=0;
   var->sv_flags=0;
   var->sv_refcnt=1;
   sv_setsv(var,value);
   return ptrs;
}

static
void undo_local_scalar(pTHX_ void *p)
{
   local_scalar_ptrs *ptrs=(local_scalar_ptrs*)p;
   if (SvREFCNT(ptrs->var)>1) {
      SvREFCNT_dec(ptrs->var);
   } else {
      SvREFCNT(ptrs->var)=0;  sv_clear(ptrs->var);
   }
   ptrs->var->sv_any=ptrs->orig.sv_any;
   ptrs->var->sv_refcnt=ptrs->orig.sv_refcnt;
   ptrs->var->sv_flags=ptrs->orig.sv_flags;
   Safefree(p);
}

MODULE = Poly::Scope		PACKAGE = Poly::Scope

void
begin_locals(scope)
   SV *scope=SvRV(ST(0));
CODE:
LEAVE;
{
   save_destructor_x(&localize_marker, scope);
}
ENTER;

void
end_locals(scope)
   SV *scope=SvRV(ST(0));
CODE:
LEAVE;
{
   ANY *mainstack=PL_savestack;
   I32 frame_top=PL_savestack_ix, frame_bottom=PL_scopestack[PL_scopestack_ix-1], f, to_save;

   /* find the marker or resign */
   for (f=frame_top-3; f >= frame_bottom; --f)
      if (mainstack[f].any_ptr == (void*)&localize_marker
	  && f+2 < frame_top
	  && mainstack[f+2].any_i32 == SAVEt_DESTRUCTOR_X) {

	 if (scope != (SV*)mainstack[f+1].any_ptr) break;

	 to_save=frame_top-(f+3);
	 if (to_save > 0) {
	    SV *marker=*av_fetch((AV*)scope, 0, 0);
	    sv_catpvn(marker, (char*)&(mainstack[f+3]), to_save*sizeof(ANY));
	    PL_savestack_ix=f;	/* pop the marker and the saved locals quickly */
	 }
	    scope=0;
	    break;
      }
   if (scope)
      croak("Scope: begin-end mismatch");
}
ENTER;

void
unwind(marker)
   SV *marker=ST(0);
CODE:
{
   I32 saved=SvCUR(marker)/sizeof(ANY);
   if (saved) {
      LEAVE;
      SSCHECK(saved);
      Copy(SvPVX(marker), &(PL_savestack[PL_savestack_ix]), saved, ANY);
      PL_savestack_ix+=saved;
      ENTER;
   }
}

MODULE = Poly::Scope		PACKAGE = Poly

void
local_scalar(var, value)
   SV *var=ST(0), *value=ST(1);
PROTOTYPE: $$
CODE:
{
   if ( (isGV(var) ? !(var=GvSV(var))
	           : SvTYPE(var) >= SVt_PVAV) ||
	SvTYPE(value) >= SVt_PVAV )
      croak("usage: local_scalar(*glob || $var, value)");
   LEAVE;
   save_destructor_x(&undo_local_scalar, do_local_scalar(var, value));
   ENTER;
}

void
local_array(var, value)
   SV *var=ST(0), *value=ST(1);
PROTOTYPE: $$
CODE:
{
   if ( (isGV(var) ? !(var=(SV*)GvAV(var))
                   : !SvROK(var) || (var=SvRV(var), SvTYPE(var) != SVt_PVAV)) ||
	(!SvROK(value) || (value=SvRV(value), SvTYPE(value) != SVt_PVAV)) )
      croak("usage: local_array(*glob || \\@array, [ value ])");
   LEAVE;
   save_destructor_x(&undo_local_var, do_local_var(var, value));
   ENTER;
}

void
local_hash(var, value)
   SV *var=ST(0), *value=ST(1);
PROTOTYPE: $$
CODE:
{
   if ( (isGV(var) ? !(var=(SV*)GvHV(var))
	           : !SvROK(var) || (var=SvRV(var), SvTYPE(var) != SVt_PVHV)) ||
	(!SvROK(value) || (value=SvRV(value), SvTYPE(value) != SVt_PVHV)) )
      croak("usage: local_hash(*glob || \\%hash, { value })");
   LEAVE;
   save_destructor_x(&undo_local_var, do_local_var(var, value));
   ENTER;
}

void
local_sub(var, value)
   SV *var=ST(0), *value=ST(1);
PROTOTYPE: $$
CODE:
{
   if ( (isGV(var) ? !(var=(SV*)GvCV(var))
	           : !SvROK(var) || (var=SvRV(var), SvTYPE(var) != SVt_PVCV)) ||
	(!SvROK(value) || (value=SvRV(value), SvTYPE(value) != SVt_PVCV)) )
      croak("usage: local_sub(*glob || \\&sub, sub { ... })");
   LEAVE;
   save_destructor_x(&undo_local_var, do_local_var(var, value));
   ENTER;
}

BOOT:
if (PL_DBgv) {
   CvNODEBUG_on(get_cv("Poly::Scope::begin_locals", FALSE));
   CvNODEBUG_on(get_cv("Poly::Scope::end_locals", FALSE));
   CvNODEBUG_on(get_cv("Poly::Scope::unwind", FALSE));
   CvNODEBUG_on(get_cv("Poly::local_scalar", FALSE));
   CvNODEBUG_on(get_cv("Poly::local_array", FALSE));
   CvNODEBUG_on(get_cv("Poly::local_hash", FALSE));
}
