Context Navigation

source: git/Singular/ipshell.cc @ 64b0315

spielwiese

Last change on this file since 64b0315 was 64b0315, checked in by Hans Schoenemann <hannes@…>, 8 years ago
fix: memory leak in error case
Property mode set to `100644`
File size: 157.6 KB

Line
1	/****************************************
2	* Computer Algebra System SINGULAR *
3	****************************************/
4	/*
5	* ABSTRACT:
6	*/
7
8	#include <kernel/mod2.h>
9
10	#include <omalloc/omalloc.h>
11
12	#include <factory/factory.h>
13
14	#include <misc/auxiliary.h>
15	#include <misc/options.h>
16	#include <misc/mylimits.h>
17	#include <misc/intvec.h>
18	#include <misc/prime.h>
19
20	#include <coeffs/numbers.h>
21	#include <coeffs/coeffs.h>
22
23	#include <coeffs/rmodulon.h>
24	#include <coeffs/longrat.h>
25
26	#include <polys/monomials/ring.h>
27	#include <polys/monomials/maps.h>
28
29	#include <polys/prCopy.h>
30	#include <polys/matpol.h>
31
32	#include <polys/weight.h>
33	#include <polys/clapsing.h>
34
35
36	#include <polys/ext_fields/algext.h>
37	#include <polys/ext_fields/transext.h>
38
39	#include <kernel/polys.h>
40	#include <kernel/ideals.h>
41
42	#include <kernel/numeric/mpr_base.h>
43	#include <kernel/numeric/mpr_numeric.h>
44
45	#include <kernel/GBEngine/syz.h>
46	#include <kernel/GBEngine/kstd1.h>
47	#include <kernel/GBEngine/kutil.h> // denominator_list
48
49	#include <kernel/combinatorics/stairc.h>
50	#include <kernel/combinatorics/hutil.h>
51
52	#include <kernel/spectrum/semic.h>
53	#include <kernel/spectrum/splist.h>
54	#include <kernel/spectrum/spectrum.h>
55
56	#include <kernel/oswrapper/feread.h>
57
58	#include <Singular/lists.h>
59	#include <Singular/attrib.h>
60	#include <Singular/ipconv.h>
61	#include <Singular/links/silink.h>
62	#include <Singular/ipshell.h>
63	#include <Singular/maps_ip.h>
64	#include <Singular/tok.h>
65	#include <Singular/ipid.h>
66	#include <Singular/subexpr.h>
67	#include <Singular/fevoices.h>
68	#include <Singular/sdb.h>
69
70	#include <math.h>
71	#include <ctype.h>
72
73	// define this if you want to use the fast_map routine for mapping ideals
74	#define FAST_MAP
75
76	#ifdef FAST_MAP
77	#include <kernel/maps/fast_maps.h>
78	#endif
79
80	#ifdef SINGULAR_4_1
81	#include <Singular/number2.h>
82	#include <coeffs/bigintmat.h>
83	#endif
84	leftv iiCurrArgs=NULL;
85	idhdl iiCurrProc=NULL;
86	const char *lastreserved=NULL;
87
88	static BOOLEAN iiNoKeepRing=TRUE;
89
90	/0 implementation/
91
92	const char * iiTwoOps(int t)
93	{
94	if (t<127)
95	{
96	static char ch[2];
97	switch (t)
98	{
99	case '&':
100	return "and";
101	case '\|':
102	return "or";
103	default:
104	ch[0]=t;
105	ch[1]='\0';
106	return ch;
107	}
108	}
109	switch (t)
110	{
111	case COLONCOLON: return "::";
112	case DOTDOT: return "..";
113	//case PLUSEQUAL: return "+=";
114	//case MINUSEQUAL: return "-=";
115	case MINUSMINUS: return "--";
116	case PLUSPLUS: return "++";
117	case EQUAL_EQUAL: return "==";
118	case LE: return "<=";
119	case GE: return ">=";
120	case NOTEQUAL: return "<>";
121	default: return Tok2Cmdname(t);
122	}
123	}
124
125	int iiOpsTwoChar(const char *s)
126	{
127	/* not handling: &&, \|\|, ** */
128	if (s[1]=='\0') return s[0];
129	else if (s[2]!='\0') return 0;
130	switch(s[0])
131	{
132	case '.': if (s[1]=='.') return DOTDOT;
133	else return 0;
134	case ':': if (s[1]==':') return COLONCOLON;
135	else return 0;
136	case '-': if (s[1]=='-') return MINUSMINUS;
137	else return 0;
138	case '+': if (s[1]=='+') return PLUSPLUS;
139	else return 0;
140	case '=': if (s[1]=='=') return EQUAL_EQUAL;
141	else return 0;
142	case '<': if (s[1]=='=') return LE;
143	else if (s[1]=='>') return NOTEQUAL;
144	else return 0;
145	case '>': if (s[1]=='=') return GE;
146	else return 0;
147	case '!': if (s[1]=='=') return NOTEQUAL;
148	else return 0;
149	}
150	return 0;
151	}
152
153	static void list1(const char* s, idhdl h,BOOLEAN c, BOOLEAN fullname)
154	{
155	char buffer[22];
156	int l;
157	char buf2[128];
158
159	if(fullname) sprintf(buf2, "%s::%s", "", IDID(h));
160	else sprintf(buf2, "%s", IDID(h));
161
162	Print("%s%-30.30s [%d] ",s,buf2,IDLEV(h));
163	if (h == currRingHdl) PrintS("*");
164	PrintS(Tok2Cmdname((int)IDTYP(h)));
165
166	ipListFlag(h);
167	switch(IDTYP(h))
168	{
169	case ALIAS_CMD: Print(" for %s",IDID((idhdl)IDDATA(h))); break;
170	case INT_CMD: Print(" %d",IDINT(h)); break;
171	case INTVEC_CMD:Print(" (%d)",IDINTVEC(h)->length()); break;
172	case INTMAT_CMD:Print(" %d x %d",IDINTVEC(h)->rows(),IDINTVEC(h)->cols());
173	break;
174	case POLY_CMD:
175	case VECTOR_CMD:if (c)
176	{
177	PrintS(" ");wrp(IDPOLY(h));
178	if(IDPOLY(h) != NULL)
179	{
180	Print(", %d monomial(s)",pLength(IDPOLY(h)));
181	}
182	}
183	break;
184	case MODUL_CMD: Print(", rk %d", (int)(IDIDEAL(h)->rank));
185	case IDEAL_CMD: Print(", %u generator(s)",
186	IDELEMS(IDIDEAL(h))); break;
187	case MAP_CMD:
188	Print(" from %s",IDMAP(h)->preimage); break;
189	case MATRIX_CMD:Print(" %u x %u"
190	,MATROWS(IDMATRIX(h))
191	,MATCOLS(IDMATRIX(h))
192	);
193	break;
194	case PACKAGE_CMD:
195	paPrint(IDID(h),IDPACKAGE(h));
196	break;
197	case PROC_CMD: if((IDPROC(h)->libname!=NULL)
198	&& (strlen(IDPROC(h)->libname)>0))
199	Print(" from %s",IDPROC(h)->libname);
200	if(IDPROC(h)->is_static)
201	PrintS(" (static)");
202	break;
203	case STRING_CMD:
204	{
205	char *s;
206	l=strlen(IDSTRING(h));
207	memset(buffer,0,22);
208	strncpy(buffer,IDSTRING(h),si_min(l,20));
209	if ((s=strchr(buffer,'\n'))!=NULL)
210	{
211	*s='\0';
212	}
213	PrintS(" ");
214	PrintS(buffer);
215	if((s!=NULL) \|\|(l>20))
216	{
217	Print("..., %d char(s)",l);
218	}
219	break;
220	}
221	case LIST_CMD: Print(", size: %d",IDLIST(h)->nr+1);
222	break;
223	case QRING_CMD:
224	case RING_CMD:
225	if ((IDRING(h)==currRing) && (currRingHdl!=h))
226	PrintS("()"); / this is an alias to currRing */
227	#ifdef RDEBUG
228	if (traceit &TRACE_SHOW_RINGS)
229	Print(" <%lx>",(long)(IDRING(h)));
230	#endif
231	break;
232	#ifdef SINGULAR_4_1
233	case CNUMBER_CMD:
234	{ number2 n=(number2)IDDATA(h);
235	Print(" (%s)",nCoeffName(n->cf));
236	break;
237	}
238	case CMATRIX_CMD:
239	{ bigintmat b=(bigintmat)IDDATA(h);
240	Print(" %d x %d (%s)",
241	b->rows(),b->cols(),
242	nCoeffName(b->basecoeffs()));
243	break;
244	}
245	#endif
246	/default: break;/
247	}
248	PrintLn();
249	}
250
251	void type_cmd(leftv v)
252	{
253	BOOLEAN oldShortOut = FALSE;
254
255	if (currRing != NULL)
256	{
257	oldShortOut = currRing->ShortOut;
258	currRing->ShortOut = 1;
259	}
260	int t=v->Typ();
261	Print("// %s %s ",v->Name(),Tok2Cmdname(t));
262	switch (t)
263	{
264	case MAP_CMD:Print(" from %s\n",((map)(v->Data()))->preimage); break;
265	case INTMAT_CMD: Print(" %d x %d\n",((intvec*)(v->Data()))->rows(),
266	((intvec*)(v->Data()))->cols()); break;
267	case MATRIX_CMD:Print(" %u x %u\n" ,
268	MATROWS((matrix)(v->Data())),
269	MATCOLS((matrix)(v->Data())));break;
270	case MODUL_CMD: Print(", rk %d\n", (int)(((ideal)(v->Data()))->rank));break;
271	case LIST_CMD: Print(", size %d\n",((lists)(v->Data()))->nr+1); break;
272
273	case PROC_CMD:
274	case RING_CMD:
275	case IDEAL_CMD:
276	case QRING_CMD: PrintLn(); break;
277
278	//case INT_CMD:
279	//case STRING_CMD:
280	//case INTVEC_CMD:
281	//case POLY_CMD:
282	//case VECTOR_CMD:
283	//case PACKAGE_CMD:
284
285	default:
286	break;
287	}
288	v->Print();
289	if (currRing != NULL)
290	currRing->ShortOut = oldShortOut;
291	}
292
293	static void killlocals0(int v, idhdl * localhdl, const ring r)
294	{
295	idhdl h = *localhdl;
296	while (h!=NULL)
297	{
298	int vv;
299	//Print("consider %s, lev: %d:",IDID(h),IDLEV(h));
300	if ((vv=IDLEV(h))>0)
301	{
302	if (vv < v)
303	{
304	if (iiNoKeepRing)
305	{
306	//PrintS(" break\n");
307	return;
308	}
309	h = IDNEXT(h);
310	//PrintLn();
311	}
312	else //if (vv >= v)
313	{
314	idhdl nexth = IDNEXT(h);
315	killhdl2(h,localhdl,r);
316	h = nexth;
317	//PrintS("kill\n");
318	}
319	}
320	else
321	{
322	h = IDNEXT(h);
323	//PrintLn();
324	}
325	}
326	}
327
328	void killlocals_rec(idhdl *root,int v, ring r)
329	{
330	idhdl h=*root;
331	while (h!=NULL)
332	{
333	if (IDLEV(h)>=v)
334	{
335	// Print("kill %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
336	idhdl n=IDNEXT(h);
337	killhdl2(h,root,r);
338	h=n;
339	}
340	else if (IDTYP(h)==PACKAGE_CMD)
341	{
342	// Print("into pack %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
343	if (IDPACKAGE(h)!=basePack)
344	killlocals_rec(&(IDRING(h)->idroot),v,r);
345	h=IDNEXT(h);
346	}
347	else if ((IDTYP(h)==RING_CMD)
348	\|\|(IDTYP(h)==QRING_CMD))
349	{
350	if ((IDRING(h)!=NULL) && (IDRING(h)->idroot!=NULL))
351	// we have to test IDRING(h)!=NULL: qring Q=groebner(...): killlocals
352	{
353	// Print("into ring %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
354	killlocals_rec(&(IDRING(h)->idroot),v,IDRING(h));
355	}
356	h=IDNEXT(h);
357	}
358	else
359	{
360	// Print("skip %s lev %d for lev %d\n",IDID(h),IDLEV(h),v);
361	h=IDNEXT(h);
362	}
363	}
364	}
365	BOOLEAN killlocals_list(int v, lists L)
366	{
367	if (L==NULL) return FALSE;
368	BOOLEAN changed=FALSE;
369	int n=L->nr;
370	for(;n>=0;n--)
371	{
372	leftv h=&(L->m[n]);
373	void *d=h->data;
374	if (((h->rtyp==RING_CMD) \|\| (h->rtyp==QRING_CMD))
375	&& (((ring)d)->idroot!=NULL))
376	{
377	if (d!=currRing) {changed=TRUE;rChangeCurrRing((ring)d);}
378	killlocals0(v,&(((ring)h->data)->idroot),(ring)h->data);
379	}
380	else if (h->rtyp==LIST_CMD)
381	changed\|=killlocals_list(v,(lists)d);
382	}
383	return changed;
384	}
385	void killlocals(int v)
386	{
387	BOOLEAN changed=FALSE;
388	idhdl sh=currRingHdl;
389	ring cr=currRing;
390	if (sh!=NULL) changed=((IDLEV(sh)<v) \|\| (IDRING(sh)->ref>0));
391	//if (changed) Print("currRing=%s(%x), lev=%d,ref=%d\n",IDID(sh),IDRING(sh),IDLEV(sh),IDRING(sh)->ref);
392
393	killlocals_rec(&(basePack->idroot),v,currRing);
394
395	if (iiRETURNEXPR_len > myynest)
396	{
397	int t=iiRETURNEXPR.Typ();
398	if ((/iiRETURNEXPR.Typ()/ t==RING_CMD)
399	\|\| (/iiRETURNEXPR.Typ()/ t==QRING_CMD))
400	{
401	leftv h=&iiRETURNEXPR;
402	if (((ring)h->data)->idroot!=NULL)
403	killlocals0(v,&(((ring)h->data)->idroot),(ring)h->data);
404	}
405	else if (/iiRETURNEXPR.Typ()/ t==LIST_CMD)
406	{
407	leftv h=&iiRETURNEXPR;
408	changed \|=killlocals_list(v,(lists)h->data);
409	}
410	}
411	if (changed)
412	{
413	currRingHdl=rFindHdl(cr,NULL);
414	if (currRingHdl==NULL)
415	currRing=NULL;
416	else if(cr!=currRing)
417	rChangeCurrRing(cr);
418	}
419
420	if (myynest<=1) iiNoKeepRing=TRUE;
421	//Print("end killlocals >= %d\n",v);
422	//listall();
423	}
424
425	void list_cmd(int typ, const char* what, const char *prefix,BOOLEAN iterate, BOOLEAN fullname)
426	{
427	package savePack=currPack;
428	idhdl h,start;
429	BOOLEAN all = typ<0;
430	BOOLEAN really_all=FALSE;
431
432	if ( typ==0 )
433	{
434	if (strcmp(what,"all")==0)
435	{
436	if (currPack!=basePack)
437	list_cmd(-1,NULL,prefix,iterate,fullname); // list current package
438	really_all=TRUE;
439	h=basePack->idroot;
440	}
441	else
442	{
443	h = ggetid(what);
444	if (h!=NULL)
445	{
446	if (iterate) list1(prefix,h,TRUE,fullname);
447	if (IDTYP(h)==ALIAS_CMD) PrintS("A");
448	if ((IDTYP(h)==RING_CMD)
449	\|\| (IDTYP(h)==QRING_CMD)
450	//\|\| (IDTYP(h)==PACKE_CMD)
451	)
452	{
453	h=IDRING(h)->idroot;
454	}
455	else if(IDTYP(h)==PACKAGE_CMD)
456	{
457	currPack=IDPACKAGE(h);
458	//Print("list_cmd:package\n");
459	all=TRUE;typ=PROC_CMD;fullname=TRUE;really_all=TRUE;
460	h=IDPACKAGE(h)->idroot;
461	}
462	else
463	{
464	currPack=savePack;
465	return;
466	}
467	}
468	else
469	{
470	Werror("%s is undefined",what);
471	currPack=savePack;
472	return;
473	}
474	}
475	all=TRUE;
476	}
477	else if (RingDependend(typ))
478	{
479	h = currRing->idroot;
480	}
481	else
482	h = IDROOT;
483	start=h;
484	while (h!=NULL)
485	{
486	if ((all
487	&& (IDTYP(h)!=PROC_CMD)
488	&&(IDTYP(h)!=PACKAGE_CMD)
489	#ifdef SINGULAR_4_1
490	&&(IDTYP(h)!=CRING_CMD)
491	#endif
492	)
493	\|\| (typ == IDTYP(h))
494	#ifdef SINGULAR_4_1
495	\|\| ((IDTYP(h)==CRING_CMD) && (typ==RING_CMD))
496	#else
497	\|\| ((IDTYP(h)==QRING_CMD) && (typ==RING_CMD))
498	#endif
499	)
500	{
501	list1(prefix,h,start==currRingHdl, fullname);
502	if (((IDTYP(h)==RING_CMD)\|\|(IDTYP(h)==QRING_CMD))
503	&& (really_all \|\| (all && (h==currRingHdl)))
504	&& ((IDLEV(h)==0)\|\|(IDLEV(h)==myynest)))
505	{
506	list_cmd(0,IDID(h),"// ",FALSE);
507	}
508	if (IDTYP(h)==PACKAGE_CMD && really_all)
509	{
510	package save_p=currPack;
511	currPack=IDPACKAGE(h);
512	list_cmd(0,IDID(h),"// ",FALSE);
513	currPack=save_p;
514	}
515	}
516	h = IDNEXT(h);
517	}
518	currPack=savePack;
519	}
520
521	void test_cmd(int i)
522	{
523	int ii;
524
525	if (i<0)
526	{
527	ii= -i;
528	if (ii < 32)
529	{
530	si_opt_1 &= ~Sy_bit(ii);
531	}
532	else if (ii < 64)
533	{
534	si_opt_2 &= ~Sy_bit(ii-32);
535	}
536	else
537	WerrorS("out of bounds\n");
538	}
539	else if (i<32)
540	{
541	ii=i;
542	if (Sy_bit(ii) & kOptions)
543	{
544	Warn("Gerhard, use the option command");
545	si_opt_1 \|= Sy_bit(ii);
546	}
547	else if (Sy_bit(ii) & validOpts)
548	si_opt_1 \|= Sy_bit(ii);
549	}
550	else if (i<64)
551	{
552	ii=i-32;
553	si_opt_2 \|= Sy_bit(ii);
554	}
555	else
556	WerrorS("out of bounds\n");
557	}
558
559	int exprlist_length(leftv v)
560	{
561	int rc = 0;
562	while (v!=NULL)
563	{
564	switch (v->Typ())
565	{
566	case INT_CMD:
567	case POLY_CMD:
568	case VECTOR_CMD:
569	case NUMBER_CMD:
570	rc++;
571	break;
572	case INTVEC_CMD:
573	case INTMAT_CMD:
574	rc += ((intvec *)(v->Data()))->length();
575	break;
576	case MATRIX_CMD:
577	case IDEAL_CMD:
578	case MODUL_CMD:
579	{
580	matrix mm = (matrix)(v->Data());
581	rc += mm->rows() * mm->cols();
582	}
583	break;
584	case LIST_CMD:
585	rc+=((lists)v->Data())->nr+1;
586	break;
587	default:
588	rc++;
589	}
590	v = v->next;
591	}
592	return rc;
593	}
594
595	BOOLEAN iiWRITE(leftv,leftv v)
596	{
597	sleftv vf;
598	if (iiConvert(v->Typ(),LINK_CMD,iiTestConvert(v->Typ(),LINK_CMD),v,&vf))
599	{
600	WerrorS("link expected");
601	return TRUE;
602	}
603	si_link l=(si_link)vf.Data();
604	if (vf.next == NULL)
605	{
606	WerrorS("write: need at least two arguments");
607	return TRUE;
608	}
609
610	BOOLEAN b=slWrite(l,vf.next); /* iiConvert preserves next */
611	if (b)
612	{
613	const char *s;
614	if ((l!=NULL)&&(l->name!=NULL)) s=l->name;
615	else s=sNoName;
616	Werror("cannot write to %s",s);
617	}
618	vf.CleanUp();
619	return b;
620	}
621
622	leftv iiMap(map theMap, const char * what)
623	{
624	idhdl w,r;
625	leftv v;
626	int i;
627	nMapFunc nMap;
628
629	r=IDROOT->get(theMap->preimage,myynest);
630	if ((currPack!=basePack)
631	&&((r==NULL) \|\| ((r->typ != RING_CMD) && (r->typ != QRING_CMD))))
632	r=basePack->idroot->get(theMap->preimage,myynest);
633	if ((r==NULL) && (currRingHdl!=NULL)
634	&& (strcmp(theMap->preimage,IDID(currRingHdl))==0))
635	{
636	r=currRingHdl;
637	}
638	if ((r!=NULL) && ((r->typ == RING_CMD) \|\| (r->typ== QRING_CMD)))
639	{
640	ring src_ring=IDRING(r);
641	if ((nMap=n_SetMap(src_ring->cf, currRing->cf))==NULL)
642	{
643	Werror("can not map from ground field of %s to current ground field",
644	theMap->preimage);
645	return NULL;
646	}
647	if (IDELEMS(theMap)<src_ring->N)
648	{
649	theMap->m=(polyset)omReallocSize((ADDRESS)theMap->m,
650	IDELEMS(theMap)*sizeof(poly),
651	(src_ring->N)*sizeof(poly));
652	for(i=IDELEMS(theMap);i<src_ring->N;i++)
653	theMap->m[i]=NULL;
654	IDELEMS(theMap)=src_ring->N;
655	}
656	if (what==NULL)
657	{
658	WerrorS("argument of a map must have a name");
659	}
660	else if ((w=src_ring->idroot->get(what,myynest))!=NULL)
661	{
662	char *save_r=NULL;
663	v=(leftv)omAlloc0Bin(sleftv_bin);
664	sleftv tmpW;
665	memset(&tmpW,0,sizeof(sleftv));
666	tmpW.rtyp=IDTYP(w);
667	if (tmpW.rtyp==MAP_CMD)
668	{
669	tmpW.rtyp=IDEAL_CMD;
670	save_r=IDMAP(w)->preimage;
671	IDMAP(w)->preimage=0;
672	}
673	tmpW.data=IDDATA(w);
674	// check overflow
675	BOOLEAN overflow=FALSE;
676	if ((tmpW.rtyp==IDEAL_CMD)
677	\|\| (tmpW.rtyp==MODUL_CMD)
678	\|\| (tmpW.rtyp==MAP_CMD))
679	{
680	ideal id=(ideal)tmpW.data;
681	for(int j=IDELEMS(theMap)-1;j>=0 && !overflow;j--)
682	{
683	if (theMap->m[j]!=NULL)
684	{
685	long deg_monexp=pTotaldegree(theMap->m[j]);
686	for(int i=IDELEMS(id)-1;i>=0;i--)
687	{
688	poly p=id->m[i];
689	if ((p!=NULL) && (p_Totaldegree(p,src_ring)!=0) &&
690	((unsigned long)deg_monexp > (currRing->bitmask / (unsigned long)p_Totaldegree(p,src_ring)/2)))
691	{
692	overflow=TRUE;
693	break;
694	}
695	}
696	}
697	}
698	}
699	else if (tmpW.rtyp==POLY_CMD)
700	{
701	for(int j=IDELEMS(theMap)-1;j>=0 && !overflow;j--)
702	{
703	if (theMap->m[j]!=NULL)
704	{
705	long deg_monexp=pTotaldegree(theMap->m[j]);
706	poly p=(poly)tmpW.data;
707	if ((p!=NULL) && (p_Totaldegree(p,src_ring)!=0) &&
708	((unsigned long)deg_monexp > (currRing->bitmask / (unsigned long)p_Totaldegree(p,src_ring)/2)))
709	{
710	overflow=TRUE;
711	break;
712	}
713	}
714	}
715	}
716	if (overflow)
717	Warn("possible OVERFLOW in map, max exponent is %ld",currRing->bitmask/2);
718	#if 0
719	if (((tmpW.rtyp==IDEAL_CMD)\|\|(tmpW.rtyp==MODUL_CMD)) && idIs0(IDIDEAL(w)))
720	{
721	v->rtyp=tmpW.rtyp;
722	v->data=idInit(IDELEMS(IDIDEAL(w)),IDIDEAL(w)->rank);
723	}
724	else
725	#endif
726	{
727	#ifdef FAST_MAP
728	if ((tmpW.rtyp==IDEAL_CMD) && (nMap == ndCopyMap)
729	#ifdef HAVE_PLURAL
730	&& (!rIsPluralRing(currRing))
731	#endif
732	)
733	{
734	v->rtyp=IDEAL_CMD;
735	char *tmp = theMap->preimage;
736	theMap->preimage=(char*)1L;
737	// map gets 1 as its rank (as an ideal)
738	v->data=fast_map(IDIDEAL(w), src_ring, (ideal)theMap, currRing);
739	theMap->preimage=tmp; // map gets its preimage back
740	}
741	#endif
742	if (v->data==NULL)
743	{
744	if (maApplyFetch(MAP_CMD,theMap,v,&tmpW,src_ring,NULL,NULL,0,nMap))
745	{
746	Werror("cannot map %s(%d)",Tok2Cmdname(w->typ),w->typ);
747	omFreeBin((ADDRESS)v, sleftv_bin);
748	if (save_r!=NULL) IDMAP(w)->preimage=save_r;
749	return NULL;
750	}
751	}
752	}
753	if (save_r!=NULL)
754	{
755	IDMAP(w)->preimage=save_r;
756	IDMAP((idhdl)v)->preimage=omStrDup(save_r);
757	v->rtyp=MAP_CMD;
758	}
759	return v;
760	}
761	else
762	{
763	Werror("%s undefined in %s",what,theMap->preimage);
764	}
765	}
766	else
767	{
768	Werror("cannot find preimage %s",theMap->preimage);
769	}
770	return NULL;
771	}
772
773	#ifdef OLD_RES
774	void iiMakeResolv(resolvente r, int length, int rlen, char * name, int typ0,
775	intvec ** weights)
776	{
777	lists L=liMakeResolv(r,length,rlen,typ0,weights);
778	int i=0;
779	idhdl h;
780	char * s=(char *)omAlloc(strlen(name)+5);
781
782	while (i<=L->nr)
783	{
784	sprintf(s,"%s(%d)",name,i+1);
785	if (i==0)
786	h=enterid(s,myynest,typ0,&(currRing->idroot), FALSE);
787	else
788	h=enterid(s,myynest,MODUL_CMD,&(currRing->idroot), FALSE);
789	if (h!=NULL)
790	{
791	h->data.uideal=(ideal)L->m[i].data;
792	h->attribute=L->m[i].attribute;
793	if (BVERBOSE(V_DEF_RES))
794	Print("//defining: %s as %d-th syzygy module\n",s,i+1);
795	}
796	else
797	{
798	idDelete((ideal *)&(L->m[i].data));
799	Warn("cannot define %s",s);
800	}
801	//L->m[i].data=NULL;
802	//L->m[i].rtyp=0;
803	//L->m[i].attribute=NULL;
804	i++;
805	}
806	omFreeSize((ADDRESS)L->m,(L->nr+1)*sizeof(sleftv));
807	omFreeBin((ADDRESS)L, slists_bin);
808	omFreeSize((ADDRESS)s,strlen(name)+5);
809	}
810	#endif
811
812	//resolvente iiFindRes(char * name, int * len, int *typ0)
813	//{
814	// char s=(char )omAlloc(strlen(name)+5);
815	// int i=-1;
816	// resolvente r;
817	// idhdl h;
818	//
819	// do
820	// {
821	// i++;
822	// sprintf(s,"%s(%d)",name,i+1);
823	// h=currRing->idroot->get(s,myynest);
824	// } while (h!=NULL);
825	// *len=i-1;
826	// if (*len<=0)
827	// {
828	// Werror("no objects %s(1),.. found",name);
829	// omFreeSize((ADDRESS)s,strlen(name)+5);
830	// return NULL;
831	// }
832	// r=(ideal )omAlloc(/(len+1)/ isizeof(ideal));
833	// memset(r,0,(len)sizeof(ideal));
834	// i=-1;
835	// *typ0=MODUL_CMD;
836	// while (i<(*len))
837	// {
838	// i++;
839	// sprintf(s,"%s(%d)",name,i+1);
840	// h=currRing->idroot->get(s,myynest);
841	// if (h->typ != MODUL_CMD)
842	// {
843	// if ((i!=0) \|\| (h->typ!=IDEAL_CMD))
844	// {
845	// Werror("%s is not of type module",s);
846	// omFreeSize((ADDRESS)r,(len)sizeof(ideal));
847	// omFreeSize((ADDRESS)s,strlen(name)+5);
848	// return NULL;
849	// }
850	// *typ0=IDEAL_CMD;
851	// }
852	// if ((i>0) && (idIs0(r[i-1])))
853	// {
854	// *len=i-1;
855	// break;
856	// }
857	// r[i]=IDIDEAL(h);
858	// }
859	// omFreeSize((ADDRESS)s,strlen(name)+5);
860	// return r;
861	//}
862
863	static resolvente iiCopyRes(resolvente r, int l)
864	{
865	int i;
866	resolvente res=(ideal )omAlloc0((l+1)sizeof(ideal));
867
868	for (i=0; i<l; i++)
869	if (r[i]!=NULL) res[i]=idCopy(r[i]);
870	return res;
871	}
872
873	BOOLEAN jjMINRES(leftv res, leftv v)
874	{
875	int len=0;
876	int typ0;
877	lists L=(lists)v->Data();
878	intvec weights=(intvec)atGet(v,"isHomog",INTVEC_CMD);
879	int add_row_shift = 0;
880	if (weights==NULL)
881	weights=(intvec*)atGet(&(L->m[0]),"isHomog",INTVEC_CMD);
882	if (weights!=NULL) add_row_shift=weights->min_in();
883	resolvente rr=liFindRes(L,&len,&typ0);
884	if (rr==NULL) return TRUE;
885	resolvente r=iiCopyRes(rr,len);
886
887	syMinimizeResolvente(r,len,0);
888	omFreeSize((ADDRESS)rr,len*sizeof(ideal));
889	len++;
890	res->data=(char *)liMakeResolv(r,len,-1,typ0,NULL,add_row_shift);
891	return FALSE;
892	}
893
894	BOOLEAN jjBETTI(leftv res, leftv u)
895	{
896	sleftv tmp;
897	memset(&tmp,0,sizeof(tmp));
898	tmp.rtyp=INT_CMD;
899	tmp.data=(void *)1;
900	if ((u->Typ()==IDEAL_CMD)
901	\|\| (u->Typ()==MODUL_CMD))
902	return jjBETTI2_ID(res,u,&tmp);
903	else
904	return jjBETTI2(res,u,&tmp);
905	}
906
907	BOOLEAN jjBETTI2_ID(leftv res, leftv u, leftv v)
908	{
909	lists l=(lists) omAllocBin(slists_bin);
910	l->Init(1);
911	l->m[0].rtyp=u->Typ();
912	l->m[0].data=u->Data();
913	attr *a=u->Attribute();
914	if (a!=NULL)
915	l->m[0].attribute=*a;
916	sleftv tmp2;
917	memset(&tmp2,0,sizeof(tmp2));
918	tmp2.rtyp=LIST_CMD;
919	tmp2.data=(void *)l;
920	BOOLEAN r=jjBETTI2(res,&tmp2,v);
921	l->m[0].data=NULL;
922	l->m[0].attribute=NULL;
923	l->m[0].rtyp=DEF_CMD;
924	l->Clean();
925	return r;
926	}
927
928	BOOLEAN jjBETTI2(leftv res, leftv u, leftv v)
929	{
930	resolvente r;
931	int len;
932	int reg,typ0;
933	lists l=(lists)u->Data();
934
935	intvec *weights=NULL;
936	int add_row_shift=0;
937	intvec ww=(intvec )atGet(&(l->m[0]),"isHomog",INTVEC_CMD);
938	if (ww!=NULL)
939	{
940	weights=ivCopy(ww);
941	add_row_shift = ww->min_in();
942	(*weights) -= add_row_shift;
943	}
944	//Print("attr:%x\n",weights);
945
946	r=liFindRes(l,&len,&typ0);
947	if (r==NULL) return TRUE;
948	res->data=(char *)syBetti(r,len,&reg,weights,(int)(long)v->Data());
949	omFreeSize((ADDRESS)r,(len)*sizeof(ideal));
950	atSet(res,omStrDup("rowShift"),(void*)(long)add_row_shift,INT_CMD);
951	if (weights!=NULL) delete weights;
952	return FALSE;
953	}
954
955	int iiRegularity(lists L)
956	{
957	int len,reg,typ0;
958
959	resolvente r=liFindRes(L,&len,&typ0);
960
961	if (r==NULL)
962	return -2;
963	intvec *weights=NULL;
964	int add_row_shift=0;
965	intvec ww=(intvec )atGet(&(L->m[0]),"isHomog",INTVEC_CMD);
966	if (ww!=NULL)
967	{
968	weights=ivCopy(ww);
969	add_row_shift = ww->min_in();
970	(*weights) -= add_row_shift;
971	}
972	//Print("attr:%x\n",weights);
973
974	intvec *dummy=syBetti(r,len,&reg,weights);
975	if (weights!=NULL) delete weights;
976	delete dummy;
977	omFreeSize((ADDRESS)r,len*sizeof(ideal));
978	return reg+1+add_row_shift;
979	}
980
981	BOOLEAN iiDebugMarker=TRUE;
982	#define BREAK_LINE_LENGTH 80
983	void iiDebug()
984	{
985	#ifdef HAVE_SDB
986	sdb_flags=1;
987	#endif
988	Print("\n-- break point in %s --\n",VoiceName());
989	if (iiDebugMarker) VoiceBackTrack();
990	char * s;
991	iiDebugMarker=FALSE;
992	s = (char *)omAlloc(BREAK_LINE_LENGTH+4);
993	loop
994	{
995	memset(s,0,80);
996	fe_fgets_stdin("",s,BREAK_LINE_LENGTH);
997	if (s[BREAK_LINE_LENGTH-1]!='\0')
998	{
999	Print("line too long, max is %d chars\n",BREAK_LINE_LENGTH);
1000	}
1001	else
1002	break;
1003	}
1004	if (*s=='\n')
1005	{
1006	iiDebugMarker=TRUE;
1007	}
1008	#if MDEBUG
1009	else if(strncmp(s,"cont;",5)==0)
1010	{
1011	iiDebugMarker=TRUE;
1012	}
1013	#endif /* MDEBUG */
1014	else
1015	{
1016	strcat( s, "\n;~\n");
1017	newBuffer(s,BT_execute);
1018	}
1019	}
1020
1021	lists scIndIndset(ideal S, BOOLEAN all, ideal Q)
1022	{
1023	int i;
1024	indset save;
1025	lists res=(lists)omAlloc0Bin(slists_bin);
1026
1027	hexist = hInit(S, Q, &hNexist, currRing);
1028	if (hNexist == 0)
1029	{
1030	intvec *iv=new intvec(rVar(currRing));
1031	for(i=0; i<rVar(currRing); i++) (*iv)[i]=1;
1032	res->Init(1);
1033	res->m[0].rtyp=INTVEC_CMD;
1034	res->m[0].data=(intvec*)iv;
1035	return res;
1036	}
1037	else if (hisModule!=0)
1038	{
1039	res->Init(0);
1040	return res;
1041	}
1042	save = ISet = (indset)omAlloc0Bin(indlist_bin);
1043	hMu = 0;
1044	hwork = (scfmon)omAlloc(hNexist * sizeof(scmon));
1045	hvar = (varset)omAlloc((rVar(currRing) + 1) * sizeof(int));
1046	hpure = (scmon)omAlloc((1 + (rVar(currRing) * rVar(currRing))) * sizeof(long));
1047	hrad = hexist;
1048	hNrad = hNexist;
1049	radmem = hCreate(rVar(currRing) - 1);
1050	hCo = rVar(currRing) + 1;
1051	hNvar = rVar(currRing);
1052	hRadical(hrad, &hNrad, hNvar);
1053	hSupp(hrad, hNrad, hvar, &hNvar);
1054	if (hNvar)
1055	{
1056	hCo = hNvar;
1057	memset(hpure, 0, (rVar(currRing) + 1) * sizeof(long));
1058	hPure(hrad, 0, &hNrad, hvar, hNvar, hpure, &hNpure);
1059	hLexR(hrad, hNrad, hvar, hNvar);
1060	hDimSolve(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1061	}
1062	if (hCo && (hCo < rVar(currRing)))
1063	{
1064	hIndMult(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1065	}
1066	if (hMu!=0)
1067	{
1068	ISet = save;
1069	hMu2 = 0;
1070	if (all && (hCo+1 < rVar(currRing)))
1071	{
1072	JSet = (indset)omAlloc0Bin(indlist_bin);
1073	hIndAllMult(hpure, hNpure, hrad, hNrad, hvar, hNvar);
1074	i=hMu+hMu2;
1075	res->Init(i);
1076	if (hMu2 == 0)
1077	{
1078	omFreeBin((ADDRESS)JSet, indlist_bin);
1079	}
1080	}
1081	else
1082	{
1083	res->Init(hMu);
1084	}
1085	for (i=0;i<hMu;i++)
1086	{
1087	res->m[i].data = (void *)save->set;
1088	res->m[i].rtyp = INTVEC_CMD;
1089	ISet = save;
1090	save = save->nx;
1091	omFreeBin((ADDRESS)ISet, indlist_bin);
1092	}
1093	omFreeBin((ADDRESS)save, indlist_bin);
1094	if (hMu2 != 0)
1095	{
1096	save = JSet;
1097	for (i=hMu;i<hMu+hMu2;i++)
1098	{
1099	res->m[i].data = (void *)save->set;
1100	res->m[i].rtyp = INTVEC_CMD;
1101	JSet = save;
1102	save = save->nx;
1103	omFreeBin((ADDRESS)JSet, indlist_bin);
1104	}
1105	omFreeBin((ADDRESS)save, indlist_bin);
1106	}
1107	}
1108	else
1109	{
1110	res->Init(0);
1111	omFreeBin((ADDRESS)ISet, indlist_bin);
1112	}
1113	hKill(radmem, rVar(currRing) - 1);
1114	omFreeSize((ADDRESS)hpure, (1 + (rVar(currRing) * rVar(currRing))) * sizeof(long));
1115	omFreeSize((ADDRESS)hvar, (rVar(currRing) + 1) * sizeof(int));
1116	omFreeSize((ADDRESS)hwork, hNexist * sizeof(scmon));
1117	hDelete(hexist, hNexist);
1118	return res;
1119	}
1120
1121	int iiDeclCommand(leftv sy, leftv name, int lev,int t, idhdl* root,BOOLEAN isring, BOOLEAN init_b)
1122	{
1123	BOOLEAN res=FALSE;
1124	const char *id = name->name;
1125
1126	memset(sy,0,sizeof(sleftv));
1127	if ((name->name==NULL)\|\|(isdigit(name->name[0])))
1128	{
1129	WerrorS("object to declare is not a name");
1130	res=TRUE;
1131	}
1132	else
1133	{
1134	if (TEST_V_ALLWARN
1135	&& (name->rtyp!=0)
1136	&& (name->rtyp!=IDHDL)
1137	&& (currRingHdl!=NULL) && (IDLEV(currRingHdl)==myynest))
1138	{
1139	Warn("`%s` is %s in %s:%d:%s",name->name,Tok2Cmdname(name->rtyp),
1140	currentVoice->filename,yylineno,my_yylinebuf);
1141	}
1142	{
1143	sy->data = (char *)enterid(id,lev,t,root,init_b);
1144	}
1145	if (sy->data!=NULL)
1146	{
1147	sy->rtyp=IDHDL;
1148	currid=sy->name=IDID((idhdl)sy->data);
1149	// name->name=NULL; /* used in enterid */
1150	//sy->e = NULL;
1151	if (name->next!=NULL)
1152	{
1153	sy->next=(leftv)omAllocBin(sleftv_bin);
1154	res=iiDeclCommand(sy->next,name->next,lev,t,root, isring);
1155	}
1156	}
1157	else res=TRUE;
1158	}
1159	name->CleanUp();
1160	return res;
1161	}
1162
1163	BOOLEAN iiDefaultParameter(leftv p)
1164	{
1165	attr at=NULL;
1166	if (iiCurrProc!=NULL)
1167	at=iiCurrProc->attribute->get("default_arg");
1168	if (at==NULL)
1169	return FALSE;
1170	sleftv tmp;
1171	memset(&tmp,0,sizeof(sleftv));
1172	tmp.rtyp=at->atyp;
1173	tmp.data=at->CopyA();
1174	return iiAssign(p,&tmp);
1175	}
1176	BOOLEAN iiBranchTo(leftv r, leftv args)
1177	{
1178	// <string1...stringN>,<proc>
1179	// known: args!=NULL, l>=1
1180	int l=args->listLength();
1181	int ll=0;
1182	if (iiCurrArgs!=NULL) ll=iiCurrArgs->listLength();
1183	if (ll!=(l-1)) return FALSE;
1184	leftv h=args;
1185	short t=(short)omAlloc(l*sizeof(short));
1186	t[0]=l-1;
1187	int b;
1188	int i;
1189	for(i=1;i<l;i++,h=h->next)
1190	{
1191	if (h->Typ()!=STRING_CMD)
1192	{
1193	omFree(t);
1194	Werror("arg %d is not a string",i);
1195	return TRUE;
1196	}
1197	int tt;
1198	b=IsCmd((char *)h->Data(),tt);
1199	if(b) t[i]=tt;
1200	else
1201	{
1202	omFree(t);
1203	Werror("arg %d is not a type name",i);
1204	return TRUE;
1205	}
1206	}
1207	if (h->Typ()!=PROC_CMD)
1208	{
1209	omFree(t);
1210	Werror("last arg (%d) is not a proc",i);
1211	return TRUE;
1212	}
1213	b=iiCheckTypes(iiCurrArgs,t,0);
1214	omFree(t);
1215	if (b && (h->rtyp==IDHDL) && (h->e==NULL))
1216	{
1217	BOOLEAN err;
1218	//Print("branchTo: %s\n",h->Name());
1219	iiCurrProc=(idhdl)h->data;
1220	procinfo * pi=IDPROC(iiCurrProc);
1221	if( pi->data.s.body==NULL )
1222	{
1223	iiGetLibProcBuffer(pi);
1224	if (pi->data.s.body==NULL) return TRUE;
1225	}
1226	if ((pi->pack!=NULL)&&(currPack!=pi->pack))
1227	{
1228	currPack=pi->pack;
1229	iiCheckPack(currPack);
1230	currPackHdl=packFindHdl(currPack);
1231	//Print("set pack=%s\n",IDID(currPackHdl));
1232	}
1233	err=iiAllStart(pi,pi->data.s.body,BT_proc,pi->data.s.body_lineno-(iiCurrArgs==NULL));
1234	exitBuffer(BT_proc);
1235	if (iiCurrArgs!=NULL)
1236	{
1237	if (!err) Warn("too many arguments for %s",IDID(iiCurrProc));
1238	iiCurrArgs->CleanUp();
1239	omFreeBin((ADDRESS)iiCurrArgs, sleftv_bin);
1240	iiCurrArgs=NULL;
1241	}
1242	return 2-err;
1243	}
1244	return FALSE;
1245	}
1246	BOOLEAN iiParameter(leftv p)
1247	{
1248	if (iiCurrArgs==NULL)
1249	{
1250	if (strcmp(p->name,"#")==0)
1251	return iiDefaultParameter(p);
1252	Werror("not enough arguments for proc %s",VoiceName());
1253	p->CleanUp();
1254	return TRUE;
1255	}
1256	leftv h=iiCurrArgs;
1257	leftv rest=h->next; /iiCurrArgs is not NULL here/
1258	BOOLEAN is_default_list=FALSE;
1259	if (strcmp(p->name,"#")==0)
1260	{
1261	is_default_list=TRUE;
1262	rest=NULL;
1263	}
1264	else
1265	{
1266	h->next=NULL;
1267	}
1268	BOOLEAN res=iiAssign(p,h);
1269	if (is_default_list)
1270	{
1271	iiCurrArgs=NULL;
1272	}
1273	else
1274	{
1275	iiCurrArgs=rest;
1276	}
1277	h->CleanUp();
1278	omFreeBin((ADDRESS)h, sleftv_bin);
1279	return res;
1280	}
1281
1282	static BOOLEAN iiInternalExport (leftv v, int toLev)
1283	{
1284	idhdl h=(idhdl)v->data;
1285	//Print("iiInternalExport('%s',%d)%s\n", v->name, toLev,"");
1286	if (IDLEV(h)==0)
1287	{
1288	if (BVERBOSE(V_REDEFINE)) Warn("`%s` is already global",IDID(h));
1289	}
1290	else
1291	{
1292	h=IDROOT->get(v->name,toLev);
1293	idhdl *root=&IDROOT;
1294	if ((h==NULL)&&(currRing!=NULL))
1295	{
1296	h=currRing->idroot->get(v->name,toLev);
1297	root=&currRing->idroot;
1298	}
1299	BOOLEAN keepring=FALSE;
1300	if ((h!=NULL)&&(IDLEV(h)==toLev))
1301	{
1302	if (IDTYP(h)==v->Typ())
1303	{
1304	if (((IDTYP(h)==RING_CMD)\|\|(IDTYP(h)==QRING_CMD))
1305	&& (v->Data()==IDDATA(h)))
1306	{
1307	IDRING(h)->ref++;
1308	keepring=TRUE;
1309	IDLEV(h)=toLev;
1310	//WarnS("keepring");
1311	return FALSE;
1312	}
1313	if (BVERBOSE(V_REDEFINE))
1314	{
1315	Warn("redefining %s",IDID(h));
1316	}
1317	#ifdef USE_IILOCALRING
1318	if (iiLocalRing[0]==IDRING(h) && (!keepring)) iiLocalRing[0]=NULL;
1319	#else
1320	proclevel *p=procstack;
1321	while (p->next!=NULL) p=p->next;
1322	if ((p->cRing==IDRING(h)) && (!keepring))
1323	{
1324	p->cRing=NULL;
1325	p->cRingHdl=NULL;
1326	}
1327	#endif
1328	killhdl2(h,root,currRing);
1329	}
1330	else
1331	{
1332	return TRUE;
1333	}
1334	}
1335	h=(idhdl)v->data;
1336	IDLEV(h)=toLev;
1337	if (keepring) IDRING(h)->ref--;
1338	iiNoKeepRing=FALSE;
1339	//Print("export %s\n",IDID(h));
1340	}
1341	return FALSE;
1342	}
1343
1344	BOOLEAN iiInternalExport (leftv v, int toLev, package rootpack)
1345	{
1346	idhdl h=(idhdl)v->data;
1347	if(h==NULL)
1348	{
1349	Warn("'%s': no such identifier\n", v->name);
1350	return FALSE;
1351	}
1352	package frompack=v->req_packhdl;
1353	if (frompack==NULL) frompack=currPack;
1354	if ((RingDependend(IDTYP(h)))
1355	\|\| ((IDTYP(h)==LIST_CMD)
1356	&& (lRingDependend(IDLIST(h)))
1357	)
1358	)
1359	{
1360	//Print("// ==> Ringdependent set nesting to 0\n");
1361	return (iiInternalExport(v, toLev));
1362	}
1363	else
1364	{
1365	IDLEV(h)=toLev;
1366	v->req_packhdl=rootpack;
1367	if (h==frompack->idroot)
1368	{
1369	frompack->idroot=h->next;
1370	}
1371	else
1372	{
1373	idhdl hh=frompack->idroot;
1374	while ((hh!=NULL) && (hh->next!=h))
1375	hh=hh->next;
1376	if ((hh!=NULL) && (hh->next==h))
1377	hh->next=h->next;
1378	else
1379	{
1380	Werror("`%s` not found",v->Name());
1381	return TRUE;
1382	}
1383	}
1384	h->next=rootpack->idroot;
1385	rootpack->idroot=h;
1386	}
1387	return FALSE;
1388	}
1389
1390	BOOLEAN iiExport (leftv v, int toLev)
1391	{
1392	BOOLEAN nok=FALSE;
1393	leftv r=v;
1394	while (v!=NULL)
1395	{
1396	if ((v->name==NULL)\|\|(v->rtyp==0)\|\|(v->e!=NULL))
1397	{
1398	Werror("cannot export:%s of internal type %d",v->name,v->rtyp);
1399	nok=TRUE;
1400	}
1401	else
1402	{
1403	if(iiInternalExport(v, toLev))
1404	{
1405	r->CleanUp();
1406	return TRUE;
1407	}
1408	}
1409	v=v->next;
1410	}
1411	r->CleanUp();
1412	return nok;
1413	}
1414
1415	/assume root!=idroot/
1416	BOOLEAN iiExport (leftv v, int toLev, package pack)
1417	{
1418	#ifdef SINGULAR_4_1
1419	if ((pack==basePack)&&(pack!=currPack))
1420	{ Warn("'exportto' to Top is depreciated in >>%s<<",my_yylinebuf);}
1421	#endif
1422	BOOLEAN nok=FALSE;
1423	leftv rv=v;
1424	while (v!=NULL)
1425	{
1426	if ((v->name==NULL)\|\|(v->rtyp==0)\|\|(v->e!=NULL)
1427	)
1428	{
1429	Werror("cannot export:%s of internal type %d",v->name,v->rtyp);
1430	nok=TRUE;
1431	}
1432	else
1433	{
1434	idhdl old=pack->idroot->get( v->name,toLev);
1435	if (old!=NULL)
1436	{
1437	if ((pack==currPack) && (old==(idhdl)v->data))
1438	{
1439	if (BVERBOSE(V_REDEFINE)) Warn("`%s` is already global",IDID(old));
1440	break;
1441	}
1442	else if (IDTYP(old)==v->Typ())
1443	{
1444	if (BVERBOSE(V_REDEFINE))
1445	{
1446	Warn("redefining %s",IDID(old));
1447	}
1448	v->name=omStrDup(v->name);
1449	killhdl2(old,&(pack->idroot),currRing);
1450	}
1451	else
1452	{
1453	rv->CleanUp();
1454	return TRUE;
1455	}
1456	}
1457	//Print("iiExport: pack=%s\n",IDID(root));
1458	if(iiInternalExport(v, toLev, pack))
1459	{
1460	rv->CleanUp();
1461	return TRUE;
1462	}
1463	}
1464	v=v->next;
1465	}
1466	rv->CleanUp();
1467	return nok;
1468	}
1469
1470	BOOLEAN iiCheckRing(int i)
1471	{
1472	if (currRing==NULL)
1473	{
1474	#ifdef SIQ
1475	if (siq<=0)
1476	{
1477	#endif
1478	if (RingDependend(i))
1479	{
1480	WerrorS("no ring active");
1481	return TRUE;
1482	}
1483	#ifdef SIQ
1484	}
1485	#endif
1486	}
1487	return FALSE;
1488	}
1489
1490	poly iiHighCorner(ideal I, int ak)
1491	{
1492	int i;
1493	if(!idIsZeroDim(I)) return NULL; // not zero-dim.
1494	poly po=NULL;
1495	if (rHasLocalOrMixedOrdering_currRing())
1496	{
1497	scComputeHC(I,currRing->qideal,ak,po);
1498	if (po!=NULL)
1499	{
1500	pGetCoeff(po)=nInit(1);
1501	for (i=rVar(currRing); i>0; i--)
1502	{
1503	if (pGetExp(po, i) > 0) pDecrExp(po,i);
1504	}
1505	pSetComp(po,ak);
1506	pSetm(po);
1507	}
1508	}
1509	else
1510	po=pOne();
1511	return po;
1512	}
1513
1514	void iiCheckPack(package &p)
1515	{
1516	if (p==basePack) return;
1517
1518	idhdl t=basePack->idroot;
1519
1520	while ((t!=NULL) && (IDTYP(t)!=PACKAGE_CMD) && (IDPACKAGE(t)!=p)) t=t->next;
1521
1522	if (t==NULL)
1523	{
1524	WarnS("package not found\n");
1525	p=basePack;
1526	}
1527	return;
1528	}
1529
1530	idhdl rDefault(const char *s)
1531	{
1532	idhdl tmp=NULL;
1533
1534	if (s!=NULL) tmp = enterid(s, myynest, RING_CMD, &IDROOT);
1535	if (tmp==NULL) return NULL;
1536
1537	// if ((currRing->ppNoether)!=NULL) pDelete(&(currRing->ppNoether));
1538	if (sLastPrinted.RingDependend())
1539	{
1540	sLastPrinted.CleanUp();
1541	memset(&sLastPrinted,0,sizeof(sleftv));
1542	}
1543
1544	ring r = IDRING(tmp);
1545
1546	r->cf = nInitChar(n_Zp, (void*)32003); // r->cf->ch = 32003;
1547	r->N = 3;
1548	/r->P = 0; Alloc0 in idhdl::set, ipid.cc/
1549	/names/
1550	r->names = (char *) omAlloc0(3 sizeof(char_ptr));
1551	r->names[0] = omStrDup("x");
1552	r->names[1] = omStrDup("y");
1553	r->names[2] = omStrDup("z");
1554	/weights: entries for 3 blocks: NULL/
1555	r->wvhdl = (int *)omAlloc0(3 sizeof(int_ptr));
1556	/order: dp,C,0/
1557	r->order = (int ) omAlloc(3 sizeof(int *));
1558	r->block0 = (int )omAlloc0(3 sizeof(int *));
1559	r->block1 = (int )omAlloc0(3 sizeof(int *));
1560	/* ringorder dp for the first block: var 1..3 */
1561	r->order[0] = ringorder_dp;
1562	r->block0[0] = 1;
1563	r->block1[0] = 3;
1564	/* ringorder C for the second block: no vars */
1565	r->order[1] = ringorder_C;
1566	/* the last block: everything is 0 */
1567	r->order[2] = 0;
1568
1569	/* complete ring intializations */
1570	rComplete(r);
1571	rSetHdl(tmp);
1572	return currRingHdl;
1573	}
1574
1575	idhdl rFindHdl(ring r, idhdl n)
1576	{
1577	idhdl h=rSimpleFindHdl(r,IDROOT,n);
1578	if (h!=NULL) return h;
1579	if (IDROOT!=basePack->idroot) h=rSimpleFindHdl(r,basePack->idroot,n);
1580	if (h!=NULL) return h;
1581	proclevel *p=procstack;
1582	while(p!=NULL)
1583	{
1584	if ((p->cPack!=basePack)
1585	&& (p->cPack!=currPack))
1586	h=rSimpleFindHdl(r,p->cPack->idroot,n);
1587	if (h!=NULL) return h;
1588	p=p->next;
1589	}
1590	idhdl tmp=basePack->idroot;
1591	while (tmp!=NULL)
1592	{
1593	if (IDTYP(tmp)==PACKAGE_CMD)
1594	h=rSimpleFindHdl(r,IDPACKAGE(tmp)->idroot,n);
1595	if (h!=NULL) return h;
1596	tmp=IDNEXT(tmp);
1597	}
1598	return NULL;
1599	}
1600
1601	void rDecomposeCF(leftv h,const ring r,const ring R)
1602	{
1603	lists L=(lists)omAlloc0Bin(slists_bin);
1604	L->Init(4);
1605	h->rtyp=LIST_CMD;
1606	h->data=(void *)L;
1607	// 0: char/ cf - ring
1608	// 1: list (var)
1609	// 2: list (ord)
1610	// 3: qideal
1611	// ----------------------------------------
1612	// 0: char/ cf - ring
1613	L->m[0].rtyp=INT_CMD;
1614	L->m[0].data=(void *)(long)r->cf->ch;
1615	// ----------------------------------------
1616	// 1: list (var)
1617	lists LL=(lists)omAlloc0Bin(slists_bin);
1618	LL->Init(r->N);
1619	int i;
1620	for(i=0; i<r->N; i++)
1621	{
1622	LL->m[i].rtyp=STRING_CMD;
1623	LL->m[i].data=(void *)omStrDup(r->names[i]);
1624	}
1625	L->m[1].rtyp=LIST_CMD;
1626	L->m[1].data=(void *)LL;
1627	// ----------------------------------------
1628	// 2: list (ord)
1629	LL=(lists)omAlloc0Bin(slists_bin);
1630	i=rBlocks(r)-1;
1631	LL->Init(i);
1632	i--;
1633	lists LLL;
1634	for(; i>=0; i--)
1635	{
1636	intvec *iv;
1637	int j;
1638	LL->m[i].rtyp=LIST_CMD;
1639	LLL=(lists)omAlloc0Bin(slists_bin);
1640	LLL->Init(2);
1641	LLL->m[0].rtyp=STRING_CMD;
1642	LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
1643	if (r->block1[i]-r->block0[i] >=0 )
1644	{
1645	j=r->block1[i]-r->block0[i];
1646	if(r->order[i]==ringorder_M) j=(j+1)*(j+1)-1;
1647	iv=new intvec(j+1);
1648	if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
1649	{
1650	for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j];
1651	}
1652	else switch (r->order[i])
1653	{
1654	case ringorder_dp:
1655	case ringorder_Dp:
1656	case ringorder_ds:
1657	case ringorder_Ds:
1658	case ringorder_lp:
1659	for(;j>=0; j--) (*iv)[j]=1;
1660	break;
1661	default: /* do nothing */;
1662	}
1663	}
1664	else
1665	{
1666	iv=new intvec(1);
1667	}
1668	LLL->m[1].rtyp=INTVEC_CMD;
1669	LLL->m[1].data=(void *)iv;
1670	LL->m[i].data=(void *)LLL;
1671	}
1672	L->m[2].rtyp=LIST_CMD;
1673	L->m[2].data=(void *)LL;
1674	// ----------------------------------------
1675	// 3: qideal
1676	L->m[3].rtyp=IDEAL_CMD;
1677	if (nCoeff_is_transExt(R->cf))
1678	L->m[3].data=(void *)idInit(1,1);
1679	else
1680	{
1681	ideal q=idInit(IDELEMS(r->qideal));
1682	q->m[0]=p_Init(R);
1683	pSetCoeff0(q->m[0],(number)(r->qideal->m[0]));
1684	L->m[3].data=(void *)q;
1685	// I->m[0] = pNSet(R->minpoly);
1686	}
1687	// ----------------------------------------
1688	}
1689	#ifdef SINGULAR_4_1
1690	static void rDecomposeC(leftv h,const coeffs C)
1691	/* field is R or C */
1692	{
1693	lists L=(lists)omAlloc0Bin(slists_bin);
1694	if (nCoeff_is_long_C(C)) L->Init(3);
1695	else L->Init(2);
1696	h->rtyp=LIST_CMD;
1697	h->data=(void *)L;
1698	// 0: char/ cf - ring
1699	// 1: list (var)
1700	// 2: list (ord)
1701	// ----------------------------------------
1702	// 0: char/ cf - ring
1703	L->m[0].rtyp=INT_CMD;
1704	L->m[0].data=(void *)0;
1705	// ----------------------------------------
1706	// 1:
1707	lists LL=(lists)omAlloc0Bin(slists_bin);
1708	LL->Init(2);
1709	LL->m[0].rtyp=INT_CMD;
1710	LL->m[0].data=(void *)(long)si_max(C->float_len,SHORT_REAL_LENGTH/2);
1711	LL->m[1].rtyp=INT_CMD;
1712	LL->m[1].data=(void *)(long)si_max(C->float_len2,SHORT_REAL_LENGTH);
1713	L->m[1].rtyp=LIST_CMD;
1714	L->m[1].data=(void *)LL;
1715	// ----------------------------------------
1716	// 2: list (par)
1717	if (nCoeff_is_long_C(C))
1718	{
1719	L->m[2].rtyp=STRING_CMD;
1720	L->m[2].data=(void )omStrDup(n_ParameterNames(C));
1721	}
1722	// ----------------------------------------
1723	}
1724	#else
1725	static void rDecomposeC(leftv h,const ring R)
1726	/* field is R or C */
1727	{
1728	lists L=(lists)omAlloc0Bin(slists_bin);
1729	if (rField_is_long_C(R)) L->Init(3);
1730	else L->Init(2);
1731	h->rtyp=LIST_CMD;
1732	h->data=(void *)L;
1733	// 0: char/ cf - ring
1734	// 1: list (var)
1735	// 2: list (ord)
1736	// ----------------------------------------
1737	// 0: char/ cf - ring
1738	L->m[0].rtyp=INT_CMD;
1739	L->m[0].data=(void *)0;
1740	// ----------------------------------------
1741	// 1:
1742	lists LL=(lists)omAlloc0Bin(slists_bin);
1743	LL->Init(2);
1744	LL->m[0].rtyp=INT_CMD;
1745	LL->m[0].data=(void *)(long)si_max(R->cf->float_len,SHORT_REAL_LENGTH/2);
1746	LL->m[1].rtyp=INT_CMD;
1747	LL->m[1].data=(void *)(long)si_max(R->cf->float_len2,SHORT_REAL_LENGTH);
1748	L->m[1].rtyp=LIST_CMD;
1749	L->m[1].data=(void *)LL;
1750	// ----------------------------------------
1751	// 2: list (par)
1752	if (rField_is_long_C(R))
1753	{
1754	L->m[2].rtyp=STRING_CMD;
1755	L->m[2].data=(void )omStrDup(rParameter(R));
1756	}
1757	// ----------------------------------------
1758	}
1759	#endif
1760
1761	#ifdef SINGULAR_4_1
1762	#ifdef HAVE_RINGS
1763	void rDecomposeRing(leftv h,const coeffs C)
1764	/* field is R or C */
1765	{
1766	lists L=(lists)omAlloc0Bin(slists_bin);
1767	if (nCoeff_is_Ring(C)) L->Init(1);
1768	else L->Init(2);
1769	h->rtyp=LIST_CMD;
1770	h->data=(void *)L;
1771	// 0: char/ cf - ring
1772	// 1: list (module)
1773	// ----------------------------------------
1774	// 0: char/ cf - ring
1775	L->m[0].rtyp=STRING_CMD;
1776	L->m[0].data=(void *)omStrDup("integer");
1777	// ----------------------------------------
1778	// 1: modulo
1779	if (nCoeff_is_Ring_Z(C)) return;
1780	lists LL=(lists)omAlloc0Bin(slists_bin);
1781	LL->Init(2);
1782	LL->m[0].rtyp=BIGINT_CMD;
1783	LL->m[0].data=nlMapGMP((number) C->modBase, C, coeffs_BIGINT);
1784	LL->m[1].rtyp=INT_CMD;
1785	LL->m[1].data=(void *) C->modExponent;
1786	L->m[1].rtyp=LIST_CMD;
1787	L->m[1].data=(void *)LL;
1788	}
1789	#endif
1790	#else
1791	#ifdef HAVE_RINGS
1792	void rDecomposeRing(leftv h,const ring R)
1793	/* field is R or C */
1794	{
1795	lists L=(lists)omAlloc0Bin(slists_bin);
1796	if (rField_is_Ring_Z(R)) L->Init(1);
1797	else L->Init(2);
1798	h->rtyp=LIST_CMD;
1799	h->data=(void *)L;
1800	// 0: char/ cf - ring
1801	// 1: list (module)
1802	// ----------------------------------------
1803	// 0: char/ cf - ring
1804	L->m[0].rtyp=STRING_CMD;
1805	L->m[0].data=(void *)omStrDup("integer");
1806	// ----------------------------------------
1807	// 1: module
1808	if (rField_is_Ring_Z(R)) return;
1809	lists LL=(lists)omAlloc0Bin(slists_bin);
1810	LL->Init(2);
1811	LL->m[0].rtyp=BIGINT_CMD;
1812	LL->m[0].data=nlMapGMP((number) R->cf->modBase, R->cf, R->cf); // TODO: what is this?? // extern number nlMapGMP(number from, const coeffs src, const coeffs dst); // FIXME: replace with n_InitMPZ(R->cf->modBase, coeffs_BIGINT); ?
1813	LL->m[1].rtyp=INT_CMD;
1814	LL->m[1].data=(void *) R->cf->modExponent;
1815	L->m[1].rtyp=LIST_CMD;
1816	L->m[1].data=(void *)LL;
1817	}
1818	#endif
1819	#endif
1820
1821
1822	#ifdef SINGULAR_4_1
1823	BOOLEAN rDecompose_CF(leftv res,const coeffs C)
1824	{
1825	assume( C != NULL );
1826
1827	// sanity check: require currRing==r for rings with polynomial data
1828	if ( nCoeff_is_algExt(C) && (C != currRing->cf))
1829	{
1830	WerrorS("ring with polynomial data must be the base ring or compatible");
1831	return TRUE;
1832	}
1833	if (nCoeff_is_numeric(C))
1834	{
1835	rDecomposeC(res,C);
1836	}
1837	#ifdef HAVE_RINGS
1838	else if (nCoeff_is_Ring(C))
1839	{
1840	rDecomposeRing(res,C);
1841	}
1842	#endif
1843	else if ( C->extRing!=NULL )// nCoeff_is_algExt(r->cf))
1844	{
1845	rDecomposeCF(res, C->extRing, currRing);
1846	}
1847	else if(nCoeff_is_GF(C))
1848	{
1849	lists Lc=(lists)omAlloc0Bin(slists_bin);
1850	Lc->Init(4);
1851	// char:
1852	Lc->m[0].rtyp=INT_CMD;
1853	Lc->m[0].data=(void*)(long)C->m_nfCharQ;
1854	// var:
1855	lists Lv=(lists)omAlloc0Bin(slists_bin);
1856	Lv->Init(1);
1857	Lv->m[0].rtyp=STRING_CMD;
1858	Lv->m[0].data=(void )omStrDup(n_ParameterNames(C));
1859	Lc->m[1].rtyp=LIST_CMD;
1860	Lc->m[1].data=(void*)Lv;
1861	// ord:
1862	lists Lo=(lists)omAlloc0Bin(slists_bin);
1863	Lo->Init(1);
1864	lists Loo=(lists)omAlloc0Bin(slists_bin);
1865	Loo->Init(2);
1866	Loo->m[0].rtyp=STRING_CMD;
1867	Loo->m[0].data=(void *)omStrDup(rSimpleOrdStr(ringorder_lp));
1868
1869	intvec iv=new intvec(1); (iv)[0]=1;
1870	Loo->m[1].rtyp=INTVEC_CMD;
1871	Loo->m[1].data=(void *)iv;
1872
1873	Lo->m[0].rtyp=LIST_CMD;
1874	Lo->m[0].data=(void*)Loo;
1875
1876	Lc->m[2].rtyp=LIST_CMD;
1877	Lc->m[2].data=(void*)Lo;
1878	// q-ideal:
1879	Lc->m[3].rtyp=IDEAL_CMD;
1880	Lc->m[3].data=(void *)idInit(1,1);
1881	// ----------------------
1882	res->rtyp=LIST_CMD;
1883	res->data=(void*)Lc;
1884	}
1885	else
1886	{
1887	res->rtyp=INT_CMD;
1888	res->data=(void *)(long)C->ch;
1889	}
1890	// ----------------------------------------
1891	return FALSE;
1892	}
1893	#endif
1894
1895	#ifdef SINGULAR_4_1
1896	lists rDecompose(const ring r)
1897	{
1898	assume( r != NULL );
1899	const coeffs C = r->cf;
1900	assume( C != NULL );
1901
1902	// sanity check: require currRing==r for rings with polynomial data
1903	if ( (r!=currRing) && (
1904	(nCoeff_is_algExt(C) && (C != currRing->cf))
1905	\|\| (r->qideal != NULL)
1906	#ifdef HAVE_PLURAL
1907	\|\| (rIsPluralRing(r))
1908	#endif
1909	)
1910	)
1911	{
1912	WerrorS("ring with polynomial data must be the base ring or compatible");
1913	return NULL;
1914	}
1915	// 0: char/ cf - ring
1916	// 1: list (var)
1917	// 2: list (ord)
1918	// 3: qideal
1919	// possibly:
1920	// 4: C
1921	// 5: D
1922	lists L=(lists)omAlloc0Bin(slists_bin);
1923	if (rIsPluralRing(r))
1924	L->Init(6);
1925	else
1926	L->Init(4);
1927	// ----------------------------------------
1928	// 0: char/ cf - ring
1929	L->m[0].rtyp=CRING_CMD;
1930	L->m[0].data=(char*)r->cf; r->cf->ref++;
1931	// ----------------------------------------
1932	// 1: list (var)
1933	lists LL=(lists)omAlloc0Bin(slists_bin);
1934	LL->Init(r->N);
1935	int i;
1936	for(i=0; i<r->N; i++)
1937	{
1938	LL->m[i].rtyp=STRING_CMD;
1939	LL->m[i].data=(void *)omStrDup(r->names[i]);
1940	}
1941	L->m[1].rtyp=LIST_CMD;
1942	L->m[1].data=(void *)LL;
1943	// ----------------------------------------
1944	// 2: list (ord)
1945	LL=(lists)omAlloc0Bin(slists_bin);
1946	i=rBlocks(r)-1;
1947	LL->Init(i);
1948	i--;
1949	lists LLL;
1950	for(; i>=0; i--)
1951	{
1952	intvec *iv;
1953	int j;
1954	LL->m[i].rtyp=LIST_CMD;
1955	LLL=(lists)omAlloc0Bin(slists_bin);
1956	LLL->Init(2);
1957	LLL->m[0].rtyp=STRING_CMD;
1958	LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
1959
1960	if(r->order[i] == ringorder_IS) // \|\| r->order[i] == ringorder_s \|\| r->order[i] == ringorder_S)
1961	{
1962	assume( r->block0[i] == r->block1[i] );
1963	const int s = r->block0[i];
1964	assume( -2 < s && s < 2);
1965
1966	iv=new intvec(1);
1967	(*iv)[0] = s;
1968	}
1969	else if (r->block1[i]-r->block0[i] >=0 )
1970	{
1971	int bl=j=r->block1[i]-r->block0[i];
1972	if (r->order[i]==ringorder_M)
1973	{
1974	j=(j+1)*(j+1)-1;
1975	bl=j+1;
1976	}
1977	else if (r->order[i]==ringorder_am)
1978	{
1979	j+=r->wvhdl[i][bl+1];
1980	}
1981	iv=new intvec(j+1);
1982	if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
1983	{
1984	for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j+(j>bl)];
1985	}
1986	else switch (r->order[i])
1987	{
1988	case ringorder_dp:
1989	case ringorder_Dp:
1990	case ringorder_ds:
1991	case ringorder_Ds:
1992	case ringorder_lp:
1993	for(;j>=0; j--) (*iv)[j]=1;
1994	break;
1995	default: /* do nothing */;
1996	}
1997	}
1998	else
1999	{
2000	iv=new intvec(1);
2001	}
2002	LLL->m[1].rtyp=INTVEC_CMD;
2003	LLL->m[1].data=(void *)iv;
2004	LL->m[i].data=(void *)LLL;
2005	}
2006	L->m[2].rtyp=LIST_CMD;
2007	L->m[2].data=(void *)LL;
2008	// ----------------------------------------
2009	// 3: qideal
2010	L->m[3].rtyp=IDEAL_CMD;
2011	if (r->qideal==NULL)
2012	L->m[3].data=(void *)idInit(1,1);
2013	else
2014	L->m[3].data=(void *)idCopy(r->qideal);
2015	// ----------------------------------------
2016	#ifdef HAVE_PLURAL // NC! in rDecompose
2017	if (rIsPluralRing(r))
2018	{
2019	L->m[4].rtyp=MATRIX_CMD;
2020	L->m[4].data=(void *)mp_Copy(r->GetNC()->C, r, r);
2021	L->m[5].rtyp=MATRIX_CMD;
2022	L->m[5].data=(void *)mp_Copy(r->GetNC()->D, r, r);
2023	}
2024	#endif
2025	return L;
2026	}
2027	#endif
2028
2029	#ifndef SINGULAR_4_1
2030	lists rDecompose(const ring r)
2031	{
2032	assume( r != NULL );
2033	const coeffs C = r->cf;
2034	assume( C != NULL );
2035
2036	// sanity check: require currRing==r for rings with polynomial data
2037	if ( (r!=currRing) && (
2038	(nCoeff_is_algExt(C) && (C != currRing->cf))
2039	\|\| (r->qideal != NULL)
2040	#ifdef HAVE_PLURAL
2041	\|\| (rIsPluralRing(r))
2042	#endif
2043	)
2044	)
2045	{
2046	WerrorS("ring with polynomial data must be the base ring or compatible");
2047	return NULL;
2048	}
2049	// 0: char/ cf - ring
2050	// 1: list (var)
2051	// 2: list (ord)
2052	// 3: qideal
2053	// possibly:
2054	// 4: C
2055	// 5: D
2056	lists L=(lists)omAlloc0Bin(slists_bin);
2057	if (rIsPluralRing(r))
2058	L->Init(6);
2059	else
2060	L->Init(4);
2061	// ----------------------------------------
2062	// 0: char/ cf - ring
2063	if (rField_is_numeric(r))
2064	{
2065	rDecomposeC(&(L->m[0]),r);
2066	}
2067	#ifdef HAVE_RINGS
2068	else if (rField_is_Ring(r))
2069	{
2070	rDecomposeRing(&(L->m[0]),r);
2071	}
2072	#endif
2073	else if ( r->cf->extRing!=NULL )// nCoeff_is_algExt(r->cf))
2074	{
2075	rDecomposeCF(&(L->m[0]), r->cf->extRing, r);
2076	}
2077	else if(rField_is_GF(r))
2078	{
2079	lists Lc=(lists)omAlloc0Bin(slists_bin);
2080	Lc->Init(4);
2081	// char:
2082	Lc->m[0].rtyp=INT_CMD;
2083	Lc->m[0].data=(void*)(long)r->cf->m_nfCharQ;
2084	// var:
2085	lists Lv=(lists)omAlloc0Bin(slists_bin);
2086	Lv->Init(1);
2087	Lv->m[0].rtyp=STRING_CMD;
2088	Lv->m[0].data=(void )omStrDup(rParameter(r));
2089	Lc->m[1].rtyp=LIST_CMD;
2090	Lc->m[1].data=(void*)Lv;
2091	// ord:
2092	lists Lo=(lists)omAlloc0Bin(slists_bin);
2093	Lo->Init(1);
2094	lists Loo=(lists)omAlloc0Bin(slists_bin);
2095	Loo->Init(2);
2096	Loo->m[0].rtyp=STRING_CMD;
2097	Loo->m[0].data=(void *)omStrDup(rSimpleOrdStr(ringorder_lp));
2098
2099	intvec iv=new intvec(1); (iv)[0]=1;
2100	Loo->m[1].rtyp=INTVEC_CMD;
2101	Loo->m[1].data=(void *)iv;
2102
2103	Lo->m[0].rtyp=LIST_CMD;
2104	Lo->m[0].data=(void*)Loo;
2105
2106	Lc->m[2].rtyp=LIST_CMD;
2107	Lc->m[2].data=(void*)Lo;
2108	// q-ideal:
2109	Lc->m[3].rtyp=IDEAL_CMD;
2110	Lc->m[3].data=(void *)idInit(1,1);
2111	// ----------------------
2112	L->m[0].rtyp=LIST_CMD;
2113	L->m[0].data=(void*)Lc;
2114	}
2115	else
2116	{
2117	L->m[0].rtyp=INT_CMD;
2118	L->m[0].data=(void *)(long)r->cf->ch;
2119	}
2120	// ----------------------------------------
2121	// 1: list (var)
2122	lists LL=(lists)omAlloc0Bin(slists_bin);
2123	LL->Init(r->N);
2124	int i;
2125	for(i=0; i<r->N; i++)
2126	{
2127	LL->m[i].rtyp=STRING_CMD;
2128	LL->m[i].data=(void *)omStrDup(r->names[i]);
2129	}
2130	L->m[1].rtyp=LIST_CMD;
2131	L->m[1].data=(void *)LL;
2132	// ----------------------------------------
2133	// 2: list (ord)
2134	LL=(lists)omAlloc0Bin(slists_bin);
2135	i=rBlocks(r)-1;
2136	LL->Init(i);
2137	i--;
2138	lists LLL;
2139	for(; i>=0; i--)
2140	{
2141	intvec *iv;
2142	int j;
2143	LL->m[i].rtyp=LIST_CMD;
2144	LLL=(lists)omAlloc0Bin(slists_bin);
2145	LLL->Init(2);
2146	LLL->m[0].rtyp=STRING_CMD;
2147	LLL->m[0].data=(void *)omStrDup(rSimpleOrdStr(r->order[i]));
2148
2149	if(r->order[i] == ringorder_IS) // \|\| r->order[i] == ringorder_s \|\| r->order[i] == ringorder_S)
2150	{
2151	assume( r->block0[i] == r->block1[i] );
2152	const int s = r->block0[i];
2153	assume( -2 < s && s < 2);
2154
2155	iv=new intvec(1);
2156	(*iv)[0] = s;
2157	}
2158	else if (r->block1[i]-r->block0[i] >=0 )
2159	{
2160	int bl=j=r->block1[i]-r->block0[i];
2161	if (r->order[i]==ringorder_M)
2162	{
2163	j=(j+1)*(j+1)-1;
2164	bl=j+1;
2165	}
2166	else if (r->order[i]==ringorder_am)
2167	{
2168	j+=r->wvhdl[i][bl+1];
2169	}
2170	iv=new intvec(j+1);
2171	if ((r->wvhdl!=NULL) && (r->wvhdl[i]!=NULL))
2172	{
2173	for(;j>=0; j--) (*iv)[j]=r->wvhdl[i][j+(j>bl)];
2174	}
2175	else switch (r->order[i])
2176	{
2177	case ringorder_dp:
2178	case ringorder_Dp:
2179	case ringorder_ds:
2180	case ringorder_Ds:
2181	case ringorder_lp:
2182	for(;j>=0; j--) (*iv)[j]=1;
2183	break;
2184	default: /* do nothing */;
2185	}
2186	}
2187	else
2188	{
2189	iv=new intvec(1);
2190	}
2191	LLL->m[1].rtyp=INTVEC_CMD;
2192	LLL->m[1].data=(void *)iv;
2193	LL->m[i].data=(void *)LLL;
2194	}
2195	L->m[2].rtyp=LIST_CMD;
2196	L->m[2].data=(void *)LL;
2197	// ----------------------------------------
2198	// 3: qideal
2199	L->m[3].rtyp=IDEAL_CMD;
2200	if (r->qideal==NULL)
2201	L->m[3].data=(void *)idInit(1,1);
2202	else
2203	L->m[3].data=(void *)idCopy(r->qideal);
2204	// ----------------------------------------
2205	#ifdef HAVE_PLURAL // NC! in rDecompose
2206	if (rIsPluralRing(r))
2207	{
2208	L->m[4].rtyp=MATRIX_CMD;
2209	L->m[4].data=(void *)mp_Copy(r->GetNC()->C, r, r);
2210	L->m[5].rtyp=MATRIX_CMD;
2211	L->m[5].data=(void *)mp_Copy(r->GetNC()->D, r, r);
2212	}
2213	#endif
2214	return L;
2215	}
2216	#endif
2217
2218	void rComposeC(lists L, ring R)
2219	/* field is R or C */
2220	{
2221	// ----------------------------------------
2222	// 0: char/ cf - ring
2223	if ((L->m[0].rtyp!=INT_CMD) \|\| (L->m[0].data!=(char *)0))
2224	{
2225	Werror("invald coeff. field description, expecting 0");
2226	return;
2227	}
2228	// R->cf->ch=0;
2229	// ----------------------------------------
2230	// 1:
2231	if (L->m[1].rtyp!=LIST_CMD)
2232	Werror("invald coeff. field description, expecting precision list");
2233	lists LL=(lists)L->m[1].data;
2234	int r1=(int)(long)LL->m[0].data;
2235	int r2=(int)(long)LL->m[1].data;
2236	if (L->nr==2) // complex
2237	R->cf = nInitChar(n_long_C, NULL);
2238	else if ((r1<=SHORT_REAL_LENGTH)
2239	&& (r2=SHORT_REAL_LENGTH))
2240	R->cf = nInitChar(n_R, NULL);
2241	else
2242	{
2243	LongComplexInfo* p = (LongComplexInfo *)omAlloc0(sizeof(LongComplexInfo));
2244	p->float_len=r1;
2245	p->float_len2=r2;
2246	R->cf = nInitChar(n_long_R, NULL);
2247	}
2248
2249	if ((r1<=SHORT_REAL_LENGTH) // should go into nInitChar
2250	&& (r2=SHORT_REAL_LENGTH))
2251	{
2252	R->cf->float_len=SHORT_REAL_LENGTH/2;
2253	R->cf->float_len2=SHORT_REAL_LENGTH;
2254	}
2255	else
2256	{
2257	R->cf->float_len=si_min(r1,32767);
2258	R->cf->float_len2=si_min(r2,32767);
2259	}
2260	// ----------------------------------------
2261	// 2: list (par)
2262	if (L->nr==2)
2263	{
2264	//R->cf->extRing->N=1;
2265	if (L->m[2].rtyp!=STRING_CMD)
2266	{
2267	Werror("invald coeff. field description, expecting parameter name");
2268	return;
2269	}
2270	//(rParameter(R))=(char*)omAlloc0(rPar(R)sizeof(char_ptr));
2271	rParameter(R)[0]=omStrDup((char *)L->m[2].data);
2272	}
2273	// ----------------------------------------
2274	}
2275
2276	#ifdef HAVE_RINGS
2277	void rComposeRing(lists L, ring R)
2278	/* field is R or C */
2279	{
2280	// ----------------------------------------
2281	// 0: string: integer
2282	// no further entries --> Z
2283	mpz_ptr modBase = NULL;
2284	unsigned int modExponent = 1;
2285
2286	modBase = (mpz_ptr) omAlloc(sizeof(mpz_t));
2287	if (L->nr == 0)
2288	{
2289	mpz_init_set_ui(modBase,0);
2290	modExponent = 1;
2291	}
2292	// ----------------------------------------
2293	// 1:
2294	else
2295	{
2296	if (L->m[1].rtyp!=LIST_CMD) Werror("invald data, expecting list of numbers");
2297	lists LL=(lists)L->m[1].data;
2298	if ((LL->nr >= 0) && LL->m[0].rtyp == BIGINT_CMD)
2299	{
2300	number tmp= (number) LL->m[0].data; // never use CopyD() on list elements
2301	// assume that tmp is integer, not rational
2302	n_MPZ (modBase, tmp, coeffs_BIGINT);
2303	}
2304	else if (LL->nr >= 0 && LL->m[0].rtyp == INT_CMD)
2305	{
2306	mpz_init_set_ui(modBase,(unsigned long) LL->m[0].data);
2307	}
2308	else
2309	{
2310	mpz_init_set_ui(modBase,0);
2311	}
2312	if (LL->nr >= 1)
2313	{
2314	modExponent = (unsigned long) LL->m[1].data;
2315	}
2316	else
2317	{
2318	modExponent = 1;
2319	}
2320	}
2321	// ----------------------------------------
2322	if ((mpz_cmp_ui(modBase, 1) == 0) && (mpz_cmp_ui(modBase, 0) < 0))
2323	{
2324	Werror("Wrong ground ring specification (module is 1)");
2325	return;
2326	}
2327	if (modExponent < 1)
2328	{
2329	Werror("Wrong ground ring specification (exponent smaller than 1");
2330	return;
2331	}
2332	// module is 0 ---> integers
2333	if (mpz_cmp_ui(modBase, 0) == 0)
2334	{
2335	R->cf=nInitChar(n_Z,NULL);
2336	}
2337	// we have an exponent
2338	else if (modExponent > 1)
2339	{
2340	//R->cf->ch = R->cf->modExponent;
2341	if ((mpz_cmp_ui(modBase, 2) == 0) && (modExponent <= 8*sizeof(unsigned long)))
2342	{
2343	/* this branch should be active for modExponent = 2..32 resp. 2..64,
2344	depending on the size of a long on the respective platform */
2345	R->cf=nInitChar(n_Z2m,(void*)(long)modExponent); // Use Z/2^ch
2346	omFreeSize (modBase, sizeof(mpz_t));
2347	}
2348	else
2349	{
2350	//ringtype 3
2351	ZnmInfo info;
2352	info.base= modBase;
2353	info.exp= modExponent;
2354	R->cf=nInitChar(n_Znm,(void*) &info);
2355	}
2356	}
2357	// just a module m > 1
2358	else
2359	{
2360	//ringtype = 2;
2361	//const int ch = mpz_get_ui(modBase);
2362	ZnmInfo info;
2363	info.base= modBase;
2364	info.exp= modExponent;
2365	R->cf=nInitChar(n_Zn,(void*) &info);
2366	}
2367	}
2368	#endif
2369
2370	static void rRenameVars(ring R)
2371	{
2372	int i,j;
2373	BOOLEAN ch;
2374	do
2375	{
2376	ch=0;
2377	for(i=0;i<R->N-1;i++)
2378	{
2379	for(j=i+1;j<R->N;j++)
2380	{
2381	if (strcmp(R->names[i],R->names[j])==0)
2382	{
2383	ch=TRUE;
2384	Warn("name conflict var(%d) and var(%d): `%s`, rename to `@%s`",i+1,j+1,R->names[i],R->names[i]);
2385	omFree(R->names[j]);
2386	R->names[j]=(char *)omAlloc(2+strlen(R->names[i]));
2387	sprintf(R->names[j],"@%s",R->names[i]);
2388	}
2389	}
2390	}
2391	}
2392	while (ch);
2393	for(i=0;i<rPar(R); i++)
2394	{
2395	for(j=0;j<R->N;j++)
2396	{
2397	if (strcmp(rParameter(R)[i],R->names[j])==0)
2398	{
2399	Warn("name conflict par(%d) and var(%d): `%s`, renaming the VARIABLE to `@@(%d)`",i+1,j+1,R->names[j],i+1);
2400	// omFree(rParameter(R)[i]);
2401	// rParameter(R)[i]=(char *)omAlloc(10);
2402	// sprintf(rParameter(R)[i],"@@(%d)",i+1);
2403	omFree(R->names[j]);
2404	R->names[j]=(char *)omAlloc(10);
2405	sprintf(R->names[j],"@@(%d)",i+1);
2406	}
2407	}
2408	}
2409	}
2410
2411	ring rCompose(const lists L, const BOOLEAN check_comp)
2412	{
2413	if ((L->nr!=3)
2414	#ifdef HAVE_PLURAL
2415	&&(L->nr!=5)
2416	#endif
2417	)
2418	return NULL;
2419	int is_gf_char=0;
2420	// 0: char/ cf - ring
2421	// 1: list (var)
2422	// 2: list (ord)
2423	// 3: qideal
2424	// possibly:
2425	// 4: C
2426	// 5: D
2427
2428	ring R = (ring) omAlloc0Bin(sip_sring_bin);
2429
2430
2431	// ------------------------------------------------------------------
2432	// 0: char:
2433	#ifdef SINGULAR_4_1
2434	if (L->m[0].Typ()==CRING_CMD)
2435	{
2436	R->cf=(coeffs)L->m[0].Data();
2437	R->cf->ref++;
2438	}
2439	else
2440	#endif
2441	if (L->m[0].Typ()==INT_CMD)
2442	{
2443	int ch = (int)(long)L->m[0].Data();
2444	assume( ch >= 0 );
2445
2446	if (ch == 0) // Q?
2447	R->cf = nInitChar(n_Q, NULL);
2448	else
2449	{
2450	int l = IsPrime(ch); // Zp?
2451	if( l != ch )
2452	{
2453	Warn("%d is invalid characteristic of ground field. %d is used.", ch, l);
2454	ch = l;
2455	}
2456	R->cf = nInitChar(n_Zp, (void*)(long)ch);
2457	}
2458	}
2459	else if (L->m[0].Typ()==LIST_CMD) // something complicated...
2460	{
2461	lists LL=(lists)L->m[0].Data();
2462
2463	#ifdef HAVE_RINGS
2464	if (LL->m[0].Typ() == STRING_CMD) // 1st comes a string?
2465	{
2466	rComposeRing(LL, R); // Ring!?
2467	}
2468	else
2469	#endif
2470	if (LL->nr < 3)
2471	rComposeC(LL,R); // R, long_R, long_C
2472	else
2473	{
2474	if (LL->m[0].Typ()==INT_CMD)
2475	{
2476	int ch = (int)(long)LL->m[0].Data();
2477	while ((ch!=fftable[is_gf_char]) && (fftable[is_gf_char])) is_gf_char++;
2478	if (fftable[is_gf_char]==0) is_gf_char=-1;
2479
2480	if(is_gf_char!= -1)
2481	{
2482	GFInfo param;
2483
2484	param.GFChar = ch;
2485	param.GFDegree = 1;
2486	param.GFPar_name = (const char*)(((lists)(LL->m[1].Data()))->m[0].Data());
2487
2488	// nfInitChar should be able to handle the case when ch is in fftables!
2489	R->cf = nInitChar(n_GF, (void*)&param);
2490	}
2491	}
2492
2493	if( R->cf == NULL )
2494	{
2495	ring extRing = rCompose((lists)L->m[0].Data(),FALSE);
2496
2497	if (extRing==NULL)
2498	{
2499	WerrorS("could not create the specified coefficient field");
2500	goto rCompose_err;
2501	}
2502
2503	if( extRing->qideal != NULL ) // Algebraic extension
2504	{
2505	AlgExtInfo extParam;
2506
2507	extParam.r = extRing;
2508
2509	R->cf = nInitChar(n_algExt, (void*)&extParam);
2510	}
2511	else // Transcendental extension
2512	{
2513	TransExtInfo extParam;
2514	extParam.r = extRing;
2515	assume( extRing->qideal == NULL );
2516
2517	R->cf = nInitChar(n_transExt, &extParam);
2518	}
2519	}
2520	}
2521	}
2522	#ifdef SINGULAR_4_1
2523	else if (L->m[0].Typ()==CRING_CMD)
2524	{
2525	R->cf=(coeffs)L->m[0].Data();
2526	R->cf->ref++;
2527	}
2528	#endif
2529	else
2530	{
2531	WerrorS("coefficient field must be described by `int` or `list`");
2532	goto rCompose_err;
2533	}
2534
2535	if( R->cf == NULL )
2536	{
2537	WerrorS("could not create coefficient field described by the input!");
2538	goto rCompose_err;
2539	}
2540
2541	// ------------------------- VARS ---------------------------
2542	if (L->m[1].Typ()==LIST_CMD)
2543	{
2544	lists v=(lists)L->m[1].Data();
2545	R->N = v->nr+1;
2546	if (R->N<=0)
2547	{
2548	WerrorS("no ring variables");
2549	goto rCompose_err;
2550	}
2551	R->names = (char *)omAlloc0(R->N sizeof(char_ptr));
2552	int i;
2553	for(i=0;i<R->N;i++)
2554	{
2555	if (v->m[i].Typ()==STRING_CMD)
2556	R->names[i]=omStrDup((char *)v->m[i].Data());
2557	else if (v->m[i].Typ()==POLY_CMD)
2558	{
2559	poly p=(poly)v->m[i].Data();
2560	int nr=pIsPurePower(p);
2561	if (nr>0)
2562	R->names[i]=omStrDup(currRing->names[nr-1]);
2563	else
2564	{
2565	Werror("var name %d must be a string or a ring variable",i+1);
2566	goto rCompose_err;
2567	}
2568	}
2569	else
2570	{
2571	Werror("var name %d must be `string`",i+1);
2572	goto rCompose_err;
2573	}
2574	}
2575	}
2576	else
2577	{
2578	WerrorS("variable must be given as `list`");
2579	goto rCompose_err;
2580	}
2581	// ------------------------ ORDER ------------------------------
2582	if (L->m[2].Typ()==LIST_CMD)
2583	{
2584	lists v=(lists)L->m[2].Data();
2585	int n= v->nr+2;
2586	int j;
2587	// initialize fields of R
2588	R->order=(int )omAlloc0(nsizeof(int));
2589	R->block0=(int )omAlloc0(nsizeof(int));
2590	R->block1=(int )omAlloc0(nsizeof(int));
2591	R->wvhdl=(int*)omAlloc0(nsizeof(int_ptr));
2592	// init order, so that rBlocks works correctly
2593	for (j=0; j < n-1; j++)
2594	R->order[j] = (int) ringorder_unspec;
2595	// orderings
2596	for(j=0;j<n-1;j++)
2597	{
2598	// todo: a(..), M
2599	if (v->m[j].Typ()!=LIST_CMD)
2600	{
2601	WerrorS("ordering must be list of lists");
2602	goto rCompose_err;
2603	}
2604	lists vv=(lists)v->m[j].Data();
2605	if ((vv->nr!=1)
2606	\|\| (vv->m[0].Typ()!=STRING_CMD)
2607	\|\| ((vv->m[1].Typ()!=INTVEC_CMD) && (vv->m[1].Typ()!=INT_CMD)))
2608	{
2609	WerrorS("ordering name must be a (string,intvec)");
2610	goto rCompose_err;
2611	}
2612	R->order[j]=rOrderName(omStrDup((char*)vv->m[0].Data())); // assume STRING
2613
2614	if (j==0) R->block0[0]=1;
2615	else
2616	{
2617	int jj=j-1;
2618	while((jj>=0)
2619	&& ((R->order[jj]== ringorder_a)
2620	\|\| (R->order[jj]== ringorder_aa)
2621	\|\| (R->order[jj]== ringorder_am)
2622	\|\| (R->order[jj]== ringorder_c)
2623	\|\| (R->order[jj]== ringorder_C)
2624	\|\| (R->order[jj]== ringorder_s)
2625	\|\| (R->order[jj]== ringorder_S)
2626	))
2627	{
2628	//Print("jj=%, skip %s\n",rSimpleOrdStr(R->order[jj]));
2629	jj--;
2630	}
2631	if (jj<0) R->block0[j]=1;
2632	else R->block0[j]=R->block1[jj]+1;
2633	}
2634	intvec *iv;
2635	if (vv->m[1].Typ()==INT_CMD)
2636	iv=new intvec((int)(long)vv->m[1].Data(),(int)(long)vv->m[1].Data());
2637	else
2638	iv=ivCopy((intvec*)vv->m[1].Data()); //assume INTVEC
2639	int iv_len=iv->length();
2640	R->block1[j]=si_max(R->block0[j],R->block0[j]+iv_len-1);
2641	if (R->block1[j]>R->N)
2642	{
2643	R->block1[j]=R->N;
2644	iv_len=R->block1[j]-R->block0[j]+1;
2645	}
2646	//Print("block %d from %d to %d\n",j,R->block0[j], R->block1[j]);
2647	int i;
2648	switch (R->order[j])
2649	{
2650	case ringorder_ws:
2651	case ringorder_Ws:
2652	R->OrdSgn=-1;
2653	case ringorder_aa:
2654	case ringorder_a:
2655	case ringorder_wp:
2656	case ringorder_Wp:
2657	R->wvhdl[j] =( int )omAlloc(iv_lensizeof(int));
2658	for (i=0; i<iv_len;i++)
2659	{
2660	R->wvhdl[j][i]=(*iv)[i];
2661	}
2662	break;
2663	case ringorder_am:
2664	R->wvhdl[j] =( int )omAlloc((iv->length()+1)sizeof(int));
2665	for (i=0; i<iv_len;i++)
2666	{
2667	R->wvhdl[j][i]=(*iv)[i];
2668	}
2669	R->wvhdl[j][i]=iv->length() - iv_len;
2670	//printf("ivlen:%d,iv->len:%d,mod:%d\n",iv_len,iv->length(),R->wvhdl[j][i]);
2671	for (; i<iv->length(); i++)
2672	{
2673	R->wvhdl[j][i+1]=(*iv)[i];
2674	}
2675	break;
2676	case ringorder_M:
2677	R->wvhdl[j] =( int )omAlloc((iv->length())sizeof(int));
2678	for (i=0; i<iv->length();i++) R->wvhdl[j][i]=(*iv)[i];
2679	R->block1[j]=si_max(R->block0[j],R->block0[j]+(int)sqrt((double)(iv->length()-1)));
2680	if (R->block1[j]>R->N)
2681	{
2682	WerrorS("ordering matrix too big");
2683	goto rCompose_err;
2684	}
2685	break;
2686	case ringorder_ls:
2687	case ringorder_ds:
2688	case ringorder_Ds:
2689	case ringorder_rs:
2690	R->OrdSgn=-1;
2691	case ringorder_lp:
2692	case ringorder_dp:
2693	case ringorder_Dp:
2694	case ringorder_rp:
2695	break;
2696	case ringorder_S:
2697	break;
2698	case ringorder_c:
2699	case ringorder_C:
2700	R->block1[j]=R->block0[j]=0;
2701	break;
2702
2703	case ringorder_s:
2704	break;
2705
2706	case ringorder_IS:
2707	{
2708	R->block1[j] = R->block0[j] = 0;
2709	if( iv->length() > 0 )
2710	{
2711	const int s = (*iv)[0];
2712	assume( -2 < s && s < 2 );
2713	R->block1[j] = R->block0[j] = s;
2714	}
2715	break;
2716	}
2717	case 0:
2718	case ringorder_unspec:
2719	break;
2720	}
2721	delete iv;
2722	}
2723	// sanity check
2724	j=n-2;
2725	if ((R->order[j]==ringorder_c)
2726	\|\| (R->order[j]==ringorder_C)
2727	\|\| (R->order[j]==ringorder_unspec)) j--;
2728	if (R->block1[j] != R->N)
2729	{
2730	if (((R->order[j]==ringorder_dp) \|\|
2731	(R->order[j]==ringorder_ds) \|\|
2732	(R->order[j]==ringorder_Dp) \|\|
2733	(R->order[j]==ringorder_Ds) \|\|
2734	(R->order[j]==ringorder_rp) \|\|
2735	(R->order[j]==ringorder_rs) \|\|
2736	(R->order[j]==ringorder_lp) \|\|
2737	(R->order[j]==ringorder_ls))
2738	&&
2739	R->block0[j] <= R->N)
2740	{
2741	R->block1[j] = R->N;
2742	}
2743	else
2744	{
2745	Werror("ordering incomplete: size (%d) should be %d",R->block1[j],R->N);
2746	goto rCompose_err;
2747	}
2748	}
2749	if (R->block0[j]>R->N)
2750	{
2751	Werror("not enough variables (%d) for ordering block %d, scanned so far:",R->N,j+1);
2752	for(int ii=0;ii<=j;ii++)
2753	Werror("ord[%d]: %s from v%d to v%d",ii+1,rSimpleOrdStr(R->order[ii]),R->block0[ii],R->block1[ii]);
2754	goto rCompose_err;
2755	}
2756	if (check_comp)
2757	{
2758	BOOLEAN comp_order=FALSE;
2759	int jj;
2760	for(jj=0;jj<n;jj++)
2761	{
2762	if ((R->order[jj]==ringorder_c) \|\|
2763	(R->order[jj]==ringorder_C)) { comp_order=TRUE; break; }
2764	}
2765	if (!comp_order)
2766	{
2767	R->order=(int)omRealloc0Size(R->order,nsizeof(int),(n+1)*sizeof(int));
2768	R->block0=(int)omRealloc0Size(R->block0,nsizeof(int),(n+1)*sizeof(int));
2769	R->block1=(int)omRealloc0Size(R->block1,nsizeof(int),(n+1)*sizeof(int));
2770	R->wvhdl=(int*)omRealloc0Size(R->wvhdl,nsizeof(int_ptr),(n+1)*sizeof(int_ptr));
2771	R->order[n-1]=ringorder_C;
2772	R->block0[n-1]=0;
2773	R->block1[n-1]=0;
2774	R->wvhdl[n-1]=NULL;
2775	n++;
2776	}
2777	}
2778	}
2779	else
2780	{
2781	WerrorS("ordering must be given as `list`");
2782	goto rCompose_err;
2783	}
2784
2785	// ------------------------ ??????? --------------------
2786
2787	rRenameVars(R);
2788	rComplete(R);
2789
2790	/*#ifdef HAVE_RINGS
2791	// currently, coefficients which are ring elements require a global ordering:
2792	if (rField_is_Ring(R) && (R->OrdSgn==-1))
2793	{
2794	WerrorS("global ordering required for these coefficients");
2795	goto rCompose_err;
2796	}
2797	#endif*/
2798
2799
2800	// ------------------------ Q-IDEAL ------------------------
2801
2802	if (L->m[3].Typ()==IDEAL_CMD)
2803	{
2804	ideal q=(ideal)L->m[3].Data();
2805	if (q->m[0]!=NULL)
2806	{
2807	if (R->cf != currRing->cf) //->cf->ch!=currRing->cf->ch)
2808	{
2809	#if 0
2810	WerrorS("coefficient fields must be equal if q-ideal !=0");
2811	goto rCompose_err;
2812	#else
2813	ring orig_ring=currRing;
2814	rChangeCurrRing(R);
2815	int *perm=NULL;
2816	int *par_perm=NULL;
2817	int par_perm_size=0;
2818	nMapFunc nMap;
2819
2820	if ((nMap=nSetMap(orig_ring->cf))==NULL)
2821	{
2822	if (rEqual(orig_ring,currRing))
2823	{
2824	nMap=n_SetMap(currRing->cf, currRing->cf);
2825	}
2826	else
2827	// Allow imap/fetch to be make an exception only for:
2828	if ( (rField_is_Q_a(orig_ring) && // Q(a..) -> Q(a..) \|\| Q \|\| Zp \|\| Zp(a)
2829	(rField_is_Q(currRing) \|\| rField_is_Q_a(currRing) \|\|
2830	(rField_is_Zp(currRing) \|\| rField_is_Zp_a(currRing))))
2831	\|\|
2832	(rField_is_Zp_a(orig_ring) && // Zp(a..) -> Zp(a..) \|\| Zp
2833	(rField_is_Zp(currRing, rInternalChar(orig_ring)) \|\|
2834	rField_is_Zp_a(currRing, rInternalChar(orig_ring)))) )
2835	{
2836	par_perm_size=rPar(orig_ring);
2837
2838	// if ((orig_ring->minpoly != NULL) \|\| (orig_ring->qideal != NULL))
2839	// naSetChar(rInternalChar(orig_ring),orig_ring);
2840	// else ntSetChar(rInternalChar(orig_ring),orig_ring);
2841
2842	nSetChar(currRing->cf);
2843	}
2844	else
2845	{
2846	WerrorS("coefficient fields must be equal if q-ideal !=0");
2847	goto rCompose_err;
2848	}
2849	}
2850	perm=(int )omAlloc0((orig_ring->N+1)sizeof(int));
2851	if (par_perm_size!=0)
2852	par_perm=(int )omAlloc0(par_perm_sizesizeof(int));
2853	int i;
2854	#if 0
2855	// use imap:
2856	maFindPerm(orig_ring->names,orig_ring->N,orig_ring->parameter,orig_ring->P,
2857	currRing->names,currRing->N,currRing->parameter, currRing->P,
2858	perm,par_perm, currRing->ch);
2859	#else
2860	// use fetch
2861	if ((rPar(orig_ring)>0) && (rPar(currRing)==0))
2862	{
2863	for(i=si_min(rPar(orig_ring),rVar(currRing))-1;i>=0;i--) par_perm[i]=i+1;
2864	}
2865	else if (par_perm_size!=0)
2866	for(i=si_min(rPar(orig_ring),rPar(currRing))-1;i>=0;i--) par_perm[i]=-(i+1);
2867	for(i=si_min(orig_ring->N,rVar(currRing));i>0;i--) perm[i]=i;
2868	#endif
2869	ideal dest_id=idInit(IDELEMS(q),1);
2870	for(i=IDELEMS(q)-1; i>=0; i--)
2871	{
2872	dest_id->m[i]=p_PermPoly(q->m[i],perm,orig_ring, currRing,nMap,
2873	par_perm,par_perm_size);
2874	// PrintS("map:");pWrite(dest_id->m[i]);PrintLn();
2875	pTest(dest_id->m[i]);
2876	}
2877	R->qideal=dest_id;
2878	if (perm!=NULL)
2879	omFreeSize((ADDRESS)perm,(orig_ring->N+1)*sizeof(int));
2880	if (par_perm!=NULL)
2881	omFreeSize((ADDRESS)par_perm,par_perm_size*sizeof(int));
2882	rChangeCurrRing(orig_ring);
2883	#endif
2884	}
2885	else
2886	R->qideal=idrCopyR(q,currRing,R);
2887	}
2888	}
2889	else
2890	{
2891	WerrorS("q-ideal must be given as `ideal`");
2892	goto rCompose_err;
2893	}
2894
2895
2896	// ---------------------------------------------------------------
2897	#ifdef HAVE_PLURAL
2898	if (L->nr==5)
2899	{
2900	if (nc_CallPlural((matrix)L->m[4].Data(),
2901	(matrix)L->m[5].Data(),
2902	NULL,NULL,
2903	R,
2904	true, // !!!
2905	true, false,
2906	currRing, FALSE)) goto rCompose_err;
2907	// takes care about non-comm. quotient! i.e. calls "nc_SetupQuotient" due to last true
2908	}
2909	#endif
2910	return R;
2911
2912	rCompose_err:
2913	if (R->N>0)
2914	{
2915	int i;
2916	if (R->names!=NULL)
2917	{
2918	i=R->N-1;
2919	while (i>=0) { if (R->names[i]!=NULL) omFree(R->names[i]); i--; }
2920	omFree(R->names);
2921	}
2922	}
2923	if (R->order!=NULL) omFree(R->order);
2924	if (R->block0!=NULL) omFree(R->block0);
2925	if (R->block1!=NULL) omFree(R->block1);
2926	if (R->wvhdl!=NULL) omFree(R->wvhdl);
2927	omFree(R);
2928	return NULL;
2929	}
2930
2931	// from matpol.cc
2932
2933	/*2
2934	* compute the jacobi matrix of an ideal
2935	*/
2936	BOOLEAN mpJacobi(leftv res,leftv a)
2937	{
2938	int i,j;
2939	matrix result;
2940	ideal id=(ideal)a->Data();
2941
2942	result =mpNew(IDELEMS(id),rVar(currRing));
2943	for (i=1; i<=IDELEMS(id); i++)
2944	{
2945	for (j=1; j<=rVar(currRing); j++)
2946	{
2947	MATELEM(result,i,j) = pDiff(id->m[i-1],j);
2948	}
2949	}
2950	res->data=(char *)result;
2951	return FALSE;
2952	}
2953
2954	/*2
2955	* returns the Koszul-matrix of degree d of a vectorspace with dimension n
2956	* uses the first n entrees of id, if id <> NULL
2957	*/
2958	BOOLEAN mpKoszul(leftv res,leftv c/ip/, leftv b/in/, leftv id)
2959	{
2960	int n=(int)(long)b->Data();
2961	int d=(int)(long)c->Data();
2962	int k,l,sign,row,col;
2963	matrix result;
2964	ideal temp;
2965	BOOLEAN bo;
2966	poly p;
2967
2968	if ((d>n) \|\| (d<1) \|\| (n<1))
2969	{
2970	res->data=(char *)mpNew(1,1);
2971	return FALSE;
2972	}
2973	int choise = (int)omAlloc(d*sizeof(int));
2974	if (id==NULL)
2975	temp=idMaxIdeal(1);
2976	else
2977	temp=(ideal)id->Data();
2978
2979	k = binom(n,d);
2980	l = k*d;
2981	l /= n-d+1;
2982	result =mpNew(l,k);
2983	col = 1;
2984	idInitChoise(d,1,n,&bo,choise);
2985	while (!bo)
2986	{
2987	sign = 1;
2988	for (l=1;l<=d;l++)
2989	{
2990	if (choise[l-1]<=IDELEMS(temp))
2991	{
2992	p = pCopy(temp->m[choise[l-1]-1]);
2993	if (sign == -1) p = pNeg(p);
2994	sign *= -1;
2995	row = idGetNumberOfChoise(l-1,d,1,n,choise);
2996	MATELEM(result,row,col) = p;
2997	}
2998	}
2999	col++;
3000	idGetNextChoise(d,n,&bo,choise);
3001	}
3002	if (id==NULL) idDelete(&temp);
3003
3004	res->data=(char *)result;
3005	return FALSE;
3006	}
3007
3008	// from syz1.cc
3009	/*2
3010	* read out the Betti numbers from resolution
3011	* (interpreter interface)
3012	*/
3013	BOOLEAN syBetti2(leftv res, leftv u, leftv w)
3014	{
3015	syStrategy syzstr=(syStrategy)u->Data();
3016
3017	BOOLEAN minim=(int)(long)w->Data();
3018	int row_shift=0;
3019	int add_row_shift=0;
3020	intvec *weights=NULL;
3021	intvec ww=(intvec )atGet(u,"isHomog",INTVEC_CMD);
3022	if (ww!=NULL)
3023	{
3024	weights=ivCopy(ww);
3025	add_row_shift = ww->min_in();
3026	(*weights) -= add_row_shift;
3027	}
3028
3029	res->data=(void *)syBettiOfComputation(syzstr,minim,&row_shift,weights);
3030	//row_shift += add_row_shift;
3031	//Print("row_shift=%d, add_row_shift=%d\n",row_shift,add_row_shift);
3032	atSet(res,omStrDup("rowShift"),(void*)(long)add_row_shift,INT_CMD);
3033
3034	return FALSE;
3035	}
3036	BOOLEAN syBetti1(leftv res, leftv u)
3037	{
3038	sleftv tmp;
3039	memset(&tmp,0,sizeof(tmp));
3040	tmp.rtyp=INT_CMD;
3041	tmp.data=(void *)1;
3042	return syBetti2(res,u,&tmp);
3043	}
3044
3045	/*3
3046	* converts a resolution into a list of modules
3047	*/
3048	lists syConvRes(syStrategy syzstr,BOOLEAN toDel,int add_row_shift)
3049	{
3050	resolvente fullres = syzstr->fullres;
3051	resolvente minres = syzstr->minres;
3052
3053	const int length = syzstr->length;
3054
3055	if ((fullres==NULL) && (minres==NULL))
3056	{
3057	if (syzstr->hilb_coeffs==NULL)
3058	{ // La Scala
3059	fullres = syReorder(syzstr->res, length, syzstr);
3060	}
3061	else
3062	{ // HRES
3063	minres = syReorder(syzstr->orderedRes, length, syzstr);
3064	syKillEmptyEntres(minres, length);
3065	}
3066	}
3067
3068	resolvente tr;
3069	int typ0=IDEAL_CMD;
3070
3071	if (minres!=NULL)
3072	tr = minres;
3073	else
3074	tr = fullres;
3075
3076	resolvente trueres=NULL; intvec ** w=NULL;
3077
3078	if (length>0)
3079	{
3080	trueres = (resolvente)omAlloc0((length)*sizeof(ideal));
3081	for (int i=(length)-1;i>=0;i--)
3082	{
3083	if (tr[i]!=NULL)
3084	{
3085	trueres[i] = idCopy(tr[i]);
3086	}
3087	}
3088	if ( id_RankFreeModule(trueres[0], currRing) > 0)
3089	typ0 = MODUL_CMD;
3090	if (syzstr->weights!=NULL)
3091	{
3092	w = (intvec*)omAlloc0(lengthsizeof(intvec*));
3093	for (int i=length-1;i>=0;i--)
3094	{
3095	if (syzstr->weights[i]!=NULL) w[i] = ivCopy(syzstr->weights[i]);
3096	}
3097	}
3098	}
3099
3100	lists li = liMakeResolv(trueres, length, syzstr->list_length,typ0,
3101	w, add_row_shift);
3102
3103	if (w != NULL) omFreeSize(w, lengthsizeof(intvec));
3104
3105	if (toDel)
3106	syKillComputation(syzstr);
3107	else
3108	{
3109	if( fullres != NULL && syzstr->fullres == NULL )
3110	syzstr->fullres = fullres;
3111
3112	if( minres != NULL && syzstr->minres == NULL )
3113	syzstr->minres = minres;
3114	}
3115	return li;
3116	}
3117
3118	/*3
3119	* converts a list of modules into a resolution
3120	*/
3121	syStrategy syConvList(lists li,BOOLEAN toDel)
3122	{
3123	int typ0;
3124	syStrategy result=(syStrategy)omAlloc0(sizeof(ssyStrategy));
3125
3126	resolvente fr = liFindRes(li,&(result->length),&typ0,&(result->weights));
3127	if (fr != NULL)
3128	{
3129
3130	result->fullres = (resolvente)omAlloc0((result->length+1)*sizeof(ideal));
3131	for (int i=result->length-1;i>=0;i--)
3132	{
3133	if (fr[i]!=NULL)
3134	result->fullres[i] = idCopy(fr[i]);
3135	}
3136	result->list_length=result->length;
3137	omFreeSize((ADDRESS)fr,(result->length)*sizeof(ideal));
3138	}
3139	else
3140	{
3141	omFreeSize(result, sizeof(ssyStrategy));
3142	result = NULL;
3143	}
3144	if (toDel) li->Clean();
3145	return result;
3146	}
3147
3148	/*3
3149	* converts a list of modules into a minimal resolution
3150	*/
3151	syStrategy syForceMin(lists li)
3152	{
3153	int typ0;
3154	syStrategy result=(syStrategy)omAlloc0(sizeof(ssyStrategy));
3155
3156	resolvente fr = liFindRes(li,&(result->length),&typ0);
3157	result->minres = (resolvente)omAlloc0((result->length+1)*sizeof(ideal));
3158	for (int i=result->length-1;i>=0;i--)
3159	{
3160	if (fr[i]!=NULL)
3161	result->minres[i] = idCopy(fr[i]);
3162	}
3163	omFreeSize((ADDRESS)fr,(result->length)*sizeof(ideal));
3164	return result;
3165	}
3166	// from weight.cc
3167	BOOLEAN kWeight(leftv res,leftv id)
3168	{
3169	ideal F=(ideal)id->Data();
3170	intvec * iv = new intvec(rVar(currRing));
3171	polyset s;
3172	int sl, n, i;
3173	int *x;
3174
3175	res->data=(char *)iv;
3176	s = F->m;
3177	sl = IDELEMS(F) - 1;
3178	n = rVar(currRing);
3179	double wNsqr = (double)2.0 / (double)n;
3180	wFunctional = wFunctionalBuch;
3181	x = (int * )omAlloc(2 * (n + 1) * sizeof(int));
3182	wCall(s, sl, x, wNsqr, currRing);
3183	for (i = n; i!=0; i--)
3184	(*iv)[i-1] = x[i + n + 1];
3185	omFreeSize((ADDRESS)x, 2 * (n + 1) * sizeof(int));
3186	return FALSE;
3187	}
3188
3189	BOOLEAN kQHWeight(leftv res,leftv v)
3190	{
3191	res->data=(char *)id_QHomWeight((ideal)v->Data(), currRing);
3192	if (res->data==NULL)
3193	res->data=(char *)new intvec(rVar(currRing));
3194	return FALSE;
3195	}
3196	/==============================================================/
3197	// from clapsing.cc
3198	#if 0
3199	BOOLEAN jjIS_SQR_FREE(leftv res, leftv u)
3200	{
3201	BOOLEAN b=singclap_factorize((poly)(u->CopyD()), &v, 0);
3202	res->data=(void *)b;
3203	}
3204	#endif
3205
3206	BOOLEAN jjRESULTANT(leftv res, leftv u, leftv v, leftv w)
3207	{
3208	res->data=singclap_resultant((poly)u->CopyD(),(poly)v->CopyD(),
3209	(poly)w->CopyD(), currRing);
3210	return errorreported;
3211	}
3212
3213	BOOLEAN jjCHARSERIES(leftv res, leftv u)
3214	{
3215	res->data=singclap_irrCharSeries((ideal)u->Data(), currRing);
3216	return (res->data==NULL);
3217	}
3218
3219	// from semic.cc
3220	#ifdef HAVE_SPECTRUM
3221
3222	// ----------------------------------------------------------------------------
3223	// Initialize a spectrum deep from a singular lists
3224	// ----------------------------------------------------------------------------
3225
3226	void copy_deep( spectrum& spec, lists l )
3227	{
3228	spec.mu = (int)(long)(l->m[0].Data( ));
3229	spec.pg = (int)(long)(l->m[1].Data( ));
3230	spec.n = (int)(long)(l->m[2].Data( ));
3231
3232	spec.copy_new( spec.n );
3233
3234	intvec num = (intvec)l->m[3].Data( );
3235	intvec den = (intvec)l->m[4].Data( );
3236	intvec mul = (intvec)l->m[5].Data( );
3237
3238	for( int i=0; i<spec.n; i++ )
3239	{
3240	spec.s[i] = (Rational)((num)[i])/(Rational)((den)[i]);
3241	spec.w[i] = (*mul)[i];
3242	}
3243	}
3244
3245	// ----------------------------------------------------------------------------
3246	// singular lists constructor for spectrum
3247	// ----------------------------------------------------------------------------
3248
3249	spectrum /former spectrum::spectrum ( lists l )/
3250	spectrumFromList( lists l )
3251	{
3252	spectrum result;
3253	copy_deep( result, l );
3254	return result;
3255	}
3256
3257	// ----------------------------------------------------------------------------
3258	// generate a Singular lists from a spectrum
3259	// ----------------------------------------------------------------------------
3260
3261	/* former spectrum::thelist ( void )*/
3262	lists getList( spectrum& spec )
3263	{
3264	lists L = (lists)omAllocBin( slists_bin);
3265
3266	L->Init( 6 );
3267
3268	intvec *num = new intvec( spec.n );
3269	intvec *den = new intvec( spec.n );
3270	intvec *mult = new intvec( spec.n );
3271
3272	for( int i=0; i<spec.n; i++ )
3273	{
3274	(*num) [i] = spec.s[i].get_num_si( );
3275	(*den) [i] = spec.s[i].get_den_si( );
3276	(*mult)[i] = spec.w[i];
3277	}
3278
3279	L->m[0].rtyp = INT_CMD; // milnor number
3280	L->m[1].rtyp = INT_CMD; // geometrical genus
3281	L->m[2].rtyp = INT_CMD; // # of spectrum numbers
3282	L->m[3].rtyp = INTVEC_CMD; // numerators
3283	L->m[4].rtyp = INTVEC_CMD; // denomiantors
3284	L->m[5].rtyp = INTVEC_CMD; // multiplicities
3285
3286	L->m[0].data = (void*)(long)spec.mu;
3287	L->m[1].data = (void*)(long)spec.pg;
3288	L->m[2].data = (void*)(long)spec.n;
3289	L->m[3].data = (void*)num;
3290	L->m[4].data = (void*)den;
3291	L->m[5].data = (void*)mult;
3292
3293	return L;
3294	}
3295	// from spectrum.cc
3296	// ----------------------------------------------------------------------------
3297	// print out an error message for a spectrum list
3298	// ----------------------------------------------------------------------------
3299
3300	typedef enum
3301	{
3302	semicOK,
3303	semicMulNegative,
3304
3305	semicListTooShort,
3306	semicListTooLong,
3307
3308	semicListFirstElementWrongType,
3309	semicListSecondElementWrongType,
3310	semicListThirdElementWrongType,
3311	semicListFourthElementWrongType,
3312	semicListFifthElementWrongType,
3313	semicListSixthElementWrongType,
3314
3315	semicListNNegative,
3316	semicListWrongNumberOfNumerators,
3317	semicListWrongNumberOfDenominators,
3318	semicListWrongNumberOfMultiplicities,
3319
3320	semicListMuNegative,
3321	semicListPgNegative,
3322	semicListNumNegative,
3323	semicListDenNegative,
3324	semicListMulNegative,
3325
3326	semicListNotSymmetric,
3327	semicListNotMonotonous,
3328
3329	semicListMilnorWrong,
3330	semicListPGWrong
3331
3332	} semicState;
3333
3334	void list_error( semicState state )
3335	{
3336	switch( state )
3337	{
3338	case semicListTooShort:
3339	WerrorS( "the list is too short" );
3340	break;
3341	case semicListTooLong:
3342	WerrorS( "the list is too long" );
3343	break;
3344
3345	case semicListFirstElementWrongType:
3346	WerrorS( "first element of the list should be int" );
3347	break;
3348	case semicListSecondElementWrongType:
3349	WerrorS( "second element of the list should be int" );
3350	break;
3351	case semicListThirdElementWrongType:
3352	WerrorS( "third element of the list should be int" );
3353	break;
3354	case semicListFourthElementWrongType:
3355	WerrorS( "fourth element of the list should be intvec" );
3356	break;
3357	case semicListFifthElementWrongType:
3358	WerrorS( "fifth element of the list should be intvec" );
3359	break;
3360	case semicListSixthElementWrongType:
3361	WerrorS( "sixth element of the list should be intvec" );
3362	break;
3363
3364	case semicListNNegative:
3365	WerrorS( "first element of the list should be positive" );
3366	break;
3367	case semicListWrongNumberOfNumerators:
3368	WerrorS( "wrong number of numerators" );
3369	break;
3370	case semicListWrongNumberOfDenominators:
3371	WerrorS( "wrong number of denominators" );
3372	break;
3373	case semicListWrongNumberOfMultiplicities:
3374	WerrorS( "wrong number of multiplicities" );
3375	break;
3376
3377	case semicListMuNegative:
3378	WerrorS( "the Milnor number should be positive" );
3379	break;
3380	case semicListPgNegative:
3381	WerrorS( "the geometrical genus should be nonnegative" );
3382	break;
3383	case semicListNumNegative:
3384	WerrorS( "all numerators should be positive" );
3385	break;
3386	case semicListDenNegative:
3387	WerrorS( "all denominators should be positive" );
3388	break;
3389	case semicListMulNegative:
3390	WerrorS( "all multiplicities should be positive" );
3391	break;
3392
3393	case semicListNotSymmetric:
3394	WerrorS( "it is not symmetric" );
3395	break;
3396	case semicListNotMonotonous:
3397	WerrorS( "it is not monotonous" );
3398	break;
3399
3400	case semicListMilnorWrong:
3401	WerrorS( "the Milnor number is wrong" );
3402	break;
3403	case semicListPGWrong:
3404	WerrorS( "the geometrical genus is wrong" );
3405	break;
3406
3407	default:
3408	WerrorS( "unspecific error" );
3409	break;
3410	}
3411	}
3412	// ----------------------------------------------------------------------------
3413	// this is the main spectrum computation function
3414	// ----------------------------------------------------------------------------
3415
3416	enum spectrumState
3417	{
3418	spectrumOK,
3419	spectrumZero,
3420	spectrumBadPoly,
3421	spectrumNoSingularity,
3422	spectrumNotIsolated,
3423	spectrumDegenerate,
3424	spectrumWrongRing,
3425	spectrumNoHC,
3426	spectrumUnspecErr
3427	};
3428
3429	// from splist.cc
3430	// ----------------------------------------------------------------------------
3431	// Compute the spectrum of a spectrumPolyList
3432	// ----------------------------------------------------------------------------
3433
3434	/* former spectrumPolyList::spectrum ( lists, int) /
3435	spectrumState spectrumStateFromList( spectrumPolyList& speclist, lists *L,int fast )
3436	{
3437	spectrumPolyNode **node = &speclist.root;
3438	spectrumPolyNode *search;
3439
3440	poly f,tmp;
3441	int found,cmp;
3442
3443	Rational smax( ( fast==0 ? 0 : rVar(currRing) ),
3444	( fast==2 ? 2 : 1 ) );
3445
3446	Rational weight_prev( 0,1 );
3447
3448	int mu = 0; // the milnor number
3449	int pg = 0; // the geometrical genus
3450	int n = 0; // number of different spectral numbers
3451	int z = 0; // number of spectral number equal to smax
3452
3453	while( (node)!=(spectrumPolyNode)NULL &&
3454	( fast==0 \|\| (*node)->weight<=smax ) )
3455	{
3456	// ---------------------------------------
3457	// determine the first normal form which
3458	// contains the monomial node->mon
3459	// ---------------------------------------
3460
3461	found = FALSE;
3462	search = *node;
3463
3464	while( search!=(spectrumPolyNode*)NULL && found==FALSE )
3465	{
3466	if( search->nf!=(poly)NULL )
3467	{
3468	f = search->nf;
3469
3470	do
3471	{
3472	// --------------------------------
3473	// look for (*node)->mon in f
3474	// --------------------------------
3475
3476	cmp = pCmp( (*node)->mon,f );
3477
3478	if( cmp<0 )
3479	{
3480	f = pNext( f );
3481	}
3482	else if( cmp==0 )
3483	{
3484	// -----------------------------
3485	// we have found a normal form
3486	// -----------------------------
3487
3488	found = TRUE;
3489
3490	// normalize coefficient
3491
3492	number inv = nInvers( pGetCoeff( f ) );
3493	pMult_nn( search->nf,inv );
3494	nDelete( &inv );
3495
3496	// exchange normal forms
3497
3498	tmp = (*node)->nf;
3499	(*node)->nf = search->nf;
3500	search->nf = tmp;
3501	}
3502	}
3503	while( cmp<0 && f!=(poly)NULL );
3504	}
3505	search = search->next;
3506	}
3507
3508	if( found==FALSE )
3509	{
3510	// ------------------------------------------------
3511	// the weight of node->mon is a spectrum number
3512	// ------------------------------------------------
3513
3514	mu++;
3515
3516	if( (*node)->weight<=(Rational)1 ) pg++;
3517	if( (*node)->weight==smax ) z++;
3518	if( (*node)->weight>weight_prev ) n++;
3519
3520	weight_prev = (*node)->weight;
3521	node = &((*node)->next);
3522	}
3523	else
3524	{
3525	// -----------------------------------------------
3526	// determine all other normal form which contain
3527	// the monomial node->mon
3528	// replace for node->mon its normal form
3529	// -----------------------------------------------
3530
3531	while( search!=(spectrumPolyNode*)NULL )
3532	{
3533	if( search->nf!=(poly)NULL )
3534	{
3535	f = search->nf;
3536
3537	do
3538	{
3539	// --------------------------------
3540	// look for (*node)->mon in f
3541	// --------------------------------
3542
3543	cmp = pCmp( (*node)->mon,f );
3544
3545	if( cmp<0 )
3546	{
3547	f = pNext( f );
3548	}
3549	else if( cmp==0 )
3550	{
3551	search->nf = pSub( search->nf,
3552	ppMult_nn( (*node)->nf,pGetCoeff( f ) ) );
3553	pNorm( search->nf );
3554	}
3555	}
3556	while( cmp<0 && f!=(poly)NULL );
3557	}
3558	search = search->next;
3559	}
3560	speclist.delete_node( node );
3561	}
3562
3563	}
3564
3565	// --------------------------------------------------------
3566	// fast computation exploits the symmetry of the spectrum
3567	// --------------------------------------------------------
3568
3569	if( fast==2 )
3570	{
3571	mu = 2*mu - z;
3572	n = ( z > 0 ? 2n - 1 : 2n );
3573	}
3574
3575	// --------------------------------------------------------
3576	// compute the spectrum numbers with their multiplicities
3577	// --------------------------------------------------------
3578
3579	intvec *nom = new intvec( n );
3580	intvec *den = new intvec( n );
3581	intvec *mult = new intvec( n );
3582
3583	int count = 0;
3584	int multiplicity = 1;
3585
3586	for( search=speclist.root; search!=(spectrumPolyNode*)NULL &&
3587	( fast==0 \|\| search->weight<=smax );
3588	search=search->next )
3589	{
3590	if( search->next==(spectrumPolyNode*)NULL \|\|
3591	search->weight<search->next->weight )
3592	{
3593	(*nom) [count] = search->weight.get_num_si( );
3594	(*den) [count] = search->weight.get_den_si( );
3595	(*mult)[count] = multiplicity;
3596
3597	multiplicity=1;
3598	count++;
3599	}
3600	else
3601	{
3602	multiplicity++;
3603	}
3604	}
3605
3606	// --------------------------------------------------------
3607	// fast computation exploits the symmetry of the spectrum
3608	// --------------------------------------------------------
3609
3610	if( fast==2 )
3611	{
3612	int n1,n2;
3613	for( n1=0, n2=n-1; n1<n2; n1++, n2-- )
3614	{
3615	(nom) [n2] = rVar(currRing)(den)[n1]-(nom)[n1];
3616	(den) [n2] = (den)[n1];
3617	(mult)[n2] = (mult)[n1];
3618	}
3619	}
3620
3621	// -----------------------------------
3622	// test if the spectrum is symmetric
3623	// -----------------------------------
3624
3625	if( fast==0 \|\| fast==1 )
3626	{
3627	int symmetric=TRUE;
3628
3629	for( int n1=0, n2=n-1 ; n1<n2 && symmetric==TRUE; n1++, n2-- )
3630	{
3631	if( (mult)[n1]!=(mult)[n2] \|\|
3632	(den) [n1]!= (den)[n2] \|\|
3633	(nom)[n1]+(nom)[n2]!=rVar(currRing)(den) [n1] )
3634	{
3635	symmetric = FALSE;
3636	}
3637	}
3638
3639	if( symmetric==FALSE )
3640	{
3641	// ---------------------------------------------
3642	// the spectrum is not symmetric => degenerate
3643	// principal part
3644	// ---------------------------------------------
3645
3646	*L = (lists)omAllocBin( slists_bin);
3647	(*L)->Init( 1 );
3648	(*L)->m[0].rtyp = INT_CMD; // milnor number
3649	(L)->m[0].data = (void)(long)mu;
3650
3651	return spectrumDegenerate;
3652	}
3653	}
3654
3655	*L = (lists)omAllocBin( slists_bin);
3656
3657	(*L)->Init( 6 );
3658
3659	(*L)->m[0].rtyp = INT_CMD; // milnor number
3660	(*L)->m[1].rtyp = INT_CMD; // geometrical genus
3661	(*L)->m[2].rtyp = INT_CMD; // number of spectrum values
3662	(*L)->m[3].rtyp = INTVEC_CMD; // nominators
3663	(*L)->m[4].rtyp = INTVEC_CMD; // denomiantors
3664	(*L)->m[5].rtyp = INTVEC_CMD; // multiplicities
3665
3666	(L)->m[0].data = (void)(long)mu;
3667	(L)->m[1].data = (void)(long)pg;
3668	(L)->m[2].data = (void)(long)n;
3669	(L)->m[3].data = (void)nom;
3670	(L)->m[4].data = (void)den;
3671	(L)->m[5].data = (void)mult;
3672
3673	return spectrumOK;
3674	}
3675
3676	spectrumState spectrumCompute( poly h,lists *L,int fast )
3677	{
3678	int i;
3679
3680	#ifdef SPECTRUM_DEBUG
3681	#ifdef SPECTRUM_PRINT
3682	#ifdef SPECTRUM_IOSTREAM
3683	cout << "spectrumCompute\n";
3684	if( fast==0 ) cout << " no optimization" << endl;
3685	if( fast==1 ) cout << " weight optimization" << endl;
3686	if( fast==2 ) cout << " symmetry optimization" << endl;
3687	#else
3688	fprintf( stdout,"spectrumCompute\n" );
3689	if( fast==0 ) fprintf( stdout," no optimization\n" );
3690	if( fast==1 ) fprintf( stdout," weight optimization\n" );
3691	if( fast==2 ) fprintf( stdout," symmetry optimization\n" );
3692	#endif
3693	#endif
3694	#endif
3695
3696	// ----------------------
3697	// check if h is zero
3698	// ----------------------
3699
3700	if( h==(poly)NULL )
3701	{
3702	return spectrumZero;
3703	}
3704
3705	// ----------------------------------
3706	// check if h has a constant term
3707	// ----------------------------------
3708
3709	if( hasConstTerm( h, currRing ) )
3710	{
3711	return spectrumBadPoly;
3712	}
3713
3714	// --------------------------------
3715	// check if h has a linear term
3716	// --------------------------------
3717
3718	if( hasLinearTerm( h, currRing ) )
3719	{
3720	*L = (lists)omAllocBin( slists_bin);
3721	(*L)->Init( 1 );
3722	(*L)->m[0].rtyp = INT_CMD; // milnor number
3723	/* (L)->m[0].data = (void)0;a -- done by Init */
3724
3725	return spectrumNoSingularity;
3726	}
3727
3728	// ----------------------------------
3729	// compute the jacobi ideal of (h)
3730	// ----------------------------------
3731
3732	ideal J = NULL;
3733	J = idInit( rVar(currRing),1 );
3734
3735	#ifdef SPECTRUM_DEBUG
3736	#ifdef SPECTRUM_PRINT
3737	#ifdef SPECTRUM_IOSTREAM
3738	cout << "\n computing the Jacobi ideal...\n";
3739	#else
3740	fprintf( stdout,"\n computing the Jacobi ideal...\n" );
3741	#endif
3742	#endif
3743	#endif
3744
3745	for( i=0; i<rVar(currRing); i++ )
3746	{
3747	J->m[i] = pDiff( h,i+1); //j );
3748
3749	#ifdef SPECTRUM_DEBUG
3750	#ifdef SPECTRUM_PRINT
3751	#ifdef SPECTRUM_IOSTREAM
3752	cout << " ";
3753	#else
3754	fprintf( stdout," " );
3755	#endif
3756	pWrite( J->m[i] );
3757	#endif
3758	#endif
3759	}
3760
3761	// --------------------------------------------
3762	// compute a standard basis stdJ of jac(h)
3763	// --------------------------------------------
3764
3765	#ifdef SPECTRUM_DEBUG
3766	#ifdef SPECTRUM_PRINT
3767	#ifdef SPECTRUM_IOSTREAM
3768	cout << endl;
3769	cout << " computing a standard basis..." << endl;
3770	#else
3771	fprintf( stdout,"\n" );
3772	fprintf( stdout," computing a standard basis...\n" );
3773	#endif
3774	#endif
3775	#endif
3776
3777	ideal stdJ = kStd(J,currRing->qideal,isNotHomog,NULL);
3778	idSkipZeroes( stdJ );
3779
3780	#ifdef SPECTRUM_DEBUG
3781	#ifdef SPECTRUM_PRINT
3782	for( i=0; i<IDELEMS(stdJ); i++ )
3783	{
3784	#ifdef SPECTRUM_IOSTREAM
3785	cout << " ";
3786	#else
3787	fprintf( stdout," " );
3788	#endif
3789
3790	pWrite( stdJ->m[i] );
3791	}
3792	#endif
3793	#endif
3794
3795	idDelete( &J );
3796
3797	// ------------------------------------------
3798	// check if the h has a singularity
3799	// ------------------------------------------
3800
3801	if( hasOne( stdJ, currRing ) )
3802	{
3803	// -------------------------------
3804	// h is smooth in the origin
3805	// return only the Milnor number
3806	// -------------------------------
3807
3808	*L = (lists)omAllocBin( slists_bin);
3809	(*L)->Init( 1 );
3810	(*L)->m[0].rtyp = INT_CMD; // milnor number
3811	/* (L)->m[0].data = (void)0;a -- done by Init */
3812
3813	return spectrumNoSingularity;
3814	}
3815
3816	// ------------------------------------------
3817	// check if the singularity h is isolated
3818	// ------------------------------------------
3819
3820	for( i=rVar(currRing); i>0; i-- )
3821	{
3822	if( hasAxis( stdJ,i, currRing )==FALSE )
3823	{
3824	return spectrumNotIsolated;
3825	}
3826	}
3827
3828	// ------------------------------------------
3829	// compute the highest corner hc of stdJ
3830	// ------------------------------------------
3831
3832	#ifdef SPECTRUM_DEBUG
3833	#ifdef SPECTRUM_PRINT
3834	#ifdef SPECTRUM_IOSTREAM
3835	cout << "\n computing the highest corner...\n";
3836	#else
3837	fprintf( stdout,"\n computing the highest corner...\n" );
3838	#endif
3839	#endif
3840	#endif
3841
3842	poly hc = (poly)NULL;
3843
3844	scComputeHC( stdJ,currRing->qideal, 0,hc );
3845
3846	if( hc!=(poly)NULL )
3847	{
3848	pGetCoeff(hc) = nInit(1);
3849
3850	for( i=rVar(currRing); i>0; i-- )
3851	{
3852	if( pGetExp( hc,i )>0 ) pDecrExp( hc,i );
3853	}
3854	pSetm( hc );
3855	}
3856	else
3857	{
3858	return spectrumNoHC;
3859	}
3860
3861	#ifdef SPECTRUM_DEBUG
3862	#ifdef SPECTRUM_PRINT
3863	#ifdef SPECTRUM_IOSTREAM
3864	cout << " ";
3865	#else
3866	fprintf( stdout," " );
3867	#endif
3868	pWrite( hc );
3869	#endif
3870	#endif
3871
3872	// ----------------------------------------
3873	// compute the Newton polygon nph of h
3874	// ----------------------------------------
3875
3876	#ifdef SPECTRUM_DEBUG
3877	#ifdef SPECTRUM_PRINT
3878	#ifdef SPECTRUM_IOSTREAM
3879	cout << "\n computing the newton polygon...\n";
3880	#else
3881	fprintf( stdout,"\n computing the newton polygon...\n" );
3882	#endif
3883	#endif
3884	#endif
3885
3886	newtonPolygon nph( h, currRing );
3887
3888	#ifdef SPECTRUM_DEBUG
3889	#ifdef SPECTRUM_PRINT
3890	cout << nph;
3891	#endif
3892	#endif
3893
3894	// -----------------------------------------------
3895	// compute the weight corner wc of (stdj,nph)
3896	// -----------------------------------------------
3897
3898	#ifdef SPECTRUM_DEBUG
3899	#ifdef SPECTRUM_PRINT
3900	#ifdef SPECTRUM_IOSTREAM
3901	cout << "\n computing the weight corner...\n";
3902	#else
3903	fprintf( stdout,"\n computing the weight corner...\n" );
3904	#endif
3905	#endif
3906	#endif
3907
3908	poly wc = ( fast==0 ? pCopy( hc ) :
3909	( fast==1 ? computeWC( nph,(Rational)rVar(currRing), currRing ) :
3910	/* fast==2 */computeWC( nph,
3911	((Rational)rVar(currRing))/(Rational)2, currRing ) ) );
3912
3913	#ifdef SPECTRUM_DEBUG
3914	#ifdef SPECTRUM_PRINT
3915	#ifdef SPECTRUM_IOSTREAM
3916	cout << " ";
3917	#else
3918	fprintf( stdout," " );
3919	#endif
3920	pWrite( wc );
3921	#endif
3922	#endif
3923
3924	// -------------
3925	// compute NF
3926	// -------------
3927
3928	#ifdef SPECTRUM_DEBUG
3929	#ifdef SPECTRUM_PRINT
3930	#ifdef SPECTRUM_IOSTREAM
3931	cout << "\n computing NF...\n" << endl;
3932	#else
3933	fprintf( stdout,"\n computing NF...\n" );
3934	#endif
3935	#endif
3936	#endif
3937
3938	spectrumPolyList NF( &nph );
3939
3940	computeNF( stdJ,hc,wc,&NF, currRing );
3941
3942	#ifdef SPECTRUM_DEBUG
3943	#ifdef SPECTRUM_PRINT
3944	cout << NF;
3945	#ifdef SPECTRUM_IOSTREAM
3946	cout << endl;
3947	#else
3948	fprintf( stdout,"\n" );
3949	#endif
3950	#endif
3951	#endif
3952
3953	// ----------------------------
3954	// compute the spectrum of h
3955	// ----------------------------
3956	// spectrumState spectrumStateFromList( spectrumPolyList& speclist, lists *L, int fast );
3957
3958	return spectrumStateFromList(NF, L, fast );
3959	}
3960
3961	// ----------------------------------------------------------------------------
3962	// this procedure is called from the interpreter
3963	// ----------------------------------------------------------------------------
3964	// first = polynomial
3965	// result = list of spectrum numbers
3966	// ----------------------------------------------------------------------------
3967
3968	void spectrumPrintError(spectrumState state)
3969	{
3970	switch( state )
3971	{
3972	case spectrumZero:
3973	WerrorS( "polynomial is zero" );
3974	break;
3975	case spectrumBadPoly:
3976	WerrorS( "polynomial has constant term" );
3977	break;
3978	case spectrumNoSingularity:
3979	WerrorS( "not a singularity" );
3980	break;
3981	case spectrumNotIsolated:
3982	WerrorS( "the singularity is not isolated" );
3983	break;
3984	case spectrumNoHC:
3985	WerrorS( "highest corner cannot be computed" );
3986	break;
3987	case spectrumDegenerate:
3988	WerrorS( "principal part is degenerate" );
3989	break;
3990	case spectrumOK:
3991	break;
3992
3993	default:
3994	WerrorS( "unknown error occurred" );
3995	break;
3996	}
3997	}
3998
3999	BOOLEAN spectrumProc( leftv result,leftv first )
4000	{
4001	spectrumState state = spectrumOK;
4002
4003	// -------------------
4004	// check consistency
4005	// -------------------
4006
4007	// check for a local ring
4008
4009	if( !ringIsLocal(currRing ) )
4010	{
4011	WerrorS( "only works for local orderings" );
4012	state = spectrumWrongRing;
4013	}
4014
4015	// no quotient rings are allowed
4016
4017	else if( currRing->qideal != NULL )
4018	{
4019	WerrorS( "does not work in quotient rings" );
4020	state = spectrumWrongRing;
4021	}
4022	else
4023	{
4024	lists L = (lists)NULL;
4025	int flag = 1; // weight corner optimization is safe
4026
4027	state = spectrumCompute( (poly)first->Data( ),&L,flag );
4028
4029	if( state==spectrumOK )
4030	{
4031	result->rtyp = LIST_CMD;
4032	result->data = (char*)L;
4033	}
4034	else
4035	{
4036	spectrumPrintError(state);
4037	}
4038	}
4039
4040	return (state!=spectrumOK);
4041	}
4042
4043	// ----------------------------------------------------------------------------
4044	// this procedure is called from the interpreter
4045	// ----------------------------------------------------------------------------
4046	// first = polynomial
4047	// result = list of spectrum numbers
4048	// ----------------------------------------------------------------------------
4049
4050	BOOLEAN spectrumfProc( leftv result,leftv first )
4051	{
4052	spectrumState state = spectrumOK;
4053
4054	// -------------------
4055	// check consistency
4056	// -------------------
4057
4058	// check for a local polynomial ring
4059
4060	if( currRing->OrdSgn != -1 )
4061	// ?? HS: the test above is also true for k[x][[y]], k[[x]][y]
4062	// or should we use:
4063	//if( !ringIsLocal( ) )
4064	{
4065	WerrorS( "only works for local orderings" );
4066	state = spectrumWrongRing;
4067	}
4068	else if( currRing->qideal != NULL )
4069	{
4070	WerrorS( "does not work in quotient rings" );
4071	state = spectrumWrongRing;
4072	}
4073	else
4074	{
4075	lists L = (lists)NULL;
4076	int flag = 2; // symmetric optimization
4077
4078	state = spectrumCompute( (poly)first->Data( ),&L,flag );
4079
4080	if( state==spectrumOK )
4081	{
4082	result->rtyp = LIST_CMD;
4083	result->data = (char*)L;
4084	}
4085	else
4086	{
4087	spectrumPrintError(state);
4088	}
4089	}
4090
4091	return (state!=spectrumOK);
4092	}
4093
4094	// ----------------------------------------------------------------------------
4095	// check if a list is a spectrum
4096	// check for:
4097	// list has 6 elements
4098	// 1st element is int (mu=Milnor number)
4099	// 2nd element is int (pg=geometrical genus)
4100	// 3rd element is int (n =number of different spectrum numbers)
4101	// 4th element is intvec (num=numerators)
4102	// 5th element is intvec (den=denomiantors)
4103	// 6th element is intvec (mul=multiplicities)
4104	// exactly n numerators
4105	// exactly n denominators
4106	// exactly n multiplicities
4107	// mu>0
4108	// pg>=0
4109	// n>0
4110	// num>0
4111	// den>0
4112	// mul>0
4113	// symmetriy with respect to numberofvariables/2
4114	// monotony
4115	// mu = sum of all multiplicities
4116	// pg = sum of all multiplicities where num/den<=1
4117	// ----------------------------------------------------------------------------
4118
4119	semicState list_is_spectrum( lists l )
4120	{
4121	// -------------------
4122	// check list length
4123	// -------------------
4124
4125	if( l->nr < 5 )
4126	{
4127	return semicListTooShort;
4128	}
4129	else if( l->nr > 5 )
4130	{
4131	return semicListTooLong;
4132	}
4133
4134	// -------------
4135	// check types
4136	// -------------
4137
4138	if( l->m[0].rtyp != INT_CMD )
4139	{
4140	return semicListFirstElementWrongType;
4141	}
4142	else if( l->m[1].rtyp != INT_CMD )
4143	{
4144	return semicListSecondElementWrongType;
4145	}
4146	else if( l->m[2].rtyp != INT_CMD )
4147	{
4148	return semicListThirdElementWrongType;
4149	}
4150	else if( l->m[3].rtyp != INTVEC_CMD )
4151	{
4152	return semicListFourthElementWrongType;
4153	}
4154	else if( l->m[4].rtyp != INTVEC_CMD )
4155	{
4156	return semicListFifthElementWrongType;
4157	}
4158	else if( l->m[5].rtyp != INTVEC_CMD )
4159	{
4160	return semicListSixthElementWrongType;
4161	}
4162
4163	// -------------------------
4164	// check number of entries
4165	// -------------------------
4166
4167	int mu = (int)(long)(l->m[0].Data( ));
4168	int pg = (int)(long)(l->m[1].Data( ));
4169	int n = (int)(long)(l->m[2].Data( ));
4170
4171	if( n <= 0 )
4172	{
4173	return semicListNNegative;
4174	}
4175
4176	intvec num = (intvec)l->m[3].Data( );
4177	intvec den = (intvec)l->m[4].Data( );
4178	intvec mul = (intvec)l->m[5].Data( );
4179
4180	if( n != num->length( ) )
4181	{
4182	return semicListWrongNumberOfNumerators;
4183	}
4184	else if( n != den->length( ) )
4185	{
4186	return semicListWrongNumberOfDenominators;
4187	}
4188	else if( n != mul->length( ) )
4189	{
4190	return semicListWrongNumberOfMultiplicities;
4191	}
4192
4193	// --------
4194	// values
4195	// --------
4196
4197	if( mu <= 0 )
4198	{
4199	return semicListMuNegative;
4200	}
4201	if( pg < 0 )
4202	{
4203	return semicListPgNegative;
4204	}
4205
4206	int i;
4207
4208	for( i=0; i<n; i++ )
4209	{
4210	if( (*num)[i] <= 0 )
4211	{
4212	return semicListNumNegative;
4213	}
4214	if( (*den)[i] <= 0 )
4215	{
4216	return semicListDenNegative;
4217	}
4218	if( (*mul)[i] <= 0 )
4219	{
4220	return semicListMulNegative;
4221	}
4222	}
4223
4224	// ----------------
4225	// check symmetry
4226	// ----------------
4227
4228	int j;
4229
4230	for( i=0, j=n-1; i<=j; i++,j-- )
4231	{
4232	if( (num)[i] != rVar(currRing)((den)[i]) - (num)[j] \|\|
4233	(den)[i] != (den)[j] \|\|
4234	(mul)[i] != (mul)[j] )
4235	{
4236	return semicListNotSymmetric;
4237	}
4238	}
4239
4240	// ----------------
4241	// check monotony
4242	// ----------------
4243
4244	for( i=0, j=1; i<n/2; i++,j++ )
4245	{
4246	if( (num)[i](den)[j] >= (num)[j](den)[i] )
4247	{
4248	return semicListNotMonotonous;
4249	}
4250	}
4251
4252	// ---------------------
4253	// check Milnor number
4254	// ---------------------
4255
4256	for( mu=0, i=0; i<n; i++ )
4257	{
4258	mu += (*mul)[i];
4259	}
4260
4261	if( mu != (int)(long)(l->m[0].Data( )) )
4262	{
4263	return semicListMilnorWrong;
4264	}
4265
4266	// -------------------------
4267	// check geometrical genus
4268	// -------------------------
4269
4270	for( pg=0, i=0; i<n; i++ )
4271	{
4272	if( (num)[i]<=(den)[i] )
4273	{
4274	pg += (*mul)[i];
4275	}
4276	}
4277
4278	if( pg != (int)(long)(l->m[1].Data( )) )
4279	{
4280	return semicListPGWrong;
4281	}
4282
4283	return semicOK;
4284	}
4285
4286	// ----------------------------------------------------------------------------
4287	// this procedure is called from the interpreter
4288	// ----------------------------------------------------------------------------
4289	// first = list of spectrum numbers
4290	// second = list of spectrum numbers
4291	// result = sum of the two lists
4292	// ----------------------------------------------------------------------------
4293
4294	BOOLEAN spaddProc( leftv result,leftv first,leftv second )
4295	{
4296	semicState state;
4297
4298	// -----------------
4299	// check arguments
4300	// -----------------
4301
4302	lists l1 = (lists)first->Data( );
4303	lists l2 = (lists)second->Data( );
4304
4305	if( (state=list_is_spectrum( l1 )) != semicOK )
4306	{
4307	WerrorS( "first argument is not a spectrum:" );
4308	list_error( state );
4309	}
4310	else if( (state=list_is_spectrum( l2 )) != semicOK )
4311	{
4312	WerrorS( "second argument is not a spectrum:" );
4313	list_error( state );
4314	}
4315	else
4316	{
4317	spectrum s1= spectrumFromList ( l1 );
4318	spectrum s2= spectrumFromList ( l2 );
4319	spectrum sum( s1+s2 );
4320
4321	result->rtyp = LIST_CMD;
4322	result->data = (char*)(getList(sum));
4323	}
4324
4325	return (state!=semicOK);
4326	}
4327
4328	// ----------------------------------------------------------------------------
4329	// this procedure is called from the interpreter
4330	// ----------------------------------------------------------------------------
4331	// first = list of spectrum numbers
4332	// second = integer
4333	// result = the multiple of the first list by the second factor
4334	// ----------------------------------------------------------------------------
4335
4336	BOOLEAN spmulProc( leftv result,leftv first,leftv second )
4337	{
4338	semicState state;
4339
4340	// -----------------
4341	// check arguments
4342	// -----------------
4343
4344	lists l = (lists)first->Data( );
4345	int k = (int)(long)second->Data( );
4346
4347	if( (state=list_is_spectrum( l ))!=semicOK )
4348	{
4349	WerrorS( "first argument is not a spectrum" );
4350	list_error( state );
4351	}
4352	else if( k < 0 )
4353	{
4354	WerrorS( "second argument should be positive" );
4355	state = semicMulNegative;
4356	}
4357	else
4358	{
4359	spectrum s= spectrumFromList( l );
4360	spectrum product( k*s );
4361
4362	result->rtyp = LIST_CMD;
4363	result->data = (char*)getList(product);
4364	}
4365
4366	return (state!=semicOK);
4367	}
4368
4369	// ----------------------------------------------------------------------------
4370	// this procedure is called from the interpreter
4371	// ----------------------------------------------------------------------------
4372	// first = list of spectrum numbers
4373	// second = list of spectrum numbers
4374	// result = semicontinuity index
4375	// ----------------------------------------------------------------------------
4376
4377	BOOLEAN semicProc3 ( leftv res,leftv u,leftv v,leftv w )
4378	{
4379	semicState state;
4380	BOOLEAN qh=(((int)(long)w->Data())==1);
4381
4382	// -----------------
4383	// check arguments
4384	// -----------------
4385
4386	lists l1 = (lists)u->Data( );
4387	lists l2 = (lists)v->Data( );
4388
4389	if( (state=list_is_spectrum( l1 ))!=semicOK )
4390	{
4391	WerrorS( "first argument is not a spectrum" );
4392	list_error( state );
4393	}
4394	else if( (state=list_is_spectrum( l2 ))!=semicOK )
4395	{
4396	WerrorS( "second argument is not a spectrum" );
4397	list_error( state );
4398	}
4399	else
4400	{
4401	spectrum s1= spectrumFromList( l1 );
4402	spectrum s2= spectrumFromList( l2 );
4403
4404	res->rtyp = INT_CMD;
4405	if (qh)
4406	res->data = (void*)(long)(s1.mult_spectrumh( s2 ));
4407	else
4408	res->data = (void*)(long)(s1.mult_spectrum( s2 ));
4409	}
4410
4411	// -----------------
4412	// check status
4413	// -----------------
4414
4415	return (state!=semicOK);
4416	}
4417	BOOLEAN semicProc ( leftv res,leftv u,leftv v )
4418	{
4419	sleftv tmp;
4420	memset(&tmp,0,sizeof(tmp));
4421	tmp.rtyp=INT_CMD;
4422	/* tmp.data = (void )0; -- done by memset /
4423
4424	return semicProc3(res,u,v,&tmp);
4425	}
4426
4427	#endif
4428
4429	BOOLEAN loNewtonP( leftv res, leftv arg1 )
4430	{
4431	res->data= (void*)loNewtonPolytope( (ideal)arg1->Data() );
4432	return FALSE;
4433	}
4434
4435	BOOLEAN loSimplex( leftv res, leftv args )
4436	{
4437	if ( !(rField_is_long_R(currRing)) )
4438	{
4439	WerrorS("Ground field not implemented!");
4440	return TRUE;
4441	}
4442
4443	simplex * LP;
4444	matrix m;
4445
4446	leftv v= args;
4447	if ( v->Typ() != MATRIX_CMD ) // 1: matrix
4448	return TRUE;
4449	else
4450	m= (matrix)(v->CopyD());
4451
4452	LP = new simplex(MATROWS(m),MATCOLS(m));
4453	LP->mapFromMatrix(m);
4454
4455	v= v->next;
4456	if ( v->Typ() != INT_CMD ) // 2: m = number of constraints
4457	return TRUE;
4458	else
4459	LP->m= (int)(long)(v->Data());
4460
4461	v= v->next;
4462	if ( v->Typ() != INT_CMD ) // 3: n = number of variables
4463	return TRUE;
4464	else
4465	LP->n= (int)(long)(v->Data());
4466
4467	v= v->next;
4468	if ( v->Typ() != INT_CMD ) // 4: m1 = number of <= constraints
4469	return TRUE;
4470	else
4471	LP->m1= (int)(long)(v->Data());
4472
4473	v= v->next;
4474	if ( v->Typ() != INT_CMD ) // 5: m2 = number of >= constraints
4475	return TRUE;
4476	else
4477	LP->m2= (int)(long)(v->Data());
4478
4479	v= v->next;
4480	if ( v->Typ() != INT_CMD ) // 6: m3 = number of == constraints
4481	return TRUE;
4482	else
4483	LP->m3= (int)(long)(v->Data());
4484
4485	#ifdef mprDEBUG_PROT
4486	Print("m (constraints) %d\n",LP->m);
4487	Print("n (columns) %d\n",LP->n);
4488	Print("m1 (<=) %d\n",LP->m1);
4489	Print("m2 (>=) %d\n",LP->m2);
4490	Print("m3 (==) %d\n",LP->m3);
4491	#endif
4492
4493	LP->compute();
4494
4495	lists lres= (lists)omAlloc( sizeof(slists) );
4496	lres->Init( 6 );
4497
4498	lres->m[0].rtyp= MATRIX_CMD; // output matrix
4499	lres->m[0].data=(void*)LP->mapToMatrix(m);
4500
4501	lres->m[1].rtyp= INT_CMD; // found a solution?
4502	lres->m[1].data=(void*)(long)LP->icase;
4503
4504	lres->m[2].rtyp= INTVEC_CMD;
4505	lres->m[2].data=(void*)LP->posvToIV();
4506
4507	lres->m[3].rtyp= INTVEC_CMD;
4508	lres->m[3].data=(void*)LP->zrovToIV();
4509
4510	lres->m[4].rtyp= INT_CMD;
4511	lres->m[4].data=(void*)(long)LP->m;
4512
4513	lres->m[5].rtyp= INT_CMD;
4514	lres->m[5].data=(void*)(long)LP->n;
4515
4516	res->data= (void*)lres;
4517
4518	return FALSE;
4519	}
4520
4521	BOOLEAN nuMPResMat( leftv res, leftv arg1, leftv arg2 )
4522	{
4523	ideal gls = (ideal)(arg1->Data());
4524	int imtype= (int)(long)arg2->Data();
4525
4526	uResultant::resMatType mtype= determineMType( imtype );
4527
4528	// check input ideal ( = polynomial system )
4529	if ( mprIdealCheck( gls, arg1->Name(), mtype, true ) != mprOk )
4530	{
4531	return TRUE;
4532	}
4533
4534	uResultant *resMat= new uResultant( gls, mtype, false );
4535	if (resMat!=NULL)
4536	{
4537	res->rtyp = MODUL_CMD;
4538	res->data= (void*)resMat->accessResMat()->getMatrix();
4539	if (!errorreported) delete resMat;
4540	}
4541	return errorreported;
4542	}
4543
4544	BOOLEAN nuLagSolve( leftv res, leftv arg1, leftv arg2, leftv arg3 )
4545	{
4546
4547	poly gls;
4548	gls= (poly)(arg1->Data());
4549	int howclean= (int)(long)arg3->Data();
4550
4551	if ( !(rField_is_R(currRing) \|\|
4552	rField_is_Q(currRing) \|\|
4553	rField_is_long_R(currRing) \|\|
4554	rField_is_long_C(currRing)) )
4555	{
4556	WerrorS("Ground field not implemented!");
4557	return TRUE;
4558	}
4559
4560	if ( !(rField_is_R(currRing) \|\| rField_is_long_R(currRing) \|\| \
4561	rField_is_long_C(currRing)) )
4562	{
4563	unsigned long int ii = (unsigned long int)arg2->Data();
4564	setGMPFloatDigits( ii, ii );
4565	}
4566
4567	if ( gls == NULL \|\| pIsConstant( gls ) )
4568	{
4569	WerrorS("Input polynomial is constant!");
4570	return TRUE;
4571	}
4572
4573	int ldummy;
4574	int deg= currRing->pLDeg( gls, &ldummy, currRing );
4575	// int deg= pDeg( gls );
4576	// int len= pLength( gls );
4577	int i,vpos=0;
4578	poly piter;
4579	lists elist;
4580	lists rlist;
4581
4582	elist= (lists)omAlloc( sizeof(slists) );
4583	elist->Init( 0 );
4584
4585	if ( rVar(currRing) > 1 )
4586	{
4587	piter= gls;
4588	for ( i= 1; i <= rVar(currRing); i++ )
4589	if ( pGetExp( piter, i ) )
4590	{
4591	vpos= i;
4592	break;
4593	}
4594	while ( piter )
4595	{
4596	for ( i= 1; i <= rVar(currRing); i++ )
4597	if ( (vpos != i) && (pGetExp( piter, i ) != 0) )
4598	{
4599	WerrorS("The input polynomial must be univariate!");
4600	return TRUE;
4601	}
4602	pIter( piter );
4603	}
4604	}
4605
4606	rootContainer * roots= new rootContainer();
4607	number * pcoeffs= (number )omAlloc( (deg+1) sizeof( number ) );
4608	piter= gls;
4609	for ( i= deg; i >= 0; i-- )
4610	{
4611	//if ( piter ) Print("deg %d, pDeg(piter) %d\n",i,pTotaldegree(piter));
4612	if ( piter && pTotaldegree(piter) == i )
4613	{
4614	pcoeffs[i]= nCopy( pGetCoeff( piter ) );
4615	//nPrint( pcoeffs[i] );PrintS(" ");
4616	pIter( piter );
4617	}
4618	else
4619	{
4620	pcoeffs[i]= nInit(0);
4621	}
4622	}
4623
4624	#ifdef mprDEBUG_PROT
4625	for (i=deg; i >= 0; i--)
4626	{
4627	nPrint( pcoeffs[i] );PrintS(" ");
4628	}
4629	PrintLn();
4630	#endif
4631
4632	roots->fillContainer( pcoeffs, NULL, 1, deg, rootContainer::onepoly, 1 );
4633	roots->solver( howclean );
4634
4635	int elem= roots->getAnzRoots();
4636	char *dummy;
4637	int j;
4638
4639	rlist= (lists)omAlloc( sizeof(slists) );
4640	rlist->Init( elem );
4641
4642	if (rField_is_long_C(currRing))
4643	{
4644	for ( j= 0; j < elem; j++ )
4645	{
4646	rlist->m[j].rtyp=NUMBER_CMD;
4647	rlist->m[j].data=(void *)nCopy((number)(roots->getRoot(j)));
4648	//rlist->m[j].data=(void *)(number)(roots->getRoot(j));
4649	}
4650	}
4651	else
4652	{
4653	for ( j= 0; j < elem; j++ )
4654	{
4655	dummy = complexToStr( (*roots)[j], gmp_output_digits, currRing->cf );
4656	rlist->m[j].rtyp=STRING_CMD;
4657	rlist->m[j].data=(void *)dummy;
4658	}
4659	}
4660
4661	elist->Clean();
4662	//omFreeSize( (ADDRESS) elist, sizeof(slists) );
4663
4664	// this is (via fillContainer) the same data as in root
4665	//for ( i= deg; i >= 0; i-- ) nDelete( &pcoeffs[i] );
4666	//omFreeSize( (ADDRESS) pcoeffs, (deg+1) * sizeof( number ) );
4667
4668	delete roots;
4669
4670	res->rtyp= LIST_CMD;
4671	res->data= (void*)rlist;
4672
4673	return FALSE;
4674	}
4675
4676	BOOLEAN nuVanderSys( leftv res, leftv arg1, leftv arg2, leftv arg3)
4677	{
4678	int i;
4679	ideal p,w;
4680	p= (ideal)arg1->Data();
4681	w= (ideal)arg2->Data();
4682
4683	// w[0] = f(p^0)
4684	// w[1] = f(p^1)
4685	// ...
4686	// p can be a vector of numbers (multivariate polynom)
4687	// or one number (univariate polynom)
4688	// tdg = deg(f)
4689
4690	int n= IDELEMS( p );
4691	int m= IDELEMS( w );
4692	int tdg= (int)(long)arg3->Data();
4693
4694	res->data= (void*)NULL;
4695
4696	// check the input
4697	if ( tdg < 1 )
4698	{
4699	WerrorS("Last input parameter must be > 0!");
4700	return TRUE;
4701	}
4702	if ( n != rVar(currRing) )
4703	{
4704	Werror("Size of first input ideal must be equal to %d!",rVar(currRing));
4705	return TRUE;
4706	}
4707	if ( m != (int)pow((double)tdg+1,(double)n) )
4708	{
4709	Werror("Size of second input ideal must be equal to %d!",
4710	(int)pow((double)tdg+1,(double)n));
4711	return TRUE;
4712	}
4713	if ( !(rField_is_Q(currRing) /* \|\|
4714	rField_is_R() \|\| rField_is_long_R() \|\|
4715	rField_is_long_C()*/ ) )
4716	{
4717	WerrorS("Ground field not implemented!");
4718	return TRUE;
4719	}
4720
4721	number tmp;
4722	number pevpoint= (number )omAlloc( n * sizeof( number ) );
4723	for ( i= 0; i < n; i++ )
4724	{
4725	pevpoint[i]=nInit(0);
4726	if ( (p->m)[i] )
4727	{
4728	tmp = pGetCoeff( (p->m)[i] );
4729	if ( nIsZero(tmp) \|\| nIsOne(tmp) \|\| nIsMOne(tmp) )
4730	{
4731	omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
4732	WerrorS("Elements of first input ideal must not be equal to -1, 0, 1!");
4733	return TRUE;
4734	}
4735	} else tmp= NULL;
4736	if ( !nIsZero(tmp) )
4737	{
4738	if ( !pIsConstant((p->m)[i]))
4739	{
4740	omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
4741	WerrorS("Elements of first input ideal must be numbers!");
4742	return TRUE;
4743	}
4744	pevpoint[i]= nCopy( tmp );
4745	}
4746	}
4747
4748	number wresults= (number )omAlloc( m * sizeof( number ) );
4749	for ( i= 0; i < m; i++ )
4750	{
4751	wresults[i]= nInit(0);
4752	if ( (w->m)[i] && !nIsZero(pGetCoeff((w->m)[i])) )
4753	{
4754	if ( !pIsConstant((w->m)[i]))
4755	{
4756	omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
4757	omFreeSize( (ADDRESS)wresults, m * sizeof( number ) );
4758	WerrorS("Elements of second input ideal must be numbers!");
4759	return TRUE;
4760	}
4761	wresults[i]= nCopy(pGetCoeff((w->m)[i]));
4762	}
4763	}
4764
4765	vandermonde vm( m, n, tdg, pevpoint, FALSE );
4766	number *ncpoly= vm.interpolateDense( wresults );
4767	// do not free ncpoly[]!!
4768	poly rpoly= vm.numvec2poly( ncpoly );
4769
4770	omFreeSize( (ADDRESS)pevpoint, n * sizeof( number ) );
4771	omFreeSize( (ADDRESS)wresults, m * sizeof( number ) );
4772
4773	res->data= (void*)rpoly;
4774	return FALSE;
4775	}
4776
4777	BOOLEAN nuUResSolve( leftv res, leftv args )
4778	{
4779	leftv v= args;
4780
4781	ideal gls;
4782	int imtype;
4783	int howclean;
4784
4785	// get ideal
4786	if ( v->Typ() != IDEAL_CMD )
4787	return TRUE;
4788	else gls= (ideal)(v->Data());
4789	v= v->next;
4790
4791	// get resultant matrix type to use (0,1)
4792	if ( v->Typ() != INT_CMD )
4793	return TRUE;
4794	else imtype= (int)(long)v->Data();
4795	v= v->next;
4796
4797	if (imtype==0)
4798	{
4799	ideal test_id=idInit(1,1);
4800	int j;
4801	for(j=IDELEMS(gls)-1;j>=0;j--)
4802	{
4803	if (gls->m[j]!=NULL)
4804	{
4805	test_id->m[0]=gls->m[j];
4806	intvec *dummy_w=id_QHomWeight(test_id, currRing);
4807	if (dummy_w!=NULL)
4808	{
4809	WerrorS("Newton polytope not of expected dimension");
4810	delete dummy_w;
4811	return TRUE;
4812	}
4813	}
4814	}
4815	}
4816
4817	// get and set precision in digits ( > 0 )
4818	if ( v->Typ() != INT_CMD )
4819	return TRUE;
4820	else if ( !(rField_is_R(currRing) \|\| rField_is_long_R(currRing) \|\| \
4821	rField_is_long_C(currRing)) )
4822	{
4823	unsigned long int ii=(unsigned long int)v->Data();
4824	setGMPFloatDigits( ii, ii );
4825	}
4826	v= v->next;
4827
4828	// get interpolation steps (0,1,2)
4829	if ( v->Typ() != INT_CMD )
4830	return TRUE;
4831	else howclean= (int)(long)v->Data();
4832
4833	uResultant::resMatType mtype= determineMType( imtype );
4834	int i,count;
4835	lists listofroots= NULL;
4836	number smv= NULL;
4837	BOOLEAN interpolate_det= (mtype==uResultant::denseResMat)?TRUE:FALSE;
4838
4839	//emptylist= (lists)omAlloc( sizeof(slists) );
4840	//emptylist->Init( 0 );
4841
4842	//res->rtyp = LIST_CMD;
4843	//res->data= (void *)emptylist;
4844
4845	// check input ideal ( = polynomial system )
4846	if ( mprIdealCheck( gls, args->Name(), mtype ) != mprOk )
4847	{
4848	return TRUE;
4849	}
4850
4851	uResultant * ures;
4852	rootContainer ** iproots;
4853	rootContainer ** muiproots;
4854	rootArranger * arranger;
4855
4856	// main task 1: setup of resultant matrix
4857	ures= new uResultant( gls, mtype );
4858	if ( ures->accessResMat()->initState() != resMatrixBase::ready )
4859	{
4860	WerrorS("Error occurred during matrix setup!");
4861	return TRUE;
4862	}
4863
4864	// if dense resultant, check if minor nonsingular
4865	if ( mtype == uResultant::denseResMat )
4866	{
4867	smv= ures->accessResMat()->getSubDet();
4868	#ifdef mprDEBUG_PROT
4869	PrintS("// Determinant of submatrix: ");nPrint(smv);PrintLn();
4870	#endif
4871	if ( nIsZero(smv) )
4872	{
4873	WerrorS("Unsuitable input ideal: Minor of resultant matrix is singular!");
4874	return TRUE;
4875	}
4876	}
4877
4878	// main task 2: Interpolate specialized resultant polynomials
4879	if ( interpolate_det )
4880	iproots= ures->interpolateDenseSP( false, smv );
4881	else
4882	iproots= ures->specializeInU( false, smv );
4883
4884	// main task 3: Interpolate specialized resultant polynomials
4885	if ( interpolate_det )
4886	muiproots= ures->interpolateDenseSP( true, smv );
4887	else
4888	muiproots= ures->specializeInU( true, smv );
4889
4890	#ifdef mprDEBUG_PROT
4891	int c= iproots[0]->getAnzElems();
4892	for (i=0; i < c; i++) pWrite(iproots[i]->getPoly());
4893	c= muiproots[0]->getAnzElems();
4894	for (i=0; i < c; i++) pWrite(muiproots[i]->getPoly());
4895	#endif
4896
4897	// main task 4: Compute roots of specialized polys and match them up
4898	arranger= new rootArranger( iproots, muiproots, howclean );
4899	arranger->solve_all();
4900
4901	// get list of roots
4902	if ( arranger->success() )
4903	{
4904	arranger->arrange();
4905	listofroots= listOfRoots(arranger, gmp_output_digits );
4906	}
4907	else
4908	{
4909	WerrorS("Solver was unable to find any roots!");
4910	return TRUE;
4911	}
4912
4913	// free everything
4914	count= iproots[0]->getAnzElems();
4915	for (i=0; i < count; i++) delete iproots[i];
4916	omFreeSize( (ADDRESS) iproots, count * sizeof(rootContainer*) );
4917	count= muiproots[0]->getAnzElems();
4918	for (i=0; i < count; i++) delete muiproots[i];
4919	omFreeSize( (ADDRESS) muiproots, count * sizeof(rootContainer*) );
4920
4921	delete ures;
4922	delete arranger;
4923	nDelete( &smv );
4924
4925	res->data= (void *)listofroots;
4926
4927	//emptylist->Clean();
4928	// omFreeSize( (ADDRESS) emptylist, sizeof(slists) );
4929
4930	return FALSE;
4931	}
4932
4933	// from mpr_numeric.cc
4934	lists listOfRoots( rootArranger* self, const unsigned int oprec )
4935	{
4936	int i,j;
4937	int count= self->roots[0]->getAnzRoots(); // number of roots
4938	int elem= self->roots[0]->getAnzElems(); // number of koordinates per root
4939
4940	lists listofroots= (lists)omAlloc( sizeof(slists) ); // must be done this way!
4941
4942	if ( self->found_roots )
4943	{
4944	listofroots->Init( count );
4945
4946	for (i=0; i < count; i++)
4947	{
4948	lists onepoint= (lists)omAlloc(sizeof(slists)); // must be done this way!
4949	onepoint->Init(elem);
4950	for ( j= 0; j < elem; j++ )
4951	{
4952	if ( !rField_is_long_C(currRing) )
4953	{
4954	onepoint->m[j].rtyp=STRING_CMD;
4955	onepoint->m[j].data=(void )complexToStr((self->roots[j])[i],oprec, currRing->cf);
4956	}
4957	else
4958	{
4959	onepoint->m[j].rtyp=NUMBER_CMD;
4960	onepoint->m[j].data=(void *)n_Copy((number)(self->roots[j]->getRoot(i)), currRing->cf);
4961	}
4962	onepoint->m[j].next= NULL;
4963	onepoint->m[j].name= NULL;
4964	}
4965	listofroots->m[i].rtyp=LIST_CMD;
4966	listofroots->m[i].data=(void *)onepoint;
4967	listofroots->m[j].next= NULL;
4968	listofroots->m[j].name= NULL;
4969	}
4970
4971	}
4972	else
4973	{
4974	listofroots->Init( 0 );
4975	}
4976
4977	return listofroots;
4978	}
4979
4980	// from ring.cc
4981	void rSetHdl(idhdl h)
4982	{
4983	ring rg = NULL;
4984	if (h!=NULL)
4985	{
4986	// Print(" new ring:%s (l:%d)\n",IDID(h),IDLEV(h));
4987	rg = IDRING(h);
4988	if (rg==NULL) return; //id <>NULL, ring==NULL
4989	omCheckAddrSize((ADDRESS)h,sizeof(idrec));
4990	if (IDID(h)) // OB: ????
4991	omCheckAddr((ADDRESS)IDID(h));
4992	rTest(rg);
4993	}
4994
4995	// clean up history
4996	if (sLastPrinted.RingDependend())
4997	{
4998	sLastPrinted.CleanUp();
4999	memset(&sLastPrinted,0,sizeof(sleftv));
5000	}
5001
5002	if ((rg!=currRing)&&(currRing!=NULL))
5003	{
5004	denominator_list dd=DENOMINATOR_LIST;
5005	if (DENOMINATOR_LIST!=NULL)
5006	{
5007	if (TEST_V_ALLWARN)
5008	Warn("deleting denom_list for ring change to %s",IDID(h));
5009	do
5010	{
5011	n_Delete(&(dd->n),currRing->cf);
5012	dd=dd->next;
5013	omFree(DENOMINATOR_LIST);
5014	DENOMINATOR_LIST=dd;
5015	} while(DENOMINATOR_LIST!=NULL);
5016	}
5017	}
5018
5019	// test for valid "currRing":
5020	if ((rg!=NULL) && (rg->idroot==NULL))
5021	{
5022	ring old=rg;
5023	rg=rAssure_HasComp(rg);
5024	if (old!=rg)
5025	{
5026	rKill(old);
5027	IDRING(h)=rg;
5028	}
5029	}
5030	/------------ change the global ring -----------------------/
5031	rChangeCurrRing(rg);
5032	currRingHdl = h;
5033	}
5034
5035	static leftv rOptimizeOrdAsSleftv(leftv ord)
5036	{
5037	// change some bad orderings/combination into better ones
5038	leftv h=ord;
5039	while(h!=NULL)
5040	{
5041	BOOLEAN change=FALSE;
5042	intvec iv = (intvec )(h->data);
5043	// ws(-i) -> wp(i)
5044	if ((*iv)[1]==ringorder_ws)
5045	{
5046	BOOLEAN neg=TRUE;
5047	for(int i=2;i<iv->length();i++)
5048	if((*iv)[i]>=0) { neg=FALSE; break; }
5049	if (neg)
5050	{
5051	(*iv)[1]=ringorder_wp;
5052	for(int i=2;i<iv->length();i++)
5053	(iv)[i]= - (iv)[i];
5054	change=TRUE;
5055	}
5056	}
5057	// Ws(-i) -> Wp(i)
5058	if ((*iv)[1]==ringorder_Ws)
5059	{
5060	BOOLEAN neg=TRUE;
5061	for(int i=2;i<iv->length();i++)
5062	if((*iv)[i]>=0) { neg=FALSE; break; }
5063	if (neg)
5064	{
5065	(*iv)[1]=ringorder_Wp;
5066	for(int i=2;i<iv->length();i++)
5067	(iv)[i]= -(iv)[i];
5068	change=TRUE;
5069	}
5070	}
5071	// wp(1) -> dp
5072	if ((*iv)[1]==ringorder_wp)
5073	{
5074	BOOLEAN all_one=TRUE;
5075	for(int i=2;i<iv->length();i++)
5076	if((*iv)[i]!=1) { all_one=FALSE; break; }
5077	if (all_one)
5078	{
5079	intvec *iv2=new intvec(3);
5080	(*iv2)[0]=1;
5081	(*iv2)[1]=ringorder_dp;
5082	(*iv2)[2]=iv->length()-2;
5083	delete iv;
5084	iv=iv2;
5085	h->data=iv2;
5086	change=TRUE;
5087	}
5088	}
5089	// Wp(1) -> Dp
5090	if ((*iv)[1]==ringorder_Wp)
5091	{
5092	BOOLEAN all_one=TRUE;
5093	for(int i=2;i<iv->length();i++)
5094	if((*iv)[i]!=1) { all_one=FALSE; break; }
5095	if (all_one)
5096	{
5097	intvec *iv2=new intvec(3);
5098	(*iv2)[0]=1;
5099	(*iv2)[1]=ringorder_Dp;
5100	(*iv2)[2]=iv->length()-2;
5101	delete iv;
5102	iv=iv2;
5103	h->data=iv2;
5104	change=TRUE;
5105	}
5106	}
5107	// dp(1)/Dp(1)/rp(1) -> lp(1)
5108	if (((*iv)[1]==ringorder_dp)
5109	\|\| ((*iv)[1]==ringorder_Dp)
5110	\|\| ((*iv)[1]==ringorder_rp))
5111	{
5112	if (iv->length()==3)
5113	{
5114	if ((*iv)[2]==1)
5115	{
5116	(*iv)[1]=ringorder_lp;
5117	change=TRUE;
5118	}
5119	}
5120	}
5121	// lp(i),lp(j) -> lp(i+j)
5122	if(((*iv)[1]==ringorder_lp)
5123	&& (h->next!=NULL))
5124	{
5125	intvec iv2 = (intvec )(h->next->data);
5126	if ((*iv2)[1]==ringorder_lp)
5127	{
5128	leftv hh=h->next;
5129	h->next=hh->next;
5130	hh->next=NULL;
5131	if ((*iv2)[0]==1)
5132	(*iv)[2] += 1; // last block unspecified, at least 1
5133	else
5134	(iv)[2] += (iv2)[2];
5135	hh->CleanUp();
5136	omFree(hh);
5137	change=TRUE;
5138	}
5139	}
5140	// -------------------
5141	if (!change) h=h->next;
5142	}
5143	return ord;
5144	}
5145
5146
5147	BOOLEAN rSleftvOrdering2Ordering(sleftv *ord, ring R)
5148	{
5149	int last = 0, o=0, n = 1, i=0, typ = 1, j;
5150	ord=rOptimizeOrdAsSleftv(ord);
5151	sleftv *sl = ord;
5152
5153	// determine nBlocks
5154	while (sl!=NULL)
5155	{
5156	intvec iv = (intvec )(sl->data);
5157	if (((iv)[1]==ringorder_c)\|\|((iv)[1]==ringorder_C))
5158	i++;
5159	else if ((*iv)[1]==ringorder_L)
5160	{
5161	R->bitmask=(*iv)[2];
5162	n--;
5163	}
5164	else if (((*iv)[1]!=ringorder_a)
5165	&& ((*iv)[1]!=ringorder_a64)
5166	&& ((*iv)[1]!=ringorder_am))
5167	o++;
5168	n++;
5169	sl=sl->next;
5170	}
5171	// check whether at least one real ordering
5172	if (o==0)
5173	{
5174	WerrorS("invalid combination of orderings");
5175	return TRUE;
5176	}
5177	// if no c/C ordering is given, increment n
5178	if (i==0) n++;
5179	else if (i != 1)
5180	{
5181	// throw error if more than one is given
5182	WerrorS("more than one ordering c/C specified");
5183	return TRUE;
5184	}
5185
5186	// initialize fields of R
5187	R->order=(int )omAlloc0(nsizeof(int));
5188	R->block0=(int )omAlloc0(nsizeof(int));
5189	R->block1=(int )omAlloc0(nsizeof(int));
5190	R->wvhdl=(int*)omAlloc0(nsizeof(int_ptr));
5191
5192	int weights=(int)omAlloc0((R->N+1)*sizeof(int));
5193
5194	// init order, so that rBlocks works correctly
5195	for (j=0; j < n-1; j++)
5196	R->order[j] = (int) ringorder_unspec;
5197	// set last _C order, if no c/C order was given
5198	if (i == 0) R->order[n-2] = ringorder_C;
5199
5200	/* init orders */
5201	sl=ord;
5202	n=-1;
5203	while (sl!=NULL)
5204	{
5205	intvec *iv;
5206	iv = (intvec *)(sl->data);
5207	if ((*iv)[1]!=ringorder_L)
5208	{
5209	n++;
5210
5211	/* the format of an ordering:
5212	* iv[0]: factor
5213	* iv[1]: ordering
5214	* iv[2..end]: weights
5215	*/
5216	R->order[n] = (*iv)[1];
5217	typ=1;
5218	switch ((*iv)[1])
5219	{
5220	case ringorder_ws:
5221	case ringorder_Ws:
5222	typ=-1;
5223	case ringorder_wp:
5224	case ringorder_Wp:
5225	R->wvhdl[n]=(int)omAlloc((iv->length()-1)sizeof(int));
5226	R->block0[n] = last+1;
5227	for (i=2; i<iv->length(); i++)
5228	{
5229	R->wvhdl[n][i-2] = (*iv)[i];
5230	last++;
5231	if (weights[last]==0) weights[last]=(iv)[i]typ;
5232	}
5233	R->block1[n] = si_min(last,R->N);
5234	break;
5235	case ringorder_ls:
5236	case ringorder_ds:
5237	case ringorder_Ds:
5238	case ringorder_rs:
5239	typ=-1;
5240	case ringorder_lp:
5241	case ringorder_dp:
5242	case ringorder_Dp:
5243	case ringorder_rp:
5244	R->block0[n] = last+1;
5245	if (iv->length() == 3) last+=(*iv)[2];
5246	else last += (*iv)[0];
5247	R->block1[n] = si_min(last,R->N);
5248	if (rCheckIV(iv)) return TRUE;
5249	for(i=si_min(rVar(R),R->block1[n]);i>=R->block0[n];i--)
5250	{
5251	if (weights[i]==0) weights[i]=typ;
5252	}
5253	break;
5254
5255	case ringorder_s: // no 'rank' params!
5256	{
5257
5258	if(iv->length() > 3)
5259	return TRUE;
5260
5261	if(iv->length() == 3)
5262	{
5263	const int s = (*iv)[2];
5264	R->block0[n] = s;
5265	R->block1[n] = s;
5266	}
5267	break;
5268	}
5269	case ringorder_IS:
5270	{
5271	if(iv->length() != 3) return TRUE;
5272
5273	const int s = (*iv)[2];
5274
5275	if( 1 < s \|\| s < -1 ) return TRUE;
5276
5277	R->block0[n] = s;
5278	R->block1[n] = s;
5279	break;
5280	}
5281	case ringorder_S:
5282	case ringorder_c:
5283	case ringorder_C:
5284	{
5285	if (rCheckIV(iv)) return TRUE;
5286	break;
5287	}
5288	case ringorder_aa:
5289	case ringorder_a:
5290	{
5291	R->block0[n] = last+1;
5292	R->block1[n] = si_min(last+iv->length()-2 , R->N);
5293	R->wvhdl[n] = (int)omAlloc((iv->length()-1)sizeof(int));
5294	for (i=2; i<iv->length(); i++)
5295	{
5296	R->wvhdl[n][i-2]=(*iv)[i];
5297	last++;
5298	if (weights[last]==0) weights[last]=(iv)[i]typ;
5299	}
5300	last=R->block0[n]-1;
5301	break;
5302	}
5303	case ringorder_am:
5304	{
5305	R->block0[n] = last+1;
5306	R->block1[n] = si_min(last+iv->length()-2 , R->N);
5307	R->wvhdl[n] = (int)omAlloc(iv->length()sizeof(int));
5308	if (R->block1[n]- R->block0[n]+2>=iv->length())
5309	WarnS("missing module weights");
5310	for (i=2; i<=(R->block1[n]-R->block0[n]+2); i++)
5311	{
5312	R->wvhdl[n][i-2]=(*iv)[i];
5313	last++;
5314	if (weights[last]==0) weights[last]=(iv)[i]typ;
5315	}
5316	R->wvhdl[n][i-2]=iv->length() -3 -(R->block1[n]- R->block0[n]);
5317	for (; i<iv->length(); i++)
5318	{
5319	R->wvhdl[n][i-1]=(*iv)[i];
5320	}
5321	last=R->block0[n]-1;
5322	break;
5323	}
5324	case ringorder_a64:
5325	{
5326	R->block0[n] = last+1;
5327	R->block1[n] = si_min(last+iv->length()-2 , R->N);
5328	R->wvhdl[n] = (int)omAlloc((iv->length()-1)sizeof(int64));
5329	int64 w=(int64 )R->wvhdl[n];
5330	for (i=2; i<iv->length(); i++)
5331	{
5332	w[i-2]=(*iv)[i];
5333	last++;
5334	if (weights[last]==0) weights[last]=(iv)[i]typ;
5335	}
5336	last=R->block0[n]-1;
5337	break;
5338	}
5339	case ringorder_M:
5340	{
5341	int Mtyp=rTypeOfMatrixOrder(iv);
5342	if (Mtyp==0) return TRUE;
5343	if (Mtyp==-1) typ = -1;
5344
5345	R->wvhdl[n] =( int )omAlloc((iv->length()-1)sizeof(int));
5346	for (i=2; i<iv->length();i++)
5347	R->wvhdl[n][i-2]=(*iv)[i];
5348
5349	R->block0[n] = last+1;
5350	last += (int)sqrt((double)(iv->length()-2));
5351	R->block1[n] = si_min(last,R->N);
5352	for(i=R->block1[n];i>=R->block0[n];i--)
5353	{
5354	if (weights[i]==0) weights[i]=typ;
5355	}
5356	break;
5357	}
5358
5359	case ringorder_no:
5360	R->order[n] = ringorder_unspec;
5361	return TRUE;
5362
5363	default:
5364	Werror("Internal Error: Unknown ordering %d", (*iv)[1]);
5365	R->order[n] = ringorder_unspec;
5366	return TRUE;
5367	}
5368	}
5369	if (last>R->N)
5370	{
5371	Werror("mismatch of number of vars (%d) and ordering (>=%d vars)",
5372	R->N,last);
5373	return TRUE;
5374	}
5375	sl=sl->next;
5376	}
5377	// find OrdSgn:
5378	R->OrdSgn = 1;
5379	for(i=1;i<=R->N;i++)
5380	{ if (weights[i]<0) { R->OrdSgn=-1;break; }}
5381	omFree(weights);
5382
5383	// check for complete coverage
5384	while ( n >= 0 && (
5385	(R->order[n]==ringorder_c)
5386	\|\| (R->order[n]==ringorder_C)
5387	\|\| (R->order[n]==ringorder_s)
5388	\|\| (R->order[n]==ringorder_S)
5389	\|\| (R->order[n]==ringorder_IS)
5390	)) n--;
5391
5392	assume( n >= 0 );
5393
5394	if (R->block1[n] != R->N)
5395	{
5396	if (((R->order[n]==ringorder_dp) \|\|
5397	(R->order[n]==ringorder_ds) \|\|
5398	(R->order[n]==ringorder_Dp) \|\|
5399	(R->order[n]==ringorder_Ds) \|\|
5400	(R->order[n]==ringorder_rp) \|\|
5401	(R->order[n]==ringorder_rs) \|\|
5402	(R->order[n]==ringorder_lp) \|\|
5403	(R->order[n]==ringorder_ls))
5404	&&
5405	R->block0[n] <= R->N)
5406	{
5407	R->block1[n] = R->N;
5408	}
5409	else
5410	{
5411	Werror("mismatch of number of vars (%d) and ordering (%d vars)",
5412	R->N,R->block1[n]);
5413	return TRUE;
5414	}
5415	}
5416	return FALSE;
5417	}
5418
5419	static BOOLEAN rSleftvList2StringArray(leftv sl, char** p)
5420	{
5421
5422	while(sl!=NULL)
5423	{
5424	if ((sl->rtyp == IDHDL)\|\|(sl->rtyp==ALIAS_CMD))
5425	{
5426	*p = omStrDup(sl->Name());
5427	}
5428	else if (sl->name!=NULL)
5429	{
5430	p = (char)sl->name;
5431	sl->name=NULL;
5432	}
5433	else if (sl->rtyp==POLY_CMD)
5434	{
5435	sleftv s_sl;
5436	iiConvert(POLY_CMD,ANY_TYPE,-1,sl,&s_sl);
5437	if (s_sl.name != NULL)
5438	{
5439	p = (char)s_sl.name; s_sl.name=NULL;
5440	}
5441	else
5442	*p = NULL;
5443	sl->next = s_sl.next;
5444	s_sl.next = NULL;
5445	s_sl.CleanUp();
5446	if (*p == NULL) return TRUE;
5447	}
5448	else return TRUE;
5449	p++;
5450	sl=sl->next;
5451	}
5452	return FALSE;
5453	}
5454
5455	const short MAX_SHORT = 32767; // (1 << (sizeof(short)*8)) - 1;
5456
5457	////////////////////
5458	//
5459	// rInit itself:
5460	//
5461	// INPUT: pn: ch & parameter (names), rv: variable (names)
5462	// ord: ordering (all !=NULL)
5463	// RETURN: currRingHdl on success
5464	// NULL on error
5465	// NOTE: * makes new ring to current ring, on success
5466	// * considers input sleftv's as read-only
5467	ring rInit(leftv pn, leftv rv, leftv ord)
5468	{
5469	#ifdef HAVE_RINGS
5470	//unsigned int ringtype = 0;
5471	mpz_ptr modBase = NULL;
5472	unsigned int modExponent = 1;
5473	#endif
5474	int float_len=0;
5475	int float_len2=0;
5476	ring R = NULL;
5477	//BOOLEAN ffChar=FALSE;
5478
5479	/* ch -------------------------------------------------------*/
5480	// get ch of ground field
5481
5482	// allocated ring
5483	R = (ring) omAlloc0Bin(sip_sring_bin);
5484
5485	coeffs cf = NULL;
5486
5487	assume( pn != NULL );
5488	const int P = pn->listLength();
5489
5490	#ifdef SINGULAR_4_1
5491	if (pn->Typ()==CRING_CMD)
5492	{
5493	cf=(coeffs)pn->CopyD();
5494	leftv pnn=pn;
5495	if(P>1) /parameter/
5496	{
5497	pnn = pnn->next;
5498	const int pars = pnn->listLength();
5499	assume( pars > 0 );
5500	char names = (char)omAlloc0(pars * sizeof(char_ptr));
5501
5502	if (rSleftvList2StringArray(pnn, names))
5503	{
5504	WerrorS("parameter expected");
5505	goto rInitError;
5506	}
5507
5508	TransExtInfo extParam;
5509
5510	extParam.r = rDefault( cf, pars, names); // Q/Zp [ p_1, ... p_pars ]
5511	for(int i=pars-1; i>=0;i--)
5512	{
5513	omFree(names[i]);
5514	}
5515	omFree(names);
5516
5517	cf = nInitChar(n_transExt, &extParam);
5518	}
5519	assume( cf != NULL );
5520	}
5521	else
5522	#endif
5523	if (pn->Typ()==INT_CMD)
5524	{
5525	int ch = (int)(long)pn->Data();
5526	leftv pnn=pn;
5527
5528	/* parameter? -------------------------------------------------------*/
5529	pnn = pnn->next;
5530
5531	if (pnn == NULL) // no params!?
5532	{
5533	if (ch!=0)
5534	{
5535	int ch2=IsPrime(ch);
5536	if ((ch<2)\|\|(ch!=ch2))
5537	{
5538	Warn("%d is invalid as characteristic of the ground field. 32003 is used.", ch);
5539	ch=32003;
5540	}
5541	cf = nInitChar(n_Zp, (void*)(long)ch);
5542	}
5543	else
5544	cf = nInitChar(n_Q, (void*)(long)ch);
5545	}
5546	else
5547	{
5548	const int pars = pnn->listLength();
5549
5550	assume( pars > 0 );
5551
5552	// predefined finite field: (p^k, a)
5553	if ((ch!=0) && (ch!=IsPrime(ch)) && (pars == 1))
5554	{
5555	GFInfo param;
5556
5557	param.GFChar = ch;
5558	param.GFDegree = 1;
5559	param.GFPar_name = pnn->name;
5560
5561	cf = nInitChar(n_GF, &param);
5562	}
5563	else // (0/p, a, b, ..., z)
5564	{
5565	if ((ch!=0) && (ch!=IsPrime(ch)))
5566	{
5567	WerrorS("too many parameters");
5568	goto rInitError;
5569	}
5570
5571	char names = (char)omAlloc0(pars * sizeof(char_ptr));
5572
5573	if (rSleftvList2StringArray(pnn, names))
5574	{
5575	WerrorS("parameter expected");
5576	goto rInitError;
5577	}
5578
5579	TransExtInfo extParam;
5580
5581	extParam.r = rDefault( ch, pars, names); // Q/Zp [ p_1, ... p_pars ]
5582	for(int i=pars-1; i>=0;i--)
5583	{
5584	omFree(names[i]);
5585	}
5586	omFree(names);
5587
5588	cf = nInitChar(n_transExt, &extParam);
5589	}
5590	}
5591
5592	// if (cf==NULL) goto rInitError;
5593	assume( cf != NULL );
5594	}
5595	else if ((pn->name != NULL)
5596	&& ((strcmp(pn->name,"real")==0) \|\| (strcmp(pn->name,"complex")==0)))
5597	{
5598	leftv pnn=pn->next;
5599	BOOLEAN complex_flag=(strcmp(pn->name,"complex")==0);
5600	if ((pnn!=NULL) && (pnn->Typ()==INT_CMD))
5601	{
5602	float_len=(int)(long)pnn->Data();
5603	float_len2=float_len;
5604	pnn=pnn->next;
5605	if ((pnn!=NULL) && (pnn->Typ()==INT_CMD))
5606	{
5607	float_len2=(int)(long)pnn->Data();
5608	pnn=pnn->next;
5609	}
5610	}
5611
5612	if (!complex_flag)
5613	complex_flag= (pnn!=NULL) && (pnn->name!=NULL);
5614	if( !complex_flag && (float_len2 <= (short)SHORT_REAL_LENGTH))
5615	cf=nInitChar(n_R, NULL);
5616	else // longR or longC?
5617	{
5618	LongComplexInfo param;
5619
5620	param.float_len = si_min (float_len, 32767);
5621	param.float_len2 = si_min (float_len2, 32767);
5622
5623	// set the parameter name
5624	if (complex_flag)
5625	{
5626	if (param.float_len < SHORT_REAL_LENGTH)
5627	{
5628	param.float_len= SHORT_REAL_LENGTH;
5629	param.float_len2= SHORT_REAL_LENGTH;
5630	}
5631	if ((pnn == NULL) \|\| (pnn->name == NULL))
5632	param.par_name=(const char*)"i"; //default to i
5633	else
5634	param.par_name = (const char*)pnn->name;
5635	}
5636
5637	cf = nInitChar(complex_flag ? n_long_C: n_long_R, (void*)&param);
5638	}
5639	assume( cf != NULL );
5640	}
5641	#ifdef HAVE_RINGS
5642	else if ((pn->name != NULL) && (strcmp(pn->name, "integer") == 0))
5643	{
5644	// TODO: change to use coeffs_BIGINT!?
5645	modBase = (mpz_ptr) omAlloc(sizeof(mpz_t));
5646	mpz_init_set_si(modBase, 0);
5647	if (pn->next!=NULL)
5648	{
5649	leftv pnn=pn;
5650	if (pnn->next->Typ()==INT_CMD)
5651	{
5652	pnn=pnn->next;
5653	mpz_set_ui(modBase, (int)(long) pnn->Data());
5654	if ((pnn->next!=NULL) && (pnn->next->Typ()==INT_CMD))
5655	{
5656	pnn=pnn->next;
5657	modExponent = (long) pnn->Data();
5658	}
5659	while ((pnn->next!=NULL) && (pnn->next->Typ()==INT_CMD))
5660	{
5661	pnn=pnn->next;
5662	mpz_mul_ui(modBase, modBase, (int)(long) pnn->Data());
5663	}
5664	}
5665	else if (pnn->next->Typ()==BIGINT_CMD)
5666	{
5667	number p=(number)pnn->next->CopyD();
5668	nlGMP(p,(number)modBase,coeffs_BIGINT); // TODO? // extern void nlGMP(number &i, number n, const coeffs r); // FIXME: n_MPZ( modBase, p, coeffs_BIGINT); ?
5669	n_Delete(&p,coeffs_BIGINT);
5670	}
5671	}
5672	else
5673	cf=nInitChar(n_Z,NULL);
5674
5675	if ((mpz_cmp_ui(modBase, 1) == 0) && (mpz_cmp_ui(modBase, 0) < 0))
5676	{
5677	Werror("Wrong ground ring specification (module is 1)");
5678	goto rInitError;
5679	}
5680	if (modExponent < 1)
5681	{
5682	Werror("Wrong ground ring specification (exponent smaller than 1");
5683	goto rInitError;
5684	}
5685	// module is 0 ---> integers ringtype = 4;
5686	// we have an exponent
5687	if (modExponent > 1 && cf == NULL)
5688	{
5689	if ((mpz_cmp_ui(modBase, 2) == 0) && (modExponent <= 8*sizeof(unsigned long)))
5690	{
5691	/* this branch should be active for modExponent = 2..32 resp. 2..64,
5692	depending on the size of a long on the respective platform */
5693	//ringtype = 1; // Use Z/2^ch
5694	cf=nInitChar(n_Z2m,(void*)(long)modExponent);
5695	mpz_clear(modBase);
5696	omFreeSize (modBase, sizeof (mpz_t));
5697	}
5698	else
5699	{
5700	if (mpz_cmp_ui(modBase,0)==0)
5701	{
5702	WerrorS("modulus must not be 0 or parameter not allowed");
5703	goto rInitError;
5704	}
5705	//ringtype = 3;
5706	ZnmInfo info;
5707	info.base= modBase;
5708	info.exp= modExponent;
5709	cf=nInitChar(n_Znm,(void*) &info); //exponent is missing
5710	}
5711	}
5712	// just a module m > 1
5713	else if (cf == NULL)
5714	{
5715	if (mpz_cmp_ui(modBase,0)==0)
5716	{
5717	WerrorS("modulus must not be 0 or parameter not allowed");
5718	goto rInitError;
5719	}
5720	//ringtype = 2;
5721	ZnmInfo info;
5722	info.base= modBase;
5723	info.exp= modExponent;
5724	cf=nInitChar(n_Zn,(void*) &info);
5725	}
5726	assume( cf != NULL );
5727	}
5728	#endif
5729	// ring NEW = OLD, (), (); where OLD is a polynomial ring...
5730	else if ((pn->Typ()==RING_CMD) && (P == 1))
5731	{
5732	TransExtInfo extParam;
5733	extParam.r = (ring)pn->Data();
5734	cf = nInitChar(n_transExt, &extParam);
5735	}
5736	else if ((pn->Typ()==QRING_CMD) && (P == 1)) // same for qrings - which should be fields!?
5737	{
5738	AlgExtInfo extParam;
5739	extParam.r = (ring)pn->Data();
5740
5741	cf = nInitChar(n_algExt, &extParam); // Q[a]/<minideal>
5742	}
5743	else
5744	{
5745	Werror("Wrong or unknown ground field specification");
5746	#ifndef SING_NDEBUG
5747	sleftv* p = pn;
5748	while (p != NULL)
5749	{
5750	Print( "pn[%p]: type: %d [%s]: %p, name: %s", (void*)p, p->Typ(), Tok2Cmdname(p->Typ()), p->Data(), (p->name == NULL? "NULL" : p->name) );
5751	PrintLn();
5752	p = p->next;
5753	}
5754	#endif
5755	goto rInitError;
5756	}
5757
5758	/every entry in the new ring is initialized to 0/
5759
5760	/* characteristic -----------------------------------------------*/
5761	/* input: 0 ch=0 : Q parameter=NULL ffChar=FALSE float_len
5762	* 0 1 : Q(a,...) *names FALSE
5763	* 0 -1 : R NULL FALSE 0
5764	* 0 -1 : R NULL FALSE prec. >6
5765	* 0 -1 : C *names FALSE prec. 0..?
5766	* p p : Fp NULL FALSE
5767	* p -p : Fp(a) *names FALSE
5768	* q q : GF(q=p^n) *names TRUE
5769	*/
5770	if (cf==NULL)
5771	{
5772	Werror("Invalid ground field specification");
5773	goto rInitError;
5774	// const int ch=32003;
5775	// cf=nInitChar(n_Zp, (void*)(long)ch);
5776	}
5777
5778	assume( R != NULL );
5779
5780	R->cf = cf;
5781
5782	/* names and number of variables-------------------------------------*/
5783	{
5784	int l=rv->listLength();
5785
5786	if (l>MAX_SHORT)
5787	{
5788	Werror("too many ring variables(%d), max is %d",l,MAX_SHORT);
5789	goto rInitError;
5790	}
5791	R->N = l; /rv->listLength();/
5792	}
5793	R->names = (char *)omAlloc0(R->N sizeof(char_ptr));
5794	if (rSleftvList2StringArray(rv, R->names))
5795	{
5796	WerrorS("name of ring variable expected");
5797	goto rInitError;
5798	}
5799
5800	/* check names and parameters for conflicts ------------------------- */
5801	rRenameVars(R); // conflicting variables will be renamed
5802	/* ordering -------------------------------------------------------------*/
5803	if (rSleftvOrdering2Ordering(ord, R))
5804	goto rInitError;
5805
5806	// Complete the initialization
5807	if (rComplete(R,1))
5808	goto rInitError;
5809
5810	/*#ifdef HAVE_RINGS
5811	// currently, coefficients which are ring elements require a global ordering:
5812	if (rField_is_Ring(R) && (R->OrdSgn==-1))
5813	{
5814	WerrorS("global ordering required for these coefficients");
5815	goto rInitError;
5816	}
5817	#endif*/
5818
5819	rTest(R);
5820
5821	// try to enter the ring into the name list
5822	// need to clean up sleftv here, before this ring can be set to
5823	// new currRing or currRing can be killed beacuse new ring has
5824	// same name
5825	pn->CleanUp();
5826	rv->CleanUp();
5827	ord->CleanUp();
5828	//if ((tmp = enterid(s, myynest, RING_CMD, &IDROOT))==NULL)
5829	// goto rInitError;
5830
5831	//memcpy(IDRING(tmp),R,sizeof(*R));
5832	// set current ring
5833	//omFreeBin(R, ip_sring_bin);
5834	//return tmp;
5835	return R;
5836
5837	// error case:
5838	rInitError:
5839	if ((R != NULL)&&(R->cf!=NULL)) rDelete(R);
5840	pn->CleanUp();
5841	rv->CleanUp();
5842	ord->CleanUp();
5843	return NULL;
5844	}
5845
5846	ring rSubring(ring org_ring, sleftv* rv)
5847	{
5848	ring R = rCopy0(org_ring);
5849	int perm=(int )omAlloc0((org_ring->N+1)*sizeof(int));
5850	int n = rBlocks(org_ring), i=0, j;
5851
5852	/* names and number of variables-------------------------------------*/
5853	{
5854	int l=rv->listLength();
5855	if (l>MAX_SHORT)
5856	{
5857	Werror("too many ring variables(%d), max is %d",l,MAX_SHORT);
5858	goto rInitError;
5859	}
5860	R->N = l; /rv->listLength();/
5861	}
5862	omFree(R->names);
5863	R->names = (char *)omAlloc0(R->N sizeof(char_ptr));
5864	if (rSleftvList2StringArray(rv, R->names))
5865	{
5866	WerrorS("name of ring variable expected");
5867	goto rInitError;
5868	}
5869
5870	/* check names for subring in org_ring ------------------------- */
5871	{
5872	i=0;
5873
5874	for(j=0;j<R->N;j++)
5875	{
5876	for(;i<org_ring->N;i++)
5877	{
5878	if (strcmp(org_ring->names[i],R->names[j])==0)
5879	{
5880	perm[i+1]=j+1;
5881	break;
5882	}
5883	}
5884	if (i>org_ring->N)
5885	{
5886	Werror("variable %d (%s) not in basering",j+1,R->names[j]);
5887	break;
5888	}
5889	}
5890	}
5891	//Print("perm=");
5892	//for(i=1;i<org_ring->N;i++) Print("v%d -> v%d\n",i,perm[i]);
5893	/* ordering -------------------------------------------------------------*/
5894
5895	for(i=0;i<n;i++)
5896	{
5897	int min_var=-1;
5898	int max_var=-1;
5899	for(j=R->block0[i];j<=R->block1[i];j++)
5900	{
5901	if (perm[j]>0)
5902	{
5903	if (min_var==-1) min_var=perm[j];
5904	max_var=perm[j];
5905	}
5906	}
5907	if (min_var!=-1)
5908	{
5909	//Print("block %d: old %d..%d, now:%d..%d\n",
5910	// i,R->block0[i],R->block1[i],min_var,max_var);
5911	R->block0[i]=min_var;
5912	R->block1[i]=max_var;
5913	if (R->wvhdl[i]!=NULL)
5914	{
5915	omFree(R->wvhdl[i]);
5916	R->wvhdl[i]=(int)omAlloc0((max_var-min_var+1)sizeof(int));
5917	for(j=org_ring->block0[i];j<=org_ring->block1[i];j++)
5918	{
5919	if (perm[j]>0)
5920	{
5921	R->wvhdl[i][perm[j]-R->block0[i]]=
5922	org_ring->wvhdl[i][j-org_ring->block0[i]];
5923	//Print("w%d=%d (orig_w%d)\n",perm[j],R->wvhdl[i][perm[j]-R->block0[i]],j);
5924	}
5925	}
5926	}
5927	}
5928	else
5929	{
5930	if(R->block0[i]>0)
5931	{
5932	//Print("skip block %d\n",i);
5933	R->order[i]=ringorder_unspec;
5934	if (R->wvhdl[i] !=NULL) omFree(R->wvhdl[i]);
5935	R->wvhdl[i]=NULL;
5936	}
5937	//else Print("keep block %d\n",i);
5938	}
5939	}
5940	i=n-1;
5941	while(i>0)
5942	{
5943	// removed unneded blocks
5944	if(R->order[i-1]==ringorder_unspec)
5945	{
5946	for(j=i;j<=n;j++)
5947	{
5948	R->order[j-1]=R->order[j];
5949	R->block0[j-1]=R->block0[j];
5950	R->block1[j-1]=R->block1[j];
5951	if (R->wvhdl[j-1] !=NULL) omFree(R->wvhdl[j-1]);
5952	R->wvhdl[j-1]=R->wvhdl[j];
5953	}
5954	R->order[n]=ringorder_unspec;
5955	n--;
5956	}
5957	i--;
5958	}
5959	n=rBlocks(org_ring)-1;
5960	while (R->order[n]==0) n--;
5961	while (R->order[n]==ringorder_unspec) n--;
5962	if ((R->order[n]==ringorder_c) \|\| (R->order[n]==ringorder_C)) n--;
5963	if (R->block1[n] != R->N)
5964	{
5965	if (((R->order[n]==ringorder_dp) \|\|
5966	(R->order[n]==ringorder_ds) \|\|
5967	(R->order[n]==ringorder_Dp) \|\|
5968	(R->order[n]==ringorder_Ds) \|\|
5969	(R->order[n]==ringorder_rp) \|\|
5970	(R->order[n]==ringorder_rs) \|\|
5971	(R->order[n]==ringorder_lp) \|\|
5972	(R->order[n]==ringorder_ls))
5973	&&
5974	R->block0[n] <= R->N)
5975	{
5976	R->block1[n] = R->N;
5977	}
5978	else
5979	{
5980	Werror("mismatch of number of vars (%d) and ordering (%d vars) in block %d",
5981	R->N,R->block1[n],n);
5982	return NULL;
5983	}
5984	}
5985	omFree(perm);
5986	// find OrdSgn:
5987	R->OrdSgn = org_ring->OrdSgn; // IMPROVE!
5988	//for(i=1;i<=R->N;i++)
5989	//{ if (weights[i]<0) { R->OrdSgn=-1;break; }}
5990	//omFree(weights);
5991	// Complete the initialization
5992	if (rComplete(R,1))
5993	goto rInitError;
5994
5995	rTest(R);
5996
5997	if (rv != NULL) rv->CleanUp();
5998
5999	return R;
6000
6001	// error case:
6002	rInitError:
6003	if (R != NULL) rDelete(R);
6004	if (rv != NULL) rv->CleanUp();
6005	return NULL;
6006	}
6007
6008	void rKill(ring r)
6009	{
6010	if ((r->ref<=0)&&(r->order!=NULL))
6011	{
6012	#ifdef RDEBUG
6013	if (traceit &TRACE_SHOW_RINGS) Print("kill ring %lx\n",(long)r);
6014	#endif
6015	if (r->qideal!=NULL)
6016	{
6017	id_Delete(&r->qideal, r);
6018	r->qideal = NULL;
6019	}
6020	int j;
6021	#ifdef USE_IILOCALRING
6022	for (j=0;j<myynest;j++)
6023	{
6024	if (iiLocalRing[j]==r)
6025	{
6026	if (j+1==myynest) Warn("killing the basering for level %d",j);
6027	iiLocalRing[j]=NULL;
6028	}
6029	}
6030	#else /* USE_IILOCALRING */
6031	//#endif /* USE_IILOCALRING */
6032	{
6033	proclevel * nshdl = procstack;
6034	int lev=myynest-1;
6035
6036	for(; nshdl != NULL; nshdl = nshdl->next)
6037	{
6038	if (nshdl->cRing==r)
6039	{
6040	Warn("killing the basering for level %d",lev);
6041	nshdl->cRing=NULL;
6042	nshdl->cRingHdl=NULL;
6043	}
6044	}
6045	}
6046	#endif /* USE_IILOCALRING */
6047	// any variables depending on r ?
6048	while (r->idroot!=NULL)
6049	{
6050	r->idroot->lev=myynest; // avoid warning about kill global objects
6051	killhdl2(r->idroot,&(r->idroot),r);
6052	}
6053	if (r==currRing)
6054	{
6055	// all dependend stuff is done, clean global vars:
6056	if ((currRing->ppNoether)!=NULL) pDelete(&(currRing->ppNoether));
6057	if (sLastPrinted.RingDependend())
6058	{
6059	sLastPrinted.CleanUp();
6060	}
6061	//if ((myynest>0) && (iiRETURNEXPR.RingDependend()))
6062	//{
6063	// WerrorS("return value depends on local ring variable (export missing ?)");
6064	// iiRETURNEXPR.CleanUp();
6065	//}
6066	currRing=NULL;
6067	currRingHdl=NULL;
6068	}
6069
6070	/* nKillChar(r); will be called from inside of rDelete */
6071	rDelete(r);
6072	return;
6073	}
6074	r->ref--;
6075	}
6076
6077	void rKill(idhdl h)
6078	{
6079	ring r = IDRING(h);
6080	int ref=0;
6081	if (r!=NULL)
6082	{
6083	ref=r->ref;
6084	rKill(r);
6085	}
6086	if (h==currRingHdl)
6087	{
6088	if (ref<=0) { currRing=NULL; currRingHdl=NULL;}
6089	else
6090	{
6091	currRingHdl=rFindHdl(r,currRingHdl);
6092	}
6093	}
6094	}
6095
6096	idhdl rSimpleFindHdl(ring r, idhdl root, idhdl n)
6097	{
6098	//idhdl next_best=NULL;
6099	idhdl h=root;
6100	while (h!=NULL)
6101	{
6102	if (((IDTYP(h)==RING_CMD)\|\|(IDTYP(h)==QRING_CMD))
6103	&& (h!=n)
6104	&& (IDRING(h)==r)
6105	)
6106	{
6107	// if (IDLEV(h)==myynest)
6108	// return h;
6109	// if ((IDLEV(h)==0) \|\| (next_best==NULL))
6110	// next_best=h;
6111	// else if (IDLEV(next_best)<IDLEV(h))
6112	// next_best=h;
6113	return h;
6114	}
6115	h=IDNEXT(h);
6116	}
6117	//return next_best;
6118	return NULL;
6119	}
6120
6121	extern BOOLEAN jjPROC(leftv res, leftv u, leftv v);
6122	ideal kGroebner(ideal F, ideal Q)
6123	{
6124	//test\|=Sy_bit(OPT_PROT);
6125	idhdl save_ringhdl=currRingHdl;
6126	ideal resid;
6127	idhdl new_ring=NULL;
6128	if ((currRingHdl==NULL) \|\| (IDRING(currRingHdl)!=currRing))
6129	{
6130	currRingHdl=enterid(omStrDup(" GROEBNERring"),0,RING_CMD,&IDROOT,FALSE);
6131	new_ring=currRingHdl;
6132	IDRING(currRingHdl)=currRing;
6133	}
6134	sleftv v; memset(&v,0,sizeof(v)); v.rtyp=IDEAL_CMD; v.data=(char *) F;
6135	idhdl h=ggetid("groebner");
6136	sleftv u; memset(&u,0,sizeof(u)); u.rtyp=IDHDL; u.data=(char *) h;
6137	u.name=IDID(h);
6138
6139	sleftv res; memset(&res,0,sizeof(res));
6140	if(jjPROC(&res,&u,&v))
6141	{
6142	resid=kStd(F,Q,testHomog,NULL);
6143	}
6144	else
6145	{
6146	//printf("typ:%d\n",res.rtyp);
6147	resid=(ideal)(res.data);
6148	}
6149	// cleanup GROEBNERring, save_ringhdl, u,v,(res )
6150	if (new_ring!=NULL)
6151	{
6152	idhdl h=IDROOT;
6153	if (h==new_ring) IDROOT=h->next;
6154	else
6155	{
6156	while ((h!=NULL) &&(h->next!=new_ring)) h=h->next;
6157	if (h!=NULL) h->next=h->next->next;
6158	}
6159	if (h!=NULL) omFreeSize(h,sizeof(*h));
6160	}
6161	currRingHdl=save_ringhdl;
6162	u.CleanUp();
6163	v.CleanUp();
6164	return resid;
6165	}
6166
6167	static void jjINT_S_TO_ID(int n,int *e, leftv res)
6168	{
6169	if (n==0) n=1;
6170	ideal l=idInit(n,1);
6171	int i;
6172	poly p;
6173	for(i=rVar(currRing);i>0;i--)
6174	{
6175	if (e[i]>0)
6176	{
6177	n--;
6178	p=pOne();
6179	pSetExp(p,i,1);
6180	pSetm(p);
6181	l->m[n]=p;
6182	if (n==0) break;
6183	}
6184	}
6185	res->data=(char*)l;
6186	setFlag(res,FLAG_STD);
6187	omFreeSize((ADDRESS)e,(rVar(currRing)+1)*sizeof(int));
6188	}
6189	BOOLEAN jjVARIABLES_P(leftv res, leftv u)
6190	{
6191	int e=(int )omAlloc0((rVar(currRing)+1)*sizeof(int));
6192	int n=pGetVariables((poly)u->Data(),e);
6193	jjINT_S_TO_ID(n,e,res);
6194	return FALSE;
6195	}
6196
6197	BOOLEAN jjVARIABLES_ID(leftv res, leftv u)
6198	{
6199	int e=(int )omAlloc0((rVar(currRing)+1)*sizeof(int));
6200	ideal I=(ideal)u->Data();
6201	int i;
6202	int n=0;
6203	for(i=I->nrows*I->ncols-1;i>=0;i--)
6204	{
6205	int n0=pGetVariables(I->m[i],e);
6206	if (n0>n) n=n0;
6207	}
6208	jjINT_S_TO_ID(n,e,res);
6209	return FALSE;
6210	}
6211
6212	void paPrint(const char *n,package p)
6213	{
6214	Print(" %s (",n);
6215	switch (p->language)
6216	{
6217	case LANG_SINGULAR: PrintS("S"); break;
6218	case LANG_C: PrintS("C"); break;
6219	case LANG_TOP: PrintS("T"); break;
6220	case LANG_NONE: PrintS("N"); break;
6221	default: PrintS("U");
6222	}
6223	if(p->libname!=NULL)
6224	Print(",%s", p->libname);
6225	PrintS(")");
6226	}
6227
6228	BOOLEAN iiApplyINTVEC(leftv res, leftv a, int op, leftv proc)
6229	{
6230	intvec aa=(intvec)a->Data();
6231	sleftv tmp_out;
6232	sleftv tmp_in;
6233	leftv curr=res;
6234	BOOLEAN bo=FALSE;
6235	for(int i=0;i<aa->length(); i++)
6236	{
6237	memset(&tmp_in,0,sizeof(tmp_in));
6238	tmp_in.rtyp=INT_CMD;
6239	tmp_in.data=(void)(long)(aa)[i];
6240	if (proc==NULL)
6241	bo=iiExprArith1(&tmp_out,&tmp_in,op);
6242	else
6243	bo=jjPROC(&tmp_out,proc,&tmp_in);
6244	if (bo)
6245	{
6246	res->CleanUp(currRing);
6247	Werror("apply fails at index %d",i+1);
6248	return TRUE;
6249	}
6250	if (i==0) { memcpy(res,&tmp_out,sizeof(tmp_out)); }
6251	else
6252	{
6253	curr->next=(leftv)omAllocBin(sleftv_bin);
6254	curr=curr->next;
6255	memcpy(curr,&tmp_out,sizeof(tmp_out));
6256	}
6257	}
6258	return FALSE;
6259	}
6260	BOOLEAN iiApplyBIGINTMAT(leftv res, leftv a, int op, leftv proc)
6261	{
6262	WerrorS("not implemented");
6263	return TRUE;
6264	}
6265	BOOLEAN iiApplyIDEAL(leftv res, leftv a, int op, leftv proc)
6266	{
6267	WerrorS("not implemented");
6268	return TRUE;
6269	}
6270	BOOLEAN iiApplyLIST(leftv res, leftv a, int op, leftv proc)
6271	{
6272	lists aa=(lists)a->Data();
6273	sleftv tmp_out;
6274	sleftv tmp_in;
6275	leftv curr=res;
6276	BOOLEAN bo=FALSE;
6277	for(int i=0;i<=aa->nr; i++)
6278	{
6279	memset(&tmp_in,0,sizeof(tmp_in));
6280	tmp_in.Copy(&(aa->m[i]));
6281	if (proc==NULL)
6282	bo=iiExprArith1(&tmp_out,&tmp_in,op);
6283	else
6284	bo=jjPROC(&tmp_out,proc,&tmp_in);
6285	tmp_in.CleanUp();
6286	if (bo)
6287	{
6288	res->CleanUp(currRing);
6289	Werror("apply fails at index %d",i+1);
6290	return TRUE;
6291	}
6292	if (i==0) { memcpy(res,&tmp_out,sizeof(tmp_out)); }
6293	else
6294	{
6295	curr->next=(leftv)omAllocBin(sleftv_bin);
6296	curr=curr->next;
6297	memcpy(curr,&tmp_out,sizeof(tmp_out));
6298	}
6299	}
6300	return FALSE;
6301	}
6302	BOOLEAN iiApply(leftv res, leftv a, int op, leftv proc)
6303	{
6304	memset(res,0,sizeof(sleftv));
6305	res->rtyp=a->Typ();
6306	switch (res->rtyp /a->Typ()/)
6307	{
6308	case INTVEC_CMD:
6309	case INTMAT_CMD:
6310	return iiApplyINTVEC(res,a,op,proc);
6311	case BIGINTMAT_CMD:
6312	return iiApplyBIGINTMAT(res,a,op,proc);
6313	case IDEAL_CMD:
6314	case MODUL_CMD:
6315	case MATRIX_CMD:
6316	return iiApplyIDEAL(res,a,op,proc);
6317	case LIST_CMD:
6318	return iiApplyLIST(res,a,op,proc);
6319	}
6320	WerrorS("first argument to `apply` must allow an index");
6321	return TRUE;
6322	}
6323
6324	BOOLEAN iiTestAssume(leftv a, leftv b)
6325	{
6326	// assume a: level
6327	if ((a->Typ()==INT_CMD)&&((long)a->Data()>=0))
6328	{
6329	if ((TEST_V_ALLWARN) && (myynest==0)) WarnS("ASSUME at top level is of no use: see documentation");
6330	char assume_yylinebuf[80];
6331	strncpy(assume_yylinebuf,my_yylinebuf,79);
6332	int lev=(long)a->Data();
6333	int startlev=0;
6334	idhdl h=ggetid("assumeLevel");
6335	if ((h!=NULL)&&(IDTYP(h)==INT_CMD)) startlev=(long)IDINT(h);
6336	if(lev <=startlev)
6337	{
6338	BOOLEAN bo=b->Eval();
6339	if (bo) { WerrorS("syntax error in ASSUME");return TRUE;}
6340	if (b->Typ()!=INT_CMD) { WerrorS("ASUMME(<level>,<int expr>)");return TRUE; }
6341	if (b->Data()==NULL) { Werror("ASSUME failed:%s",assume_yylinebuf);return TRUE;}
6342	}
6343	}
6344	b->CleanUp();
6345	a->CleanUp();
6346	return FALSE;
6347	}
6348
6349	#include "libparse.h"
6350
6351	BOOLEAN iiARROW(leftv r, char* a, char *s)
6352	{
6353	char ss=(char)omAlloc(strlen(a)+strlen(s)+30); /* max. 27 currently */
6354	// find end of s:
6355	int end_s=strlen(s);
6356	while ((end_s>0) && ((s[end_s]<=' ')\|\|(s[end_s]==';'))) end_s--;
6357	s[end_s+1]='\0';
6358	char name=(char )omAlloc(strlen(a)+strlen(s)+30);
6359	sprintf(name,"%s->%s",a,s);
6360	// find start of last expression
6361	int start_s=end_s-1;
6362	while ((start_s>=0) && (s[start_s]!=';')) start_s--;
6363	if (start_s<0) // ';' not found
6364	{
6365	sprintf(ss,"parameter def %s;return(%s);\n",a,s);
6366	}
6367	else // s[start_s] is ';'
6368	{
6369	s[start_s]='\0';
6370	sprintf(ss,"parameter def %s;%s;return(%s);\n",a,s,s+start_s+1);
6371	}
6372	memset(r,0,sizeof(*r));
6373	// now produce procinfo for PROC_CMD:
6374	r->data = (void *)omAlloc0Bin(procinfo_bin);
6375	((procinfo *)(r->data))->language=LANG_NONE;
6376	iiInitSingularProcinfo((procinfo *)r->data,"",name,0,0);
6377	((procinfo *)r->data)->data.s.body=ss;
6378	omFree(name);
6379	r->rtyp=PROC_CMD;
6380	//r->rtyp=STRING_CMD;
6381	//r->data=ss;
6382	return FALSE;
6383	}
6384
6385	BOOLEAN iiAssignCR(leftv r, leftv arg)
6386	{
6387	int t=arg->Typ();
6388	char* ring_name=omStrDup((char*)r->Name());
6389	if ((t==RING_CMD) \|\|(t==QRING_CMD))
6390	{
6391	sleftv tmp;
6392	memset(&tmp,0,sizeof(tmp));
6393	tmp.rtyp=IDHDL;
6394	tmp.data=(char*)rDefault(ring_name);
6395	if (tmp.data!=NULL)
6396	{
6397	BOOLEAN b=iiAssign(&tmp,arg);
6398	if (b) return TRUE;
6399	rSetHdl(ggetid(ring_name));
6400	omFree(ring_name);
6401	return FALSE;
6402	}
6403	else
6404	return TRUE;
6405	}
6406	#ifdef SINGULAR_4_1
6407	else if (t==CRING_CMD)
6408	{
6409	sleftv tmp;
6410	sleftv n;
6411	memset(&n,0,sizeof(n));
6412	n.name=ring_name;
6413	if (iiDeclCommand(&tmp,&n,myynest,CRING_CMD,&IDROOT)) return TRUE;
6414	if (iiAssign(&tmp,arg)) return TRUE;
6415	//Print("create %s\n",r->Name());
6416	//Print("from %s(%d)\n",Tok2Cmdname(arg->Typ()),arg->Typ());
6417	return FALSE;
6418	}
6419	#endif
6420	//Print("create %s\n",r->Name());
6421	//Print("from %s(%d)\n",Tok2Cmdname(arg->Typ()),arg->Typ());
6422	return TRUE;// not handled -> error for now
6423	}
6424
6425	static void iiReportTypes(int nr,int t,const short *T)
6426	{
6427	char buf=(char)omAlloc(250);
6428	buf[0]='\0';
6429	if (nr==0)
6430	sprintf(buf,"wrong length of parameters(%d), expected ",t);
6431	else
6432	sprintf(buf,"par. %d is of type `%s`, expected ",nr,Tok2Cmdname(t));
6433	for(int i=1;i<=T[0];i++)
6434	{
6435	strcat(buf,"`");
6436	strcat(buf,Tok2Cmdname(T[i]));
6437	strcat(buf,"`");
6438	if (i<T[0]) strcat(buf,",");
6439	}
6440	WerrorS(buf);
6441	}
6442
6443	BOOLEAN iiCheckTypes(leftv args, const short *type_list, int report)
6444	{
6445	if (args==NULL)
6446	{
6447	if (type_list[0]==0) return TRUE;
6448	else
6449	{
6450	if (report) WerrorS("no arguments expected");
6451	return FALSE;
6452	}
6453	}
6454	int l=args->listLength();
6455	if (l!=(int)type_list[0])
6456	{
6457	if (report) iiReportTypes(0,l,type_list);
6458	return FALSE;
6459	}
6460	for(int i=1;i<=l;i++,args=args->next)
6461	{
6462	short t=type_list[i];
6463	if (t!=ANY_TYPE)
6464	{
6465	if (((t==IDHDL)&&(args->rtyp!=IDHDL))
6466	\|\| (t!=args->Typ()))
6467	{
6468	if (report) iiReportTypes(i,args->Typ(),type_list);
6469	return FALSE;
6470	}
6471	}
6472	}
6473	return TRUE;
6474	}

Note: See TracBrowser for help on using the repository browser.

Download in other formats: