source: git/Singular/ipshell.cc @ 80aabd0

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