source: git/Singular/ipshell.cc @ 110345

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