Math-Pari
view release on metacpan or search on metacpan
CASE_INTERFACE(73);
CASE_INTERFACE(86);
CASE_INTERFACE(87);
CASE_INTERFACE(9900);
default:
if (!ep)
croak("Unsupported interface %ld for \"direct-link\" Pari function %s",
valence, olds);
if (!ep->code)
croak("Unsupported interface %ld and no code for a Pari function %s",
valence, olds);
flexible:
s1 = s = ep->code;
if (*s1 == 'x')
s1++;
if (*s1 == 'v') {
pbuf = "_flexible_void";
DO_INTERFACE(_flexible_void);
}
else if (*s1 == 'l') {
pbuf = "_flexible_long";
DO_INTERFACE(_flexible_long);
}
else if (*s1 == 'i') {
pbuf = "_flexible_int";
DO_INTERFACE(_flexible_int);
}
else {
pbuf = "_flexible_gen";
DO_INTERFACE(_flexible_gen);
}
flexible = 1;
}
strcpy(subname+12,"interface");
strcpy(subname+12+9,pbuf);
protocv = perl_get_cv(subname, FALSE);
if (protocv) {
proto = SvPV((SV*)protocv,na);
}
strcpy(subname+12,olds);
RETVAL = newXS(subname,math_pari_subaddr,file);
if (proto)
sv_setpv((SV*)RETVAL, proto);
XSINTERFACE_FUNC_SET(RETVAL, flexible ? (void*)ep : (void*)func);
} else {
croak( "Cannot load a Pari macro `%s': macros are unsupported; VALENCE=%#04x, code=<%s>, isFunction=%d, EpVAR=%d",
olds, (ep ? (int)EpVALENCE(ep) : 0x666), (ep->code ? ep->code : "<null>"), isPariFunction(ep), (int)EpVAR);
}
}
OUTPUT:
RETVAL
# Tag is menu entry, or -1 for all.
void
_listPari(tag)
int tag
PPCODE:
{
long valence;
entree *ep, *table = functions_basic;
int i=-1;
while (++i <= 1) {
if (i==1)
#if defined(NO_HIGHLEVEL_PARI) || PARI_VERSION_EXP >= 2009000 /* Probably disappered earlier */
break;
#else
table = functions_highlevel;
#endif
for(ep = table; ep->name; ep++) {
valence = EpVALENCE(ep);
if ((tag == -1 && !_is_internal(ep->menu)) || ep->menu == tag) {
switch (valence) {
default:
case 0:
if (ep->code == 0)
break;
/* FALL THROUGH */
case 1:
case 10:
case 199:
case 109:
case 11:
case 15:
case 2:
case 20:
case 299:
case 209:
case 2099:
case 2199:
case 3:
case 30:
case 4:
case 5:
case 21:
case 23:
case 24:
case 25:
case 29:
case 32:
case 33:
case 35:
case 12:
case 13:
case 14:
case 26:
case 28:
case 31:
case 34:
case 22:
case 27:
case 37:
case 47:
case 48:
case 49:
case 83:
# endif
}
#endif /* PARI_VERSION_EXP >= 2003000 */
PariStack = (SV *) GENfirstOnStack;
if (!worksv)
worksv = NEWSV(910,0);
if (workErrsv)
sv_setpvn(workErrsv, "", 0); /* Just in case, on restart */
else
workErrsv = newSVpvn("",0);
pariErr = &perlErr;
#if PARI_VERSION_EXP >= 2003000
pari_set_last_newline(1); /* Bug in PARI: at the start, we do not need extra newlines */
#endif
#if PARI_VERSION_EXP >= 2004000 /* Undocumented when it appeared; present in 2.5.0 */
cb_pari_err_recover = _svErrdie; /* XXXX Not enough for our needs! */
cb_pari_handle_exception = math_pari_handle_exception;
# ifdef CB_EXCEPTION_FLAGS
cb_exception_resets_avma = 1;
cb_exception_flushes_err = 1;
# endif
av = avma;
/* Init the rest ourselves */
#if PARI_VERSION_EXP >= 2009000
if (!GP_DATA->colormap) /* init_defaults() leaves them NULL */
sd_graphcolormap("[\"white\",\"black\",\"gray\",\"violetred\",\"red\",\"green\",\"blue\",\"gainsboro\",\"purple\"]",0);
if (!GP_DATA->graphcolors)
sd_graphcolors("[4,5]",0);
avma = av;
#else /* !(PARI_VERSION_EXP >= 2009000) */
if (!pari_colormap) /* init_defaults() leaves them NULL */
pari_colormap = gclone(readseq("[\"white\",\"black\",\"gray\",\"violetred\",\"red\",\"green\",\"blue\",\"gainsboro\",\"purple\"]"));
if (!pari_graphcolors)
pari_graphcolors = gclone(readseq("[4,5]"));
avma = av;
#endif /* !(PARI_VERSION_EXP >= 2009000) */
#endif
#if PARI_VERSION_EXP < 2005000 /* Undocumented when it disappeared; missing in 2.5.0 */
foreignHandler = (void*)&callPerlFunction;
foreignExprSwitch = (char)SVt_PVCV;
foreignExprHandler = &exprHandler_Perl;
#endif
foreignAutoload = &autoloadPerlFunction;
foreignFuncFree = &freePerlFunction;
pariStash = gv_stashpv("Math::Pari", TRUE);
pariEpStash = gv_stashpv("Math::Pari::Ep", TRUE);
perlavma = sentinel = avma;
fmt_nbPset(def_fmt_nb);
global_top = myPARI_top;
#if PARI_VERSION_EXP >= 2004002 /* Undocumented when it appeared; present in 2.5.0 */
if (! code_return_1) {
code_return_1 = gclone(compile_str("x->1"));
code2_return_1 = gclone(compile_str("(x,y)->1"));
avma = sentinel;
}
#endif
}
void
memUsage()
PPCODE:
#ifdef DEBUG_PARI
EXTEND(sp, 4); /* Got cv + 0, - but on newer Perls, this does not count. Return 4. */
PUSHs(sv_2mortal(newSViv(SVnumtotal)));
PUSHs(sv_2mortal(newSViv(SVnum)));
PUSHs(sv_2mortal(newSViv(onStack)));
PUSHs(sv_2mortal(newSViv(offStack)));
#endif
void
dumpStack()
PPCODE:
long i = 0, ssize, oursize = 0;
SV *ret, *sv1, *nextsv;
const char *pref = "";
switch(GIMME_V) {
case G_VOID:
pref = "# ";
case G_SCALAR:
ssize = getstack();
ret = newSVpvf("%sstack size is %ld bytes (%ld x %ld longs)\n",
pref, ssize, (long)sizeof(long), ssize/sizeof(long));
for (sv1 = PariStack; sv1 != (SV *) GENfirstOnStack; sv1 = nextsv) {
GEN x = (GEN) SV_myvoidp_get(sv1);
SV* tmp = pari_print(x);
sv_catpvf(ret,"%s %2ld: %s\n", pref, i, SvPV_nolen(tmp));
SvREFCNT_dec(tmp);
i++;
oursize += gsizeword(x);
nextsv = SV_Stack_find_next(sv1);
}
sv_catpvf(ret,"%sour data takes %ld words out of %ld words on stack\n", pref, oursize, ssize/sizeof(long));
if(GIMME_V == G_VOID) {
PerlIO_puts(PerlIO_stdout(), SvPV_nolen(ret));
SvREFCNT_dec(ret);
XSRETURN(0);
} else {
ST(0) = sv_2mortal(ret);
XSRETURN(1);
}
case G_ARRAY:
for (sv1 = PariStack; sv1 != (SV *) GENfirstOnStack; sv1 = nextsv) {
GEN x = (GEN) SV_myvoidp_get(sv1);
XPUSHs(sv_2mortal(pari_print(x)));
nextsv = SV_Stack_find_next(sv1);
}
}
void
__dumpStack()
PPCODE:
GEN x = (GEN)avma; /* If this works, it is accidental only: it assumes the entry point to “the region on stack” is at its smallest address. */
long ssize, i = 0;
SV* ret;
switch(GIMME_V) {
case G_VOID:
case G_SCALAR:
ssize = getstack();
ret = newSVpvf("stack size is %ld bytes (%ld x %ld longs)\n",
ssize,(long)sizeof(long),ssize/sizeof(long));
for(; x < (GEN)myPARI_top; x += gsizeword(x), i++) {
SV* tmp = pari_print(x);
sv_catpvf(ret," %2ld: %s\n",i,SvPV_nolen(tmp));
SvREFCNT_dec(tmp);
}
if(GIMME_V == G_VOID) {
PerlIO_puts(PerlIO_stdout(), SvPV_nolen(ret));
SvREFCNT_dec(ret);
XSRETURN(0);
} else {
ST(0) = sv_2mortal(ret);
XSRETURN(1);
}
case G_ARRAY:
for(; x < (GEN)myPARI_top; x += gsizeword(x), i++)
XPUSHs(sv_2mortal(pari_print(x)));
}
void
dumpHeap()
PPCODE:
heap_dumper_t hd;
int context = GIMME_V, m;
SV* ret = Nullsv; /* Avoid unit warning */
switch(context) {
case G_VOID:
case G_SCALAR: ret = newSVpvn("",0); break;
case G_ARRAY: ret = (SV*)newAV(); break;
}
hd.words = hd.items = 0;
hd.acc = ret;
hd.context = context;
heap_dumper(&hd);
switch(context) {
case G_VOID:
case G_SCALAR: {
SV* tmp = newSVpvf("heap had %ld bytes (%ld items)\n",
(hd.words + BL_HEAD * hd.items) * sizeof(long),
hd.items);
sv_catsv(tmp,ret);
SvREFCNT_dec(ret);
if(GIMME_V == G_VOID) {
PerlIO_puts(PerlIO_stdout(), SvPV_nolen(tmp));
SvREFCNT_dec(tmp);
XSRETURN(0);
} else {
ST(0) = sv_2mortal(tmp);
XSRETURN(1);
}
}
case G_ARRAY:
for(m = 0; m <= av_len((AV*)ret); m++)
XPUSHs(sv_2mortal(SvREFCNT_inc(*av_fetch((AV*)ret,m,0))));
SvREFCNT_dec(ret);
}
MODULE = Math::Pari PACKAGE = Math::Pari
void
DESTROY(rv)
SV * rv
CODE:
{
/* PariStack keeps the latest SV that keeps a GEN on stack. */
SV* sv = SvRV(rv);
char* ostack; /* The value of PariStack when the
* variable was created, thus the
* previous SV that keeps a GEN from
* stack, or some atoms. */
long oldavma; /* The value of avma on the entry
* to function having the SV as
* argument. */
long howmany;
SV_OAVMA_PARISTACK_get(sv, oldavma, ostack);
oldavma += myPARI_bot;
#if 1
( run in 1.538 second using v1.01-cache-2.11-cpan-71847e10f99 )