source: git/Singular/ipshell.cc @ 4508ce5

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