Changeset 752f86 in git


Ignore:
Timestamp:
Dec 10, 2003, 5:28:03 PM (20 years ago)
Author:
Hans Schönemann <hannes@…>
Branches:
(u'spielwiese', '5b153614cbc72bfa198d75b1e9e33dab2645d9fe')
Children:
a830d2b37c7773703c1a3bd90df80f6f51dfc703
Parents:
e5a253c36a55093898d26a21f0ebdff4b3b6d024
Message:
*hannes: moved ippart to ipshell.cc


git-svn-id: file:///usr/local/Singular/svn/trunk@6962 2c84dea3-7e68-4137-9b89-c4e89433aadc
File:
1 edited

Legend:

Unmodified
Added
Removed
  • kernel/ring.cc

    re5a253 r752f86  
    22*  Computer Algebra System SINGULAR     *
    33****************************************/
    4 /* $Id: ring.cc,v 1.1.1.1 2003-10-06 12:15:55 Singular Exp $ */
     4/* $Id: ring.cc,v 1.2 2003-12-10 16:28:03 Singular Exp $ */
    55
    66/*
     
    105105}
    106106
    107 void rSetHdl(idhdl h)
    108 {
    109   int i;
    110   ring rg = NULL;
    111   if (h!=NULL)
    112   {
    113 //   Print(" new ring:%s (l:%d)\n",IDID(h),IDLEV(h));
    114     rg = IDRING(h);
    115     omCheckAddrSize((ADDRESS)h,sizeof(idrec));
    116     if (IDID(h))  // OB: ????
    117       omCheckAddr((ADDRESS)IDID(h));
    118     rTest(rg);
    119   }
    120 
    121   // clean up history
    122   if (sLastPrinted.RingDependend())
    123   {
    124     sLastPrinted.CleanUp();
    125     memset(&sLastPrinted,0,sizeof(sleftv));
    126   }
    127 
    128    /*------------ change the global ring -----------------------*/
    129   rChangeCurrRing(rg);
    130   currRingHdl = h;
    131 }
    132107
    133108ring rDefault(int ch, int N, char **n)
     
    207182
    208183// set R->order, R->block, R->wvhdl, r->OrdSgn from sleftv
    209 static BOOLEAN rSleftvOrdering2Ordering(sleftv *ord, ring R)
    210 {
    211   int last = 0, o=0, n = 1, i=0, typ = 1, j;
    212   sleftv *sl = ord;
    213 
    214   // determine nBlocks
    215   while (sl!=NULL)
    216   {
    217     intvec *iv = (intvec *)(sl->data);
    218     if (((*iv)[1]==ringorder_c)||((*iv)[1]==ringorder_C)) i++;
    219     else if ((*iv)[1]==ringorder_L)
    220     {
    221       R->bitmask=(*iv)[2];
    222       n--;
    223     }
    224     else if ((*iv)[1]!=ringorder_a) o++;
    225     n++;
    226     sl=sl->next;
    227   }
    228   // check whether at least one real ordering
    229   if (o==0)
    230   {
    231     WerrorS("invalid combination of orderings");
    232     return TRUE;
    233   }
    234   // if no c/C ordering is given, increment n
    235   if (i==0) n++;
    236   else if (i != 1)
    237   {
    238     // throw error if more than one is given
    239     WerrorS("more than one ordering c/C specified");
    240     return TRUE;
    241   }
    242 
    243   // initialize fields of R
    244   R->order=(int *)omAlloc0(n*sizeof(int));
    245   R->block0=(int *)omAlloc0(n*sizeof(int));
    246   R->block1=(int *)omAlloc0(n*sizeof(int));
    247   R->wvhdl=(int**)omAlloc0(n*sizeof(int_ptr));
    248 
    249   // init order, so that rBlocks works correctly
    250   for (j=0; j < n-1; j++)
    251     R->order[j] = (int) ringorder_unspec;
    252   // set last _C order, if no c/C order was given
    253   if (i == 0) R->order[n-2] = ringorder_C;
    254 
    255   /* init orders */
    256   sl=ord;
    257   n=-1;
    258   while (sl!=NULL)
    259   {
    260     intvec *iv;
    261     iv = (intvec *)(sl->data);
    262     if ((*iv)[1]!=ringorder_L)
    263     {
    264       n++;
    265 
    266       /* the format of an ordering:
    267        *  iv[0]: factor
    268        *  iv[1]: ordering
    269        *  iv[2..end]: weights
    270        */
    271       R->order[n] = (*iv)[1];
    272       switch ((*iv)[1])
    273       {
    274           case ringorder_ws:
    275           case ringorder_Ws:
    276             typ=-1;
    277           case ringorder_wp:
    278           case ringorder_Wp:
    279             R->wvhdl[n]=(int*)omAlloc((iv->length()-1)*sizeof(int));
    280             for (i=2; i<iv->length(); i++)
    281               R->wvhdl[n][i-2] = (*iv)[i];
    282             R->block0[n] = last+1;
    283             last += iv->length()-2;
    284             R->block1[n] = last;
    285             break;
    286           case ringorder_ls:
    287           case ringorder_ds:
    288           case ringorder_Ds:
    289             typ=-1;
    290           case ringorder_lp:
    291           case ringorder_dp:
    292           case ringorder_Dp:
    293           case ringorder_rp:
    294             R->block0[n] = last+1;
    295             if (iv->length() == 3) last+=(*iv)[2];
    296             else last += (*iv)[0];
    297             R->block1[n] = last;
    298             if (rCheckIV(iv)) return TRUE;
    299             break;
    300           case ringorder_S:
    301           case ringorder_c:
    302           case ringorder_C:
    303             if (rCheckIV(iv)) return TRUE;
    304             break;
    305           case ringorder_aa:
    306           case ringorder_a:
    307             R->block0[n] = last+1;
    308             R->block1[n] = min(last+iv->length()-2 , R->N);
    309             R->wvhdl[n] = (int*)omAlloc((iv->length()-1)*sizeof(int));
    310             for (i=2; i<iv->length(); i++)
    311             {
    312               R->wvhdl[n][i-2]=(*iv)[i];
    313               if ((*iv)[i]<0) typ=-1;
    314             }
    315             break;
    316           case ringorder_M:
    317           {
    318             int Mtyp=rTypeOfMatrixOrder(iv);
    319             if (Mtyp==0) return TRUE;
    320             if (Mtyp==-1) typ = -1;
    321 
    322             R->wvhdl[n] =( int *)omAlloc((iv->length()-1)*sizeof(int));
    323             for (i=2; i<iv->length();i++)
    324               R->wvhdl[n][i-2]=(*iv)[i];
    325 
    326             R->block0[n] = last+1;
    327             last += (int)sqrt((double)(iv->length()-2));
    328             R->block1[n] = last;
    329             break;
    330           }
    331 
    332           case ringorder_no:
    333             R->order[n] = ringorder_unspec;
    334             return TRUE;
    335 
    336           default:
    337             Werror("Internal Error: Unknown ordering %d", (*iv)[1]);
    338             R->order[n] = ringorder_unspec;
    339             return TRUE;
    340       }
    341     }
    342     sl=sl->next;
    343   }
    344 
    345   // check for complete coverage
    346   if ((R->order[n]==ringorder_c) ||  (R->order[n]==ringorder_C)) n--;
    347   if (R->block1[n] != R->N)
    348   {
    349     if (((R->order[n]==ringorder_dp) ||
    350          (R->order[n]==ringorder_ds) ||
    351          (R->order[n]==ringorder_Dp) ||
    352          (R->order[n]==ringorder_Ds) ||
    353          (R->order[n]==ringorder_rp) ||
    354          (R->order[n]==ringorder_lp) ||
    355          (R->order[n]==ringorder_ls))
    356         &&
    357         R->block0[n] <= R->N)
    358     {
    359       R->block1[n] = R->N;
    360     }
    361     else
    362     {
    363       Werror("mismatch of number of vars (%d) and ordering (%d vars)",
    364              R->N,R->block1[n]);
    365       return TRUE;
    366     }
    367   }
    368   R->OrdSgn = typ;
    369   return FALSE;
    370 }
     184BOOLEAN rSleftvOrdering2Ordering(sleftv *ord, ring R);
    371185
    372186// get array of strings from list of sleftv's
    373 static BOOLEAN rSleftvList2StringArray(sleftv* sl, char** p)
    374 {
    375 
    376   while(sl!=NULL)
    377   {
    378     if (sl->Name() == sNoName)
    379     {
    380       if (sl->Typ()==POLY_CMD)
    381       {
    382         sleftv s_sl;
    383         iiConvert(POLY_CMD,ANY_TYPE,-1,sl,&s_sl);
    384         if (s_sl.Name() != sNoName)
    385           *p = omStrDup(s_sl.Name());
    386         else
    387           *p = NULL;
    388         sl->next = s_sl.next;
    389         s_sl.next = NULL;
    390         s_sl.CleanUp();
    391         if (*p == NULL) return TRUE;
    392       }
    393       else
    394         return TRUE;
    395     }
    396     else
    397       *p = omStrDup(sl->Name());
    398     p++;
    399     sl=sl->next;
    400   }
    401   return FALSE;
    402 }
    403 
    404 
    405 ////////////////////
    406 //
    407 // rInit itself:
    408 //
    409 // INPUT:  s: name, pn: ch & parameter (names), rv: variable (names)
    410 //         ord: ordering
    411 // RETURN: currRingHdl on success
    412 //         NULL        on error
    413 // NOTE:   * makes new ring to current ring, on success
    414 //         * considers input sleftv's as read-only
    415 //idhdl rInit(char *s, sleftv* pn, sleftv* rv, sleftv* ord)
    416 ring rInit(sleftv* pn, sleftv* rv, sleftv* ord)
    417 {
    418   int ch;
    419   int float_len=0;
    420   int float_len2=0;
    421   ring R = NULL;
    422   idhdl tmp = NULL;
    423   BOOLEAN ffChar=FALSE;
    424   int typ = 1;
    425 
    426   /* ch -------------------------------------------------------*/
    427   // get ch of ground field
    428   int numberOfAllocatedBlocks;
    429 
    430   if (pn->Typ()==INT_CMD)
    431   {
    432     ch=(int)pn->Data();
    433   }
    434   else if ((pn->name != NULL)
    435   && ((strcmp(pn->name,"real")==0) || (strcmp(pn->name,"complex")==0)))
    436   {
    437     BOOLEAN complex_flag=(strcmp(pn->name,"complex")==0);
    438     ch=-1;
    439     if ((pn->next!=NULL) && (pn->next->Typ()==INT_CMD))
    440     {
    441       float_len=(int)pn->next->Data();
    442       float_len2=float_len;
    443       pn=pn->next;
    444       if ((pn->next!=NULL) && (pn->next->Typ()==INT_CMD))
    445       {
    446         float_len2=(int)pn->next->Data();
    447         pn=pn->next;
    448       }
    449     }
    450     if ((pn->next==NULL) && complex_flag)
    451     {
    452       pn->next=(leftv)omAlloc0Bin(sleftv_bin);
    453       pn->next->name=omStrDup("i");
    454     }
    455   }
    456   else
    457   {
    458     Werror("Wrong ground field specification");
    459     goto rInitError;
    460   }
    461   pn=pn->next;
    462 
    463   int l, last;
    464   sleftv * sl;
    465   /*every entry in the new ring is initialized to 0*/
    466 
    467   /* characteristic -----------------------------------------------*/
    468   /* input: 0 ch=0 : Q     parameter=NULL    ffChar=FALSE   float_len
    469    *         0    1 : Q(a,...)        *names         FALSE
    470    *         0   -1 : R               NULL           FALSE  0
    471    *         0   -1 : R               NULL           FALSE  prec. >6
    472    *         0   -1 : C               *names         FALSE  prec. 0..?
    473    *         p    p : Fp              NULL           FALSE
    474    *         p   -p : Fp(a)           *names         FALSE
    475    *         q    q : GF(q=p^n)       *names         TRUE
    476   */
    477   if (ch!=-1)
    478   {
    479     int l = 0;
    480 
    481     if (ch!=0 && (ch<2)
    482     #ifndef NV_OPS
    483     || (ch > 32003)
    484     #endif
    485     )
    486     {
    487       Warn("%d is invalid characteristic of ground field. 32003 is used.", ch);
    488       ch=32003;
    489     }
    490     // load fftable, if necessary
    491     if (pn!=NULL)
    492     {
    493       while ((ch!=fftable[l]) && (fftable[l])) l++;
    494       if (fftable[l]==0) ch = IsPrime(ch);
    495       else
    496       {
    497         char *m[1]={(char *)sNoName};
    498         nfSetChar(ch,m);
    499         if (errorreported) goto rInitError;
    500         else ffChar=TRUE;
    501       }
    502     }
    503     else
    504       ch = IsPrime(ch);
    505   }
    506   // allocated ring and set ch
    507   R = (ring) omAlloc0Bin(sip_sring_bin);
    508   R->ch = ch;
    509   if (ch == -1)
    510   {
    511     R->float_len= min(float_len,32767);
    512     R->float_len2= min(float_len2,32767);
    513   }
    514 
    515   /* parameter -------------------------------------------------------*/
    516   if (pn!=NULL)
    517   {
    518     R->P=pn->listLength();
    519     //if ((ffChar|| (ch == 1)) && (R->P > 1))
    520     if ((R->P > 1) && (ffChar || (ch == -1)))
    521     {
    522       WerrorS("too many parameters");
    523       goto rInitError;
    524     }
    525     R->parameter=(char**)omAlloc0(R->P*sizeof(char_ptr));
    526     if (rSleftvList2StringArray(pn, R->parameter))
    527     {
    528       WerrorS("parameter expected");
    529       goto rInitError;
    530     }
    531     if (ch>1 && !ffChar) R->ch=-ch;
    532     else if (ch==0) R->ch=1;
    533   }
    534   else if (ffChar)
    535   {
    536     WerrorS("need one parameter");
    537     goto rInitError;
    538   }
    539   /* post-processing of field description */
    540   // we have short reals, but no short complex
    541   if ((R->ch == - 1)
    542   && (R->parameter !=NULL)
    543   && (R->float_len < SHORT_REAL_LENGTH))
    544   {
    545     R->float_len = SHORT_REAL_LENGTH;
    546     R->float_len2 = SHORT_REAL_LENGTH;
    547   }
    548 
    549   /* names and number of variables-------------------------------------*/
    550   {
    551     int l=rv->listLength();
    552 #if SIZEOF_SHORT == 2
    553 #define MAX_SHORT 0x7fff
    554 #endif
    555     if (l>MAX_SHORT)
    556     {
    557       Werror("too many ring variables(%d), max is %d",l,MAX_SHORT);
    558        goto rInitError;
    559     }
    560     R->N = l; /*rv->listLength();*/
    561   }
    562   R->names   = (char **)omAlloc0(R->N * sizeof(char_ptr));
    563   if (rSleftvList2StringArray(rv, R->names))
    564   {
    565     WerrorS("name of ring variable expected");
    566     goto rInitError;
    567   }
    568 
    569   /* check names and parameters for conflicts ------------------------- */
    570   {
    571     int i,j;
    572     for(i=0;i<R->P; i++)
    573     {
    574       for(j=0;j<R->N;j++)
    575       {
    576         if (strcmp(R->parameter[i],R->names[j])==0)
    577         {
    578           Werror("parameter %d conflicts with variable %d",i+1,j+1);
    579           goto rInitError;
    580         }
    581       }
    582     }
    583   }
    584   /* ordering -------------------------------------------------------------*/
    585   if (rSleftvOrdering2Ordering(ord, R))
    586     goto rInitError;
    587 
    588   // Complete the initialization
    589   if (rComplete(R,1))
    590     goto rInitError;
    591 
    592   rTest(R);
    593 
    594   // try to enter the ring into the name list
    595   // need to clean up sleftv here, before this ring can be set to
    596   // new currRing or currRing can be killed beacuse new ring has
    597   // same name
    598   if (pn != NULL) pn->CleanUp();
    599   if (rv != NULL) rv->CleanUp();
    600   if (ord != NULL) ord->CleanUp();
    601   //if ((tmp = enterid(s, myynest, RING_CMD, &IDROOT))==NULL)
    602   //  goto rInitError;
    603 
    604   //memcpy(IDRING(tmp),R,sizeof(*R));
    605   // set current ring
    606   //omFreeBin(R,  ip_sring_bin);
    607   //return tmp;
    608   return R;
    609 
    610   // error case:
    611   rInitError:
    612   if  (R != NULL) rDelete(R);
    613   if (pn != NULL) pn->CleanUp();
    614   if (rv != NULL) rv->CleanUp();
    615   if (ord != NULL) ord->CleanUp();
    616   return NULL;
    617 }
     187BOOLEAN rSleftvList2StringArray(sleftv* sl, char** p);
     188
    618189
    619190/*2
     
    843414  }
    844415  omFreeBin(r, ip_sring_bin);
    845 }
    846 
    847 void rKill(ring r)
    848 {
    849   if ((r->ref<=0)&&(r->order!=NULL))
    850   {
    851 #ifdef RDEBUG
    852     if (traceit &TRACE_SHOW_RINGS) Print("kill ring %x\n",r);
    853 #endif
    854     if (r==currRing)
    855     {
    856       if (r->qideal!=NULL)
    857       {
    858         idDelete(&r->qideal);
    859         r->qideal=NULL;
    860         currQuotient=NULL;
    861       }
    862       if (ppNoether!=NULL) pDelete(&ppNoether);
    863       if (sLastPrinted.RingDependend())
    864       {
    865         sLastPrinted.CleanUp();
    866       }
    867       if ((myynest>0) && (iiRETURNEXPR[myynest].RingDependend()))
    868       {
    869         WerrorS("return value depends on local ring variable (export missing ?)");
    870         iiRETURNEXPR[myynest].CleanUp();
    871       }
    872       currRing=NULL;
    873       currRingHdl=NULL;
    874     }
    875     else if (r->qideal!=NULL)
    876     {
    877       id_Delete(&r->qideal, r);
    878       r->qideal = NULL;
    879     }
    880     #ifdef HAVE_PLURAL
    881     // delete noncommutative extension
    882     if (r->nc!=NULL)
    883     {
    884       if (r->nc->ref>1) r->nc->ref--;
    885       else ncKill(r);
    886     }
    887     #endif
    888     nKillChar(r);
    889     int i=1;
    890     int j;
    891     int *pi=r->order;
    892 #ifdef USE_IILOCALRING
    893     for (j=0;j<iiRETURNEXPR_len;j++)
    894     {
    895       if (iiLocalRing[j]==r)
    896       {
    897         if (j<myynest) Warn("killing the basering for level %d",j);
    898         iiLocalRing[j]=NULL;
    899       }
    900     }
    901 #else /* USE_IILOCALRING */
    902 //#endif /* USE_IILOCALRING */
    903     {
    904       proclevel * nshdl = procstack;
    905       int lev=myynest-1;
    906 
    907       for(; nshdl != NULL; nshdl = nshdl->next)
    908       {
    909         if (nshdl->cRing==r)
    910         {
    911           Warn("killing the basering for level %d",lev);
    912           nshdl->cRing=NULL;
    913           nshdl->cRingHdl=NULL;
    914         }
    915       }
    916     }
    917 #endif /* USE_IILOCALRING */
    918 
    919     rDelete(r);
    920     return;
    921   }
    922   r->ref--;
    923 }
    924 
    925 void rKill(idhdl h)
    926 {
    927   ring r = IDRING(h);
    928   int ref=0;
    929   if (r!=NULL)
    930   {
    931     ref=r->ref;
    932     rKill(r);
    933   }
    934   if (h==currRingHdl)
    935   {
    936     if (ref<=0) { currRing=NULL; currRingHdl=NULL;}
    937     else
    938     {
    939       currRingHdl=rFindHdl(r,currRingHdl,NULL);
    940     }
    941   }
    942 }
    943 
    944 idhdl rSimpleFindHdl(ring r, idhdl root, idhdl n=NULL)
    945 {
    946   idhdl h=root;
    947   while (h!=NULL)
    948   {
    949     if (((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
    950     && (h!=n)
    951     && (h->data.uring==r)
    952     )
    953       return h;
    954     h=IDNEXT(h);
    955   }
    956   return NULL;
    957416}
    958417
Note: See TracChangeset for help on using the changeset viewer.