1 #ifdef _WIN32 /* including windows.h later leads to macro name collisions */
2 # define WIN32_LEAN_AND_MEAN
3 # include <windows.h>
4 #endif
5
6 # include <pari.h>
7 # include <graph/rect.h>
8 # include <language/anal.h>
9
10 #ifdef HAVE_PARIPRIV
11 # include <headers/paripriv.h>
12 #endif
13
14 # include <gp/gp.h> /* init_opts */
15
16 /* On some systems /usr/include/sys/dl.h attempts to declare
17 ladd which pari.h already defined with a different meaning.
18
19 It is not clear whether this is a correct fix...
20 */
21 #undef ladd
22
23 #define PERL_POLLUTE /* We use older varnames */
24
25 #ifdef __cplusplus
26 extern "C" {
27 #endif
28
29 #include "EXTERN.h"
30 #include "perl.h"
31 #include "XSUB.h"
32 #include "func_codes.h"
33
34 #ifdef __cplusplus
35 }
36 #endif
37
38 #if !defined(na) && defined(PERL_VERSION) && (PERL_VERSION > 7) /* Added in 6 (???), Removed in 13 */
39 # define na PL_na
40 # define sv_no PL_sv_no
41 # define sv_yes PL_sv_yes
42 #endif
43
44 #if PARI_VERSION_EXP < 2002012
45 void init_defaults(int force); /* Probably, will never be fixed in 2.1.* */
46 #endif
47
48 /* This should not be defined at this moment, but in 5.001n is. */
49 #ifdef coeff
50 # undef coeff
51 #endif
52
53 #ifdef warner
54 # undef warner
55 #endif
56
57 /* $Id: Pari.xs,v 1.7 1995/01/23 18:50:58 ilya Exp ilya $ */
58 /* dFUNCTION should be the last declaration! */
59
60 #ifdef __cplusplus
61 #define VARARG ...
62 #else
63 #define VARARG
64 #endif
65
66 #define dFUNCTION(retv) retv (*FUNCTION)(VARARG) = \
67 (retv (*)(VARARG)) XSANY.any_dptr
68
69 #if DEBUG_PARI
70 static int pari_debug = 0;
71 # define RUN_IF_DEBUG_PARI(a) \
72 do { if (pari_debug) {a;} } while (0)
73 # define PARI_DEBUG_set(d) ((pari_debug = (d)), 1)
74 # define PARI_DEBUG() (pari_debug)
75 #else
76 # define RUN_IF_DEBUG_PARI(a)
77 # define PARI_DEBUG_set(d) (0)
78 # define PARI_DEBUG(d) (0)
79 #endif
80
81 #define DO_INTERFACE(inter) math_pari_subaddr = CAT2(XS_Math__Pari_interface, inter)
82 #define CASE_INTERFACE(inter) case inter: \
83 DO_INTERFACE(inter); break
84
85 #ifndef XSINTERFACE_FUNC_SET /* Not in 5.004_04 */
86 # define XSINTERFACE_FUNC_SET(cv,f) \
87 CvXSUBANY(cv).any_dptr = (void (*) (void*))(f)
88 #endif
89
90 #ifndef SvPV_nolen
91 STRLEN n___a;
92 # define SvPV_nolen(sv) SvPV((sv),n___a)
93 #endif
94
95 #ifndef PERL_UNUSED_VAR
96 # define PERL_UNUSED_VAR(var) if (0) var = var
97 #endif
98
99 /* Here is the rationals for managing SVs which keep GENs: when newly
100 created SVs from GENs on stack, the same moved to heap, and
101 originally from heap. We assume that we do not need to free stuff
102 that was originally on heap. However, we need to free the stuff we
103 moved from the stack ourself.
104
105 Here is how we do it: The variables that were initially off stack
106 have SvPVX == GENheap.
107
108 The variables that were moved from the stack have SvPVX ==
109 GENmovedOffStack.
110
111 If the variable is on stack, and it is the oldest one which is on
112 stack, then SvPVX == GENfirstOnStack.
113
114 Otherwise SvPVX is the next older SV that refers to a GEN on stack.
115
116 In the last two cases SvCUR is the offset on stack of the stack
117 frame on the entry into the function for which SV is the argument.
118 */
119
120 #ifndef USE_SLOW_NARGS_ACCESS
121 # define USE_SLOW_NARGS_ACCESS (defined(PERL_VERSION) && (PERL_VERSION > 9))
122 #endif
123
124 #if USE_SLOW_NARGS_ACCESS
125 # define PARI_MAGIC_TYPE ((char)0xDE)
126 # define PARI_MAGIC_PRIVATE 0x2020
127
128 /* Can't return IV, since may not fit in mg_ptr;
129 However, we use it to store numargs, and result of gclone() */
130 static void**
PARI_SV_to_voidpp(SV * const sv)131 PARI_SV_to_voidpp(SV *const sv)
132 {
133 MAGIC *mg;
134 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
135 if (mg->mg_type == PARI_MAGIC_TYPE
136 && mg->mg_private == PARI_MAGIC_PRIVATE)
137 return (void **) &mg->mg_ptr;
138 }
139 croak("panic: PARI narg value not attached");
140 return NULL;
141 }
142 # define PARI_SV_to_intp(sv) ((int*)PARI_SV_to_voidpp(sv))
143
144 static void
SV_myvoidp_set(SV * sv,void * p)145 SV_myvoidp_set(SV *sv, void *p)
146 {
147 MAGIC *mg;
148
149 mg = sv_magicext((SV*)sv, NULL, PARI_MAGIC_TYPE, NULL, p, 0);
150 mg->mg_private = PARI_MAGIC_PRIVATE;
151 }
152
153 # define SV_myvoidp_reset_clone(sv) \
154 STMT_START { \
155 if(SvTYPE(sv) == SVt_PVAV) { \
156 void **p = PARI_SV_to_voidpp(sv); \
157 *p = (void*) gclone((GEN)*p); \
158 } else { \
159 SV_myvoidp_reset_clone_IVX(sv); \
160 } } STMT_END
161
162
163 /* Should be applied to SV* and AV* only */
164 # define SV_myvoidp_get(sv) \
165 ((SvTYPE(sv) == SVt_PVAV) ? *PARI_SV_to_voidpp(sv) : INT2PTR(void*,SvIV(sv)))
166 # define CV_myint_get(sv) INT2PTR(int, *PARI_SV_to_voidpp(sv))
167 # define CV_myint_set(sv,i) SV_myvoidp_set((sv), INT2PTR(void*,i))
168 #else /* !USE_SLOW_NARGS_ACCESS */
169 # define CV_myint_get(sv) SvIVX(sv) /* IVOK is not set! */
170 # define CV_myint_set(sv, i) (SvIVX(sv) = (i))
171 # define SV_myvoidp_get(sv) INT2PTR(void*, SvIVX(sv))
172 # define SV_myvoidp_set(sv, p) (SvIVX(sv) = PTR2IV(p))
173 # define SV_myvoidp_reset_clone SV_myvoidp_reset_clone_IVX
174 #endif
175
176 #define SV_myvoidp_reset_clone_IVX(sv) (SvIVX(sv) = PTR2IV(gclone(INT2PTR(GEN, SvIV(sv)))))
177 #define CV_NUMARGS_get CV_myint_get
178 #define CV_NUMARGS_set CV_myint_set
179
180 #ifndef USE_SLOW_ARRAY_ACCESS
181 # define USE_SLOW_ARRAY_ACCESS (defined(PERL_VERSION) && (PERL_VERSION > 9))
182 #endif
183
184 #if USE_SLOW_ARRAY_ACCESS
185 /* 5.9.x and later assert that you're not using SvPVX() and SvCUR() on arrays,
186 so need a little more code to cheat round this. */
187 # define NEED_SLOW_ARRAY_ACCESS(sv) (SvTYPE(sv) == SVt_PVAV)
188 # define AV_SET_LEVEL(sv, val) (AvARRAY(sv) = (SV **)(val))
189 # define AV_GET_LEVEL(sv) ((char*)AvARRAY(sv))
190 #else
191 # define NEED_SLOW_ARRAY_ACCESS(sv) 0
192 # define AV_SET_LEVEL(sv, val) croak("Panic AV LEVEL") /* This will never be called */
193 # define AV_GET_LEVEL(sv) (croak("Panic AV LEVEL"),Nullch) /* This will never be called */
194 #endif
195
196 /* XXXX May need a flavor when we know it is an AV??? */
197 #define SV_PARISTACK_set(sv, stack) \
198 (NEED_SLOW_ARRAY_ACCESS(sv) ? ( \
199 AV_SET_LEVEL(sv, stack), (void)0 \
200 ) : ( \
201 SvPVX(sv) = stack, (void)0 \
202 ))
203
204 #define SV_OAVMA_PARISTACK_set(sv, level, stack) \
205 (NEED_SLOW_ARRAY_ACCESS(sv) ? ( \
206 AvFILLp(sv) = (level), \
207 AV_SET_LEVEL(sv, (stack)), (void)0 \
208 ) : ( \
209 SvCUR(sv) = (level), \
210 SvPVX(sv) = (char*)(stack), (void)0 \
211 ))
212
213 #define SV_OAVMA_PARISTACK_get(sv, level, stack) \
214 (NEED_SLOW_ARRAY_ACCESS(sv) ? ( \
215 (level) = AvFILLp(sv), \
216 (stack) = AV_GET_LEVEL(sv), (void)0 \
217 ) : ( \
218 (level) = SvCUR(sv), \
219 (stack) = SvPVX(sv), (void)0 \
220 ))
221
222 #define SV_OAVMA_switch(next, sv, newval) \
223 ( NEED_SLOW_ARRAY_ACCESS(sv) ? ( \
224 (next) = (SV *)AvARRAY(sv), \
225 AV_SET_LEVEL(sv, newval), (void)0 \
226 ) : ( \
227 next = (SV *) SvPVX(sv), \
228 SvPVX(sv) = newval, (void)0 \
229 ))
230
231 #define GENmovedOffStack ((char*) 1) /* Just an atom. */
232 #define GENfirstOnStack ((char*) 2) /* Just an atom. */
233 #define GENheap NULL
234 #define ifact mpfact
235
236 typedef entree * PariVar; /* For loop variables. */
237 typedef entree * PariName; /* For changevalue. */
238 typedef char * PariExpr;
239 typedef GEN * GEN_Ptr;
240
241 XS((*math_pari_subaddr)); /* On CygWin XS() has attribute conflicting with static */
242
243
244 #if defined(MYMALLOC) && defined(EMBEDMYMALLOC) && defined(UNEMBEDMYMALLOC)
245
246 Malloc_t
malloc(register size_t nbytes)247 malloc(register size_t nbytes)
248 {
249 return Perl_malloc(nbytes);
250 }
251
252 Free_t
free(void * mp)253 free(void *mp)
254 {
255 Perl_mfree(mp); /* What to return? */
256 }
257
258 Malloc_t
realloc(void * mp,size_t nbytes)259 realloc(void *mp, size_t nbytes)
260 {
261 return Perl_realloc(mp, nbytes);
262 }
263
264 #endif
265
266 /* We make a "fake" PVAV, not enough entries. */
267
268 /* This macro resets avma *immediately* if IN is a global
269 static GEN (such as gnil, gun etc). So it should be called near
270 the end of stack-manipulating scope */
271 #define setSVpari(sv, in, oldavma) \
272 setSVpari_or_do(sv, in, oldavma, avma = oldavma)
273
274 #define setSVpari_keep_avma(sv, in, oldavma) \
275 setSVpari_or_do(sv, in, oldavma, ((void)0))
276
277 #define setSVpari_or_do(sv, in, oldavma, action) do { \
278 sv_setref_pv(sv, "Math::Pari", (void*)in); \
279 morphSVpari(sv, in, oldavma, action); \
280 } while (0)
281
282 #define morphSVpari(sv, in, oldavma, action) do { \
283 if (is_matvec_t(typ(in)) && SvTYPE(SvRV(sv)) != SVt_PVAV) { \
284 make_PariAV(sv); \
285 } \
286 if (isonstack(in)) { \
287 SV* g = SvRV(sv); \
288 SV_OAVMA_PARISTACK_set(g, oldavma - bot, PariStack); \
289 PariStack = g; \
290 perlavma = avma; \
291 onStack_inc; \
292 } else { \
293 action; \
294 } \
295 SVnum_inc; \
296 } while (0)
297
298 SV* PariStack; /* PariStack keeps the latest SV that
299 * keeps a GEN on stack. */
300 long perlavma; /* How much stack is needed
301 for GENs in Perl variables. */
302 long sentinel; /* How much stack was used
303 when Pari called Perl. */
304
305 #ifdef DEBUG_PARI
306
307 long SVnum;
308 long SVnumtotal;
309 long onStack;
310 long offStack;
311
312 # define SVnum_inc (SVnum++, SVnumtotal++)
313 # define SVnum_dec (SVnum--)
314 # define onStack_inc (onStack++)
315 # define onStack_dec (onStack--)
316 # define offStack_inc (offStack++)
317 #else /* !defined DEBUG_PARI */
318 # define SVnum_inc
319 # define SVnum_dec
320 # define onStack_inc
321 # define onStack_dec
322 # define offStack_inc
323 #endif /* !defined DEBUG_PARI */
324
325 #define pari_version_exp() PARI_VERSION_EXP
326
327 #if PARI_VERSION_EXP >= 2002012
328 # define prec precreal
329 #endif
330
331
332 #if PARI_VERSION_EXP >= 2000018
333
334 GEN
_gbitneg(GEN g)335 _gbitneg(GEN g)
336 {
337 return gbitneg(g,-1);
338 }
339
340 #endif /* PARI_VERSION_EXP >= 2000018 */
341
342 #if PARI_VERSION_EXP >= 2002001
343
344 GEN
_gbitshiftl(GEN g,long s)345 _gbitshiftl(GEN g, long s)
346 {
347 return gshift(g, s);
348 }
349
350 #endif
351 #if PARI_VERSION_EXP >= 2002001 && PARI_VERSION_EXP <= 2002007
352
353 GEN
_gbitshiftr(GEN g,long s)354 _gbitshiftr(GEN g, long s)
355 {
356 return gshift3(g, -s, signe(g) < 0); /* Bug up to 2.2.2: 1 should be OK */
357 }
358
359
360 #endif /* PARI_VERSION_EXP >= 2002001 && PARI_VERSION_EXP <= 2002007 */
361
362 /* Upgrade to PVAV, attach a magic of type 'P' which is just a reference to
363 ourselves (non-standard refcounts, so needs special logic on DESTROY) */
364 void
make_PariAV(SV * sv)365 make_PariAV(SV *sv)
366 {
367 AV *av = (AV*)SvRV(sv);
368 char *s = SvPVX(av);
369 void *p = INT2PTR(void*, SvIVX(av));
370 SV *newsub = newRV_noinc((SV*)av); /* cannot use sv, it may be
371 sv_restore()d */
372
373 (void)SvUPGRADE((SV*)av, SVt_PVAV);
374 SV_PARISTACK_set(av, s);
375 SV_myvoidp_set((SV*)av, p);
376 sv_magic((SV*)av, newsub, 'P', Nullch, 0);
377 SvREFCNT_dec(newsub); /* now RC(newsub)==1 */
378 /* We avoid an reference loop, so should be careful on DESTROY */
379 #if 0
380 if ((mg = SvMAGIC((SV*)av)) && mg->mg_type == 'P' /* be extra paranoid */
381 && (mg->mg_flags & MGf_REFCOUNTED)) {
382 /* mg->mg_flags &= ~MGf_REFCOUNTED; */
383 /* SvREFCNT_dec(sv); */
384 sv_2mortal((SV*)av); /* We restore refcount on DESTROY */
385 }
386 #endif
387 }
388
389 SV*
wrongT(SV * sv,char * file,int line)390 wrongT(SV *sv, char *file, int line)
391 {
392 if (SvTYPE(sv) != SVt_PVCV && SvTYPE(sv) != SVt_PVGV) {
393 croak("Got the type 0x%x instead of CV=0x%x or GV=0x%x in %s, %i",
394 SvTYPE(sv), SVt_PVCV, SVt_PVGV, file, line);
395 } else {
396 croak("Something very wrong in %s, %i", file, line);
397 }
398 return NULL; /* To pacify compiler. */
399 }
400
401 HV *pariStash; /* For quick id. */
402 HV *pariEpStash;
403
404 #if PARI_VERSION_EXP >= 2002012 /* Probably earlier too */
405 # define HAVE_FETCH_NAMED_VAR
406 #else
407
408 /* Copied from anal.c. */
409 static entree *
installep(void * f,char * name,int len,int valence,int add,entree ** table)410 installep(void *f, char *name, int len, int valence, int add, entree **table)
411 {
412 entree *ep = (entree *) gpmalloc(sizeof(entree) + add + len+1);
413 const entree *ep1 = initial_value(ep);
414 char *u = (char *) ep1 + add;
415
416 ep->name = u; strncpy(u, name,len); u[len]=0;
417 ep->args = NULL; ep->help = NULL; ep->code = NULL;
418 ep->value = f? f: (void *) ep1;
419 ep->next = *table;
420 ep->valence = valence;
421 ep->menu = 0;
422 return *table = ep;
423 }
424 #endif /* PARI_VERSION_EXP >= 2002012 */
425
426 #if PARI_VERSION_EXP <= 2002000 /* Global after 2.2.0 */
427 static void
changevalue(entree * ep,GEN val)428 changevalue(entree *ep, GEN val)
429 {
430 GEN y = gclone(val), x = (GEN)ep->value;
431
432 ep->value = (void *)y;
433 if (x == (GEN) initial_value(ep) || !isclone(x))
434 {
435 y[-1] = (long)x; /* push new value */
436 return;
437 }
438 y[-1] = x[-1]; /* save initial value */
439 killbloc(x); /* destroy intermediate one */
440 }
441 #endif
442
443 static GEN
my_gpui(GEN x,GEN y)444 my_gpui(GEN x, GEN y)
445 {
446 return gpui(x, y, prec);
447 }
448
449 static long
numvar(GEN x)450 numvar(GEN x)
451 {
452 if (typ(x) != t_POL || lgef(x) != 4 ||
453 !gcmp0((GEN)x[2]) || !gcmp1((GEN)x[3]))
454 croak("Corrupted data: should be variable");
455 return varn(x);
456 }
457
458
459 static SV *
PARIvar(char * s)460 PARIvar(char *s)
461 {
462 #if 0
463 char *olds = s, *u, *v;
464 GEN p1;
465 #endif
466 long hash;
467 SV *sv;
468 entree *ep;
469
470 #ifdef HAVE_FETCH_NAMED_VAR
471 ep = fetch_named_var(s);
472 #else
473 ep = is_entry_intern(s, functions_hash, &hash);
474 if (ep) {
475 if (EpVALENCE(ep) != EpVAR)
476 croak("Got a function name instead of a variable");
477 } else {
478 ep = installep(NULL, s, strlen(s), EpVAR, 7*sizeof(long),
479 functions_hash + hash);
480 manage_var(0,ep);
481 # if 0
482 ep = (entree *)gpmalloc(sizeof(entree) + 7*BYTES_IN_LONG
483 + s - olds + 1);
484 ep->name = (char *)ep + sizeof(entree) + 7*BYTES_IN_LONG;
485 for (u = ep->name, v = olds; v < s;) *u++ = *v++; *u = 0;
486 ep->value = (void *)((char *)ep + sizeof(entree));
487 ep->code = ep->help = NULL;
488 ep->next = hashtable[n];
489 hashtable[n] = ep;
490 p1 = (GEN)ep->value;
491 if (nvar == MAXVAR) err(trucer1);
492 ep->valence = 200;
493 p1[0] = evaltyp(10)+evalpere(1)+evallg(4);
494 p1[1] = evalsigne(1)+evallgef(4)+evalvarn(nvar);
495 p1[2] = zero; p1[3] = un;
496 polx[nvar] = p1;
497 polvar[nvar+1] = (long)p1;
498 p1 += 4;
499 p1[0] = evaltyp(10)+evalpere(1)+evallg(3);
500 p1[1] = evalsigne(1)+evallgef(3)+evalvarn(nvar); p1[2] = un;
501 polun[nvar] = p1;
502 varentries[nvar++] = ep;
503 setlg(polvar, nvar+1);
504 # endif
505 }
506 #endif /* !( defined HAVE_FETCH_NAMED_VAR ) */
507
508 #if 0
509 found:
510 #endif
511 sv = NEWSV(909,0);
512 sv_setref_pv(sv, "Math::Pari::Ep", (void*)ep);
513 make_PariAV(sv);
514 return sv;
515 }
516
517 static entree *
findVariable(SV * sv,int generate)518 findVariable(SV *sv, int generate)
519 {
520 /* There may be 4 important cases:
521 a) we got a 'word' string, which we interpret as the name of
522 the variable to use;
523 b1) It is a pari value containing a polynomial 0+1*v, we use it;
524 b2) It is other pari value, we ignore it;
525 c) it is a string containing junk, same as 'b';
526 d) It is an ep value => typo (same iterator in two loops).
527 In any case we localize the value.
528 */
529 char *s = Nullch;
530 char *s1;
531 long hash;
532 entree *ep;
533 char name[50];
534 #if 0
535 char *u, *v;
536 GEN p1;
537 #endif
538
539 if (SvROK(sv)) {
540 SV* tsv = SvRV(sv);
541 if (SvOBJECT(tsv)) {
542 if (SvSTASH(tsv) == pariStash) {
543 is_pari:
544 {
545 GEN x = (GEN)SV_myvoidp_get(tsv);
546 if (typ(x) == t_POL /* Polynomial. */
547 && lgef(x)==4 /* 2 terms */
548 && (gcmp0((GEN)x[2])) /* Free */
549 && (gcmp1((GEN)x[3]))) { /* Leading */
550 s = varentries[ordvar[varn(x)]]->name;
551 goto repeat;
552 }
553 goto ignore;
554 }
555 } else if (SvSTASH(tsv) == pariEpStash) {
556 is_pari_ep:
557 {
558 /* Itsn't good to croak: $v=PARIvar 'v'; vector(3,$v,'v'); */
559 if (generate)
560 /*croak("Same iterator in embedded PARI loop construct")*/;
561 return (entree*) SV_myvoidp_get(tsv);
562 }
563 } else if (sv_derived_from(sv, "Math::Pari")) { /* Avoid recursion */
564 if (sv_derived_from(sv, "Math::Pari::Ep"))
565 goto is_pari_ep;
566 else
567 goto is_pari;
568 }
569 }
570 }
571 if (!SvOK(sv))
572 goto ignore;
573 s = SvPV(sv,na);
574 repeat:
575 s1 = s;
576 while (isalnum((unsigned char)*s1))
577 s1++;
578 if (*s1 || s1 == s || !isalpha((unsigned char)*s)) {
579 static int depth;
580
581 ignore:
582 if (!generate)
583 croak("Bad PARI variable name \"%s\" specified",s);
584 SAVEINT(depth);
585 sprintf(name, "intiter%i",depth++);
586 s = name;
587 goto repeat;
588 }
589
590 #ifdef HAVE_FETCH_NAMED_VAR
591 ep = fetch_named_var(s);
592 #else
593 ep = is_entry_intern(s, functions_hash, &hash);
594
595 if (ep) {
596 if (EpVALENCE(ep) != EpVAR)
597 croak("Got a function name instead of a variable");
598 } else {
599 ep = installep(NULL, s, s1 - s, EpVAR, 7*sizeof(long),
600 functions_hash + hash);
601 manage_var(0,ep);
602 }
603 #endif /* !( defined HAVE_FETCH_NAMED_VAR ) */
604
605 #if 0
606 olds = s;
607 for (n = 0; isalnum(*s); s++) n = n << 1 ^ *s;
608 if (n < 0) n = -n; n %= TBLSZ;
609 for(ep = hashtable[n]; ep; ep = ep->next)
610 {
611 for(u = ep->name, v = olds; (*u) && *u == *v; u++, v++);
612 if (!*u && !*v) {
613 if (EpVALENCE(ep) != 200)
614 croak("Got a function name instead of a variable");
615 return ep;
616 }
617 }
618 ep = (entree *)gpmalloc(sizeof(entree) + 7*BYTES_IN_LONG
619 + s - olds + 1);
620 ep->name = (char *)ep + sizeof(entree) + 7*BYTES_IN_LONG;
621 for (u = ep->name, v = olds; v < s;) *u++ = *v++; *u = 0;
622 ep->value = (void *)((char *)ep + sizeof(entree));
623 ep->code = ep->help = NULL;
624 ep->next = hashtable[n];
625 hashtable[n] = ep;
626 p1 = (GEN)ep->value;
627 if (nvar == MAXVAR) err(trucer1);
628 ep->valence = 200;
629 p1[0] = evaltyp(10)+evalpere(1)+evallg(4);
630 p1[1] = evalsigne(1)+evallgef(4)+evalvarn(nvar);
631 p1[2] = zero; p1[3] = un;
632 polx[nvar] = p1;
633 polvar[nvar+1] = (long)p1;
634 p1 += 4;
635 p1[0] = evaltyp(10)+evalpere(1)+evallg(3);
636 p1[1] = evalsigne(1)+evallgef(3)+evalvarn(nvar); p1[2] = un;
637 polun[nvar] = p1;
638 varentries[nvar++] = ep;
639 setlg(polvar, nvar+1);
640 #endif
641 return ep;
642 }
643
644 static PariVar
bindVariable(SV * sv)645 bindVariable(SV *sv)
646 {
647 /* There may be 4 important cases:
648 a) we got a 'word' string, which we interpret as the name of
649 the variable to use;
650 b1) It is a pari value containing a polynomial 0+1*v, we use it;
651 b2) It is other pari value, we ignore it;
652 c) it is a string containing junk, same as 'b';
653 d) It is an ep value => typo (same iterator in two loops).
654 In any case we localize the value.
655 */
656 long override = 0;
657 entree *ep;
658
659 if (!SvREADONLY(sv)) {
660 save_item(sv); /* Localize it. */
661 override = 1;
662 }
663 ep = findVariable(sv, 1);
664 if (override) {
665 sv_setref_pv(sv, "Math::Pari::Ep", (void*)ep);
666 make_PariAV(sv);
667 }
668 return ep;
669 }
670
671 static int
not_here(char * s)672 not_here(char *s)
673 {
674 croak("%s not implemented on this architecture", s);
675 return -1;
676 }
677
678 unsigned long
longword(GEN x,long n)679 longword(GEN x, long n)
680 {
681 if (n < 0 || n >= lg(x))
682 croak("The longword %ld ordinal out of bound", n);
683 return x[n];
684 }
685
686
687
688 SV* worksv;
689 SV* workErrsv;
690
691 void
svputc(char c)692 svputc(char c)
693 {
694 sv_catpvn(worksv,&c,1);
695 }
696
697 #if PARI_VERSION_EXP >= 2002005
698 # define PUTS_CONST const
699 #else
700 # define PUTS_CONST
701 #endif
702
703 void
svputs(PUTS_CONST char * p)704 svputs(PUTS_CONST char* p)
705 {
706 sv_catpv(worksv,p);
707 }
708
709 void
svErrputc(char c)710 svErrputc(char c)
711 {
712 sv_catpvn(workErrsv,&c,1);
713 }
714
715
716 void
svErrputs(PUTS_CONST char * p)717 svErrputs(PUTS_CONST char* p)
718 {
719 sv_catpv(workErrsv,p);
720 }
721
722 void
svOutflush(void)723 svOutflush(void)
724 {
725 /* EMPTY */
726 }
727
728 /* Support error messages of the form (calling PARI('O(det2($mat))')):
729 PARI: *** obsolete function: O(det2($mat))
730 ^----------- */
731
732 void
svErrflush(void)733 svErrflush(void)
734 {
735 STRLEN l;
736 char *s = SvPV(workErrsv, l);
737
738 if (s && l) {
739 char *nl = memchr(s,'\n',l);
740
741 /* Avoid signed/unsigned mismatch */
742 if (nl && (STRLEN)(nl - s) < l - 1)
743 warn("PARI: %.*s%*s%s", nl + 1 - s, s, 6, "", nl + 1);
744 else
745 warn("PARI: %s", s);
746 sv_setpv(workErrsv,"");
747 }
748 }
749
750 void
svErrdie(void)751 svErrdie(void)
752 {
753 SV *errSv = newSVsv(workErrsv);
754 STRLEN l;
755 char *s = SvPV(errSv,l);
756 char *nl = memchr(s,'\n',l);
757
758 sv_setpv(workErrsv,"");
759 sv_2mortal(errSv);
760 /* Avoid signed/unsigned mismatch */
761 if (nl && (STRLEN)(nl - s) < l - 1)
762 croak("PARI: %.*s%*s%s", nl + 1 - s, s, 6, "", nl + 1);
763 else
764 croak("PARI: %s", s);
765 }
766
767
768 PariOUT perlOut={svputc, svputs, svOutflush, NULL};
769 PariOUT perlErr={svErrputc, svErrputs, svErrflush, svErrdie};
770
771 static GEN
my_ulongtoi(ulong uv)772 my_ulongtoi(ulong uv)
773 {
774 long oldavma = avma;
775 GEN a = stoi((long)(uv>>1));
776
777 a = gshift(a, 1);
778 if (uv & 0x1)
779 a = gadd(a, gun);
780 return gerepileupto(oldavma, a);
781 }
782
783 #ifdef LONG_SHORTER_THAN_IV
784 GEN
my_UVtoi(UV uv)785 my_UVtoi(UV uv)
786 {
787 long oldavma = avma;
788 GEN a = my_ulongtoi((ulong)(uv>>(8*sizeof(ulong))));
789 GEN b = my_ulongtoi((ulong)(uv & ((((UV)1)<<(8*sizeof(ulong))) - 1)));
790
791 a = gshift(a, (8*sizeof(ulong)));
792 return gerepileupto(oldavma, gadd(a,b));
793 }
794 GEN
my_IVtoi(IV iv)795 my_IVtoi(IV iv)
796 {
797 long oldavma = avma;
798 GEN a;
799
800 if (iv >= 0)
801 return my_UVtoi((UV)iv);
802 oldavma = avma;
803 return gerepileupto(oldavma, gneg(my_UVtoi((UV)-iv)));
804 }
805
806 #else
807 #define my_IVtoi stoi
808 #define my_UVtoi my_ulongtoi
809 #endif
810
811 #ifdef SvIsUV
812 # define mySvIsUV SvIsUV
813 #else
814 # define mySvIsUV(sv) 0
815 #endif
816 #define PerlInt_to_i(sv) (mySvIsUV(sv) ? my_UVtoi(SvUV(sv)) : my_IVtoi(SvIV(sv)))
817
818 GEN
sv2pari(SV * sv)819 sv2pari(SV* sv)
820 {
821 if (SvGMAGICAL(sv)) mg_get(sv); /* MAYCHANGE in perlguts.pod - bug in perl */
822 if (SvROK(sv)) {
823 SV* tsv = SvRV(sv);
824 if (SvOBJECT(tsv)) {
825 if (SvSTASH(tsv) == pariStash) {
826 is_pari:
827 {
828 return (GEN) SV_myvoidp_get(tsv);
829 }
830 } else if (SvSTASH(tsv) == pariEpStash) {
831 is_pari_ep:
832 {
833 return (GEN)(((entree*) SV_myvoidp_get(tsv))->value);
834 }
835 } else if (sv_derived_from(sv, "Math::Pari")) { /* Avoid recursion */
836 if (sv_derived_from(sv, "Math::Pari::Ep"))
837 goto is_pari_ep;
838 else
839 goto is_pari;
840 }
841 }
842 {
843 int type = SvTYPE(tsv);
844 if (type==SVt_PVAV) {
845 AV* av=(AV*) tsv;
846 I32 len=av_len(av); /* Length-1 */
847 GEN ret=cgetg(len+2, t_VEC);
848 int i;
849 for (i=0;i<=len;i++) {
850 SV** svp=av_fetch(av,i,0);
851 if (!svp) croak("Internal error in sv2pari!");
852 ret[i+1]=(long)sv2pari(*svp);
853 }
854 return ret;
855 } else {
856 return lisexpr(SvPV(sv,na)); /* For overloading */
857 }
858 }
859 }
860 else if (SvIOK(sv)) return PerlInt_to_i(sv);
861 else if (SvNOK(sv)) {
862 double n = (double)SvNV(sv);
863 #if !defined(PERL_VERSION) || (PERL_VERSION < 6)
864 /* Earlier needed more voodoo, since sv_true sv_false are NOK,
865 but not IOK. Now we propagate them to IOK in Pari.pm;
866 This works at least with 5.5.640 onwards. */
867 /* With 5.00553 they are (NOK,POK,READONLY,pNOK,pPOK).
868 This would special-case all READONLY double-headed stuff;
869 let's hope it is not too frequent... */
870 if (SvREADONLY(sv) && SvPOK(sv) && (n == 1 || n == 0))
871 return stoi((long)n);
872 #endif /* !defined(PERL_VERSION) || (PERL_VERSION < 6) */
873 return dbltor(n);
874 }
875 else if (SvPOK(sv)) return lisexpr(SvPV(sv,na));
876 else if (SvIOKp(sv)) return PerlInt_to_i(sv);
877 else if (SvNOKp(sv)) return dbltor((double)SvNV(sv));
878 else if (SvPOKp(sv)) return lisexpr(SvPV(sv,na));
879 else if (SvOK(sv)) croak("Variable in sv2pari is not of known type");
880
881 return stoi(0); /* !SvOK(sv) */
882 }
883
884 GEN
sv2parimat(SV * sv)885 sv2parimat(SV* sv)
886 {
887 GEN in=sv2pari(sv);
888 if (typ(in)==t_VEC) {
889 long len=lg(in)-1;
890 long t;
891 long l=lg(in[1]);
892 for (;len;len--) {
893 if ((t=typ(in[len])) == t_VEC) {
894 settyp(in[len], t_COL);
895 } else if (t != t_COL) {
896 croak("Not a vector where column of a matrix expected");
897 }
898 if (lg(in[len])!=l) {
899 croak("Columns of input matrix are of different height");
900 }
901 }
902 settyp(in, t_MAT);
903 } else if (typ(in) != t_MAT) {
904 croak("Not a matrix where matrix expected");
905 }
906 return in;
907 }
908
909 SV*
pari2iv(GEN in)910 pari2iv(GEN in)
911 {
912 #ifdef SvIsUV
913 # define HAVE_UVs 1
914 UV uv;
915 #else
916 # define HAVE_UVs 0
917 IV uv;
918 #endif
919 int overflow = 0;
920
921 if (typ(in) != t_INT)
922 return newSViv((IV)gtolong(in));
923 switch (lgef(in)) {
924 case 2:
925 uv = 0;
926 break;
927 case 3:
928 uv = in[2];
929 if (sizeof(long) >= sizeof(IV) && in[2] < 0)
930 overflow = 1;
931 break;
932 case 4:
933 if ( 2 * sizeof(long) > sizeof(IV)
934 || ((2 * sizeof(long) == sizeof(IV)) && !HAVE_UVs && in[2] < 0) )
935 goto do_nv;
936 uv = in[2];
937 uv = (uv << TWOPOTBYTES_IN_LONG) + in[3];
938 break;
939 default:
940 goto do_nv;
941 }
942 if (overflow) {
943 #ifdef SvIsUV
944 if (signe(in) > 0) {
945 SV *sv = newSViv((IV)uv);
946
947 SvIsUV_on(sv);
948 return sv;
949 } else
950 #endif
951 goto do_nv;
952 }
953 return newSViv(signe(in) > 0 ? (IV)uv : -(IV)uv);
954 do_nv:
955 return newSVnv(gtodouble(in)); /* XXXX to NV, not to double? */
956 }
957
958 #if PARI_VERSION_EXP >= 2002005 && PARI_VERSION_EXP <= 2002007
959 # define _gtodouble gtodouble
960 static void
_initout(pariout_t * T,char f,long sigd,long sp,long fieldw,int prettyp)961 _initout(pariout_t *T, char f, long sigd, long sp, long fieldw, int prettyp)
962 {
963 T->format = f;
964 T->sigd = sigd;
965 T->sp = sp;
966 T->fieldw = fieldw;
967 T->initial = 1;
968 T->prettyp = prettyp;
969 }
970
971 void
mybruteall(GEN g,char f,long d,long sp)972 mybruteall(GEN g, char f, long d, long sp)
973 {
974 pariout_t T; _initout(&T,f,d,sp,0, f_RAW);
975 gen_output(g, &T);
976 }
977
978 #else
979
980 #ifndef m_evallg
981 # define m_evallg _evallg
982 #endif
983
984 double
_gtodouble(GEN x)985 _gtodouble(GEN x)
986 {
987 static long reel4[4]={ evaltyp(t_REAL) | m_evallg(4),0,0,0 };
988
989 if (typ(x)==t_REAL) return rtodbl(x);
990 gaffect(x,(GEN)reel4); return rtodbl((GEN)reel4);
991 }
992
993 #define mybruteall bruteall
994
995 #endif
996
997
998 SV*
pari2nv(GEN in)999 pari2nv(GEN in)
1000 {
1001 return newSVnv(_gtodouble(in));
1002 }
1003
1004 SV*
pari2pv(GEN in)1005 pari2pv(GEN in)
1006 {
1007 if (typ(in) == t_STR) /* Puts "" around without special-casing */
1008 return newSVpv(GSTR(in),0);
1009 {
1010 PariOUT *oldOut = pariOut;
1011 pariOut = &perlOut;
1012 worksv = newSVpv("",0);
1013 mybruteall(in,'g',-1,0); /* 0: compact pari-readable form */
1014 pariOut = oldOut;
1015 return worksv;
1016 }
1017 }
1018
1019 int fmt_nb;
1020
1021 #ifdef LONG_IS_64BIT
1022 # define def_fmt_nb 38
1023 #else
1024 # define def_fmt_nb 28
1025 #endif
1026
1027 #ifndef pariK1
1028 # define pariK1 (0.103810253/(BYTES_IN_LONG/4)) /* log(10)/(SL*log(2)) */
1029 #endif
1030
1031 long
setprecision(long digits)1032 setprecision(long digits)
1033 {
1034 long m = fmt_nb;
1035
1036 if(digits>0) {fmt_nb = digits; prec = (long)(digits*pariK1 + 3);}
1037 return m;
1038 }
1039
1040 #if PARI_VERSION_EXP < 2002012 || PARI_VERSION_EXP >= 2003000
1041 long
setseriesprecision(long digits)1042 setseriesprecision(long digits)
1043 {
1044 long m = precdl;
1045
1046 if(digits>0) {precdl = digits;}
1047 return m;
1048 }
1049 #endif /* PARI_VERSION_EXP < 2002012 || PARI_VERSION_EXP >= 2003000 */
1050
1051 static IV primelimit;
1052 static UV parisize;
1053
1054 IV
setprimelimit(IV n)1055 setprimelimit(IV n)
1056 {
1057 byteptr ptr;
1058 IV o = primelimit;
1059
1060 if (n != 0) {
1061 ptr = initprimes(n);
1062 free(diffptr);
1063 diffptr = ptr;
1064 primelimit = n;
1065 }
1066 return o;
1067 }
1068
1069 SV*
pari_print(GEN in)1070 pari_print(GEN in)
1071 {
1072 PariOUT *oldOut = pariOut;
1073 pariOut = &perlOut;
1074 worksv = newSVpv("",0);
1075 brute(in, 'g', fmt_nb);
1076 pariOut = oldOut;
1077 return worksv;
1078 }
1079
1080 SV*
pari_pprint(GEN in)1081 pari_pprint(GEN in)
1082 {
1083 PariOUT *oldOut = pariOut;
1084 pariOut = &perlOut;
1085 worksv = newSVpv("",0);
1086 sor(in, 'g'/*fmt.format*/, fmt_nb, 0/*fmt.field*/);
1087 pariOut = oldOut;
1088 return worksv;
1089 }
1090
1091 SV*
pari_texprint(GEN in)1092 pari_texprint(GEN in)
1093 {
1094 PariOUT *oldOut = pariOut;
1095 pariOut = &perlOut;
1096 worksv = newSVpv("",0);
1097 texe(in, 'g', fmt_nb);
1098 pariOut = oldOut;
1099 return worksv;
1100 }
1101
1102 SV*
pari2mortalsv(GEN in,long oldavma)1103 pari2mortalsv(GEN in, long oldavma)
1104 { /* Oldavma should keep the value of
1105 * avma when entering a function call. */
1106 SV *sv = sv_newmortal();
1107
1108 setSVpari_keep_avma(sv, in, oldavma);
1109 return sv;
1110 }
1111
1112 typedef struct {
1113 long items, words;
1114 SV *acc;
1115 int context;
1116 } heap_dumper_t;
1117
1118 #define BL_HEAD 3 /* from init.c */
1119 static void
heap_dump_one(heap_dumper_t * d,GEN x)1120 heap_dump_one(heap_dumper_t *d, GEN x)
1121 {
1122 SV* tmp;
1123
1124 d->items++;
1125 if(!x[0]) { /* user function */
1126 d->words += strlen((char *)(x+2))/sizeof(long);
1127 tmp = newSVpv((char*)(x+2),0);
1128 } else if (x==bernzone) {
1129 d->words += x[0];
1130 tmp = newSVpv("bernzone",8);
1131 } else { /* GEN */
1132 d->words += taille(x);
1133 tmp = pari_print(x);
1134 }
1135 /* add to output */
1136 switch(d->context) {
1137 case G_VOID:
1138 case G_SCALAR: sv_catpvf(d->acc, " %2d: %s\n",
1139 d->items - 1, SvPV_nolen(tmp));
1140 SvREFCNT_dec(tmp); break;
1141 case G_ARRAY: av_push((AV*)d->acc,tmp); break;
1142 }
1143 }
1144
1145 #if PARI_VERSION_EXP >= 2002012
1146
1147 static void
heap_dump_one_v(GEN x,void * v)1148 heap_dump_one_v(GEN x, void *v)
1149 {
1150 heap_dumper_t *d = (heap_dumper_t *)v;
1151
1152 heap_dump_one(d, x);
1153 }
1154
1155 static void
heap_dumper(heap_dumper_t * d)1156 heap_dumper(heap_dumper_t *d)
1157 {
1158 traverseheap(&heap_dump_one_v, (void*)d);
1159 }
1160
1161 #else /* !( PARI_VERSION_EXP >= 2002012 ) */
1162
1163 static void
heap_dumper(heap_dumper_t * d)1164 heap_dumper(heap_dumper_t *d)
1165 {
1166 /* create a new block on the heap so we can examine the linked list */
1167 GEN tmp1 = newbloc(1); /* at least 1 to avoid warning */
1168 GEN x = (GEN)bl_prev(tmp1);
1169
1170 killbloc(tmp1);
1171
1172 /* code adapted from getheap() in PARI src/language/init.c */
1173 for(; x; x = (GEN)bl_prev(x))
1174 heap_dump_one(d, x);
1175 }
1176
1177 #endif /* !( PARI_VERSION_EXP >= 2002012 ) */
1178
1179 void
resetSVpari(SV * sv,GEN g,long oldavma)1180 resetSVpari(SV* sv, GEN g, long oldavma)
1181 {
1182 if (SvROK(sv)) {
1183 SV* tsv = SvRV(sv);
1184
1185 if (g && SvOBJECT(tsv)) {
1186 IV tmp = 0;
1187
1188 if (SvSTASH(tsv) == pariStash) {
1189 #if 0 /* To dangerous to muck with this */
1190 is_pari:
1191 #endif
1192 {
1193 tmp = SvIV(tsv);
1194 }
1195 }
1196 #if 0 /* To dangerous to muck with this */
1197 else if (SvSTASH(tsv) == pariEpStash) {
1198 is_pari_ep:
1199 {
1200 tmp = SvIV(tsv);
1201 tmp = PTR2IV((INT2PTR(entree*, tmp))->value);
1202 }
1203 }
1204 else if (sv_derived_from(sv, "Math::Pari")) { /* Avoid recursion */
1205 if (sv_derived_from(sv, "Math::Pari::Ep"))
1206 goto is_pari_ep;
1207 else
1208 goto is_pari;
1209 }
1210 #endif
1211 if (tmp == PTR2IV(g)) /* Did not change */
1212 return;
1213 }
1214 }
1215 /* XXXX do it the non-optimized way */
1216 setSVpari_keep_avma(sv,g,oldavma);
1217 }
1218
1219 static const
1220 unsigned char defcode[] = "\06xD0,G,D0,G,D0,G,D0,G,D0,G,D0,G,";
1221
1222 static int doing_PARI_autoload = 0;
1223
1224 entree *
installPerlFunctionCV(SV * cv,char * name,I32 numargs,char * help)1225 installPerlFunctionCV(SV* cv, char *name, I32 numargs, char *help)
1226 {
1227 char *code, *s;
1228 I32 req = numargs, opt = 0;
1229 entree *ep;
1230
1231 if(SvROK(cv))
1232 cv = SvRV(cv);
1233
1234 if (numargs < 0 && SvPOK(cv) && (s = SvPV(cv,na))) {
1235 /* Get number of arguments. */
1236 req = opt = 0;
1237 while (*s == '$')
1238 req++, s++;
1239 if (*s == ';')
1240 s++;
1241 while (*s == '$')
1242 opt++, s++;
1243 if (*s == '@') {
1244 opt += 6; /* Max 6 optional arguments. */
1245 s++;
1246 }
1247 if (*s == 0) { /* Got it! */
1248 numargs = req + opt;
1249 } else {
1250 croak("Can't install Perl function with prototype `%s'", s);
1251 }
1252 }
1253
1254 if (numargs < 0) { /* Variable number of arguments. */
1255 /* Install something hairy with <= 6 args */
1256 code = (char*)defcode + 1; /* Remove constness. */
1257 numargs = code[-1];
1258 } else if (numargs >= 256) {
1259 croak("Import of Perl function with too many arguments");
1260 } else {
1261 /* Should not use gpmalloc(), since we call free()... */
1262 code = (char *)malloc(numargs*6 - req*5 + 2);
1263 code[0] = 'x';
1264 memset(code + 1, 'G', req);
1265 s = code + 1 + req;
1266 while (opt--) {
1267 strcpy(s, "D0,G,");
1268 s += 6;
1269 }
1270 *s = '\0';
1271 }
1272 CV_NUMARGS_set(cv, numargs);
1273 SAVEINT(doing_PARI_autoload);
1274 doing_PARI_autoload = 1;
1275 ep = install((void*)SvREFCNT_inc(cv), name, code);
1276 doing_PARI_autoload = 0;
1277 if (code != (char*)defcode + 1)
1278 free(code);
1279 ep->help = help;
1280 return ep;
1281 }
1282
1283 void
freePerlFunction(entree * ep)1284 freePerlFunction(entree *ep)
1285 {
1286 if (!ep->code || (*ep->code != 'x')) {
1287 croak("Attempt to ask Perl to free PARI function not installed from Perl");
1288 }
1289 if (ep->code != (char *)defcode + 1)
1290 free(ep->code - 1);
1291 if (ep->help)
1292 free(ep->help);
1293 SvREFCNT_dec((SV*)ep->value);
1294 }
1295
1296 long
moveoffstack_newer_than(SV * sv)1297 moveoffstack_newer_than(SV* sv)
1298 {
1299 SV* sv1;
1300 SV* nextsv;
1301 long ret=0;
1302
1303 for (sv1 = PariStack; sv1 != sv; sv1 = nextsv) {
1304 ret++;
1305 SV_OAVMA_switch(nextsv, sv1, GENmovedOffStack); /* Mark as moved off stack. */
1306 SV_myvoidp_reset_clone(sv1);
1307 onStack_dec;
1308 offStack_inc;
1309 }
1310 PariStack = sv;
1311 return ret;
1312 }
1313
1314 void
detach_stack(void)1315 detach_stack(void)
1316 {
1317 moveoffstack_newer_than((SV *) GENfirstOnStack);
1318 }
1319
1320 UV
allocatemem(UV newsize)1321 allocatemem(UV newsize)
1322 {
1323 if (newsize) {
1324 detach_stack();
1325 parisize = allocatemoremem(newsize);
1326 perlavma = sentinel = avma;
1327 }
1328 return parisize;
1329 }
1330
1331
1332 GEN
callPerlFunction(entree * ep,...)1333 callPerlFunction(entree *ep, ...)
1334 {
1335 va_list args;
1336 SV *cv = (SV*) ep->value;
1337 int numargs = CV_NUMARGS_get(cv);
1338 GEN res;
1339 int i;
1340 dSP;
1341 int count ;
1342 long oldavma = avma;
1343 SV *oPariStack = PariStack;
1344 SV *sv;
1345
1346 va_start(args, ep);
1347 ENTER ;
1348 SAVETMPS;
1349 SAVEINT(sentinel);
1350 sentinel = avma;
1351 PUSHMARK(sp);
1352 EXTEND(sp, numargs + 1);
1353 for (i = 0; i < numargs; i++) {
1354 /* It should be OK to have the same oldavma here, since avma
1355 is not modified... */
1356 PUSHs(pari2mortalsv(va_arg(args, GEN), oldavma));
1357 }
1358 va_end(args);
1359 PUTBACK;
1360 count = perl_call_sv(cv, G_SCALAR);
1361
1362 SPAGAIN;
1363 if (count != 1)
1364 croak("Perl function exported into PARI did not return a value");
1365
1366 sv = SvREFCNT_inc(POPs); /* Preserve the guy. */
1367
1368 PUTBACK ;
1369 FREETMPS ;
1370 LEAVE ;
1371 /* Now PARI data created inside this subroutine sits above
1372 oldavma, but the caller is going to unwind the stack: */
1373 if (PariStack != oPariStack)
1374 moveoffstack_newer_than(oPariStack);
1375 /* Now, when everything is moved off stack, and avma is reset, we
1376 can get the answer: */
1377 res = sv2pari(sv); /* XXXX When to decrement the count? */
1378 /* We need to copy it back to stack, otherwise we cannot decrement
1379 the count. The ABI is that a C function [which can be put into a
1380 GP/PARI function C-function slot] should have its result
1381 completely on stack. */
1382 res = forcecopy(res);
1383 SvREFCNT_dec(sv);
1384
1385 return res;
1386 }
1387
1388 /* Currently with <=6 arguments only! */
1389
1390 entree *
autoloadPerlFunction(char * s,long len)1391 autoloadPerlFunction(char *s, long len)
1392 {
1393 CV *cv;
1394 SV* name;
1395 HV* converted;
1396
1397 if (doing_PARI_autoload)
1398 return 0;
1399 converted = perl_get_hv("Math::Pari::converted",TRUE);
1400 if (hv_fetch(converted, s, len, FALSE))
1401 return 0;
1402
1403 name = sv_2mortal(newSVpv(s, len));
1404
1405 cv = perl_get_cv(SvPVX(name), FALSE);
1406 if (cv == Nullcv) {
1407 return 0;
1408 }
1409 /* Got it! */
1410 return installPerlFunctionCV((SV*)cv, SvPVX(name), -1, NULL); /* -1 gives variable. */
1411 }
1412
1413 GEN
exprHandler_Perl(char * s)1414 exprHandler_Perl(char *s)
1415 {
1416 SV* dummy = Nullsv; /* Avoid "without initialization" warnings from M$ */
1417 SV* cv = (SV*)(s - LSB_in_U32 -
1418 ((char*)&(dummy->sv_flags) - ((char*)dummy)));
1419 GEN res;
1420 long count;
1421 dSP;
1422 SV *sv;
1423 SV *oPariStack = PariStack;
1424
1425 ENTER ;
1426 SAVETMPS;
1427 PUSHMARK(sp);
1428 SAVEINT(sentinel);
1429 sentinel = avma;
1430 count = perl_call_sv(cv, G_SCALAR);
1431
1432 SPAGAIN;
1433 sv = SvREFCNT_inc(POPs); /* Preserve it through FREETMPS */
1434
1435 PUTBACK ;
1436 FREETMPS ;
1437 LEAVE ;
1438
1439 /* Now PARI data created inside this subroutine sits above
1440 oldavma, but the caller is going to unwind the stack: */
1441 if (PariStack != oPariStack)
1442 moveoffstack_newer_than(oPariStack);
1443 /* Now, when everything is moved off stack, and avma is reset, we
1444 can get the answer: */
1445 res = sv2pari(sv);
1446 /* We need to copy it back to stack, otherwise we cannot decrement
1447 the count. */
1448 res = forcecopy(res);
1449 SvREFCNT_dec(sv);
1450
1451 return res;
1452 }
1453
1454
1455 static GEN
Arr_FETCH(GEN g,I32 n)1456 Arr_FETCH(GEN g, I32 n)
1457 {
1458 I32 l = lg(g) - 1;
1459
1460 if (!is_matvec_t(typ(g)))
1461 croak("Access to elements of not-a-vector");
1462 if (n >= l || n < 0)
1463 croak("Array index %i out of range", n);
1464 #if 0
1465 warn("fetching %d-th element of type %d", n, typ((GEN)g[n + 1]));
1466 #endif
1467 return (GEN)g[n + 1];
1468 }
1469
1470 static void
Arr_STORE(GEN g,I32 n,GEN elt)1471 Arr_STORE(GEN g, I32 n, GEN elt)
1472 {
1473 I32 l = lg(g) - 1, docol = 0;
1474 GEN old;
1475
1476 if (!is_matvec_t(typ(g)))
1477 croak("Access to elements of not-a-vector");
1478 if (n >= l || n < 0)
1479 croak("Array index %i out of range", n);
1480 #if 0
1481 warn("storing %d-th element of type %d", n, typ((GEN)g[n + 1]));
1482 #endif /* 0 */
1483
1484 if (typ(g) == t_MAT) {
1485 long len = lg(g);
1486 long l = lg(g[1]);
1487 if (typ(elt) != t_COL) {
1488 if (typ(elt) != t_VEC)
1489 croak("Not a vector where column of a matrix expected");
1490 docol = 1;
1491 }
1492 if (lg(elt)!=l && len != 2)
1493 croak("Assignment of a columns into a matrix of incompatible height");
1494 }
1495
1496 old = (GEN)g[n + 1];
1497 /* It is not clear whether we need to clone if the elt is offstack */
1498 elt = gclone(elt);
1499 if (docol)
1500 settyp(elt, t_COL);
1501
1502 /* anal.c is optimizing inspection away around here... */
1503 if (isclone(old)) killbloc(old);
1504 g[n + 1] = (long)elt;
1505 }
1506
1507 #define Arr_FETCHSIZE(g) (lg(g) - 1)
1508 #define Arr_EXISTS(g,l) ((l)>=0 && l < lg(g) - 1)
1509
1510 #define DFT_VAR (GEN)-1
1511 #define DFT_GEN (GEN)NULL
1512
1513 static void
check_pointer(unsigned int ptrs,GEN argvec[])1514 check_pointer(unsigned int ptrs, GEN argvec[])
1515 {
1516 unsigned int i;
1517 for (i=0; ptrs; i++,ptrs>>=1)
1518 if (ptrs & 1) *((GEN*)argvec[i]) = gclone(*((GEN*)argvec[i]));
1519 }
1520
1521 #define RETTYPE_VOID 0
1522 #define RETTYPE_LONG 1
1523 #define RETTYPE_GEN 2
1524 #define RETTYPE_INT 3
1525
1526 #define ARGS_SUPPORTED 9
1527 #define THE_ARGS_SUPPORTED \
1528 argvec[0], argvec[1], argvec[2], argvec[3], \
1529 argvec[4], argvec[5], argvec[6], argvec[7], argvec[8]
1530
1531 static void
fill_argvect(entree * ep,char * s,long * has_pointer,GEN * argvec,long * rettype,SV ** args,int items,SV ** sv_OUT,GEN * gen_OUT,long * OUT_cnt)1532 fill_argvect(entree *ep, char *s, long *has_pointer, GEN *argvec,
1533 long *rettype, SV **args, int items,
1534 SV **sv_OUT, GEN *gen_OUT, long *OUT_cnt)
1535 { /* The last 3 to support '&' code - treated after the call */
1536 entree *ep1;
1537 int i = 0, j = 0, saw_M = 0;
1538 long fake;
1539 PariExpr expr;
1540
1541 if (!ep)
1542 croak("XSUB call through interface did not provide *function");
1543 if (!s)
1544 croak("XSUB call through interface with a NULL code");
1545
1546 *OUT_cnt = 0;
1547 while (*s) {
1548 if (i >= ARGS_SUPPORTED - 1)
1549 croak("Too many args for a flexible-interface function");
1550 switch (*s++)
1551 {
1552 case 'G': /* GEN */
1553 argvec[i++] = sv2pari(args[j++]);
1554 break;
1555
1556 case 'M': /* long or a mneumonic string (string not supported) */
1557 saw_M = 1;
1558 /* Fall through */
1559 case 'L': /* long */
1560 argvec[i++] = (GEN) (long)SvIV(args[j]);
1561 j++;
1562 break;
1563
1564 case 'n': /* var number */
1565 argvec[i++] = (GEN) numvar(sv2pari(args[j++]));
1566 break;
1567
1568 case 'V': /* variable */
1569 ep1 = bindVariable(args[j++]);
1570 argvec[i++] = (GEN)ep1;
1571 if (EpVALENCE(ep1) != EpVAR && *(s-1) == 'V')
1572 croak("Did not get a variable");
1573 break;
1574 case 'S': /* symbol */
1575 ep1 = bindVariable(args[j++]);
1576 argvec[i++] = (GEN)ep1;
1577 break;
1578 case '&': /* *GEN */
1579 gen_OUT[*OUT_cnt] = sv2pari(args[j]);
1580 argvec[i++] = (GEN)(gen_OUT + *OUT_cnt);
1581 sv_OUT[(*OUT_cnt)++] = args[j++];
1582 break;
1583 case 'E': /* Input position - subroutine */
1584 case 'I': /* Input position - subroutine */
1585 if (SvROK(args[j]) && SvTYPE(SvRV(args[j])) == SVt_PVCV) {
1586 expr = ((char*)&(SvRV(args[j])->sv_flags)) + LSB_in_U32;
1587 } else expr = (char *)SvPV(args[j],na);
1588 argvec[i++] = (GEN) expr;
1589 j++;
1590 break;
1591
1592 case 'r': /* raw */
1593 case 's': /* expanded string; empty arg yields "" */
1594 argvec[i++] = (GEN) SvPV(args[j],na);
1595 j++;
1596 break;
1597
1598 case 'p': /* precision */
1599 argvec[i++] = (GEN) prec;
1600 break;
1601
1602 case '=':
1603 case ',':
1604 break;
1605
1606 case 'D': /* Has a default value */
1607 if (j >= items || !SvOK(args[j]))
1608 {
1609 char *pre = s;
1610
1611 if (j < items)
1612 j++;
1613
1614 if ( *s == 'G' || *s == '&'
1615 || *s == 'E' || *s == 'I' || *s == 'V') {
1616 argvec[i++]=DFT_GEN; s++;
1617 break;
1618 }
1619 if (*s == 'n') {
1620 argvec[i++]=DFT_VAR; s++;
1621 break;
1622 }
1623 while (*s++ != ',');
1624 switch (*s) {
1625 case 'r': case 's':
1626 if (pre[0] == '\"' && pre[1] == '\"'
1627 && s - pre == 3) {
1628 argvec[i++] = (GEN) "";
1629 break;
1630 }
1631 goto unknown;
1632 case 'M': /* long or a mneumonic string
1633 (string not supported) */
1634 saw_M = 1;
1635 /* Fall through */
1636 case 'L': /* long */
1637 argvec[i++] = (GEN) atol(pre);
1638 break;
1639 case 'G':
1640 if ((*pre == '1' || *pre == '0') && pre[1]==',') {
1641 argvec[i++] = (*pre == '1'
1642 ? gun : gzero);
1643 break;
1644 }
1645 default:
1646 unknown:
1647 croak("Cannot process default argument %.*s of type %.1s",
1648 s - pre - 1, pre, s);
1649 }
1650 s++; /* Skip ',' */
1651 }
1652 else
1653 if (*s == 'G' || *s == '&' || *s == 'n'
1654 || *s == 'E' || *s == 'I' || *s == 'V')
1655 break;
1656 while (*s++ != ',');
1657 break;
1658
1659 case 'P': /* series precision */
1660 argvec[i++] = (GEN) precdl;
1661 break;
1662
1663 case 'f': /* Fake *long argument */
1664 argvec[i++] = (GEN) &fake;
1665 break;
1666
1667 case 'x': /* Foreign function */
1668 croak("Calling Perl via PARI with an unknown interface: avoiding loop");
1669 break;
1670
1671 case 'l': /* Return long */
1672 *rettype = RETTYPE_LONG; break;
1673
1674 case 'i': /* Return int */
1675 *rettype = RETTYPE_INT; break;
1676
1677 case 'v': /* Return void */
1678 *rettype = RETTYPE_VOID; break;
1679
1680 case '\n': /* Mneumonic starts */
1681 if (saw_M) {
1682 s = ""; /* Finish processing */
1683 break;
1684 }
1685 /* FALL THROUGH */
1686 default:
1687 croak("Unsupported code '%.1s' in signature of a PARI function", s-1);
1688 }
1689 if (j > items)
1690 croak("Too few args %d for PARI function %s", items, ep->name);
1691 }
1692 if (j < items)
1693 croak("%d unused args for PARI function %s", items - j, ep->name);
1694 #if PURIFY
1695 for ( ; i<ARGS_SUPPORTED; i++) argvec[i]=NULL;
1696 #endif
1697 }
1698
1699 static void
fill_outvect(SV ** sv_OUT,GEN * gen_OUT,long c,long oldavma)1700 fill_outvect(SV **sv_OUT, GEN *gen_OUT, long c, long oldavma)
1701 {
1702 while (c-- > 0)
1703 resetSVpari(sv_OUT[c], gen_OUT[c], oldavma);
1704 }
1705
1706
1707 #define _to_int(in,dummy1,dummy2) to_int(in)
1708
1709 static GEN
to_int(GEN in)1710 to_int(GEN in)
1711 {
1712 long sign = gcmp(in,gzero);
1713
1714 if (!sign)
1715 return gzero;
1716 switch (typ(in)) {
1717 case t_INT:
1718 #if PARI_VERSION_EXP < 2002008
1719 case t_SMALL:
1720 #endif
1721 return in;
1722 case t_INTMOD:
1723 return lift0(in, -1); /* -1: not as polmod */
1724 default:
1725 return gtrunc(in);
1726 }
1727 }
1728
1729 typedef int (*FUNC_PTR)();
1730 typedef void (*TSET_FP)(char *s);
1731
1732 #ifdef NO_HIGHLEVEL_PARI
1733 # define NO_GRAPHICS_PARI
1734 # define have_highlevel() 0
1735 #else
1736 # define have_highlevel() 1
1737 #endif
1738
1739 #ifdef NO_GRAPHICS_PARI
1740 # define have_graphics() 0
1741 # define set_gnuterm(a,b,c) croak("This build of Math::Pari has no plotting support")
1742 # define int_set_term_ftable(a) croak("This build of Math::Pari has no plotting support")
1743 #else
1744 # define have_graphics() 1
1745 # if PARI_VERSION_EXP < 2000013
1746 # define set_gnuterm(a,b,c) \
1747 set_term_funcp((FUNC_PTR)(a),(struct termentry *)(b))
1748 # else /* !( PARI_VERSION_EXP < 2000013 ) */
1749 # define set_gnuterm(a,b,c) \
1750 set_term_funcp3((FUNC_PTR)(INT2PTR(void*, a)), INT2PTR(struct termentry *, b), INT2PTR(TSET_FP,c))
1751 extern void set_term_funcp3(FUNC_PTR change_p, void *term_p, TSET_FP tchange);
1752
1753 # endif /* PARI_VERSION_EXP < 2000013 */
1754
1755 # define int_set_term_ftable(a) (v_set_term_ftable(INT2PTR(void*,a)))
1756 #endif
1757
1758 extern void v_set_term_ftable(void *a);
1759
1760 /* Cast off `const' */
1761 #define s_type_name(x) (char *)type_name(typ(x));
1762
1763 static int reset_on_reload = 0;
1764
1765 int
s_reset_on_reload(int newvalue)1766 s_reset_on_reload(int newvalue)
1767 {
1768 int old = reset_on_reload;
1769 if (newvalue >= 0)
1770 reset_on_reload = newvalue;
1771 return old;
1772 }
1773
1774 MODULE = Math::Pari PACKAGE = Math::Pari PREFIX = Arr_
1775
1776 PROTOTYPES: ENABLE
1777
1778 GEN
1779 Arr_FETCH(g,n)
1780 long oldavma=avma;
1781 GEN g
1782 I32 n
1783
1784 void
1785 Arr_STORE(g,n,elt)
1786 long oldavma=avma;
1787 GEN g
1788 I32 n
1789 GEN elt
1790 CLEANUP:
1791 avma=oldavma;
1792
1793 I32
1794 Arr_FETCHSIZE(g)
1795 long oldavma=avma;
1796 GEN g
1797 CLEANUP:
1798 avma=oldavma;
1799
1800 I32
1801 Arr_EXISTS(g,elt)
1802 long oldavma=avma;
1803 GEN g
1804 long elt
1805 CLEANUP:
1806 avma=oldavma;
1807
1808 MODULE = Math::Pari PACKAGE = Math::Pari
1809
1810 PROTOTYPES: ENABLE
1811
1812 GEN
1813 sv2pari(sv)
1814 long oldavma=avma;
1815 SV * sv
1816
1817 GEN
1818 sv2parimat(sv)
1819 long oldavma=avma;
1820 SV * sv
1821
1822
1823 SV *
1824 pari2iv(in)
1825 long oldavma=avma;
1826 GEN in
1827 CLEANUP:
1828 avma=oldavma;
1829
1830
1831 SV *
1832 pari2nv(in)
1833 long oldavma=avma;
1834 GEN in
1835 CLEANUP:
1836 avma=oldavma;
1837
1838
1839 SV *
1840 pari2num_(in,...)
1841 long oldavma=avma;
1842 GEN in
1843 CODE:
1844 if (typ(in) == t_INT) {
1845 RETVAL=pari2iv(in);
1846 } else {
1847 RETVAL=pari2nv(in);
1848 }
1849 OUTPUT:
1850 RETVAL
1851 CLEANUP:
1852 avma=oldavma;
1853
1854 SV *
1855 pari2num(in)
1856 long oldavma=avma;
1857 GEN in
1858 CODE:
1859 if (typ(in) == t_INT) {
1860 RETVAL=pari2iv(in);
1861 } else {
1862 RETVAL=pari2nv(in);
1863 }
1864 OUTPUT:
1865 RETVAL
1866 CLEANUP:
1867 avma=oldavma;
1868
1869 SV *
1870 pari2pv(in,...)
1871 long oldavma=avma;
1872 GEN in
1873 CODE:
1874 RETVAL=pari2pv(in);
1875 OUTPUT:
1876 RETVAL
1877 CLEANUP:
1878 avma=oldavma;
1879
1880 GEN
1881 _to_int(in, dummy1, dummy2)
1882 long oldavma=avma;
1883 GEN in
1884 SV *dummy1 = NO_INIT
1885 SV *dummy2 = NO_INIT
1886 CODE:
1887 PERL_UNUSED_VAR(dummy1); /* -W */
1888 PERL_UNUSED_VAR(dummy2); /* -W */
1889 RETVAL = _to_int(in, dummy1, dummy2);
1890 OUTPUT:
1891 RETVAL
1892
1893 GEN
1894 PARI(...)
1895 long oldavma=avma;
1896 CODE:
1897 if (items==1) {
1898 RETVAL=sv2pari(ST(0));
1899 } else {
1900 int i;
1901
1902 RETVAL=cgetg(items+1, t_VEC);
1903 for (i=0;i<items;i++) {
1904 RETVAL[i+1]=(long)sv2pari(ST(i));
1905 }
1906 }
1907 OUTPUT:
1908 RETVAL
1909
1910 GEN
1911 PARIcol(...)
1912 long oldavma=avma;
1913 CODE:
1914 if (items==1) {
1915 RETVAL=sv2pari(ST(0));
1916 } else {
1917 int i;
1918
1919 RETVAL=cgetg(items+1, t_VEC);
1920 for (i=0;i<items;i++) {
1921 RETVAL[i+1]=(long)sv2pari(ST(i));
1922 }
1923 }
1924 settyp(RETVAL, t_COL);
1925 OUTPUT:
1926 RETVAL
1927
1928 GEN
1929 PARImat(...)
1930 long oldavma=avma;
1931 CODE:
1932 if (items==1) {
1933 RETVAL=sv2parimat(ST(0));
1934 } else {
1935 int i;
1936
1937 RETVAL=cgetg(items+1, t_VEC);
1938 for (i=0;i<items;i++) {
1939 RETVAL[i+1]=(long)sv2pari(ST(i));
1940 settyp(RETVAL[i+1], t_COL);
1941 }
1942 }
1943 settyp(RETVAL, t_MAT);
1944 OUTPUT:
1945 RETVAL
1946
1947 void
1948 installPerlFunctionCV(cv, name, numargs = 1, help = NULL)
1949 SV* cv
1950 char *name
1951 I32 numargs
1952 char *help
1953 PROTOTYPE: DISABLE
1954
1955 # In what follows if a function returns long, we do not need anything
1956 # on the stack, thus we add a cleanup section.
1957
1958 void
1959 interface_flexible_void(...)
1960 long oldavma=avma;
1961 CODE:
1962 {
1963 entree *ep = (entree *) XSANY.any_dptr;
1964 void (*FUNCTION_real)(VARARG)
1965 = (void (*)(VARARG))ep->value;
1966 GEN argvec[ARGS_SUPPORTED];
1967 long rettype = RETTYPE_GEN;
1968 long has_pointer = 0; /* XXXX ?? */
1969 long OUT_cnt;
1970 SV *sv_OUT[ARGS_SUPPORTED];
1971 GEN gen_OUT[ARGS_SUPPORTED];
1972
1973 fill_argvect(ep, ep->code, &has_pointer, argvec, &rettype, &ST(0), items,
1974 sv_OUT, gen_OUT, &OUT_cnt);
1975
1976 if (rettype != RETTYPE_VOID)
1977 croak("Expected VOID return type, got code '%s'", ep->code);
1978
1979 (FUNCTION_real)(THE_ARGS_SUPPORTED);
1980 if (has_pointer)
1981 check_pointer(has_pointer,argvec);
1982 if (OUT_cnt)
1983 fill_outvect(sv_OUT, gen_OUT, OUT_cnt, oldavma);
1984 }
1985
1986 GEN
1987 interface_flexible_gen(...)
1988 long oldavma=avma;
1989 CODE:
1990 {
1991 entree *ep = (entree *) XSANY.any_dptr;
1992 GEN (*FUNCTION_real)(VARARG)
1993 = (GEN (*)(VARARG))ep->value;
1994 GEN argvec[9];
1995 long rettype = RETTYPE_GEN;
1996 long has_pointer = 0; /* XXXX ?? */
1997 long OUT_cnt;
1998 SV *sv_OUT[ARGS_SUPPORTED];
1999 GEN gen_OUT[ARGS_SUPPORTED];
2000
2001 fill_argvect(ep, ep->code, &has_pointer, argvec, &rettype, &ST(0), items,
2002 sv_OUT, gen_OUT, &OUT_cnt);
2003
2004 if (rettype != RETTYPE_GEN)
2005 croak("Expected GEN return type, got code '%s'", ep->code);
2006
2007 RETVAL = (FUNCTION_real)(THE_ARGS_SUPPORTED);
2008 if (has_pointer)
2009 check_pointer(has_pointer,argvec);
2010 if (OUT_cnt)
2011 fill_outvect(sv_OUT, gen_OUT, OUT_cnt, oldavma);
2012 }
2013 OUTPUT:
2014 RETVAL
2015
2016 long
2017 interface_flexible_long(...)
2018 long oldavma=avma;
2019 CODE:
2020 {
2021 entree *ep = (entree *) XSANY.any_dptr;
2022 long (*FUNCTION_real)(VARARG)
2023 = (long (*)(VARARG))ep->value;
2024 GEN argvec[9];
2025 long rettype = RETTYPE_GEN;
2026 long has_pointer = 0; /* XXXX ?? */
2027 long OUT_cnt;
2028 SV *sv_OUT[ARGS_SUPPORTED];
2029 GEN gen_OUT[ARGS_SUPPORTED];
2030
2031 fill_argvect(ep, ep->code, &has_pointer, argvec, &rettype, &ST(0), items,
2032 sv_OUT, gen_OUT, &OUT_cnt);
2033
2034 if (rettype != RETTYPE_LONG)
2035 croak("Expected long return type, got code '%s'", ep->code);
2036
2037 RETVAL = FUNCTION_real(THE_ARGS_SUPPORTED);
2038 if (has_pointer)
2039 check_pointer(has_pointer,argvec);
2040 if (OUT_cnt)
2041 fill_outvect(sv_OUT, gen_OUT, OUT_cnt, oldavma);
2042 }
2043 OUTPUT:
2044 RETVAL
2045
2046 int
2047 interface_flexible_int(...)
2048 long oldavma=avma;
2049 CODE:
2050 {
2051 entree *ep = (entree *) XSANY.any_dptr;
2052 int (*FUNCTION_real)(VARARG)
2053 = (int (*)(VARARG))ep->value;
2054 GEN argvec[9];
2055 long rettype = RETTYPE_GEN;
2056 long has_pointer = 0; /* XXXX ?? */
2057 long OUT_cnt;
2058 SV *sv_OUT[ARGS_SUPPORTED];
2059 GEN gen_OUT[ARGS_SUPPORTED];
2060
2061 fill_argvect(ep, ep->code, &has_pointer, argvec, &rettype, &ST(0), items,
2062 sv_OUT, gen_OUT, &OUT_cnt);
2063
2064 if (rettype != RETTYPE_INT)
2065 croak("Expected int return type, got code '%s'", ep->code);
2066
2067 RETVAL=FUNCTION_real(argvec[0], argvec[1], argvec[2], argvec[3],
2068 argvec[4], argvec[5], argvec[6], argvec[7], argvec[8]);
2069 if (has_pointer)
2070 check_pointer(has_pointer,argvec);
2071 if (OUT_cnt)
2072 fill_outvect(sv_OUT, gen_OUT, OUT_cnt, oldavma);
2073 }
2074 OUTPUT:
2075 RETVAL
2076
2077 GEN
2078 interface0()
2079 long oldavma=avma;
2080 CODE:
2081 {
2082 dFUNCTION(GEN);
2083
2084 if (!FUNCTION) {
2085 croak("XSUB call through interface did not provide *function");
2086 }
2087
2088 RETVAL=FUNCTION(prec);
2089 }
2090 OUTPUT:
2091 RETVAL
2092
2093 GEN
2094 interface9900()
2095 long oldavma=avma;
2096 CODE:
2097 {
2098 dFUNCTION(GEN);
2099
2100 if (!FUNCTION) {
2101 croak("XSUB call through interface did not provide *function");
2102 }
2103
2104 RETVAL=FUNCTION();
2105 }
2106 OUTPUT:
2107 RETVAL
2108
2109 GEN
2110 interface1(arg1)
2111 long oldavma=avma;
2112 GEN arg1
2113 CODE:
2114 {
2115 dFUNCTION(GEN);
2116
2117 if (!FUNCTION) {
2118 croak("XSUB call through interface did not provide *function");
2119 }
2120
2121 RETVAL=FUNCTION(arg1,prec);
2122 }
2123 OUTPUT:
2124 RETVAL
2125
2126 # with fake arguments for overloading
2127
2128 GEN
2129 interface199(arg1,arg2,inv)
2130 long oldavma=avma;
2131 GEN arg1
2132 GEN arg2 = NO_INIT
2133 long inv = NO_INIT
2134 CODE:
2135 {
2136 dFUNCTION(GEN);
2137
2138 if (!FUNCTION) {
2139 croak("XSUB call through interface did not provide *function");
2140 }
2141
2142 PERL_UNUSED_VAR(arg2); /* -W */
2143 PERL_UNUSED_VAR(inv); /* -W */
2144 RETVAL=FUNCTION(arg1,prec);
2145 }
2146 OUTPUT:
2147 RETVAL
2148
2149
2150 long
2151 interface10(arg1)
2152 long oldavma=avma;
2153 GEN arg1
2154 CODE:
2155 {
2156 dFUNCTION(long);
2157
2158 if (!FUNCTION) {
2159 croak("XSUB call through interface did not provide *function");
2160 }
2161
2162 RETVAL=FUNCTION(arg1);
2163 }
2164 OUTPUT:
2165 RETVAL
2166 CLEANUP:
2167 avma=oldavma;
2168
2169 # With fake arguments for overloading
2170
2171 long
2172 interface109(arg1,arg2,inv)
2173 long oldavma=avma;
2174 GEN arg1
2175 GEN arg2 = NO_INIT
2176 long inv = NO_INIT
2177 CODE:
2178 {
2179 dFUNCTION(long);
2180
2181 if (!FUNCTION) {
2182 croak("XSUB call through interface did not provide *function");
2183 }
2184
2185 PERL_UNUSED_VAR(arg2); /* -W */
2186 PERL_UNUSED_VAR(inv); /* -W */
2187 RETVAL=FUNCTION(arg1);
2188 }
2189 OUTPUT:
2190 RETVAL
2191 CLEANUP:
2192 avma=oldavma;
2193
2194 GEN
2195 interface11(arg1)
2196 long oldavma=avma;
2197 long arg1
2198 CODE:
2199 {
2200 dFUNCTION(GEN);
2201
2202 if (!FUNCTION) {
2203 croak("XSUB call through interface did not provide *function");
2204 }
2205
2206 RETVAL=FUNCTION(arg1);
2207 }
2208 OUTPUT:
2209 RETVAL
2210
2211 long
2212 interface15(arg1)
2213 long oldavma=avma;
2214 long arg1
2215 CODE:
2216 {
2217 dFUNCTION(long);
2218
2219 if (!FUNCTION) {
2220 croak("XSUB call through interface did not provide *function");
2221 }
2222
2223 RETVAL=FUNCTION(arg1);
2224 }
2225 OUTPUT:
2226 RETVAL
2227 CLEANUP:
2228 avma=oldavma;
2229
2230 GEN
2231 interface18(arg1)
2232 long oldavma=avma;
2233 GEN arg1
2234 CODE:
2235 {
2236 dFUNCTION(GEN);
2237
2238 if (!FUNCTION) {
2239 croak("XSUB call through interface did not provide *function");
2240 }
2241
2242 RETVAL=FUNCTION(arg1);
2243 }
2244 OUTPUT:
2245 RETVAL
2246
2247 GEN
2248 interface2(arg1,arg2)
2249 long oldavma=avma;
2250 GEN arg1
2251 GEN arg2
2252 CODE:
2253 {
2254 dFUNCTION(GEN);
2255
2256 if (!FUNCTION) {
2257 croak("XSUB call through interface did not provide *function");
2258 }
2259
2260 RETVAL=FUNCTION(arg1,arg2);
2261 }
2262 OUTPUT:
2263 RETVAL
2264
2265 # With fake arguments for overloading
2266
2267 GEN
2268 interface299(arg1,arg2,inv)
2269 long oldavma=avma;
2270 GEN arg1
2271 GEN arg2
2272 bool inv
2273 CODE:
2274 {
2275 dFUNCTION(GEN);
2276
2277 if (!FUNCTION) {
2278 croak("XSUB call through interface did not provide *function");
2279 }
2280
2281 RETVAL = inv? FUNCTION(arg2,arg1): FUNCTION(arg1,arg2);
2282 }
2283 OUTPUT:
2284 RETVAL
2285
2286 long
2287 interface20(arg1,arg2)
2288 long oldavma=avma;
2289 GEN arg1
2290 GEN arg2
2291 CODE:
2292 {
2293 dFUNCTION(long);
2294
2295 if (!FUNCTION) {
2296 croak("XSUB call through interface did not provide *function");
2297 }
2298
2299 RETVAL=FUNCTION(arg1,arg2);
2300 }
2301 OUTPUT:
2302 RETVAL
2303 CLEANUP:
2304 avma=oldavma;
2305
2306 # With fake arguments for overloading and comparison to gun for speed
2307
2308 long
2309 interface2099(arg1,arg2,inv)
2310 long oldavma=avma;
2311 GEN arg1
2312 GEN arg2
2313 bool inv
2314 CODE:
2315 {
2316 dFUNCTION(GEN);
2317
2318 if (!FUNCTION) {
2319 croak("XSUB call through interface did not provide *function");
2320 }
2321
2322 RETVAL = (inv? FUNCTION(arg2,arg1): FUNCTION(arg1,arg2)) == gun;
2323 }
2324 OUTPUT:
2325 RETVAL
2326 CLEANUP:
2327 avma=oldavma;
2328
2329 # With fake arguments for overloading
2330
2331 long
2332 interface209(arg1,arg2,inv)
2333 long oldavma=avma;
2334 GEN arg1
2335 GEN arg2
2336 bool inv
2337 CODE:
2338 {
2339 dFUNCTION(long);
2340
2341 if (!FUNCTION) {
2342 croak("XSUB call through interface did not provide *function");
2343 }
2344
2345 RETVAL = inv? FUNCTION(arg2,arg1): FUNCTION(arg1,arg2);
2346 }
2347 OUTPUT:
2348 RETVAL
2349 CLEANUP:
2350 avma=oldavma;
2351
2352 # With fake arguments for overloading, int return
2353
2354 int
2355 interface2091(arg1,arg2,inv)
2356 long oldavma=avma;
2357 GEN arg1
2358 GEN arg2
2359 bool inv
2360 CODE:
2361 {
2362 dFUNCTION(int);
2363
2364 if (!FUNCTION) {
2365 croak("XSUB call through interface did not provide *function");
2366 }
2367
2368 RETVAL = inv? FUNCTION(arg2,arg1): FUNCTION(arg1,arg2);
2369 }
2370 OUTPUT:
2371 RETVAL
2372 CLEANUP:
2373 avma=oldavma;
2374
2375 GEN
2376 interface29(arg1,arg2)
2377 long oldavma=avma;
2378 GEN arg1
2379 GEN arg2
2380 CODE:
2381 {
2382 dFUNCTION(GEN);
2383
2384 if (!FUNCTION) {
2385 croak("XSUB call through interface did not provide *function");
2386 }
2387
2388 RETVAL=FUNCTION(arg1,arg2,prec);
2389 }
2390 OUTPUT:
2391 RETVAL
2392
2393 GEN
2394 interface3(arg1,arg2,arg3)
2395 long oldavma=avma;
2396 GEN arg1
2397 GEN arg2
2398 GEN arg3
2399 CODE:
2400 {
2401 dFUNCTION(GEN);
2402
2403 if (!FUNCTION) {
2404 croak("XSUB call through interface did not provide *function");
2405 }
2406
2407 RETVAL=FUNCTION(arg1,arg2,arg3);
2408 }
2409 OUTPUT:
2410 RETVAL
2411
2412 long
2413 interface30(arg1,arg2,arg3)
2414 long oldavma=avma;
2415 GEN arg1
2416 GEN arg2
2417 GEN arg3
2418 CODE:
2419 {
2420 dFUNCTION(long);
2421
2422 if (!FUNCTION) {
2423 croak("XSUB call through interface did not provide *function");
2424 }
2425
2426 RETVAL=FUNCTION(arg1,arg2,arg3);
2427 }
2428 OUTPUT:
2429 RETVAL
2430 CLEANUP:
2431 avma=oldavma;
2432
2433 GEN
2434 interface4(arg1,arg2,arg3,arg4)
2435 long oldavma=avma;
2436 GEN arg1
2437 GEN arg2
2438 GEN arg3
2439 GEN arg4
2440 CODE:
2441 {
2442 dFUNCTION(GEN);
2443
2444 if (!FUNCTION) {
2445 croak("XSUB call through interface did not provide *function");
2446 }
2447
2448 RETVAL=FUNCTION(arg1,arg2,arg3,arg4);
2449 }
2450 OUTPUT:
2451 RETVAL
2452
2453 GEN
2454 interface5(arg1,arg2,arg3,arg4)
2455 long oldavma=avma;
2456 GEN arg1
2457 GEN arg2
2458 GEN arg3
2459 GEN arg4
2460 CODE:
2461 {
2462 dFUNCTION(GEN);
2463
2464 if (!FUNCTION) {
2465 croak("XSUB call through interface did not provide *function");
2466 }
2467
2468 RETVAL=FUNCTION(arg1,arg2,arg3,arg4,prec);
2469 }
2470 OUTPUT:
2471 RETVAL
2472
2473 GEN
2474 interface12(arg1,arg2)
2475 long oldavma=avma;
2476 GEN arg1
2477 GEN arg2
2478 CODE:
2479 {
2480 dFUNCTION(GEN);
2481
2482 if (!FUNCTION) {
2483 croak("XSUB call through interface did not provide *function");
2484 }
2485
2486 RETVAL=FUNCTION(arg1,numvar(arg2), precdl);
2487 }
2488 OUTPUT:
2489 RETVAL
2490
2491
2492 GEN
2493 interface13(arg1, arg2=0, arg3=gzero)
2494 long oldavma=avma;
2495 GEN arg1
2496 long arg2
2497 GEN arg3
2498 CODE:
2499 {
2500 dFUNCTION(GEN);
2501
2502 if (!FUNCTION) {
2503 croak("XSUB call through interface did not provide *function");
2504 }
2505
2506 RETVAL=FUNCTION(arg1, arg2, arg3);
2507 }
2508 OUTPUT:
2509 RETVAL
2510
2511
2512 GEN
2513 interface14(arg1,arg2=0)
2514 long oldavma=avma;
2515 GEN arg1
2516 GEN arg2
2517 CODE:
2518 {
2519 dFUNCTION(GEN);
2520
2521 if (!FUNCTION) {
2522 croak("XSUB call through interface did not provide *function");
2523 }
2524
2525 RETVAL=FUNCTION(arg1,arg2 ? numvar(arg2) : -1);
2526 }
2527 OUTPUT:
2528 RETVAL
2529
2530
2531 GEN
2532 interface21(arg1,arg2)
2533 long oldavma=avma;
2534 GEN arg1
2535 long arg2
2536 CODE:
2537 {
2538 dFUNCTION(GEN);
2539
2540 if (!FUNCTION) {
2541 croak("XSUB call through interface did not provide *function");
2542 }
2543
2544 RETVAL=FUNCTION(arg1,arg2);
2545 }
2546 OUTPUT:
2547 RETVAL
2548
2549 # With fake arguments for overloading
2550 # This is very hairy: we need to chose the translation of arguments
2551 # depending on the value of inv
2552
2553 GEN
2554 interface2199(arg1,arg2,inv)
2555 long oldavma=avma;
2556 GEN arg1 = NO_INIT
2557 long arg2 = NO_INIT
2558 bool inv
2559 CODE:
2560 {
2561 dFUNCTION(GEN);
2562
2563 if (!FUNCTION) {
2564 croak("XSUB call through interface did not provide *function");
2565 }
2566 if (inv) {
2567 arg1 = sv2pari(ST(1));
2568 arg2 = (long)SvIV(ST(0));
2569 } else {
2570 arg1 = sv2pari(ST(0));
2571 arg2 = (long)SvIV(ST(1));
2572 }
2573
2574 RETVAL = FUNCTION(arg1,arg2);
2575 }
2576 OUTPUT:
2577 RETVAL
2578
2579
2580 GEN
2581 interface22(arg1,arg2,arg3)
2582 long oldavma=avma;
2583 GEN arg1
2584 PariVar arg2
2585 PariExpr arg3
2586 CODE:
2587 {
2588 dFUNCTION(GEN);
2589
2590 if (!FUNCTION) {
2591 croak("XSUB call through interface did not provide *function");
2592 }
2593
2594 RETVAL = FUNCTION(arg1, arg2, arg3);
2595 }
2596 OUTPUT:
2597 RETVAL
2598
2599 GEN
2600 interface23(arg1,arg2)
2601 long oldavma=avma;
2602 GEN arg1
2603 long arg2
2604 CODE:
2605 {
2606 dFUNCTION(GEN);
2607
2608 if (!FUNCTION) {
2609 croak("XSUB call through interface did not provide *function");
2610 }
2611
2612 RETVAL=FUNCTION(arg1,arg2);
2613 }
2614 OUTPUT:
2615 RETVAL
2616
2617 GEN
2618 interface24(arg1,arg2)
2619 long oldavma=avma;
2620 long arg1
2621 GEN arg2
2622 CODE:
2623 {
2624 dFUNCTION(GEN);
2625
2626 if (!FUNCTION) {
2627 croak("XSUB call through interface did not provide *function");
2628 }
2629
2630 RETVAL=FUNCTION(arg1,arg2);
2631 }
2632 OUTPUT:
2633 RETVAL
2634
2635 GEN
2636 interface25(arg1,arg2,arg3=0)
2637 long oldavma=avma;
2638 GEN arg1
2639 GEN arg2
2640 long arg3
2641 CODE:
2642 {
2643 dFUNCTION(GEN);
2644
2645 if (!FUNCTION) {
2646 croak("XSUB call through interface did not provide *function");
2647 }
2648
2649 RETVAL=FUNCTION(arg1,arg2,arg3);
2650 }
2651 OUTPUT:
2652 RETVAL
2653
2654 GEN
2655 interface26(arg1,arg2,arg3)
2656 long oldavma=avma;
2657 GEN arg1
2658 GEN arg2
2659 GEN arg3
2660 CODE:
2661 {
2662 dFUNCTION(GEN);
2663
2664 if (!FUNCTION) {
2665 croak("XSUB call through interface did not provide *function");
2666 }
2667
2668 RETVAL=FUNCTION(arg1, numvar(arg2), arg3);
2669 }
2670 OUTPUT:
2671 RETVAL
2672
2673 GEN
2674 interface27(arg1,arg2,arg3)
2675 long oldavma=avma;
2676 PariVar arg1
2677 GEN arg2
2678 PariExpr arg3
2679 CODE:
2680 {
2681 dFUNCTION(GEN);
2682
2683 if (!FUNCTION) {
2684 croak("XSUB call through interface did not provide *function");
2685 }
2686
2687 RETVAL=FUNCTION(arg1, arg2, arg3, prec);
2688 }
2689 OUTPUT:
2690 RETVAL
2691
2692 GEN
2693 interface28(arg1,arg2=0,arg3=0)
2694 long oldavma=avma;
2695 GEN arg1
2696 PariVar arg2
2697 PariExpr arg3
2698 CODE:
2699 {
2700 dFUNCTION(GEN);
2701
2702 if (!FUNCTION) {
2703 croak("XSUB call through interface did not provide *function");
2704 }
2705
2706 RETVAL = FUNCTION(arg1, arg2, arg3);
2707 }
2708 OUTPUT:
2709 RETVAL
2710
2711 GEN
2712 interface28_old(arg1,arg2)
2713 long oldavma=avma;
2714 GEN arg1
2715 GEN arg2
2716 CODE:
2717 {
2718 long junk;
2719 dFUNCTION(GEN);
2720
2721 if (!FUNCTION) {
2722 croak("XSUB call through interface did not provide *function");
2723 }
2724
2725 RETVAL=FUNCTION(arg1, arg2, &junk);
2726 }
2727 OUTPUT:
2728 RETVAL
2729
2730 long
2731 interface29_old(arg1,arg2)
2732 long oldavma=avma;
2733 GEN arg1
2734 long arg2
2735 CODE:
2736 {
2737 dFUNCTION(long);
2738
2739 if (!FUNCTION) {
2740 croak("XSUB call through interface did not provide *function");
2741 }
2742
2743 RETVAL=FUNCTION(arg1,arg2);
2744 }
2745 OUTPUT:
2746 RETVAL
2747 CLEANUP:
2748 avma=oldavma;
2749
2750 GEN
2751 interface31(arg1,arg2=0,arg3=0,arg4=0)
2752 long oldavma=avma;
2753 GEN arg1
2754 GEN arg2
2755 GEN arg3
2756 GEN arg4
2757 CODE:
2758 {
2759 dFUNCTION(GEN);
2760
2761 if (!FUNCTION) {
2762 croak("XSUB call through interface did not provide *function");
2763 }
2764
2765 RETVAL=FUNCTION(arg1, arg2, arg3, arg4 ? &arg4 : NULL);
2766 }
2767 OUTPUT:
2768 RETVAL
2769
2770 GEN
2771 interface32(arg1,arg2,arg3)
2772 long oldavma=avma;
2773 GEN arg1
2774 GEN arg2
2775 long arg3
2776 CODE:
2777 {
2778 dFUNCTION(GEN);
2779
2780 if (!FUNCTION) {
2781 croak("XSUB call through interface did not provide *function");
2782 }
2783
2784 RETVAL=FUNCTION(arg1,arg2,arg3);
2785 }
2786 OUTPUT:
2787 RETVAL
2788
2789 GEN
2790 interface33(arg1,arg2,arg3,arg4=0)
2791 long oldavma=avma;
2792 GEN arg1
2793 GEN arg2
2794 GEN arg3
2795 long arg4
2796 CODE:
2797 {
2798 dFUNCTION(GEN);
2799
2800 if (!FUNCTION) {
2801 croak("XSUB call through interface did not provide *function");
2802 }
2803
2804 RETVAL=FUNCTION(arg1,arg2,arg3,arg4,prec);
2805 }
2806 OUTPUT:
2807 RETVAL
2808
2809 void
interface34(arg1,arg2,arg3)2810 interface34(arg1,arg2,arg3)
2811 long arg1
2812 long arg2
2813 long arg3
2814 CODE:
2815 {
2816 dFUNCTION(GEN);
2817
2818 if (!FUNCTION) {
2819 croak("XSUB call through interface did not provide *function");
2820 }
2821
2822 FUNCTION(arg1, arg2, arg3);
2823 }
2824
2825 void
2826 interface35(arg1,arg2,arg3)
2827 long oldavma=avma;
2828 long arg1
2829 GEN arg2
2830 GEN arg3
2831 CODE:
2832 {
2833 dFUNCTION(GEN);
2834
2835 if (!FUNCTION) {
2836 croak("XSUB call through interface did not provide *function");
2837 }
2838
2839 FUNCTION(arg1,arg2,arg3);
2840 }
2841 CLEANUP:
2842 avma=oldavma;
2843
2844 GEN
2845 interface37(arg1,arg2,arg3,arg4)
2846 long oldavma=avma;
2847 PariVar arg1
2848 GEN arg2
2849 GEN arg3
2850 PariExpr arg4
2851 CODE:
2852 {
2853 dFUNCTION(GEN);
2854
2855 if (!FUNCTION) {
2856 croak("XSUB call through interface did not provide *function");
2857 }
2858
2859 RETVAL=FUNCTION(arg1, arg2, arg3, arg4, prec);
2860 }
2861 OUTPUT:
2862 RETVAL
2863
2864 GEN
2865 interface47(arg1,arg2,arg3,arg4,arg0=0)
2866 long oldavma=avma;
2867 GEN arg0
2868 PariVar arg1
2869 GEN arg2
2870 GEN arg3
2871 PariExpr arg4
2872 CODE:
2873 {
2874 dFUNCTION(GEN);
2875
2876 if (!FUNCTION) {
2877 croak("XSUB call through interface did not provide *function");
2878 }
2879
2880 RETVAL=FUNCTION(arg1, arg2, arg3, arg4, arg0);
2881 }
2882 OUTPUT:
2883 RETVAL
2884
2885 GEN
2886 interface48(arg1,arg2,arg3,arg4,arg0=0)
2887 long oldavma=avma;
2888 GEN arg0
2889 PariVar arg1
2890 GEN arg2
2891 GEN arg3
2892 PariExpr arg4
2893 CODE:
2894 {
2895 dFUNCTION(GEN);
2896
2897 if (!FUNCTION) {
2898 croak("XSUB call through interface did not provide *function");
2899 }
2900
2901 RETVAL=FUNCTION(arg1, arg2, arg3, arg4, arg0);
2902 }
2903 OUTPUT:
2904 RETVAL
2905
2906 GEN
2907 interface49(arg0,arg00,arg1=0,arg2=0,arg3=0)
2908 long oldavma=avma;
2909 GEN arg0
2910 GEN arg00
2911 PariVar arg1
2912 PariVar arg2
2913 PariExpr arg3
2914 CODE:
2915 {
2916 dFUNCTION(GEN);
2917 # arg1 and arg2 may finish to be the same entree*, like after $x=$y=PARIvar 'x'
2918 if (arg1 == arg2 && arg1) {
2919 if (ST(2) == ST(3))
2920 croak("Same iterator for a double loop");
2921 # ST(3) is localized now
2922 sv_unref(ST(3));
2923 arg2 = findVariable(ST(3),1);
2924 sv_setref_pv(ST(3), "Math::Pari::Ep", (void*)arg2);
2925 }
2926 if (!FUNCTION) {
2927 croak("XSUB call through interface did not provide *function");
2928 }
2929
2930 RETVAL=FUNCTION(arg0, arg00, arg1, arg2, arg3);
2931 }
2932 OUTPUT:
2933 RETVAL
2934
2935 void
2936 interface83(arg1,arg2,arg3,arg4)
2937 long oldavma=avma;
2938 PariVar arg1
2939 GEN arg2
2940 GEN arg3
2941 PariExpr arg4
2942 CODE:
2943 {
2944 dFUNCTION(void);
2945
2946 if (!FUNCTION) {
2947 croak("XSUB call through interface did not provide *function");
2948 }
2949
2950 FUNCTION(arg1, arg2, arg3, arg4);
2951 }
2952 CLEANUP:
2953 avma=oldavma;
2954
2955 void
2956 interface84(arg1,arg2,arg3)
2957 long oldavma=avma;
2958 GEN arg1
2959 PariVar arg2
2960 PariExpr arg3
2961 CODE:
2962 {
2963 dFUNCTION(void);
2964
2965 if (!FUNCTION) {
2966 croak("XSUB call through interface did not provide *function");
2967 }
2968
2969 FUNCTION(arg1, arg2, arg3);
2970 }
2971 CLEANUP:
2972 avma=oldavma;
2973
2974
2975 # These interfaces were automatically generated:
2976
2977 long
2978 interface16(arg1)
2979 long oldavma=avma;
2980 char * arg1
2981 CODE:
2982 {
2983 dFUNCTION(long);
2984
2985 if (!FUNCTION) {
2986 croak("XSUB call through interface did not provide *function");
2987 }
2988
2989 RETVAL=FUNCTION(arg1);
2990 }
2991 OUTPUT:
2992 RETVAL
2993 CLEANUP:
2994 avma=oldavma;
2995
2996
2997 void
interface19(arg1,arg2)2998 interface19(arg1, arg2)
2999 long arg1
3000 long arg2
3001 CODE:
3002 {
3003 dFUNCTION(GEN);
3004
3005 if (!FUNCTION) {
3006 croak("XSUB call through interface did not provide *function");
3007 }
3008
3009 FUNCTION(arg1, arg2);
3010 }
3011
3012
3013 GEN
3014 interface44(arg1, arg2, arg3, arg4)
3015 long oldavma=avma;
3016 long arg1
3017 long arg2
3018 long arg3
3019 long arg4
3020 CODE:
3021 {
3022 dFUNCTION(GEN);
3023
3024 if (!FUNCTION) {
3025 croak("XSUB call through interface did not provide *function");
3026 }
3027
3028 RETVAL=FUNCTION(arg1, arg2, arg3, arg4);
3029 }
3030 OUTPUT:
3031 RETVAL
3032
3033
3034 GEN
3035 interface45(arg1, arg2, arg3=0)
3036 long oldavma=avma;
3037 long arg1
3038 GEN arg2
3039 long arg3
3040 CODE:
3041 {
3042 dFUNCTION(GEN);
3043
3044 if (!FUNCTION) {
3045 croak("XSUB call through interface did not provide *function");
3046 }
3047
3048 RETVAL=FUNCTION(arg1, arg2, arg3);
3049 }
3050 OUTPUT:
3051 RETVAL
3052
3053
3054 void
3055 interface59(arg1, arg2, arg3, arg4, arg5)
3056 long oldavma=avma;
3057 long arg1
3058 GEN arg2
3059 GEN arg3
3060 GEN arg4
3061 GEN arg5
3062 CODE:
3063 {
3064 dFUNCTION(GEN);
3065
3066 if (!FUNCTION) {
3067 croak("XSUB call through interface did not provide *function");
3068 }
3069
3070 FUNCTION(arg1, arg2, arg3, arg4, arg5);
3071 }
3072 CLEANUP:
3073 avma=oldavma;
3074
3075
3076 GEN
3077 interface73(arg1, arg2, arg3, arg4, arg5, arg6=0, arg7=0)
3078 long oldavma=avma;
3079 long arg1
3080 PariVar arg2
3081 GEN arg3
3082 GEN arg4
3083 PariExpr arg5
3084 long arg6
3085 long arg7
3086 CODE:
3087 {
3088 dFUNCTION(GEN);
3089
3090 if (!FUNCTION) {
3091 croak("XSUB call through interface did not provide *function");
3092 }
3093
3094 RETVAL=FUNCTION(arg1, arg2, arg3, arg4, arg5, prec, arg6, arg7);
3095 }
3096 OUTPUT:
3097 RETVAL
3098
3099
3100 void
3101 interface86(arg1, arg2, arg3, arg4, arg5)
3102 long oldavma=avma;
3103 PariVar arg1
3104 GEN arg2
3105 GEN arg3
3106 GEN arg4
3107 PariExpr arg5
3108 CODE:
3109 {
3110 dFUNCTION(GEN);
3111
3112 if (!FUNCTION) {
3113 croak("XSUB call through interface did not provide *function");
3114 }
3115
3116 FUNCTION(arg1, arg2, arg3, arg4, arg5);
3117 }
3118 CLEANUP:
3119 avma=oldavma;
3120
3121
3122 void
3123 interface87(arg1, arg2, arg3, arg4=0)
3124 long oldavma=avma;
3125 PariVar arg1
3126 GEN arg2
3127 PariExpr arg3
3128 long arg4
3129 CODE:
3130 {
3131 dFUNCTION(GEN);
3132
3133 if (!FUNCTION) {
3134 croak("XSUB call through interface did not provide *function");
3135 }
3136
3137 FUNCTION(arg1, arg2, arg3, arg4);
3138 }
3139 CLEANUP:
3140 avma=oldavma;
3141
3142
3143 bool
3144 _2bool(arg1,arg2,inv)
3145 long oldavma=avma;
3146 GEN arg1
3147 GEN arg2 = NO_INIT
3148 long inv = NO_INIT
3149 CODE:
3150 PERL_UNUSED_VAR(arg2); /* -W */
3151 PERL_UNUSED_VAR(inv); /* -W */
3152 RETVAL=!gcmp0(arg1);
3153 OUTPUT:
3154 RETVAL
3155 CLEANUP:
3156 avma=oldavma;
3157
3158 bool
3159 pari2bool(arg1)
3160 long oldavma=avma;
3161 GEN arg1
3162 CODE:
3163 RETVAL=!gcmp0(arg1);
3164 OUTPUT:
3165 RETVAL
3166 CLEANUP:
3167 avma=oldavma;
3168
3169 CV *
3170 loadPari(name, v = 99)
3171 char * name
3172 int v
3173 CODE:
3174 {
3175 char *olds = name;
3176 entree *ep=NULL;
3177 long hash, valence = -1; /* Avoid uninit warning */
3178 void (*func)(void*)=NULL;
3179 void (*unsupported)(void*) = (void (*)(void*)) not_here;
3180
3181 if (*name=='g') {
3182 switch (name[1]) {
3183 case 'a':
3184 if (strEQ(name,"gadd")) {
3185 valence=2;
3186 func=(void (*)(void*)) gadd;
3187 } else if (strEQ(name,"gand")) {
3188 valence=2;
3189 func=(void (*)(void*)) gand;
3190 }
3191 break;
3192 case 'c':
3193 if (strEQ(name,"gcmp0")) {
3194 valence=10;
3195 func=(void (*)(void*)) gcmp0;
3196 } else if (strEQ(name,"gcmp1")) {
3197 valence=10;
3198 func=(void (*)(void*)) gcmp1;
3199 } else if (strEQ(name,"gcmp_1")) {
3200 valence=10;
3201 func=(void (*)(void*)) gcmp_1;
3202 } else if (strEQ(name,"gcmp")) {
3203 valence=20;
3204 func=(void (*)(void*)) gcmp;
3205 }
3206 break;
3207 case 'd':
3208 if (strEQ(name,"gdiv")) {
3209 valence=2;
3210 func=(void (*)(void*)) gdiv;
3211 } else if (strEQ(name,"gdivent")) {
3212 valence=2;
3213 func=(void (*)(void*)) gdivent;
3214 } else if (strEQ(name,"gdivround")) {
3215 valence=2;
3216 func=(void (*)(void*)) gdivround;
3217 }
3218 break;
3219 case 'e':
3220 if (strEQ(name,"geq")) {
3221 valence=2;
3222 func=(void (*)(void*)) geq;
3223 } else if (strEQ(name,"gegal")) {
3224 valence=20;
3225 func=(void (*)(void*)) gegal;
3226 }
3227 break;
3228 case 'g':
3229 if (strEQ(name,"gge")) {
3230 valence=2;
3231 func=(void (*)(void*)) gge;
3232 } else if (strEQ(name,"ggt")) {
3233 valence=2;
3234 func=(void (*)(void*)) ggt;
3235 }
3236 break;
3237 case 'l':
3238 if (strEQ(name,"gle")) {
3239 valence=2;
3240 func=(void (*)(void*)) gle;
3241 } else if (strEQ(name,"glt")) {
3242 valence=2;
3243 func=(void (*)(void*)) glt;
3244 }
3245 break;
3246 case 'm':
3247 if (strEQ(name,"gmul")) {
3248 valence=2;
3249 func=(void (*)(void*)) gmul;
3250 } else if (strEQ(name,"gmod")) {
3251 valence=2;
3252 func=(void (*)(void*)) gmod;
3253 }
3254 break;
3255 case 'n':
3256 if (strEQ(name,"gneg")) {
3257 valence=1;
3258 func=(void (*)(void*)) gneg;
3259 } else if (strEQ(name,"gne")) {
3260 valence=2;
3261 func=(void (*)(void*)) gne;
3262 }
3263 break;
3264 case 'o':
3265 if (strEQ(name,"gor")) {
3266 valence=2;
3267 func=(void (*)(void*)) gor;
3268 }
3269 break;
3270 case 'p':
3271 if (strEQ(name,"gpui")) {
3272 valence=2;
3273 func=(void (*)(void*)) my_gpui;
3274 }
3275 break;
3276 case 's':
3277 if (strEQ(name,"gsub")) {
3278 valence=2;
3279 func=(void (*)(void*)) gsub;
3280 }
3281 break;
3282 }
3283 } else if (*name=='_') {
3284 if (name[1] == 'g') {
3285 switch (name[2]) {
3286 case 'a':
3287 if (strEQ(name,"_gadd")) {
3288 valence=299;
3289 func=(void (*)(void*)) gadd;
3290 } else if (strEQ(name,"_gand")) {
3291 valence=2099;
3292 func=(void (*)(void*)) gand;
3293 }
3294 break;
3295 #if PARI_VERSION_EXP >= 2000018
3296 case 'b':
3297 if (strEQ(name,"_gbitand")) {
3298 valence=299;
3299 func=(void (*)(void*)) gbitand;
3300 } else if (strEQ(name,"_gbitor")) {
3301 valence=299;
3302 func=(void (*)(void*)) gbitor;
3303 } else if (strEQ(name,"_gbitxor")) {
3304 valence=299;
3305 func=(void (*)(void*)) gbitxor;
3306 } else if (strEQ(name,"_gbitneg")) {
3307 valence=199;
3308 func=(void (*)(void*)) _gbitneg;
3309 #if PARI_VERSION_EXP >= 2002001
3310 } else if (strEQ(name,"_gbitshiftl")) {
3311 valence=2199;
3312 func=(void (*)(void*)) _gbitshiftl;
3313 #endif
3314 #if PARI_VERSION_EXP >= 2002001 && PARI_VERSION_EXP <= 2002007
3315 } else if (strEQ(name,"_gbitshiftr")) {
3316 valence=2199;
3317 func=(void (*)(void*)) _gbitshiftr;
3318 #endif
3319 }
3320 break;
3321 #endif
3322 case 'c':
3323 if (strEQ(name,"_gcmp")) {
3324 valence=209;
3325 func=(void (*)(void*)) gcmp;
3326 } else if (strEQ(name,"_gcmp0")) {
3327 valence=109;
3328 func=(void (*)(void*)) gcmp0;
3329 }
3330 break;
3331 case 'd':
3332 if (strEQ(name,"_gdiv")) {
3333 valence=299;
3334 func=(void (*)(void*)) gdiv;
3335 }
3336 break;
3337 case 'e':
3338 if (strEQ(name,"_geq")) {
3339 valence=2099;
3340 func=(void (*)(void*)) geq;
3341 }
3342 break;
3343 case 'g':
3344 if (strEQ(name,"_gge")) {
3345 valence=2099;
3346 func=(void (*)(void*)) gge;
3347 } else if (strEQ(name,"_ggt")) {
3348 valence=2099;
3349 func=(void (*)(void*)) ggt;
3350 }
3351 break;
3352 case 'l':
3353 if (strEQ(name,"_gle")) {
3354 valence=2099;
3355 func=(void (*)(void*)) gle;
3356 } else if (strEQ(name,"_glt")) {
3357 valence=2099;
3358 func=(void (*)(void*)) glt;
3359 }
3360 break;
3361 case 'm':
3362 if (strEQ(name,"_gmul")) {
3363 valence=299;
3364 func=(void (*)(void*)) gmul;
3365 } else if (strEQ(name,"_gmod")) {
3366 valence=299;
3367 func=(void (*)(void*)) gmod;
3368 }
3369 break;
3370 case 'n':
3371 if (strEQ(name,"_gneg")) {
3372 valence=199;
3373 func=(void (*)(void*)) gneg;
3374 } else if (strEQ(name,"_gne")) {
3375 valence=2099;
3376 func=(void (*)(void*)) gne;
3377 }
3378 break;
3379 case 'o':
3380 if (strEQ(name,"_gor")) {
3381 valence=2099;
3382 func=(void (*)(void*)) gor;
3383 }
3384 break;
3385 case 'p':
3386 if (strEQ(name,"_gpui")) {
3387 valence=299;
3388 func=(void (*)(void*)) my_gpui;
3389 }
3390 break;
3391 case 's':
3392 if (strEQ(name,"_gsub")) {
3393 valence=299;
3394 func=(void (*)(void*)) gsub;
3395 }
3396 break;
3397 }
3398 } else {
3399 switch (name[1]) {
3400 case 'a':
3401 if (strEQ(name,"_abs")) {
3402 valence=199;
3403 func=(void (*)(void*)) gabs;
3404 }
3405 break;
3406 case 'c':
3407 if (strEQ(name,"_cos")) {
3408 valence=199;
3409 func=(void (*)(void*)) gcos;
3410 }
3411 break;
3412 case 'e':
3413 if (strEQ(name,"_exp")) {
3414 valence=199;
3415 func=(void (*)(void*)) gexp;
3416 }
3417 break;
3418 case 'l':
3419 if (strEQ(name,"_lex")) {
3420 valence=2091;
3421 func=(void (*)(void*)) lexcmp;
3422 } else if (strEQ(name,"_log")) {
3423 valence=199;
3424 func=(void (*)(void*)) glog;
3425 }
3426 break;
3427 case 's':
3428 if (strEQ(name,"_sin")) {
3429 valence=199;
3430 func=(void (*)(void*)) gsin;
3431 } else if (strEQ(name,"_sqrt")) {
3432 valence=199;
3433 func=(void (*)(void*)) gsqrt;
3434 }
3435 break;
3436 }
3437 }
3438 }
3439 if (!func) {
3440 SAVEINT(doing_PARI_autoload);
3441 doing_PARI_autoload = 1;
3442 ep = is_entry_intern(name, functions_hash, &hash);
3443 doing_PARI_autoload = 0;
3444 #if 0
3445 for (n = 0; *name; name++) n = n << 1 ^ *name;
3446 if (n < 0) n = -n; n %= TBLSZ;
3447 for(ep = hashtable[n]; ep; ep = ep->next) {
3448 if (strEQ(olds,ep->name)) { /* Name in the symbol table */
3449 break;
3450 }
3451 }
3452 #endif
3453 if (!ep) {
3454 #if 0 /* findentry() is static. */
3455 ep = findentry(name,strlen(name),funct_old_hash[hash]);
3456 #endif
3457 if (!ep)
3458 croak("`%s' is not a Pari function name",name);
3459 else
3460 warn("`%s' is an obsolete Pari function name", name);
3461 }
3462 if (ep && (EpVALENCE(ep) < EpUSER
3463 /* && ep>=fonctions && ep < fonctions+NUMFUNC) */)) {
3464 /* Builtin */
3465 IV table_valence = 99;
3466
3467 if (ep->code
3468 && (*(ep->code) ? (PERL_constant_ISIV == func_ord_by_type (aTHX_ ep->code,
3469 strlen(ep->code), &table_valence))
3470 : (table_valence = 9900)))
3471 valence = table_valence;
3472 else
3473 valence = 99;
3474 #ifdef CHECK_VALENCE
3475 if (ep->code && valence != EpVALENCE(ep)
3476 && !(valence == 23 && EpVALENCE(ep) == 21)
3477 && !(valence == 48 && EpVALENCE(ep) == 47)
3478 && !(valence == 96 && EpVALENCE(ep) == 91)
3479 && !(valence == 99 && EpVALENCE(ep) == 0)
3480 && !(valence == 9900 && EpVALENCE(ep) == 0)
3481 && EpVALENCE(ep) != 99)
3482 warn("funcname=`%s', code=`%s', val=%d, calc_val=%d\n",
3483 name, ep->code, (int)EpVALENCE(ep), (int)valence);
3484 #endif
3485 func=(void (*)(void*)) ep->value;
3486 if (!func) {
3487 func = unsupported;
3488 }
3489 }
3490 }
3491 if (func == unsupported) {
3492 croak("Do not know how to work with Pari control structure `%s'",
3493 olds);
3494 } else if (func) {
3495 char* file = __FILE__, *proto = NULL;
3496 char subname[276]="Math::Pari::";
3497 char buf[64], *s, *s1;
3498 CV *protocv;
3499 int flexible = 0;
3500
3501 sprintf(buf, "%ld", valence);
3502 switch (valence) {
3503 case 0:
3504 if (!ep->code) {
3505 croak("Unsupported Pari function %s, interface 0 code NULL");
3506 } else if (ep->code[0] == 'p' && ep->code[1] == 0) {
3507 DO_INTERFACE(0);
3508 } else if (ep->code[0] == 0) {
3509 DO_INTERFACE(9900);
3510 } else {
3511 goto flexible;
3512 }
3513 break;
3514 CASE_INTERFACE(1);
3515 CASE_INTERFACE(10);
3516 CASE_INTERFACE(199);
3517 CASE_INTERFACE(109);
3518 CASE_INTERFACE(11);
3519 CASE_INTERFACE(15);
3520 CASE_INTERFACE(2);
3521 CASE_INTERFACE(20);
3522 CASE_INTERFACE(299);
3523 CASE_INTERFACE(209);
3524 CASE_INTERFACE(2099);
3525 CASE_INTERFACE(2091);
3526 CASE_INTERFACE(2199);
3527 CASE_INTERFACE(3);
3528 CASE_INTERFACE(30);
3529 CASE_INTERFACE(4);
3530 CASE_INTERFACE(5);
3531 CASE_INTERFACE(21);
3532 CASE_INTERFACE(23);
3533 CASE_INTERFACE(24);
3534 CASE_INTERFACE(25);
3535 CASE_INTERFACE(29);
3536 CASE_INTERFACE(32);
3537 CASE_INTERFACE(33);
3538 CASE_INTERFACE(35);
3539 CASE_INTERFACE(12);
3540 CASE_INTERFACE(13);
3541 CASE_INTERFACE(14);
3542 CASE_INTERFACE(26);
3543 CASE_INTERFACE(28);
3544 CASE_INTERFACE(31);
3545 CASE_INTERFACE(34);
3546 CASE_INTERFACE(22);
3547 CASE_INTERFACE(27);
3548 CASE_INTERFACE(37);
3549 CASE_INTERFACE(47);
3550 CASE_INTERFACE(48);
3551 CASE_INTERFACE(49);
3552 CASE_INTERFACE(83);
3553 CASE_INTERFACE(84);
3554 CASE_INTERFACE(18);
3555 /* These interfaces were automatically generated: */
3556 CASE_INTERFACE(16);
3557 CASE_INTERFACE(19);
3558 CASE_INTERFACE(44);
3559 CASE_INTERFACE(45);
3560 CASE_INTERFACE(59);
3561 CASE_INTERFACE(73);
3562 CASE_INTERFACE(86);
3563 CASE_INTERFACE(87);
3564 CASE_INTERFACE(9900);
3565
3566 default:
3567 if (!ep)
3568 croak("Unsupported interface %d for \"direct-link\" Pari function %s",
3569 valence, olds);
3570 if (!ep->code)
3571 croak("Unsupported interface %d and no code for a Pari function %s",
3572 valence, olds);
3573 flexible:
3574 s1 = s = ep->code;
3575 if (*s1 == 'x')
3576 s1++;
3577 if (*s1 == 'v') {
3578 strcpy(buf, "_flexible_void");
3579 DO_INTERFACE(_flexible_void);
3580 }
3581 else if (*s1 == 'l') {
3582 strcpy(buf, "_flexible_long");
3583 DO_INTERFACE(_flexible_long);
3584 }
3585 else if (*s1 == 'i') {
3586 strcpy(buf, "_flexible_int");
3587 DO_INTERFACE(_flexible_int);
3588 }
3589 else {
3590 strcpy(buf, "_flexible_gen");
3591 DO_INTERFACE(_flexible_gen);
3592 }
3593
3594 flexible = 1;
3595 }
3596 strcpy(subname+12,"interface");
3597 strcpy(subname+12+9,buf);
3598 protocv = perl_get_cv(subname, FALSE);
3599 if (protocv) {
3600 proto = SvPV((SV*)protocv,na);
3601 }
3602
3603 strcpy(subname+12,olds);
3604 RETVAL = newXS(subname,math_pari_subaddr,file);
3605 if (proto)
3606 sv_setpv((SV*)RETVAL, proto);
3607 XSINTERFACE_FUNC_SET(RETVAL, flexible ? (void*)ep : (void*)func);
3608 } else {
3609 croak("Cannot load a Pari macro `%s': macros are unsupported", olds);
3610 }
3611 }
3612 OUTPUT:
3613 RETVAL
3614
3615
3616 # Tag is menu entry, or -1 for all.
3617
3618 void
listPari(tag)3619 listPari(tag)
3620 int tag
3621 PPCODE:
3622 {
3623 long valence;
3624 entree *ep, *table = functions_basic;
3625 int i=-1;
3626
3627 while (++i <= 1) {
3628 if (i==1)
3629 #ifdef NO_HIGHLEVEL_PARI
3630 break;
3631 #else
3632 table = functions_highlevel;
3633 #endif
3634
3635 for(ep = table; ep->name; ep++) {
3636 valence = EpVALENCE(ep);
3637 if (tag == -1 || ep->menu == tag) {
3638 switch (valence) {
3639 default:
3640 case 0:
3641 if (ep->code == 0)
3642 break;
3643 /* FALL THROUGH */
3644 case 1:
3645 case 10:
3646 case 199:
3647 case 109:
3648 case 11:
3649 case 15:
3650 case 2:
3651 case 20:
3652 case 299:
3653 case 209:
3654 case 2099:
3655 case 2199:
3656 case 3:
3657 case 30:
3658 case 4:
3659 case 5:
3660 case 21:
3661 case 23:
3662 case 24:
3663 case 25:
3664 case 29:
3665 case 32:
3666 case 33:
3667 case 35:
3668 case 12:
3669 case 13:
3670 case 14:
3671 case 26:
3672 case 28:
3673 case 31:
3674 case 34:
3675 case 22:
3676 case 27:
3677 case 37:
3678 case 47:
3679 case 48:
3680 case 49:
3681 case 83:
3682 case 84:
3683 case 18:
3684 /* These interfaces were automatically generated: */
3685 case 16:
3686 case 19:
3687 case 44:
3688 case 45:
3689 case 59:
3690 case 73:
3691 case 86:
3692 case 87:
3693 XPUSHs(sv_2mortal(newSVpv(ep->name, 0)));
3694 }
3695 }
3696 }
3697 }
3698 }
3699
3700 BOOT:
3701 {
3702 static int reboot;
3703 SV *mem = perl_get_sv("Math::Pari::initmem", FALSE);
3704 SV *pri = perl_get_sv("Math::Pari::initprimes", FALSE);
3705 if (!mem || !SvOK(mem)) {
3706 croak("$Math::Pari::initmem not defined!");
3707 }
3708 if (!pri || !SvOK(pri)) {
3709 croak("$Math::Pari::initprimes not defined!");
3710 }
3711 #if PARI_VERSION_EXP < 2002012 /* XXXX HOW to do otherwise */
3712 if (reboot) {
3713 detach_stack();
3714 if (reset_on_reload)
3715 freeall();
3716 else
3717 allocatemoremem(1008);
3718 }
3719 #endif
3720 #if PARI_VERSION_EXP >= 2002012
3721 pari_init_defaults();
3722 #else
3723 INIT_JMP_off;
3724 INIT_SIG_off;
3725 /* These guys are new in 2.0. */
3726 init_defaults(1);
3727 #endif
3728 /* Different order of init required */
3729 #if PARI_VERSION_EXP < 2003000
3730 if (!(reboot++)) {
3731 # ifndef NO_HIGHLEVEL_PARI
3732 # if PARI_VERSION_EXP >= 2002012
3733 pari_add_module(functions_highlevel);
3734 # else /* !( PARI_VERSION_EXP >= 2002012 ) */
3735 pari_addfunctions(&pari_modules,
3736 functions_highlevel, helpmessages_highlevel);
3737 # endif /* !( PARI_VERSION_EXP >= 2002012 ) */
3738 init_graph();
3739 # endif
3740 }
3741 #endif /* PARI_VERSION_EXP < 2003000 */
3742 primelimit = SvIV(pri);
3743 parisize = SvIV(mem);
3744 #if PARI_VERSION_EXP >= 2002012
3745 pari_init_opts(parisize, primelimit, INIT_DFTm);
3746 /* Default: take four million bytes of
3747 * memory for the stack, calculate
3748 * primes up to 500000. */
3749 #else
3750 init(parisize, primelimit); /* Default: take four million bytes of
3751 * memory for the stack, calculate
3752 * primes up to 500000. */
3753 #endif
3754 /* Different order of init required */
3755 #if PARI_VERSION_EXP >= 2003000
3756 if (!(reboot++)) {
3757 # ifndef NO_HIGHLEVEL_PARI
3758 # if PARI_VERSION_EXP >= 2002012
3759 pari_add_module(functions_highlevel);
3760 # else /* !( PARI_VERSION_EXP >= 2002012 ) */
3761 pari_addfunctions(&pari_modules,
3762 functions_highlevel, helpmessages_highlevel);
3763 # endif /* !( PARI_VERSION_EXP >= 2002012 ) */
3764 init_graph();
3765 # endif
3766 }
3767 #endif /* PARI_VERSION_EXP >= 2003000 */
3768 PariStack = (SV *) GENfirstOnStack;
3769 workErrsv = newSVpv("",0);
3770 pariErr = &perlErr;
3771 #if PARI_VERSION_EXP >= 2003000
3772 pari_set_last_newline(1); /* Bug in PARI: at the start, we do not need extra newlines */
3773 #endif
3774 foreignHandler = (void*)&callPerlFunction;
3775 foreignAutoload = &autoloadPerlFunction;
3776 foreignExprSwitch = (char)SVt_PVCV;
3777 foreignExprHandler = &exprHandler_Perl;
3778 foreignFuncFree = &freePerlFunction;
3779 pariStash = gv_stashpv("Math::Pari", TRUE);
3780 pariEpStash = gv_stashpv("Math::Pari::Ep", TRUE);
3781 perlavma = sentinel = avma;
3782 fmt_nb = def_fmt_nb;
3783 }
3784
3785 void
3786 memUsage()
3787 PPCODE:
3788 #ifdef DEBUG_PARI
3789 EXTEND(sp, 3); /* Got cv + 0, return 4. */
3790 PUSHs(sv_2mortal(newSViv(SVnumtotal)));
3791 PUSHs(sv_2mortal(newSViv(SVnum)));
3792 PUSHs(sv_2mortal(newSViv(onStack)));
3793 PUSHs(sv_2mortal(newSViv(offStack)));
3794 #endif
3795
3796
3797 void
3798 dumpStack()
3799 PPCODE:
3800 GEN x = (GEN)avma;
3801 UV i = 0;
3802 long ssize = getstack();
3803 SV* ret;
3804
3805 switch(GIMME_V) {
3806 case G_VOID:
3807 case G_SCALAR:
3808 ret = newSVpvf("stack size is %d bytes (%d x %d longs)\n",
3809 ssize,sizeof(long),ssize/sizeof(long));
3810 for(; x < (GEN)top; x += taille(x), i++) {
3811 SV* tmp = pari_print(x);
3812 sv_catpvf(ret," %2d: %s\n",i,SvPV_nolen(tmp));
3813 SvREFCNT_dec(tmp);
3814 }
3815 if(GIMME_V == G_VOID) {
3816 PerlIO_puts(PerlIO_stdout(), SvPV_nolen(ret));
3817 SvREFCNT_dec(ret);
3818 XSRETURN(0);
3819 } else {
3820 ST(0) = sv_2mortal(ret);
3821 XSRETURN(1);
3822 }
3823 case G_ARRAY:
3824 for(; x < (GEN)top; x += taille(x), i++)
3825 XPUSHs(sv_2mortal(pari_print(x)));
3826 }
3827
3828 void
3829 dumpHeap()
3830 PPCODE:
3831 heap_dumper_t hd;
3832 int context = GIMME_V, m;
3833
3834 SV* ret = Nullsv; /* Avoid unit warning */
3835
3836 switch(context) {
3837 case G_VOID:
3838 case G_SCALAR: ret = newSVpvn("",0); break;
3839 case G_ARRAY: ret = (SV*)newAV(); break;
3840 }
3841
3842 hd.words = hd.items = 0;
3843 hd.acc = ret;
3844 hd.context = context;
3845
3846 heap_dumper(&hd);
3847
3848 switch(context) {
3849 case G_VOID:
3850 case G_SCALAR: {
3851 SV* tmp = newSVpvf("heap had %ld bytes (%ld items)\n",
3852 (hd.words + BL_HEAD * hd.items) * sizeof(long),
3853 hd.items);
3854 sv_catsv(tmp,ret);
3855 SvREFCNT_dec(ret);
3856 if(GIMME_V == G_VOID) {
3857 PerlIO_puts(PerlIO_stdout(), SvPV_nolen(tmp));
3858 SvREFCNT_dec(tmp);
3859 XSRETURN(0);
3860 } else {
3861 ST(0) = sv_2mortal(tmp);
3862 XSRETURN(1);
3863 }
3864 }
3865 case G_ARRAY:
3866 for(m = 0; m <= av_len((AV*)ret); m++)
3867 XPUSHs(sv_2mortal(SvREFCNT_inc(*av_fetch((AV*)ret,m,0))));
3868 SvREFCNT_dec(ret);
3869 }
3870
3871 MODULE = Math::Pari PACKAGE = Math::Pari
3872
3873 void
DESTROY(rv)3874 DESTROY(rv)
3875 SV * rv
3876 CODE:
3877 {
3878 /* PariStack keeps the latest SV that keeps a GEN on stack. */
3879 SV* sv = SvRV(rv);
3880 char* ostack; /* The value of PariStack when the
3881 * variable was created, thus the
3882 * previous SV that keeps a GEN from
3883 * stack, or some atoms. */
3884 long oldavma; /* The value of avma on the entry
3885 * to function having the SV as
3886 * argument. */
3887 long howmany;
3888 SV_OAVMA_PARISTACK_get(sv, oldavma, ostack);
3889 oldavma += bot;
3890 #if 1
3891 if (SvMAGICAL(sv) && SvTYPE(sv) == SVt_PVAV) {
3892 MAGIC *mg = mg_find(sv, 'P');
3893 SV *obj;
3894
3895 /* Be extra paranoid: is refcount is artificially low? */
3896 if (mg && (obj = mg->mg_obj) && SvROK(obj) && SvRV(obj) == sv) {
3897 mg->mg_flags &= ~MGf_REFCOUNTED;
3898 SvREFCNT_inc(sv);
3899 SvREFCNT_dec(obj);
3900 }
3901 /* We manipulated SvCUR(), which for AV overwrites AvFILLp();
3902 make sure that array looks like an empty one */
3903 AvFILLp((AV*)sv) = -1;
3904 }
3905 #endif
3906 SV_PARISTACK_set(sv, GENheap); /* To avoid extra free() in moveoff.... */
3907 if (ostack == GENheap) /* Leave it alone? XXXX */
3908 /* break */ ;
3909 else if (ostack == GENmovedOffStack) {/* Know that it _was temporary. */
3910 killbloc((GEN)SV_myvoidp_get(sv));
3911 } else {
3912 /* Still on stack */
3913 if (ostack != (char*)PariStack) { /* But not the newest one. */
3914 howmany = moveoffstack_newer_than(sv);
3915 RUN_IF_DEBUG_PARI( warn("%li items moved off stack", howmany) );
3916 }
3917 /* Now fall through: */
3918 /* case (IV)GENfirstOnStack: */
3919 /* Now sv is the newest one on stack. */
3920 onStack_dec;
3921 perlavma = oldavma;
3922 if (oldavma > sentinel) {
3923 avma = sentinel; /* Mark the space on stack as free. */
3924 } else {
3925 avma = oldavma; /* Mark the space on stack as free. */
3926 }
3927 PariStack = (SV*)ostack; /* The same on the Perl/PARI side. */
3928 }
3929 SVnum_dec;
3930 }
3931
3932
3933 SV *
3934 pari_print(in)
3935 GEN in
3936
3937 SV *
3938 pari_pprint(in)
3939 GEN in
3940
3941 SV *
3942 pari_texprint(in)
3943 GEN in
3944
3945 I32
3946 typ(in)
3947 GEN in
3948
3949 SV *
3950 PARIvar(in)
3951 char *in
3952
3953 GEN
3954 ifact(arg1)
3955 long oldavma=avma;
3956 long arg1
3957
3958 void
3959 changevalue(name, val)
3960 PariName name
3961 GEN val
3962
3963 void
3964 set_gnuterm(a,b,c=0)
3965 IV a
3966 IV b
3967 IV c
3968
3969 long
3970 setprecision(digits=0)
3971 long digits
3972
3973 long
3974 setseriesprecision(digits=0)
3975 long digits
3976
3977 IV
3978 setprimelimit(n = 0)
3979 IV n
3980
3981 void
3982 int_set_term_ftable(a)
3983 IV a
3984
3985 long
3986 pari_version_exp()
3987
3988 long
3989 have_highlevel()
3990
3991 long
3992 have_graphics()
3993
3994 int
3995 PARI_DEBUG()
3996
3997 int
3998 PARI_DEBUG_set(val)
3999 int val
4000
4001 # Cannot do this: it is xsubpp which needs the typemap entry for UV,
4002 # and it needs to convert *all* the branches.
4003 #/* #if defined(PERL_VERSION) && (PERL_VERSION >= 6)*//* 5.6.0 has UV in the typemap */
4004
4005 #if 0
4006 #UV
4007 #allocatemem(newsize = 0)
4008 #UV newsize
4009
4010 #else /* !( HAVE_UVs ) */
4011
4012 unsigned long
4013 allocatemem(newsize = 0)
4014 unsigned long newsize
4015
4016 #endif /* !( HAVE_UVs ) */
4017
4018 long
4019 lgef(x)
4020 GEN x
4021
4022 long
4023 lgefint(x)
4024 GEN x
4025
4026 long
4027 lg(x)
4028 GEN x
4029
4030 unsigned long
4031 longword(x,n)
4032 GEN x
4033 long n
4034
4035 MODULE = Math::Pari PACKAGE = Math::Pari PREFIX = s_
4036
4037 char *
4038 s_type_name(x)
4039 GEN x
4040
4041 int
4042 s_reset_on_reload(newvalue = -1)
4043 int newvalue
4044