source: git/Singular/ipshell.cc @ 16acb0

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