source: git/Singular/ipshell.cc @ c232af

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