source: git/Singular/ipshell.cc @ bb354a

spielwiese
Last change on this file since bb354a was bb354a, checked in by Hans Schönemann <hannes@…>, 25 years ago
* hannes: minor fixes git-svn-id: file:///usr/local/Singular/svn/trunk@2931 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 24.7 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: ipshell.cc,v 1.38 1999-03-15 16:18:53 Singular 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=StringSet("");
501
502  for (i=0; i<ii; i++)
503  {
504    for (j=0; j<jj; j++)
505    {
506      pString0(*pp++);
507      s=StringAppend("%c\n",ch);
508    }
509  }
510  s[strlen(s)-2]='\0';
511  return s;
512}
513
514int IsPrime(int p)  /* brute force !!!! */
515{
516  int i,j;
517  if      (p == 0) return 0;
518  else if (p == 1) return 1/*1*/;
519  else if (p == 2) return p;
520  else if (p <  0) return (-IsPrime(-p));
521  else if (!(p & 1)) return IsPrime(p-1);
522  for (j=p/2+1,i=3; i<p; i+=2)
523  {
524    if ((p%i) == 0) return IsPrime(p-2);
525    if (j < i) return p;
526  }
527  return p;
528}
529
530BOOLEAN iiWRITE(leftv res,leftv v)
531{
532  sleftv vf;
533  if (iiConvert(v->Typ(),LINK_CMD,iiTestConvert(v->Typ(),LINK_CMD),v,&vf))
534  {
535    WerrorS("link expected");
536    return TRUE;
537  }
538  si_link l=(si_link)vf.Data();
539  if (vf.next == NULL)
540  {
541    WerrorS("write: need at least two arguments");
542    return TRUE;
543  }
544
545  BOOLEAN b=slWrite(l,vf.next); /* iiConvert preserves next */
546  if (b)
547  {
548    const char *s;
549    if ((l!=NULL)&&(l->name!=NULL)) s=l->name;
550    else                            s=sNoName;
551    Werror("cannot write to %s",s);
552  }
553  vf.CleanUp();
554  return b;
555}
556
557leftv iiMap(map theMap, char * what)
558{
559  idhdl w,r;
560  leftv v;
561  int i;
562
563#ifdef HAVE_NAMESPACES
564  idhdl pack;
565  //r=namespaceroot->get(theMap->preimage,myynest);
566  iiname2hdl(theMap->preimage,&pack,&r);
567#else
568  r=idroot->get(theMap->preimage,myynest);
569#endif /* HAVE_NAMESPACES */
570  if ((r!=NULL) && ((r->typ == RING_CMD) || (r->typ== QRING_CMD)))
571  {
572    if (!nSetMap(rInternalChar(IDRING(r)),
573                 IDRING(r)->parameter,
574                 rPar(IDRING(r)),
575                 IDRING(r)->minpoly))
576    {
577      Werror("can not map from ground field of %s to current ground field", theMap->preimage);
578      return NULL;
579    }
580    if (IDELEMS(theMap)<IDRING(r)->N)
581    {
582      theMap->m=(polyset)ReAlloc((ADDRESS)theMap->m,
583                                 IDELEMS(theMap)*sizeof(poly),
584                                 (IDRING(r)->N)*sizeof(poly));
585      for(i=IDELEMS(theMap);i<IDRING(r)->N;i++)
586        theMap->m[i]=NULL;
587      IDELEMS(theMap)=IDRING(r)->N;
588    }
589    if (what==NULL)
590    {
591      WerrorS("argument of a map must have a name");
592    }
593    else if ((w=IDRING(r)->idroot->get(what,myynest))!=NULL)
594    {
595      v=(leftv)Alloc0(sizeof(*v));
596      sleftv tmpW;
597      memset(&tmpW,0,sizeof(sleftv));
598      tmpW.rtyp=IDTYP(w);
599      tmpW.data=IDDATA(w);
600      if (maApplyFetch(MAP_CMD,theMap,v,&tmpW,IDRING(r),NULL,NULL,0))
601      {
602        Werror("cannot map %s(%d)",Tok2Cmdname(w->typ),w->typ);
603        Free((ADDRESS)v,sizeof(*v));
604        return NULL;
605      }
606      return v;
607    }
608    else
609    {
610      Werror("%s undefined in %s",what,theMap->preimage);
611    }
612  }
613  else
614  {
615    Werror("cannot find preimage %s",theMap->preimage);
616  }
617  return NULL;
618}
619
620#ifdef OLD_RES
621void  iiMakeResolv(resolvente r, int length, int rlen, char * name, int typ0,
622                   intvec ** weights)
623{
624  lists L=liMakeResolv(r,length,rlen,typ0,weights);
625  int i=0;
626  idhdl h;
627  char * s=(char *)Alloc(strlen(name)+5);
628
629  while (i<=L->nr)
630  {
631    sprintf(s,"%s(%d)",name,i+1);
632    if (i==0)
633      h=enterid(mstrdup(s),myynest,typ0,&(currRing->idroot), FALSE);
634    else
635      h=enterid(mstrdup(s),myynest,MODUL_CMD,&(currRing->idroot), FALSE);
636    if (h!=NULL)
637    {
638      h->data.uideal=(ideal)L->m[i].data;
639      h->attribute=L->m[i].attribute;
640      if (BVERBOSE(V_DEF_RES))
641        Print("//defining: %s as %d-th syzygy module\n",s,i+1);
642    }
643    else
644    {
645      idDelete((ideal *)&(L->m[i].data));
646      Warn("cannot define %s",s);
647    }
648    //L->m[i].data=NULL;
649    //L->m[i].rtyp=0;
650    //L->m[i].attribute=NULL;
651    i++;
652  }
653  Free((ADDRESS)L->m,(L->nr+1)*sizeof(sleftv));
654  Free((ADDRESS)L,sizeof(slists));
655  Free((ADDRESS)s,strlen(name)+5);
656}
657#endif
658
659//resolvente iiFindRes(char * name, int * len, int *typ0)
660//{
661//  char *s=(char *)Alloc(strlen(name)+5);
662//  int i=-1;
663//  resolvente r;
664//  idhdl h;
665//
666//  do
667//  {
668//    i++;
669//    sprintf(s,"%s(%d)",name,i+1);
670//    h=currRing->idroot->get(s,myynest);
671//  } while (h!=NULL);
672//  *len=i-1;
673//  if (*len<=0)
674//  {
675//    Werror("no objects %s(1),.. found",name);
676//    Free((ADDRESS)s,strlen(name)+5);
677//    return NULL;
678//  }
679//  r=(ideal *)Alloc(/*(len+1)*/ i*sizeof(ideal));
680//  memset(r,0,(*len)*sizeof(ideal));
681//  i=-1;
682//  *typ0=MODUL_CMD;
683//  while (i<(*len))
684//  {
685//    i++;
686//    sprintf(s,"%s(%d)",name,i+1);
687//    h=currRing->idroot->get(s,myynest);
688//    if (h->typ != MODUL_CMD)
689//    {
690//      if ((i!=0) || (h->typ!=IDEAL_CMD))
691//      {
692//        Werror("%s is not of type module",s);
693//        Free((ADDRESS)r,(*len)*sizeof(ideal));
694//        Free((ADDRESS)s,strlen(name)+5);
695//        return NULL;
696//      }
697//      *typ0=IDEAL_CMD;
698//    }
699//    if ((i>0) && (idIs0(r[i-1])))
700//    {
701//      *len=i-1;
702//      break;
703//    }
704//    r[i]=IDIDEAL(h);
705//  }
706//  Free((ADDRESS)s,strlen(name)+5);
707//  return r;
708//}
709
710static resolvente iiCopyRes(resolvente r, int l)
711{
712  int i;
713  resolvente res=(ideal *)Alloc0((l+1)*sizeof(ideal));
714
715  for (i=0; i<l; i++)
716    res[i]=idCopy(r[i]);
717  return res;
718}
719
720BOOLEAN jjMINRES(leftv res, leftv v)
721{
722  int len=0;
723  int typ0;
724  resolvente rr=liFindRes((lists)v->Data(),&len,&typ0);
725  if (rr==NULL) return TRUE;
726  resolvente r=iiCopyRes(rr,len);
727
728  syMinimizeResolvente(r,len,0);
729  Free((ADDRESS)rr,len*sizeof(ideal));
730  len++;
731  res->data=(char *)liMakeResolv(r,len,-1,typ0,NULL);
732  return FALSE;
733}
734
735BOOLEAN jjBETTI(leftv res, leftv v)
736{
737  resolvente r;
738  int len;
739  int reg,typ0;
740
741  r=liFindRes((lists)v->Data(),&len,&typ0);
742  if (r==NULL) return TRUE;
743  res->data=(char *)syBetti(r,len,&reg);
744  Free((ADDRESS)r,(len)*sizeof(ideal));
745  return FALSE;
746}
747
748int iiRegularity(lists L)
749{
750  resolvente r;
751  int len,reg,typ0;
752  intvec * dummy;
753
754  r=liFindRes(L,&len,&typ0);
755  if (r==NULL) return -2;
756  dummy=syBetti(r,len,&reg);
757  Free((ADDRESS)r,len*sizeof(ideal));
758  delete dummy;
759  return reg-1;
760}
761
762BOOLEAN iiDebugMarker=TRUE;
763void iiDebug()
764{
765  Print("\n-- break point in %s --\n",VoiceName());
766  if (iiDebugMarker) VoiceBackTrack();
767  char * s;
768  iiDebugMarker=FALSE;
769  s = (char *)AllocL(84);
770  fe_fgets_stdin("",s,80);
771  if (*s=='\n')
772  {
773    iiDebugMarker=TRUE;
774  }
775#if MDEBUG
776  else if(strncmp(s,"cont;",5)==0)
777  {
778    iiDebugMarker=TRUE;
779  }
780#endif /* MDEBUG */
781  else
782  {
783    strcat( s, "\n;~\n");
784    newBuffer(s,BT_execute);
785  }
786}
787
788int iiDeclCommand(leftv sy, leftv name, int lev,int t, idhdl* root,BOOLEAN isring, BOOLEAN init_b)
789{
790  BOOLEAN res=FALSE;
791  char *id = name->name;
792
793  memset(sy,0,sizeof(sleftv));
794  if ((name->name==NULL)||(isdigit(name->name[0])))
795  {
796    WerrorS("object to declare is not a name");
797    res=TRUE;
798  }
799  else
800  {
801    //if (name->rtyp!=0)
802    //{
803    //  Warn("`%s` is already in use",name->name);
804    //}
805#ifdef HAVE_NAMESPACES
806    if(name->req_packhdl != NULL && name->packhdl != NULL &&
807       name->req_packhdl != name->packhdl)
808      id = mstrdup(name->name);
809
810    //if(name->req_packhdl != NULL /*&& !isring*/) {
811    if(name->req_packhdl != NULL && !isring &&
812       IDPACKAGE(name->req_packhdl) != root) {
813      //Print("iiDeclCommand: PUSH(%s)\n",IDID(name->req_packhdl));
814      namespaceroot->push( IDPACKAGE(name->req_packhdl) ,
815                           IDID(name->req_packhdl));
816      sy->data = (char *)enterid(id,lev,t,
817                                 &IDPACKAGE(name->req_packhdl)->idroot,init_b);
818      namespaceroot->pop();
819    }
820    else
821#endif /* HAVE_NAMESPACES */
822    {
823      sy->data = (char *)enterid(id,lev,t,root,init_b);
824    }
825    if (sy->data!=NULL)
826    {
827      sy->rtyp=IDHDL;
828      currid=sy->name=IDID((idhdl)sy->data);
829      name->name=NULL; /* used in enterid */
830      //sy->e = NULL;
831      if (name->next!=NULL)
832      {
833        sy->next=(leftv)Alloc(sizeof(sleftv));
834        res=iiDeclCommand(sy->next,name->next,lev,t,root, isring);
835      }
836    }
837    else res=TRUE;
838  }
839  name->CleanUp();
840  return res;
841}
842
843BOOLEAN iiParameter(leftv p)
844{
845  if (iiCurrArgs==NULL)
846  {
847    if (strcmp(p->name,"#")==0) return FALSE;
848    Werror("not enough arguments for proc %s",VoiceName());
849    p->CleanUp();
850    return TRUE;
851  }
852  leftv h=iiCurrArgs;
853  if (strcmp(p->name,"#")==0)
854  {
855    iiCurrArgs=NULL;
856  }
857  else
858  {
859    iiCurrArgs=h->next;
860    h->next=NULL;
861  }
862  BOOLEAN res=iiAssign(p,h);
863  Free((ADDRESS)h,sizeof(sleftv));
864  return res;
865}
866
867static BOOLEAN iiInternalExport (leftv v, int toLev)
868{
869  idhdl h=(idhdl)v->data;
870  //Print("iiInternalExport('%s',%d)%s\n", v->name, toLev,"");
871  if (IDLEV(h)==0) Warn("`%s` is already global",IDID(h));
872  else
873  {
874    h=IDROOT->get(v->name,toLev);
875    idhdl *root=&IDROOT;
876    if ((h==NULL)&&(currRing!=NULL))
877    {
878      h=currRing->idroot->get(v->name,toLev);
879      root=&currRing->idroot;
880    }
881    if ((h!=NULL)&&(IDLEV(h)==toLev))
882    {
883      if (IDTYP(h)==v->Typ())
884      {
885        if (BVERBOSE(V_REDEFINE))
886        {
887#ifdef KAI
888          Warn("!!! redefining %s",IDID(h));
889#else
890          Warn("redefining %s",IDID(h));
891#endif
892        }
893#ifdef HAVE_NAMESPACES
894        //if (namespaceroot->currRing==IDRING(h)) namespaceroot->currRing=NULL;
895#endif /* HAVE_NAMESPACES */
896#ifdef USE_IILOCALRING
897            if (iiLocalRing[0]==IDRING(h)) iiLocalRing[0]=NULL;
898#else
899            if (namespaceroot->root->currRing==IDRING(h))
900              namespaceroot->root->currRing=NULL;
901#endif
902        killhdl(h,root);
903      }
904      else
905      {
906        return TRUE;
907      }
908    }
909    h=(idhdl)v->data;
910    IDLEV(h)=toLev;
911    iiNoKeepRing=FALSE;
912  }
913  return FALSE;
914}
915
916#ifdef HAVE_NAMESPACES
917BOOLEAN iiInternalExport (leftv v, int toLev, idhdl roothdl)
918{
919  idhdl h=(idhdl)v->data;
920  if(h==NULL) {
921    Warn("'%s': no such identifier\n", v->name);
922    return FALSE;
923  }
924  package rootpack = IDPACKAGE(roothdl);
925  //Print("iiInternalExport('%s',%d,%s) %s\n", v->name, toLev, IDID(roothdl),"");
926//  if (IDLEV(h)==0) Warn("`%s` is already global",IDID(h));
927//  else
928  {
929    /* is not ring or ring-element */
930    if( (IDTYP(h) == RING_CMD) || (IDTYP(h) == QRING_CMD)) {
931      sleftv tmp_expr;
932      //Print("// ==> Ring set nesting to 0\n");
933      //Print("// ++> make a copy of ring\n");
934      if(iiInternalExport(v, toLev)) return TRUE;
935      if(IDPACKAGE(roothdl) != NSPACK(namespaceroot)) {
936        namespaceroot->push(rootpack, IDID(roothdl));
937        //namespaceroot->push(NSPACK(namespaceroot->root), "Top");
938        idhdl rl=enterid(mstrdup(v->name), toLev, IDTYP(h),
939                         &(rootpack->idroot), FALSE);
940        namespaceroot->pop();
941
942        if( rl == NULL) return TRUE;
943        ring r=(ring)v->Data();
944        if(r != NULL) {
945          if (&IDRING(rl)!=NULL) rKill(rl);
946          r->ref++;
947          IDRING(rl)=r;
948        }
949        else PrintS("! ! ! ! ! r is empty!!!!!!!!!!!!\n");
950      }
951    }
952    else if ((BEGIN_RING<IDTYP(h)) && (IDTYP(h)<END_RING)
953             || ((IDTYP(h)==LIST_CMD) && (lRingDependend(IDLIST(h))))) {
954      //Print("// ==> Ringdependent set nesting to 0\n");
955      if(iiInternalExport(v, toLev)) return TRUE;
956    } else {
957      if (h==IDROOT)
958      {
959        IDROOT=h->next;
960      }
961      else
962      {
963        idhdl hh=IDROOT;
964        while ((hh->next!=h)&&(hh->next!=NULL))
965          hh=hh->next;
966        if (hh->next==h)
967          hh->next=h->next;
968        else
969          return TRUE;
970      }
971      h->next=rootpack->idroot;
972      rootpack->idroot=h;
973    }
974    IDLEV(h)=toLev;
975  }
976  return FALSE;
977}
978#endif /* HAVE_NAMESAPCES */
979
980BOOLEAN iiExport (leftv v, int toLev)
981{
982  BOOLEAN nok=FALSE;
983  leftv r=v;
984  while (v!=NULL)
985  {
986    if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL))
987    {
988      WerrorS("cannot export");
989      nok=TRUE;
990    }
991    else
992    {
993      if(iiInternalExport(v, toLev)) {
994        r->CleanUp();
995        return TRUE;
996      }
997    }
998    v=v->next;
999  }
1000  r->CleanUp();
1001  return nok;
1002}
1003
1004/*assume root!=idroot*/
1005#ifdef HAVE_NAMESPACES
1006BOOLEAN iiExport (leftv v, int toLev, idhdl root)
1007{
1008  BOOLEAN nok=FALSE;
1009  leftv rv=v;
1010  while (v!=NULL)
1011  {
1012    if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL)
1013    )
1014    {
1015      WerrorS("cannot export");
1016      nok=TRUE;
1017    }
1018    else
1019    {
1020      idhdl old=root->get(v->name,toLev);
1021      if (old!=NULL)
1022      {
1023        if (IDTYP(old)==v->Typ())
1024        {
1025          if (BVERBOSE(V_REDEFINE))
1026          {
1027            Warn("redefining %s",IDID(old));
1028          }
1029          killhdl(old,&root);
1030        }
1031        else
1032        {
1033          rv->CleanUp();
1034          return TRUE;
1035        }
1036      }
1037      if(iiInternalExport(v, toLev, root)) {
1038        rv->CleanUp();
1039        return TRUE;
1040      }
1041    }
1042    v=v->next;
1043  }
1044  rv->CleanUp();
1045  return nok;
1046}
1047#endif /* HAVE_NAMESPACES */
1048
1049BOOLEAN iiCheckRing(int i)
1050{
1051  if (currRingHdl==NULL)
1052  {
1053    #ifdef SIQ
1054    if (siq<=0)
1055    {
1056    #endif
1057      if ((i>BEGIN_RING) && (i<END_RING))
1058      {
1059        WerrorS("no ring active");
1060        return TRUE;
1061      }
1062    #ifdef SIQ
1063    }
1064    #endif
1065  }
1066  return FALSE;
1067}
1068
1069poly    iiHighCorner(ideal I, int ak)
1070{
1071  BOOLEAN *UsedAxis=(BOOLEAN *)Alloc0(pVariables*sizeof(BOOLEAN));
1072  int i,n;
1073  poly po;
1074  for(i=IDELEMS(I)-1;i>=0;i--)
1075  {
1076    po=I->m[i];
1077    if ((po!=NULL) &&((n=pIsPurePower(po))!=0)) UsedAxis[n-1]=TRUE;
1078  }
1079  for(i=pVariables-1;i>=0;i--)
1080  {
1081    if(UsedAxis[i]==FALSE) return NULL; // not zero-dim.
1082  }
1083  if (currRing->OrdSgn== -1)
1084  {
1085    po=NULL;
1086    scComputeHC(I,ak,po);
1087    if (po!=NULL)
1088    {
1089      pGetCoeff(po)=nInit(1);
1090      for (i=pVariables; i>0; i--)
1091      {
1092        if (pGetExp(po, i) > 0) pDecrExp(po,i);
1093      }
1094    }
1095  }
1096  if (po!=NULL)
1097  {
1098    pSetComp(po,ak);
1099    pSetm(po);
1100  }
1101  return po;
1102}
Note: See TracBrowser for help on using the repository browser.