source: git/Singular/ipshell.cc @ 7d51c4

fieker-DuValspielwiese
Last change on this file since 7d51c4 was cd22d1a, checked in by Hans Schönemann <hannes@…>, 21 years ago
*hannes: modified IsPrime: now also for p>32003, faster git-svn-id: file:///usr/local/Singular/svn/trunk@6452 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 25.8 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: ipshell.cc,v 1.79 2003-01-31 09:04:38 Singular Exp $ */
5/*
6* ABSTRACT:
7*/
8
9//#include <stdlib.h>
10#include <stdio.h>
11#include <string.h>
12#include <ctype.h>
13#include <math.h>
14
15#include "mod2.h"
16#include "tok.h"
17#include "ipid.h"
18#include "intvec.h"
19#include "omalloc.h"
20#include "febase.h"
21#include "polys.h"
22#include "ideals.h"
23#include "matpol.h"
24#include "kstd1.h"
25#include "ring.h"
26#include "subexpr.h"
27#include "maps.h"
28#include "syz.h"
29#include "numbers.h"
30#include "lists.h"
31#include "attrib.h"
32#include "ipconv.h"
33#include "silink.h"
34#include "stairc.h"
35#include "ipshell.h"
36#ifdef HAVE_FACTORY
37#define SI_DONT_HAVE_GLOBAL_VARS
38#include <factory.h>
39#endif
40
41// define this if you want to use the fast_map routine for mapping ideals
42#define FAST_MAP
43
44#ifdef FAST_MAP
45#include "fast_maps.h"
46#endif
47
48leftv iiCurrArgs=NULL;
49int  traceit = 0;
50char *lastreserved=NULL;
51
52int  myynest = -1;
53
54static BOOLEAN iiNoKeepRing=TRUE;
55
56/*0 implementation*/
57
58char * Tok2Cmdname(int tok)
59{
60  int i = 0;
61  if (tok < 0)
62  {
63    return cmds[0].name;
64  }
65  if (tok==ANY_TYPE) return "any_type";
66  if (tok==NONE) return "nothing";
67  //if (tok==IFBREAK) return "if_break";
68  //if (tok==VECTOR_FROM_POLYS) return "vector_from_polys";
69  //if (tok==ORDER_VECTOR) return "ordering";
70  //if (tok==REF_VAR) return "ref";
71  //if (tok==OBJECT) return "object";
72  //if (tok==PRINT_EXPR) return "print_expr";
73  if (tok==IDHDL) return "identifier";
74  while (cmds[i].tokval!=0)
75  {
76    if ((cmds[i].tokval == tok)&&(cmds[i].alias==0))
77    {
78      return cmds[i].name;
79    }
80    i++;
81  }
82  return cmds[0].name;
83}
84
85char * iiTwoOps(int t)
86{
87  if (t<127)
88  {
89    static char ch[2];
90    switch (t)
91    {
92      case '&':
93        return "and";
94      case '|':
95        return "or";
96      default:
97        ch[0]=t;
98        ch[1]='\0';
99        return ch;
100    }
101  }
102  switch (t)
103  {
104    case COLONCOLON:  return "::";
105    case DOTDOT:      return "..";
106    //case PLUSEQUAL:   return "+=";
107    //case MINUSEQUAL:  return "-=";
108    case MINUSMINUS:  return "--";
109    case PLUSPLUS:    return "++";
110    case EQUAL_EQUAL: return "==";
111    case LE:          return "<=";
112    case GE:          return ">=";
113    case NOTEQUAL:    return "<>";
114    default:          return Tok2Cmdname(t);
115  }
116}
117
118static void list1(char* s, idhdl h,BOOLEAN c, BOOLEAN fullname)
119{
120  char buffer[22];
121  int l;
122  char buf2[128];
123
124  if(fullname) sprintf(buf2, "%s::%s", "", IDID(h));
125  else sprintf(buf2, "%s", IDID(h));
126
127  Print("%s%-20.20s [%d]  ",s,buf2,IDLEV(h));
128  if (h == currRingHdl) PrintS("*");
129  PrintS(Tok2Cmdname((int)IDTYP(h)));
130
131  ipListFlag(h);
132  switch(IDTYP(h))
133  {
134    case INT_CMD:   Print(" %d",IDINT(h)); break;
135    case INTVEC_CMD:Print(" (%d)",IDINTVEC(h)->length()); break;
136    case INTMAT_CMD:Print(" %d x %d",IDINTVEC(h)->rows(),IDINTVEC(h)->cols());
137                    break;
138    case POLY_CMD:
139    case VECTOR_CMD:if (c)
140                    {
141                      PrintS(" ");wrp(IDPOLY(h));
142                      if(IDPOLY(h) != NULL)
143                      {
144                        Print(", %d monomial(s)",pLength(IDPOLY(h)));
145                      }
146                    }
147                    break;
148    case MODUL_CMD: Print(", rk %d", IDIDEAL(h)->rank);
149    case IDEAL_CMD: Print(", %u generator(s)",
150                    IDELEMS(IDIDEAL(h)),IDIDEAL(h)->rank); break;
151    case MAP_CMD:
152                    Print(" from %s",IDMAP(h)->preimage); break;
153    case MATRIX_CMD:Print(" %u x %u"
154                      ,MATROWS(IDMATRIX(h))
155                      ,MATCOLS(IDMATRIX(h))
156                    );
157                    break;
158    case PACKAGE_CMD:
159                    PrintS(" (");
160                    switch (IDPACKAGE(h)->language)
161                    {
162                        case LANG_SINGULAR: PrintS("S"); break;
163                        case LANG_C:        PrintS("C"); break;
164                        case LANG_TOP:      PrintS("T"); break;
165                        case LANG_NONE:     PrintS("N"); break;
166                        default:            PrintS("U");
167                    }
168                    if(IDPACKAGE(h)->libname!=NULL)
169                      Print(",%s", IDPACKAGE(h)->libname);
170                    PrintS(")");
171                    break;
172    case PROC_CMD: if(strlen(IDPROC(h)->libname)>0)
173                     Print(" from %s",IDPROC(h)->libname);
174                   if(IDPROC(h)->is_static)
175                     PrintS(" (static)");
176                   break;
177    case STRING_CMD:
178                   {
179                     char *s;
180                     l=strlen(IDSTRING(h));
181                     memset(buffer,0,22);
182                     strncpy(buffer,IDSTRING(h),min(l,20));
183                     if ((s=strchr(buffer,'\n'))!=NULL)
184                     {
185                       *s='\0';
186                     }
187                     PrintS(" ");
188                     PrintS(buffer);
189                     if((s!=NULL) ||(l>20))
190                     {
191                       Print("..., %d char(s)",l);
192                     }
193                     break;
194                   }
195    case LIST_CMD: Print(", size: %d",IDLIST(h)->nr+1);
196                   break;
197    case QRING_CMD:
198    case RING_CMD:
199#ifdef RDEBUG
200                   if (traceit &TRACE_SHOW_RINGS)
201                     Print(" <%x>",IDRING(h));
202#endif
203                   break;
204    /*default:     break;*/
205  }
206  PrintLn();
207}
208
209void type_cmd(idhdl h)
210{
211  BOOLEAN oldShortOut = FALSE;
212
213  if (currRing != NULL)
214  {
215    oldShortOut = currRing->ShortOut;
216    currRing->ShortOut = 1;
217  }
218  list1("// ",h,FALSE,FALSE);
219  if (IDTYP(h)!=INT_CMD)
220  {
221    sleftv expr;
222    memset(&expr,0,sizeof(expr));
223    expr.rtyp=IDHDL;
224    expr.name=IDID(h);
225    expr.data=(void *)h;
226    expr.Print();
227  }
228  if (currRing != NULL)
229    currRing->ShortOut = oldShortOut;
230}
231
232static void killlocals0(int v, idhdl * localhdl)
233{
234  idhdl h = *localhdl;
235  while (h!=NULL)
236  {
237    int vv;
238    //Print("consider %s, lev: %d:",IDID(h),IDLEV(h));
239    if ((vv=IDLEV(h))>0)
240    {
241      if (vv < v)
242      {
243        if (iiNoKeepRing)
244        {
245          //PrintS(" break\n");
246          return;
247        }
248        h = IDNEXT(h);
249        //PrintLn();
250      }
251      else if (vv >= v)
252      {
253        idhdl nexth = IDNEXT(h);
254        killhdl2(h,localhdl,currRing);
255        h = nexth;
256        //PrintS("kill\n");
257      }
258    }
259    else
260    {
261      h = IDNEXT(h);
262      //PrintLn();
263    }
264  }
265}
266#ifndef HAVE_NS
267void killlocals(int v)
268{
269  killlocals0(v,&IDROOT);
270
271  if ((iiRETURNEXPR_len > myynest)
272  && ((iiRETURNEXPR[myynest].Typ()==RING_CMD)
273    || (iiRETURNEXPR[myynest].Typ()==QRING_CMD)))
274  {
275    leftv h=&iiRETURNEXPR[myynest];
276    killlocals0(v,&(((ring)h->data)->idroot));
277  }
278
279  idhdl sh=currRingHdl;
280  ring sr=currRing;
281  BOOLEAN changed=FALSE;
282  idhdl h = IDROOT;
283
284//  Print("killlocals in %s\n",IDID(currPackHdl));
285  while (h!=NULL)
286  {
287    if (((IDTYP(h)==QRING_CMD) || (IDTYP(h) == RING_CMD))
288    && (IDRING(h)->idroot!=NULL))
289    {
290      if (IDRING(h)!=currRing) {changed=TRUE;rSetHdl(h);}
291      killlocals0(v,&(IDRING(h)->idroot));
292    }
293    else if (IDTYP(h) == PACKAGE_CMD)
294    {
295      killlocals0(v,&(IDPACKAGE(h)->idroot));
296    }
297    h = IDNEXT(h);
298  }
299  if (changed)
300  {
301    currRing=NULL;
302    currRingHdl=NULL;
303    if (sh!=NULL) rSetHdl(sh);
304    else if (sr!=NULL)
305    {
306      sh=rFindHdl(sr,NULL,NULL);
307      rSetHdl(sh);
308    }
309  }
310
311  if (myynest<=1) iiNoKeepRing=TRUE;
312  //Print("end killlocals  >= %d\n",v);
313  //listall();
314}
315#endif
316#ifdef HAVE_NS
317void killlocals_rec(idhdl *root,int v, ring r)
318{
319  idhdl h=*root;
320  while (h!=NULL)
321  {
322    if (IDLEV(h)>=v)
323    {
324//      Print("kill %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
325      idhdl n=IDNEXT(h);
326      killhdl2(h,root,r);
327      h=n;
328    }
329    else if (IDTYP(h)==PACKAGE_CMD)
330    {
331 //     Print("into pack %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
332      if (IDPACKAGE(h)!=basePack)
333        killlocals_rec(&(IDRING(h)->idroot),v,r);
334      h=IDNEXT(h);
335    }
336    else if ((IDTYP(h)==RING_CMD)
337    ||(IDTYP(h)==QRING_CMD))
338    {
339      if (IDRING(h)->idroot!=NULL)
340      {
341  //    Print("into ring %s, lev %d for lev %d\n",IDID(h),IDLEV(h),v);
342        killlocals_rec(&(IDRING(h)->idroot),v,IDRING(h));
343      }
344      h=IDNEXT(h);
345    }
346    else
347    {
348//      Print("skip %s lev %d for lev %d\n",IDID(h),IDLEV(h),v);
349      h=IDNEXT(h);
350    }
351  }
352}
353void killlocals(int v)
354{
355  BOOLEAN changed=FALSE;
356  idhdl sh=currRingHdl;
357  if (sh!=NULL) changed=((IDLEV(sh)<v) || (IDRING(sh)->ref>0));
358  //if (changed) Print("currRing=%s(%x), lev=%d,ref=%d\n",IDID(sh),IDRING(sh),IDLEV(sh),IDRING(sh)->ref);
359
360  killlocals_rec(&(basePack->idroot),v,currRing);
361
362  if ((iiRETURNEXPR_len > myynest)
363  && ((iiRETURNEXPR[myynest].Typ()==RING_CMD)
364    || (iiRETURNEXPR[myynest].Typ()==QRING_CMD)))
365  {
366    leftv h=&iiRETURNEXPR[myynest];
367    killlocals0(v,&(((ring)h->data)->idroot));
368  }
369
370  if (changed)
371  {
372    currRingHdl=rFindHdl(currRing,NULL,NULL);
373  }
374
375  if (myynest<=1) iiNoKeepRing=TRUE;
376  //Print("end killlocals  >= %d\n",v);
377  //listall();
378}
379#endif
380
381void list_cmd(int typ, const char* what, char *prefix,BOOLEAN iterate, BOOLEAN fullname)
382{
383  idhdl h,start;
384  BOOLEAN all = typ<0;
385  BOOLEAN really_all=FALSE;
386  BOOLEAN do_packages=FALSE;
387
388  if ( typ == -1 ) do_packages=TRUE;
389  if ( typ==0 )
390  {
391    if (strcmp(what,"all")==0)
392    {
393      really_all=TRUE;
394#ifdef HAVE_NS
395      h=basePack->idroot;
396#else
397      h=IDROOT;
398#endif
399    }
400    else
401    {
402      h = ggetid(what);
403      if (h!=NULL)
404      {
405        if (iterate) list1(prefix,h,TRUE,fullname);
406        if ((IDTYP(h)==RING_CMD)
407            || (IDTYP(h)==QRING_CMD)
408#ifdef HAVE_NS
409            //|| (IDTYP(h)==PACKE_CMD)
410#endif
411        )
412        {
413          h=IDRING(h)->idroot;
414        }
415        else if((IDTYP(h)==PACKAGE_CMD) || (IDTYP(h)==POINTER_CMD))
416        {
417          Print("list_cmd:package or pointer\n");
418          all=TRUE;typ=PROC_CMD;fullname=TRUE;really_all=TRUE;
419          h=IDPACKAGE(h)->idroot;
420        }
421        else
422          return;
423      }
424      else
425      {
426        Werror("%s is undefined",what);
427        return;
428      }
429    }
430    all=TRUE;
431  }
432  else if (RingDependend(typ))
433  {
434    h = currRing->idroot;
435  }
436  else
437    h = IDROOT;
438  start=h;
439  while (h!=NULL)
440  {
441    if ((all && (IDTYP(h)!=PROC_CMD) &&(IDTYP(h)!=PACKAGE_CMD))
442    || (typ == IDTYP(h))
443    || ((IDTYP(h)==QRING_CMD) && (typ==RING_CMD)))
444    {
445      list1(prefix,h,start==currRingHdl, fullname);
446      if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
447        && (really_all || (all && (h==currRingHdl)))
448        && ((IDLEV(h)==0)||(IDLEV(h)==myynest)))
449      {
450        list_cmd(0,IDID(h),"//      ",FALSE);
451      }
452#ifdef HAVE_NS
453      if (IDTYP(h)==PACKAGE_CMD && really_all)
454      {
455        list_cmd(0,IDID(h),"//      ",FALSE);
456      }
457#endif /* HAVE_NS */
458    }
459    h = IDNEXT(h);
460  }
461}
462
463void test_cmd(int i)
464{
465  int ii=(char)i;
466
467  if (i == (-32))
468  {
469    test = 0;
470  }
471  else
472  {
473    if (i<0)
474    {
475      ii= -i;
476      if (Sy_bit(ii) & kOptions)
477      {
478        Warn("Gerhard, use the option command");
479        test &= ~Sy_bit(ii);
480      }
481      else if (Sy_bit(ii) & validOpts)
482        test &= ~Sy_bit(ii);
483    }
484    else if (i<32)
485    {
486      if (Sy_bit(ii) & kOptions)
487      {
488        Warn("Gerhard, use the option command");
489        test |= Sy_bit(ii);
490      }
491      else if (Sy_bit(ii) & validOpts)
492        test |= Sy_bit(ii);
493    }
494  }
495}
496
497int exprlist_length(leftv v)
498{
499  int rc = 0;
500  while (v!=NULL)
501  {
502    switch (v->Typ())
503    {
504      case INT_CMD:
505      case POLY_CMD:
506      case VECTOR_CMD:
507      case NUMBER_CMD:
508        rc++;
509        break;
510      case INTVEC_CMD:
511      case INTMAT_CMD:
512        rc += ((intvec *)(v->Data()))->length();
513        break;
514      case MATRIX_CMD:
515      case IDEAL_CMD:
516      case MODUL_CMD:
517        {
518          matrix mm = (matrix)(v->Data());
519          rc += mm->rows() * mm->cols();
520        }
521        break;
522      case LIST_CMD:
523        rc+=((lists)v->Data())->nr+1;
524        break;
525      default:
526        rc++;
527    }
528    v = v->next;
529  }
530  return rc;
531}
532
533void iiWriteMatrix(matrix im, const char *n, int dim,int spaces)
534{
535  int i,ii = MATROWS(im)-1;
536  int j,jj = MATCOLS(im)-1;
537  poly *pp = im->m;
538
539  for (i=0; i<=ii; i++)
540  {
541    for (j=0; j<=jj; j++)
542    {
543      if (spaces>0)
544        Print("%-*.*s",spaces,spaces," ");
545      if (dim == 2) Print("%s[%u,%u]=",n,i+1,j+1);
546      else if (dim == 1) Print("%s[%u]=",n,j+1);
547      else if (dim == 0) Print("%s=",n);
548      if ((i<ii)||(j<jj)) pWrite(*pp++);
549      else                pWrite0(*pp);
550    }
551  }
552}
553
554char * iiStringMatrix(matrix im, int dim,char ch)
555{
556  int i,ii = MATROWS(im);
557  int j,jj = MATCOLS(im);
558  poly *pp = im->m;
559  char *s=StringSetS("");
560
561  for (i=0; i<ii; i++)
562  {
563    for (j=0; j<jj; j++)
564    {
565      pString0(*pp++);
566      s=StringAppend("%c",ch);
567      if (dim > 1) s = StringAppendS("\n");
568    }
569  }
570  s[strlen(s)- (dim > 1 ? 2 : 1)]='\0';
571  return s;
572}
573
574int IsPrime(int p)  /* brute force !!!! */
575{
576  int i,j;
577  if      (p == 0)    return 0;
578  else if (p == 1)    return 1/*1*/;
579  else if (p == 2)    return p;
580  else if (p < 0)     return (-IsPrime(-p));
581  else if (!(p & 1)) return IsPrime(p-1);
582#ifdef HAVE_FACTORY
583  else if (p<=32749) // max. small prime in factory
584  {
585    int a=0;
586    int e=cf_getNumSmallPrimes()-1;
587    i=e/2;
588    do
589    {
590      if (p==(j=cf_getSmallPrime(i))) return p;
591      if (p<j) e=i-1;
592      else     a=i+1;
593      i=a+(e-a)/2;
594    } while ( a<= e);
595    if (p>j) return j;
596    else     return cf_getSmallPrime(i-1);
597  }
598#endif
599#ifdef HAVE_FACTORY
600  int end_i=cf_getNumSmallPrimes()-1;
601#else
602  int end_i=p/2;
603#endif 
604  int end_p=(int)sqrt((double)p);
605restart:
606  for (i=0; i<end_i; i++)
607  {
608#ifdef HAVE_FACTORY
609    j=cf_getSmallPrime(i);
610#else
611    if (i==0) j=2;
612    else j=2*i-1;
613#endif   
614    if ((p%j) == 0)
615    {
616    #ifdef HAVE_FACTORY
617      if (p<=32751) return IsPrime(p-2);
618    #endif 
619      p-=2;
620      goto restart;
621    }
622    if (j > end_p) return p;
623  }
624  return p;
625}
626
627BOOLEAN iiWRITE(leftv res,leftv v)
628{
629  sleftv vf;
630  if (iiConvert(v->Typ(),LINK_CMD,iiTestConvert(v->Typ(),LINK_CMD),v,&vf))
631  {
632    WerrorS("link expected");
633    return TRUE;
634  }
635  si_link l=(si_link)vf.Data();
636  if (vf.next == NULL)
637  {
638    WerrorS("write: need at least two arguments");
639    return TRUE;
640  }
641
642  BOOLEAN b=slWrite(l,vf.next); /* iiConvert preserves next */
643  if (b)
644  {
645    const char *s;
646    if ((l!=NULL)&&(l->name!=NULL)) s=l->name;
647    else                            s=sNoName;
648    Werror("cannot write to %s",s);
649  }
650  vf.CleanUp();
651  return b;
652}
653
654leftv iiMap(map theMap, char * what)
655{
656  idhdl w,r;
657  leftv v;
658  int i;
659  nMapFunc nMap;
660
661  r=IDROOT->get(theMap->preimage,myynest);
662#ifdef HAVE_NS
663  if ((currPack!=basePack)
664  &&((r==NULL) || ((r->typ != RING_CMD) && (r->typ != QRING_CMD))))
665    r=basePack->idroot->get(theMap->preimage,myynest);
666#endif /* HAVE_NS */
667  if ((r!=NULL) && ((r->typ == RING_CMD) || (r->typ== QRING_CMD)))
668  {
669    //if ((nMap=nSetMap(rInternalChar(IDRING(r)),
670    //             IDRING(r)->parameter,
671    //             rPar(IDRING(r)),
672    //             IDRING(r)->minpoly)))
673    if ((nMap=nSetMap(IDRING(r)))==NULL)
674    {
675      if (rEqual(IDRING(r),currRing))
676      {
677        nMap=nCopy;
678      }
679      else
680      {
681        Werror("can not map from ground field of %s to current ground field",
682          theMap->preimage);
683        return NULL;
684      }
685    }
686    if (IDELEMS(theMap)<IDRING(r)->N)
687    {
688      theMap->m=(polyset)omReallocSize((ADDRESS)theMap->m,
689                                 IDELEMS(theMap)*sizeof(poly),
690                                 (IDRING(r)->N)*sizeof(poly));
691      for(i=IDELEMS(theMap);i<IDRING(r)->N;i++)
692        theMap->m[i]=NULL;
693      IDELEMS(theMap)=IDRING(r)->N;
694    }
695    if (what==NULL)
696    {
697      WerrorS("argument of a map must have a name");
698    }
699    else if ((w=IDRING(r)->idroot->get(what,myynest))!=NULL)
700    {
701      v=(leftv)omAlloc0Bin(sleftv_bin);
702      sleftv tmpW;
703      memset(&tmpW,0,sizeof(sleftv));
704      tmpW.rtyp=IDTYP(w);
705      tmpW.data=IDDATA(w);
706      #ifdef FAST_MAP
707      if ((tmpW.rtyp==IDEAL_CMD) && (nMap==nCopy))
708      {
709        v->rtyp=IDEAL_CMD;
710        v->data=fast_map(IDIDEAL(w), IDRING(r), (ideal)theMap, currRing);
711      }
712      else
713      #endif
714      if (maApplyFetch(MAP_CMD,theMap,v,&tmpW,IDRING(r),NULL,NULL,0,nMap))
715      {
716        Werror("cannot map %s(%d)",Tok2Cmdname(w->typ),w->typ);
717        omFreeBin((ADDRESS)v, sleftv_bin);
718        return NULL;
719      }
720      return v;
721    }
722    else
723    {
724      Werror("%s undefined in %s",what,theMap->preimage);
725    }
726  }
727  else
728  {
729    Werror("cannot find preimage %s",theMap->preimage);
730  }
731  return NULL;
732}
733
734#ifdef OLD_RES
735void  iiMakeResolv(resolvente r, int length, int rlen, char * name, int typ0,
736                   intvec ** weights)
737{
738  lists L=liMakeResolv(r,length,rlen,typ0,weights);
739  int i=0;
740  idhdl h;
741  char * s=(char *)omAlloc(strlen(name)+5);
742
743  while (i<=L->nr)
744  {
745    sprintf(s,"%s(%d)",name,i+1);
746    if (i==0)
747      h=enterid(s,myynest,typ0,&(currRing->idroot), FALSE);
748    else
749      h=enterid(s,myynest,MODUL_CMD,&(currRing->idroot), FALSE);
750    if (h!=NULL)
751    {
752      h->data.uideal=(ideal)L->m[i].data;
753      h->attribute=L->m[i].attribute;
754      if (BVERBOSE(V_DEF_RES))
755        Print("//defining: %s as %d-th syzygy module\n",s,i+1);
756    }
757    else
758    {
759      idDelete((ideal *)&(L->m[i].data));
760      Warn("cannot define %s",s);
761    }
762    //L->m[i].data=NULL;
763    //L->m[i].rtyp=0;
764    //L->m[i].attribute=NULL;
765    i++;
766  }
767  omFreeSize((ADDRESS)L->m,(L->nr+1)*sizeof(sleftv));
768  omFreeBin((ADDRESS)L, slists_bin);
769  omFreeSize((ADDRESS)s,strlen(name)+5);
770}
771#endif
772
773//resolvente iiFindRes(char * name, int * len, int *typ0)
774//{
775//  char *s=(char *)omAlloc(strlen(name)+5);
776//  int i=-1;
777//  resolvente r;
778//  idhdl h;
779//
780//  do
781//  {
782//    i++;
783//    sprintf(s,"%s(%d)",name,i+1);
784//    h=currRing->idroot->get(s,myynest);
785//  } while (h!=NULL);
786//  *len=i-1;
787//  if (*len<=0)
788//  {
789//    Werror("no objects %s(1),.. found",name);
790//    omFreeSize((ADDRESS)s,strlen(name)+5);
791//    return NULL;
792//  }
793//  r=(ideal *)omAlloc(/*(len+1)*/ i*sizeof(ideal));
794//  memset(r,0,(*len)*sizeof(ideal));
795//  i=-1;
796//  *typ0=MODUL_CMD;
797//  while (i<(*len))
798//  {
799//    i++;
800//    sprintf(s,"%s(%d)",name,i+1);
801//    h=currRing->idroot->get(s,myynest);
802//    if (h->typ != MODUL_CMD)
803//    {
804//      if ((i!=0) || (h->typ!=IDEAL_CMD))
805//      {
806//        Werror("%s is not of type module",s);
807//        omFreeSize((ADDRESS)r,(*len)*sizeof(ideal));
808//        omFreeSize((ADDRESS)s,strlen(name)+5);
809//        return NULL;
810//      }
811//      *typ0=IDEAL_CMD;
812//    }
813//    if ((i>0) && (idIs0(r[i-1])))
814//    {
815//      *len=i-1;
816//      break;
817//    }
818//    r[i]=IDIDEAL(h);
819//  }
820//  omFreeSize((ADDRESS)s,strlen(name)+5);
821//  return r;
822//}
823
824static resolvente iiCopyRes(resolvente r, int l)
825{
826  int i;
827  resolvente res=(ideal *)omAlloc0((l+1)*sizeof(ideal));
828
829  for (i=0; i<l; i++)
830    res[i]=idCopy(r[i]);
831  return res;
832}
833
834BOOLEAN jjMINRES(leftv res, leftv v)
835{
836  int len=0;
837  int typ0;
838  resolvente rr=liFindRes((lists)v->Data(),&len,&typ0);
839  if (rr==NULL) return TRUE;
840  resolvente r=iiCopyRes(rr,len);
841
842  syMinimizeResolvente(r,len,0);
843  omFreeSize((ADDRESS)rr,len*sizeof(ideal));
844  len++;
845  res->data=(char *)liMakeResolv(r,len,-1,typ0,NULL);
846  return FALSE;
847}
848
849BOOLEAN jjBETTI(leftv res, leftv v)
850{
851  resolvente r;
852  int len;
853  int reg,typ0;
854
855  r=liFindRes((lists)v->Data(),&len,&typ0);
856  if (r==NULL) return TRUE;
857  res->data=(char *)syBetti(r,len,&reg);
858  omFreeSize((ADDRESS)r,(len)*sizeof(ideal));
859  return FALSE;
860}
861
862int iiRegularity(lists L)
863{
864  int len,reg,typ0;
865
866  resolvente r=liFindRes(L,&len,&typ0);
867
868  if (r==NULL)
869    return -2;
870  intvec * dummy=syBetti(r,len,&reg);
871  omFreeSize((ADDRESS)r,len*sizeof(ideal));
872  delete dummy;
873  return reg+1;
874}
875
876BOOLEAN iiDebugMarker=TRUE;
877#define BREAK_LINE_LENGTH 80
878void iiDebug()
879{
880  Print("\n-- break point in %s --\n",VoiceName());
881  if (iiDebugMarker) VoiceBackTrack();
882  char * s;
883  iiDebugMarker=FALSE;
884  s = (char *)omAlloc(BREAK_LINE_LENGTH+4);
885  loop
886  {
887    memset(s,0,80);
888    fe_fgets_stdin("",s,BREAK_LINE_LENGTH);
889    if (s[BREAK_LINE_LENGTH-1]!='\0')
890    {
891      Print("line too long, max is %d chars\n",BREAK_LINE_LENGTH);
892    }
893    else
894      break;
895  }
896  if (*s=='\n')
897  {
898    iiDebugMarker=TRUE;
899  }
900#if MDEBUG
901  else if(strncmp(s,"cont;",5)==0)
902  {
903    iiDebugMarker=TRUE;
904  }
905#endif /* MDEBUG */
906  else
907  {
908    strcat( s, "\n;~\n");
909    newBuffer(s,BT_execute);
910  }
911}
912
913int iiDeclCommand(leftv sy, leftv name, int lev,int t, idhdl* root,BOOLEAN isring, BOOLEAN init_b)
914{
915  BOOLEAN res=FALSE;
916  char *id = name->name;
917
918  memset(sy,0,sizeof(sleftv));
919  if ((name->name==NULL)||(isdigit(name->name[0])))
920  {
921    WerrorS("object to declare is not a name");
922    res=TRUE;
923  }
924  else
925  {
926    //if (name->rtyp!=0)
927    //{
928    //  Warn("`%s` is already in use",name->name);
929    //}
930    {
931      sy->data = (char *)enterid(id,lev,t,root,init_b);
932    }
933    if (sy->data!=NULL)
934    {
935      sy->rtyp=IDHDL;
936      currid=sy->name=IDID((idhdl)sy->data);
937      // name->name=NULL; /* used in enterid */
938      //sy->e = NULL;
939      if (name->next!=NULL)
940      {
941        sy->next=(leftv)omAllocBin(sleftv_bin);
942        res=iiDeclCommand(sy->next,name->next,lev,t,root, isring);
943      }
944    }
945    else res=TRUE;
946  }
947  name->CleanUp();
948  return res;
949}
950
951BOOLEAN iiParameter(leftv p)
952{
953  if (iiCurrArgs==NULL)
954  {
955    if (strcmp(p->name,"#")==0) return FALSE;
956    Werror("not enough arguments for proc %s",VoiceName());
957    p->CleanUp();
958    return TRUE;
959  }
960  leftv h=iiCurrArgs;
961  if (strcmp(p->name,"#")==0)
962  {
963    iiCurrArgs=NULL;
964  }
965  else
966  {
967    iiCurrArgs=h->next;
968    h->next=NULL;
969  }
970  BOOLEAN res=iiAssign(p,h);
971  omFreeBin((ADDRESS)h, sleftv_bin);
972  return res;
973}
974
975static BOOLEAN iiInternalExport (leftv v, int toLev)
976{
977  idhdl h=(idhdl)v->data;
978  //Print("iiInternalExport('%s',%d)%s\n", v->name, toLev,"");
979  if (IDLEV(h)==0) Warn("`%s` is already global",IDID(h));
980  else
981  {
982    h=IDROOT->get(v->name,toLev);
983    idhdl *root=&IDROOT;
984    if ((h==NULL)&&(currRing!=NULL))
985    {
986      h=currRing->idroot->get(v->name,toLev);
987      root=&currRing->idroot;
988    }
989    if ((h!=NULL)&&(IDLEV(h)==toLev))
990    {
991      if (IDTYP(h)==v->Typ())
992      {
993        if (BVERBOSE(V_REDEFINE))
994        {
995          Warn("redefining %s",IDID(h));
996        }
997#ifdef USE_IILOCALRING
998        if (iiLocalRing[0]==IDRING(h)) iiLocalRing[0]=NULL;
999#else
1000        proclevel *p=procstack;
1001        while (p->next!=NULL) p=p->next;
1002        if (p->cRing==IDRING(h))
1003        {
1004          p->cRing=NULL;
1005          p->cRingHdl=NULL;
1006        }
1007#endif
1008        killhdl2(h,root,currRing);
1009      }
1010      else
1011      {
1012        return TRUE;
1013      }
1014    }
1015    h=(idhdl)v->data;
1016    IDLEV(h)=toLev;
1017    iiNoKeepRing=FALSE;
1018    //Print("export %s\n",IDID(h));
1019  }
1020  return FALSE;
1021}
1022
1023#ifdef HAVE_NS
1024BOOLEAN iiInternalExport (leftv v, int toLev, idhdl roothdl)
1025{
1026  idhdl h=(idhdl)v->data;
1027  if(h==NULL)
1028  {
1029    Warn("'%s': no such identifier\n", v->name);
1030    return FALSE;
1031  }
1032  package frompack=v->req_packhdl; 
1033  if (frompack==NULL) frompack=currPack;
1034  package rootpack = IDPACKAGE(roothdl);
1035//  Print("iiInternalExport('%s',%d,%s->%s) typ:%d\n", v->name, toLev, IDID(currPackHdl),IDID(roothdl),v->Typ());
1036  if (RingDependend(IDTYP(h)))
1037  {
1038    //Print("// ==> Ringdependent set nesting to 0\n");
1039    return (iiInternalExport(v, toLev));
1040  }
1041  else
1042  {
1043    IDLEV(h)=toLev;
1044    v->req_packhdl=rootpack;
1045    if (h==frompack->idroot)
1046    {
1047      frompack->idroot=h->next;
1048    }
1049    else
1050    {
1051      idhdl hh=frompack->idroot;
1052      while ((hh!=NULL) && (hh->next!=h))
1053        hh=hh->next;
1054      if ((hh!=NULL) && (hh->next==h))
1055        hh->next=h->next;
1056      else
1057      {
1058        Werror("`%s` not found",v->Name());
1059        return TRUE;
1060      }
1061    }
1062    h->next=rootpack->idroot;
1063    rootpack->idroot=h;
1064  }
1065  return FALSE;
1066}
1067#endif /* HAVE_NS */
1068
1069BOOLEAN iiExport (leftv v, int toLev)
1070{
1071#ifdef HAVE_NS
1072  checkall();
1073#endif
1074  BOOLEAN nok=FALSE;
1075  leftv r=v;
1076  while (v!=NULL)
1077  {
1078    if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL))
1079    {
1080      WerrorS("cannot export");
1081      nok=TRUE;
1082    }
1083    else
1084    {
1085      if(iiInternalExport(v, toLev))
1086      {
1087        r->CleanUp();
1088        return TRUE;
1089      }
1090    }
1091    v=v->next;
1092  }
1093  r->CleanUp();
1094#ifdef HAVE_NS
1095  checkall();
1096#endif
1097  return nok;
1098}
1099
1100/*assume root!=idroot*/
1101#ifdef HAVE_NS
1102BOOLEAN iiExport (leftv v, int toLev, idhdl root)
1103{
1104  checkall();
1105//      Print("iiExport1: pack=%s\n",IDID(root));
1106  BOOLEAN nok=FALSE;
1107  leftv rv=v;
1108  while (v!=NULL)
1109  {
1110    if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL)
1111    )
1112    {
1113      WerrorS("cannot export");
1114      nok=TRUE;
1115    }
1116    else
1117    {
1118      idhdl old=root->get(v->name,toLev);
1119      if (old!=NULL)
1120      {
1121        if (IDTYP(old)==v->Typ())
1122        {
1123          if (BVERBOSE(V_REDEFINE))
1124          {
1125            Warn("redefining %s",IDID(old));
1126          }
1127          killhdl2(old,&root,currRing);
1128        }
1129        else
1130        {
1131          rv->CleanUp();
1132          return TRUE;
1133        }
1134      }
1135      //Print("iiExport: pack=%s\n",IDID(root));
1136      if(iiInternalExport(v, toLev, root))
1137      {
1138        rv->CleanUp();
1139        return TRUE;
1140      }
1141    }
1142    v=v->next;
1143  }
1144  rv->CleanUp();
1145  checkall();
1146  return nok;
1147}
1148#endif
1149
1150BOOLEAN iiCheckRing(int i)
1151{
1152  if (currRingHdl==NULL)
1153  {
1154    #ifdef SIQ
1155    if (siq<=0)
1156    {
1157    #endif
1158      if (RingDependend(i))
1159      {
1160        WerrorS("no ring active");
1161        return TRUE;
1162      }
1163    #ifdef SIQ
1164    }
1165    #endif
1166  }
1167  return FALSE;
1168}
1169
1170poly    iiHighCorner(ideal I, int ak)
1171{
1172  int i;
1173  if(!idIsZeroDim(I)) return NULL; // not zero-dim.
1174  poly po=NULL;
1175  if (currRing->OrdSgn== -1)
1176  {
1177    scComputeHC(I,currQuotient,ak,po);
1178    if (po!=NULL)
1179    {
1180      pGetCoeff(po)=nInit(1);
1181      for (i=pVariables; i>0; i--)
1182      {
1183        if (pGetExp(po, i) > 0) pDecrExp(po,i);
1184      }
1185      pSetComp(po,ak);
1186      pSetm(po);
1187    }
1188  }
1189  else
1190    po=pOne();
1191  return po;
1192}
1193
1194#ifdef HAVE_NS
1195void iiCheckPack(package &p)
1196{
1197  if (p==basePack) return;
1198
1199  idhdl t=basePack->idroot;
1200
1201  while ((t!=NULL) && (IDTYP(t)!=PACKAGE_CMD) && (IDPACKAGE(t)!=p)) t=t->next;
1202
1203  if (t==NULL)
1204  {
1205    WarnS("package not found\n");
1206    p=basePack;
1207  }
1208  return;
1209}
1210#endif
Note: See TracBrowser for help on using the repository browser.