source: git/Singular/ipshell.cc @ 811826

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