source: git/Singular/ipshell.cc @ 97a7b44

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