source: git/Singular/ipshell.cc @ 29467f

spielwiese
Last change on this file since 29467f was 29467f, checked in by Olaf Bachmann <obachman@…>, 24 years ago
* personal warning to Gerhard git-svn-id: file:///usr/local/Singular/svn/trunk@3229 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 25.1 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: ipshell.cc,v 1.43 1999-07-05 13:52:06 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("Gerhard, 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("Gerhard, 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;
764#define BREAK_LINE_LENGTH 80
765void iiDebug()
766{
767  Print("\n-- break point in %s --\n",VoiceName());
768  if (iiDebugMarker) VoiceBackTrack();
769  char * s;
770  iiDebugMarker=FALSE;
771  s = (char *)AllocL(BREAK_LINE_LENGTH+4);
772  loop
773  {
774    memset(s,0,80);
775    fe_fgets_stdin("",s,BREAK_LINE_LENGTH);
776    if (s[BREAK_LINE_LENGTH-1]!='\0')
777    {
778      Print("line too long, max is %d chars\n",BREAK_LINE_LENGTH);
779    }
780    else
781      break;
782  }
783  if (*s=='\n')
784  {
785    iiDebugMarker=TRUE;
786  }
787#if MDEBUG
788  else if(strncmp(s,"cont;",5)==0)
789  {
790    iiDebugMarker=TRUE;
791  }
792#endif /* MDEBUG */
793  else
794  {
795    strcat( s, "\n;~\n");
796    newBuffer(s,BT_execute);
797  }
798}
799
800int iiDeclCommand(leftv sy, leftv name, int lev,int t, idhdl* root,BOOLEAN isring, BOOLEAN init_b)
801{
802  BOOLEAN res=FALSE;
803  char *id = name->name;
804
805  memset(sy,0,sizeof(sleftv));
806  if ((name->name==NULL)||(isdigit(name->name[0])))
807  {
808    WerrorS("object to declare is not a name");
809    res=TRUE;
810  }
811  else
812  {
813    //if (name->rtyp!=0)
814    //{
815    //  Warn("`%s` is already in use",name->name);
816    //}
817#ifdef HAVE_NAMESPACES
818    if(name->req_packhdl != NULL && name->packhdl != NULL &&
819       name->req_packhdl != name->packhdl)
820      id = mstrdup(name->name);
821
822    //if(name->req_packhdl != NULL /*&& !isring*/) {
823    if(name->req_packhdl != NULL && !isring &&
824       IDPACKAGE(name->req_packhdl) != root) {
825      //Print("iiDeclCommand: PUSH(%s)\n",IDID(name->req_packhdl));
826      namespaceroot->push( IDPACKAGE(name->req_packhdl) ,
827                           IDID(name->req_packhdl));
828      sy->data = (char *)enterid(id,lev,t,
829                                 &IDPACKAGE(name->req_packhdl)->idroot,init_b);
830      namespaceroot->pop();
831    }
832    else
833#endif /* HAVE_NAMESPACES */
834    {
835      sy->data = (char *)enterid(id,lev,t,root,init_b);
836    }
837    if (sy->data!=NULL)
838    {
839      sy->rtyp=IDHDL;
840      currid=sy->name=IDID((idhdl)sy->data);
841      name->name=NULL; /* used in enterid */
842      //sy->e = NULL;
843      if (name->next!=NULL)
844      {
845        sy->next=(leftv)Alloc(sizeof(sleftv));
846        res=iiDeclCommand(sy->next,name->next,lev,t,root, isring);
847      }
848    }
849    else res=TRUE;
850  }
851  name->CleanUp();
852  return res;
853}
854
855BOOLEAN iiParameter(leftv p)
856{
857  if (iiCurrArgs==NULL)
858  {
859    if (strcmp(p->name,"#")==0) return FALSE;
860    Werror("not enough arguments for proc %s",VoiceName());
861    p->CleanUp();
862    return TRUE;
863  }
864  leftv h=iiCurrArgs;
865  if (strcmp(p->name,"#")==0)
866  {
867    iiCurrArgs=NULL;
868  }
869  else
870  {
871    iiCurrArgs=h->next;
872    h->next=NULL;
873  }
874  BOOLEAN res=iiAssign(p,h);
875  Free((ADDRESS)h,sizeof(sleftv));
876  return res;
877}
878
879static BOOLEAN iiInternalExport (leftv v, int toLev)
880{
881  idhdl h=(idhdl)v->data;
882  //Print("iiInternalExport('%s',%d)%s\n", v->name, toLev,"");
883  if (IDLEV(h)==0) Warn("`%s` is already global",IDID(h));
884  else
885  {
886    h=IDROOT->get(v->name,toLev);
887    idhdl *root=&IDROOT;
888    if ((h==NULL)&&(currRing!=NULL))
889    {
890      h=currRing->idroot->get(v->name,toLev);
891      root=&currRing->idroot;
892    }
893    if ((h!=NULL)&&(IDLEV(h)==toLev))
894    {
895      if (IDTYP(h)==v->Typ())
896      {
897        if (BVERBOSE(V_REDEFINE))
898        {
899#ifdef KAI
900          Warn("!!! redefining %s",IDID(h));
901#else
902          Warn("redefining %s",IDID(h));
903#endif
904        }
905#ifdef HAVE_NAMESPACES
906        //if (namespaceroot->currRing==IDRING(h)) namespaceroot->currRing=NULL;
907#endif /* HAVE_NAMESPACES */
908#ifdef USE_IILOCALRING
909            if (iiLocalRing[0]==IDRING(h)) iiLocalRing[0]=NULL;
910#else
911            if (namespaceroot->root->currRing==IDRING(h))
912              namespaceroot->root->currRing=NULL;
913#endif
914        killhdl(h,root);
915      }
916      else
917      {
918        return TRUE;
919      }
920    }
921    h=(idhdl)v->data;
922    IDLEV(h)=toLev;
923    iiNoKeepRing=FALSE;
924  }
925  return FALSE;
926}
927
928#ifdef HAVE_NAMESPACES
929BOOLEAN iiInternalExport (leftv v, int toLev, idhdl roothdl)
930{
931  idhdl h=(idhdl)v->data;
932  if(h==NULL) {
933    Warn("'%s': no such identifier\n", v->name);
934    return FALSE;
935  }
936  package rootpack = IDPACKAGE(roothdl);
937  //Print("iiInternalExport('%s',%d,%s) %s\n", v->name, toLev, IDID(roothdl),"");
938//  if (IDLEV(h)==0) Warn("`%s` is already global",IDID(h));
939//  else
940  {
941    /* is not ring or ring-element */
942    if( (IDTYP(h) == RING_CMD) || (IDTYP(h) == QRING_CMD)) {
943      sleftv tmp_expr;
944      //Print("// ==> Ring set nesting to 0\n");
945      //Print("// ++> make a copy of ring\n");
946      if(iiInternalExport(v, toLev)) return TRUE;
947      if(IDPACKAGE(roothdl) != NSPACK(namespaceroot)) {
948        namespaceroot->push(rootpack, IDID(roothdl));
949        //namespaceroot->push(NSPACK(namespaceroot->root), "Top");
950        idhdl rl=enterid(mstrdup(v->name), toLev, IDTYP(h),
951                         &(rootpack->idroot), FALSE);
952        namespaceroot->pop();
953
954        if( rl == NULL) return TRUE;
955        ring r=(ring)v->Data();
956        if(r != NULL) {
957          if (&IDRING(rl)!=NULL) rKill(rl);
958          r->ref++;
959          IDRING(rl)=r;
960        }
961        else PrintS("! ! ! ! ! r is empty!!!!!!!!!!!!\n");
962      }
963    }
964    else if ((BEGIN_RING<IDTYP(h)) && (IDTYP(h)<END_RING)
965             || ((IDTYP(h)==LIST_CMD) && (lRingDependend(IDLIST(h))))) {
966      //Print("// ==> Ringdependent set nesting to 0\n");
967      if(iiInternalExport(v, toLev)) return TRUE;
968    } else {
969      if (h==IDROOT)
970      {
971        IDROOT=h->next;
972      }
973      else
974      {
975        idhdl hh=IDROOT;
976        while ((hh->next!=h)&&(hh->next!=NULL))
977          hh=hh->next;
978        if (hh->next==h)
979          hh->next=h->next;
980        else
981          return TRUE;
982      }
983      h->next=rootpack->idroot;
984      rootpack->idroot=h;
985    }
986    IDLEV(h)=toLev;
987  }
988  return FALSE;
989}
990#endif /* HAVE_NAMESAPCES */
991
992BOOLEAN iiExport (leftv v, int toLev)
993{
994  BOOLEAN nok=FALSE;
995  leftv r=v;
996  while (v!=NULL)
997  {
998    if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL))
999    {
1000      WerrorS("cannot export");
1001      nok=TRUE;
1002    }
1003    else
1004    {
1005      if(iiInternalExport(v, toLev)) {
1006        r->CleanUp();
1007        return TRUE;
1008      }
1009    }
1010    v=v->next;
1011  }
1012  r->CleanUp();
1013  return nok;
1014}
1015
1016/*assume root!=idroot*/
1017#ifdef HAVE_NAMESPACES
1018BOOLEAN iiExport (leftv v, int toLev, idhdl root)
1019{
1020  BOOLEAN nok=FALSE;
1021  leftv rv=v;
1022  while (v!=NULL)
1023  {
1024    if ((v->name==NULL)||(v->rtyp==0)||(v->e!=NULL)
1025    )
1026    {
1027      WerrorS("cannot export");
1028      nok=TRUE;
1029    }
1030    else
1031    {
1032      idhdl old=root->get(v->name,toLev);
1033      if (old!=NULL)
1034      {
1035        if (IDTYP(old)==v->Typ())
1036        {
1037          if (BVERBOSE(V_REDEFINE))
1038          {
1039            Warn("redefining %s",IDID(old));
1040          }
1041          killhdl(old,&root);
1042        }
1043        else
1044        {
1045          rv->CleanUp();
1046          return TRUE;
1047        }
1048      }
1049      if(iiInternalExport(v, toLev, root)) {
1050        rv->CleanUp();
1051        return TRUE;
1052      }
1053    }
1054    v=v->next;
1055  }
1056  rv->CleanUp();
1057  return nok;
1058}
1059#endif /* HAVE_NAMESPACES */
1060
1061BOOLEAN iiCheckRing(int i)
1062{
1063  if (currRingHdl==NULL)
1064  {
1065    #ifdef SIQ
1066    if (siq<=0)
1067    {
1068    #endif
1069      if ((i>BEGIN_RING) && (i<END_RING))
1070      {
1071        WerrorS("no ring active");
1072        return TRUE;
1073      }
1074    #ifdef SIQ
1075    }
1076    #endif
1077  }
1078  return FALSE;
1079}
1080
1081poly    iiHighCorner(ideal I, int ak)
1082{
1083  BOOLEAN *UsedAxis=(BOOLEAN *)Alloc0(pVariables*sizeof(BOOLEAN));
1084  int i,n;
1085  poly po;
1086  for(i=IDELEMS(I)-1;i>=0;i--)
1087  {
1088    po=I->m[i];
1089    if ((po!=NULL) &&((n=pIsPurePower(po))!=0)) UsedAxis[n-1]=TRUE;
1090  }
1091  for(i=pVariables-1;i>=0;i--)
1092  {
1093    if(UsedAxis[i]==FALSE) return NULL; // not zero-dim.
1094  }
1095  if (currRing->OrdSgn== -1)
1096  {
1097    po=NULL;
1098    scComputeHC(I,ak,po);
1099    if (po!=NULL)
1100    {
1101      pGetCoeff(po)=nInit(1);
1102      for (i=pVariables; i>0; i--)
1103      {
1104        if (pGetExp(po, i) > 0) pDecrExp(po,i);
1105      }
1106    }
1107  }
1108  if (po!=NULL)
1109  {
1110    pSetComp(po,ak);
1111    pSetm(po);
1112  }
1113  return po;
1114}
Note: See TracBrowser for help on using the repository browser.