Changeset 7df2ef in git


Ignore:
Timestamp:
Mar 19, 1999, 3:18:06 PM (25 years ago)
Author:
Olaf Bachmann <obachman@…>
Branches:
(u'spielwiese', '8e0ad00ce244dfd0756200662572aef8402f13d5')
Children:
105efeceef55c91a7f3c55acd25aac54cf6ae7ba
Parents:
d848cbc60006fd0a077acd65adeeba164c6fab9d
Message:
* reimplemented rInit
* added top-level command leadmonom
* re-added mmTestList


git-svn-id: file:///usr/local/Singular/svn/trunk@2961 2c84dea3-7e68-4137-9b89-c4e89433aadc
Location:
Singular
Files:
9 edited

Legend:

Unmodified
Added
Removed

  • Singular/grammar.y

    rd848cbc r7df2ef  
    22*  Computer Algebra System SINGULAR     *
    33****************************************/
    4 /* $Id: grammar.y,v 1.56 1999-01-07 12:21:51 Singular Exp $ */
     4/* $Id: grammar.y,v 1.57 1999-03-19 14:17:58 obachman Exp $ */
    55/*
    66* ABSTRACT: SINGULAR shell grammatik
    … …  
    190190%token <i> LEADEXP_CMD
    191191%token <i> LEAD_CMD
     192%token <i> LEADMONOM_CMD
    192193%token <i> LIFTSTD_CMD
    193194%token <i> LIFT_CMD
    … …  
    927928        UNKNOWN_IDENT
    928929        {
     930#if 0         
    929931          if (!($$=rOrderName($1)))
    930932            YYERROR;
     933#else
     934          // let rInit take care of any errors
     935          $$=rOrderName($1);
     936#endif         
    931937        }
    932938        ;
    … …  
    13291335              MYYERROR("cannot make ring");
    13301336            }
     1337            else
     1338            {
     1339              rSetHdl(b);
     1340            }
    13311341          }
    13321342        | ringcmd1 elemexpr
    … …  
    13851395              YYERROR;
    13861396            }
     1397            rSetHdl(h);
    13871398            setFlag(h,FLAG_DRING);
    13881399            rDSet();

  • Singular/iparith.cc

    rd848cbc r7df2ef  
    22*  Computer Algebra System SINGULAR     *
    33****************************************/
    4 /* $Id: iparith.cc,v 1.139 1999-03-17 14:26:28 pohl Exp $ */
     4/* $Id: iparith.cc,v 1.140 1999-03-19 14:18:00 obachman Exp $ */
    55
    66/*
    … …  
    197197  { "leadcoef",    0, LEADCOEF_CMD ,      CMD_1},
    198198  { "leadexp",     0, LEADEXP_CMD ,       CMD_1},
     199  { "leadmonom",   0, LEADMONOM_CMD ,     CMD_1},
    199200  { "LIB",         0, LIB_CMD ,           SYSVAR},
    200201  { "lift",        0, LIFT_CMD ,          CMD_23},
    … …  
    12591260{
    12601261  if(u->name==NULL) return TRUE;
    1261   char * nn = (char *)AllocL(strlen(u->name) + 13);
     1262  char * nn = (char *)AllocL(strlen(u->name) + 14);
    12621263  sprintf(nn,"%s(%d)",u->name,(int)v->Data());
    12631264  FreeL((ADDRESS)u->name);
    … …  
    12821283  leftv p=NULL;
    12831284  int i;
    1284   char *n;
     1285  int slen = strlen(u->name) + 14;
     1286  char *n = (char*) Alloc(slen);
    12851287#ifdef HAVE_NAMESPACES
    12861288  BOOLEAN needpop=FALSE;
    … …  
    13041306      p=p->next;
    13051307    }
    1306     n = (char *)AllocL(strlen(u->name) + 6);
    13071308    sprintf(n,"%s(%d)",u->name,(*iv)[i]);
    1308     syMake(p,n);
     1309    syMake(p,mstrdup(n));
    13091310  }
    13101311  FreeL((ADDRESS)u->name);
    1311   u->name=NULL;
     1312  u->name = NULL;
     1313  Free(n, slen);
    13121314#ifdef HAVE_NAMESPACES
    13131315  if(needpop) namespaceroot->pop();
    … …  
    27232725  return FALSE;
    27242726}
     2727static BOOLEAN jjLEADMONOM(leftv res, leftv v)
     2728{
     2729  poly p=(poly)v->Data();
     2730  if (p == NULL)
     2731  {
     2732    res->data = (char*) NULL;
     2733  }
     2734  else
     2735  {
     2736    poly lm = pCopy1(p);
     2737    pSetCoeff(lm, nInit(1));
     2738    res->data = (char*) lm;
     2739  }
     2740  return FALSE;
     2741}
    27252742static BOOLEAN jjLIB(leftv res, leftv v)
    27262743{
    … …  
    34733490,{jjLEADEXP,    LEADEXP_CMD,     INTVEC_CMD,     POLY_CMD }
    34743491,{jjLEADEXP,    LEADEXP_CMD,     INTVEC_CMD,     VECTOR_CMD }
     3492,{jjLEADMONOM,  LEADMONOM_CMD,   POLY_CMD,       POLY_CMD }
     3493,{jjLEADMONOM,  LEADMONOM_CMD,   VECTOR_CMD,     VECTOR_CMD }
    34753494,{jjLIB,        LIB_CMD,         NONE,           STRING_CMD }
    34763495,{jjCALL1MANY,  LIST_CMD,        LIST_CMD,       DEF_CMD }

  • Singular/mmemory.h

    rd848cbc r7df2ef  
    44*  Computer Algebra System SINGULAR     *
    55****************************************/
    6 /* $Id: mmemory.h,v 1.15 1999-01-26 14:41:39 obachman Exp $ */
     6/* $Id: mmemory.h,v 1.16 1999-03-19 14:18:01 obachman Exp $ */
    77/*
    88* ABSTRACT
    … …  
    153153size_t mmSizeL( void* );
    154154
     155/* max size of blocks which our memory managment handles */
     156#define MAX_BLOCK_SIZE  (((SIZE_OF_HEAP_PAGE) / 16)*4)
     157
    155158/**********************************************************************
    156159 *

  • Singular/mmisc.c

    rd848cbc r7df2ef  
    22*  Computer Algebra System SINGULAR     *
    33****************************************/
    4 /* $Id: mmisc.c,v 1.2 1999-01-26 14:41:41 obachman Exp $ */
     4/* $Id: mmisc.c,v 1.3 1999-03-19 14:18:02 obachman Exp $ */
    55
    66/*
    … …  
    136136#endif
    137137
     138#ifdef MLIST
     139void mmTestList ( )
     140{
     141  DBMCB * what=mm_theDBused.next;
     142  fprintf(stderr,"list of used blocks:\n");
     143  while (what!=NULL)
     144  {
     145    (void)fprintf( stderr, "%d bytes at %p in: %s:%d\n",
     146      (int)what->size, what, what->fname, what->lineno);
     147    what=what->next;
     148  }
     149}
     150#endif
     151
    138152
    139153/**********************************************************************

  • Singular/mmprivate.h

    rd848cbc r7df2ef  
    44*  Computer Algebra System SINGULAR     *
    55****************************************/
    6 /* $Id: mmprivate.h,v 1.5 1999-03-18 16:30:53 Singular Exp $ */
     6/* $Id: mmprivate.h,v 1.6 1999-03-19 14:18:03 obachman Exp $ */
    77/*
    88* ABSTRACT
    … …  
    1010#include "structs.h"
    1111#include "mmheap.h"
    12 
    13 #define MAX_BLOCK_SIZE  (((SIZE_OF_HEAP_PAGE) / 16)*4)
    1412
    1513#define INDEX_ENTRY_T   char

  • Singular/mod2.h.in

    rd848cbc r7df2ef  
    345345/* define TEST for non time critical tests, undefine otherwise */
    346346#define TEST
    347 /* define MM_LIST for printing block of used memory on exit */
    348 #define MM_LIST 1
     347/* define MLIST for printing block of used memory on exit */
     348#define MLIST 1
    349349
    350350/* #define PAGE_TEST */

  • Singular/polys-impl.h

    rd848cbc r7df2ef  
    44*  Computer Algebra System SINGULAR     *
    55****************************************/
    6 /* $Id: polys-impl.h,v 1.28 1998-12-16 18:43:44 Singular Exp $ */
     6/* $Id: polys-impl.h,v 1.29 1999-03-19 14:18:04 obachman Exp $ */
    77
    88/***************************************************************
    … …  
    5252#define POLYSIZE (sizeof(poly) + sizeof(number) + sizeof(Order_t))
    5353#define POLYSIZEW (POLYSIZE / sizeof(long))
     54#define MAX_EXPONENT_NUMBER ((MAX_BLOCK_SIZE - POLYSIZE) / SIZEOF_EXPONENT)
     55
    5456// number of Variables
    5557extern int pVariables;

  • Singular/ring.cc

    rd848cbc r7df2ef  
    22*  Computer Algebra System SINGULAR     *
    33****************************************/
    4 /* $Id: ring.cc,v 1.47 1999-03-15 14:05:31 Singular Exp $ */
     4/* $Id: ring.cc,v 1.48 1999-03-19 14:18:05 obachman Exp $ */
    55
    66/*
    … …  
    3232short rNumber=0;
    3333#endif
     34
     35// static procedures
     36// unconditionally deletes fields in r
     37static void rDelete(ring r);
    3438
    3539/*0 implementation*/
    … …  
    244248}
    245249
    246 /*2
    247  *check intvec, describing the ordering
    248  */
    249 BOOLEAN rCheckIV(intvec *iv)
     250///////////////////////////////////////////////////////////////////////////
     251//
     252// rInit: define a new ring from sleftv's
     253//
     254
     255/////////////////////////////
     256// Auxillary functions
     257//
     258
     259// check intvec, describing the ordering
     260static BOOLEAN rCheckIV(intvec *iv)
    250261{
    251262  if ((iv->length()!=2)&&(iv->length()!=3))
    … …  
    279290}
    280291
    281 /*2
    282  * define a new ring from the data:
    283  *s: name, chr: ch, parameter names (or NULL): pn,
    284  *varnames: rv, ordering: ord, typ: typ
    285  */
     292// set R->order, R->block, R->wvhdl, r->OrdSgn from sleftv
     293static BOOLEAN rSleftvOrdering2Ordering(sleftv *ord, ring R)
     294{
     295  int last = 0, o=0, n = 1, i=0, typ = 1, j;
     296  sleftv *sl = ord;
     297
     298  // determine nBlocks
     299  while (sl!=NULL)
     300  {
     301    intvec *iv = (intvec *)(sl->data);
     302    if (((*iv)[1]==ringorder_c)||((*iv)[1]==ringorder_C)) i++;
     303    else if ((*iv)[1]!=ringorder_a) o++;
     304    n++;
     305    sl=sl->next;
     306  }
     307  // check whether at least one real ordering
     308  if (o==0)
     309  {
     310    WerrorS("invalid combination of orderings");
     311    return TRUE;
     312  }
     313  // if no c/C ordering is given, increment n
     314  if (i==0) n++;
     315  else if (i != 1)
     316  {
     317    // throw error if more than one is given
     318    WerrorS("more than one ordering c/C specified");
     319    return TRUE;
     320  }
     321 
     322  // initialize fields of R
     323  R->order=(int *)Alloc0(n*sizeof(int));
     324  R->block0=(int *)Alloc0(n*sizeof(int));
     325  R->block1=(int *)Alloc0(n*sizeof(int));
     326  R->wvhdl=(short**)Alloc0(n*sizeof(short*));
     327
     328  // init order, so that rBlocks works correctly
     329  for (j=0; j < n-1; j++)
     330    R->order[j] = (int) ringorder_unspec;
     331  // set last _C order, if no c/C order was given
     332  if (i == 0) R->order[n-2] = ringorder_C;
     333
     334  /* init orders */
     335  sl=ord;
     336  n=-1;
     337  while (sl!=NULL)
     338  {
     339    intvec *iv;
     340    iv = (intvec *)(sl->data);
     341    n++;
     342
     343    /* the format of an ordering:
     344     *  iv[0]: factor
     345     *  iv[1]: ordering
     346     *  iv[2..end]: weights
     347     */
     348    R->order[n] = (*iv)[1];
     349    switch ((*iv)[1])
     350    {
     351        case ringorder_ws:
     352        case ringorder_Ws:
     353          typ=-1;
     354        case ringorder_wp:
     355        case ringorder_Wp:
     356          R->wvhdl[n]=(short*)AllocL((iv->length()-1)*sizeof(short));
     357          for (i=2; i<iv->length(); i++)
     358            R->wvhdl[n][i-2] = (short)(*iv)[i];
     359          R->block0[n] = last+1;
     360          last += iv->length()-2;
     361          R->block1[n] = last;
     362          break;
     363        case ringorder_ls:
     364        case ringorder_ds:
     365        case ringorder_Ds:
     366          typ=-1;
     367        case ringorder_lp:
     368        case ringorder_dp:
     369        case ringorder_Dp:
     370          R->block0[n] = last+1;
     371          if (iv->length() == 3) last+=(*iv)[2];
     372          else last += (*iv)[0];
     373          R->block1[n] = last;
     374          if (rCheckIV(iv)) return TRUE;
     375          break;
     376        case ringorder_c:
     377        case ringorder_C:
     378          if (rCheckIV(iv)) return TRUE;
     379          break;
     380        case ringorder_a:
     381          R->block0[n] = last+1;
     382          R->block1[n] = last + iv->length() - 2;
     383          R->wvhdl[n] = (short*)AllocL((iv->length()-1)*sizeof(short));
     384          for (i=2; i<iv->length(); i++)
     385          {
     386            R->wvhdl[n][i-2]=(short)(*iv)[i];
     387            if ((*iv)[i]<0) typ=-1;
     388          }
     389          break;
     390        case ringorder_M:
     391        {
     392          int Mtyp=rTypeOfMatrixOrder(iv);
     393          if (Mtyp==0) return TRUE;
     394          if (Mtyp==-1) typ = -1;
     395
     396          R->wvhdl[n] =( short*)AllocL((iv->length()-1)*sizeof(short));
     397          for (i=2; i<iv->length();i++)
     398            R->wvhdl[n][i-2]=(short)(*iv)[i];
     399
     400          R->block0[n] = last+1;
     401          last += (int)sqrt((double)(iv->length()-2));
     402          R->block1[n] = last;
     403          break;
     404        }
     405       
     406        case ringorder_no:
     407           R->order[n] = ringorder_unspec;
     408           return TRUE;
     409           
     410        default:
     411          Werror("Internal Error: Unknown ordering %d", (*iv)[1]);
     412          R->order[n] = ringorder_unspec;
     413          return TRUE;
     414    }
     415    sl=sl->next;
     416  }
     417
     418  // check for complete coverage
     419  if ((R->order[n]==ringorder_c) ||  (R->order[n]==ringorder_C)) n--;
     420  if (R->block1[n] != R->N)
     421  {
     422    if (((R->order[n]==ringorder_dp) ||
     423         (R->order[n]==ringorder_ds) ||
     424         (R->order[n]==ringorder_Dp) ||
     425         (R->order[n]==ringorder_Ds) ||
     426         (R->order[n]==ringorder_lp) ||
     427         (R->order[n]==ringorder_ls))
     428        &&
     429        R->block0[n] <= R->N)
     430    {
     431      R->block1[n] = R->N;
     432    }
     433    else
     434    {
     435      Werror("mismatch of number of vars (%d) and ordering (%d vars)",
     436             R->N,R->block1[n]);
     437      return TRUE;
     438    }
     439  }
     440  R->OrdSgn = typ;
     441  return FALSE;
     442}
     443
     444// get array of strings from list of sleftv's
     445static BOOLEAN rSleftvList2StringArray(sleftv* sl, char** p)
     446{
     447 
     448  while(sl!=NULL)
     449  {
     450    if (sl->Name() == sNoName)
     451    {
     452      if (sl->Typ()==POLY_CMD)
     453      {
     454        sleftv s_sl;
     455        iiConvert(POLY_CMD,ANY_TYPE,-1,sl,&s_sl);
     456        if (s_sl.Name() != sNoName)
     457          *p = mstrdup(s_sl.Name());
     458        else
     459          *p = NULL;
     460        sl->next = s_sl.next;
     461        s_sl.next = NULL;
     462        s_sl.CleanUp();
     463        if (*p == NULL) return TRUE;
     464      }
     465      else
     466        return TRUE;
     467    }
     468    else
     469      *p = mstrdup(sl->Name());
     470    p++;
     471    sl=sl->next;
     472  }
     473  return FALSE;
     474}
     475
     476
     477////////////////////
     478//
     479// rInit itself:
     480//
     481// INPUT:  s: name, pn: ch & parameter (names), rv: variable (names)
     482//         ord: ordering
     483// RETURN: currRingHdl on success
     484//         NULL        on error
     485// NOTE:   * makes new ring to current ring, on success
     486//         * considers input sleftv's as read-only
    286487idhdl rInit(char *s, sleftv* pn, sleftv* rv, sleftv* ord,
    287488            BOOLEAN isDRing)
    288489{
    289490  int ch;
     491  ring R = NULL;
     492  idhdl tmp = NULL;
     493  BOOLEAN ffChar=FALSE;
     494
     495  /* ch -------------------------------------------------------*/
     496  // get ch of ground field
    290497  if (pn->Typ()==INT_CMD)
    291498  {
    292499    ch=(int)pn->Data();
    293500  }
    294   else if (strcmp(pn->name,"real")==0)
     501  else if (pn->name != NULL && strcmp(pn->name,"real")==0)
    295502  {
    296503    ch=-1;
    … …  
    298505  else
    299506  {
    300     return NULL;
     507    Werror("Wrong ground field specification");
     508    goto rInitError;
    301509  }
    302510  pn=pn->next;
    303 
    304   int l, last;
    305   int typ = 1;
    306   sleftv * sl;
    307   idhdl tmp;
    308   ip_sring tmpR;
    309   BOOLEAN ffChar=FALSE;
    310   /*every entry in the new ring is initialized to 0*/
    311 
     511 
    312512  /* characteristic -----------------------------------------------*/
    313513  /* input: 0 ch=0 : Q     parameter=NULL    ffChar=FALSE
    … …  
    320520  if (ch!=-1)
    321521  {
    322     if ((ch!=0) &&((ch<2) || (ch > 32003)))
    323     {
     522    int l = 0;
     523   
     524    if (ch!=0 && (ch<2) || (ch > 32003))
     525    {
     526      Warn("%d is invalid characteristic of ground field. 32203 is used.", ch);
    324527      ch=32003;
    325528    }
    326     l=0;
     529    // load fftable, if necessary
    327530    if (pn!=NULL)
    328531    {
    329532      while ((ch!=fftable[l]) && (fftable[l])) l++;
    330       if (fftable[l]==0)
    331       {
    332         ch = IsPrime(ch);
    333       }
     533      if (fftable[l]==0) ch = IsPrime(ch);
    334534      else
    335535      {
    336536        char *m[1]={(char *)sNoName};
    337537        nfSetChar(ch,m);
    338         if(errorreported)
    339         {
    340           return NULL;
    341         }
    342         else
    343         {
    344           ffChar=TRUE;
    345         }
     538        if (errorreported) goto rInitError;
     539        else ffChar=TRUE;
    346540      }
    347541    }
    348542    else
    349     {
    350543      ch = IsPrime(ch);
    351     }
    352   }
    353   memset(&tmpR,0,sizeof(tmpR));
    354 
    355   tmpR.ch = ch;
    356 
     544  }
     545  // allocated ring and set ch
     546  R = (ring) Alloc0(sizeof(sip_sring));
     547  R->ch = ch;
     548 
    357549  /* parameter -------------------------------------------------------*/
    358   sleftv* hs;
    359   const char* h;
    360 
    361   if ((pn!=NULL)&& (ffChar||(ch==-1)))
    362   {
    363     if((ffChar && (pn->next!=NULL))
    364        || (ch==-1))
    365     {
    366       WarnS("too many parameters");
    367       if (ffChar) hs=pn->next;
    368       else hs=pn;
    369       hs->CleanUp();
    370       if (ffChar)
    371       {
    372         pn->next=NULL;
    373         Free((ADDRESS)hs,sizeof(sleftv));
    374       }
    375       else pn=NULL;
    376     }
    377   }
    378   /* a tempory pointer for typ conversion
    379    * and for deallocating sleftv*-lists:
    380    *  don't deallocate the first but all other entries*/
    381 
    382550  if (pn!=NULL)
    383551  {
    384     tmpR.P=pn->listLength();
    385     if((ffChar && (tmpR.P>1))
    386        || ((ch==-1) && (tmpR.P>0)))
    387     {
    388       tmpR.P=ffChar; /* GF(q): 1, R: 0 */
    389       WarnS("too many parameters");
    390       if (ffChar) hs=pn->next;
    391       else hs=pn;
    392       hs->CleanUp();
    393       Free((ADDRESS)hs,sizeof(sleftv));
    394       if (ffChar) pn->next=NULL;
    395       else pn=NULL;
    396     }
    397     tmpR.parameter=(char**)Alloc(tmpR.P*sizeof(char *));
    398     sl=pn;
    399     char** p=tmpR.parameter;
    400     while(sl!=NULL)
    401     {
    402       hs=NULL;
    403       h=sl->Name();
    404       if ((h==sNoName)&&(sl->Typ()==POLY_CMD))
    405       {
    406         hs=(leftv)Alloc(sizeof(sleftv));
    407         iiConvert(POLY_CMD,ANY_TYPE,-1,sl,hs);
    408         sl->next=hs->next;
    409         hs->next=NULL;
    410         h=hs->Name();
    411       }
    412       if (h==sNoName)
    413       {
    414         WerrorS("parameter expected");
    415         return NULL;
    416       }
    417       *p=mstrdup(h);
    418       p++;
    419       if (hs!=NULL)
    420       {
    421         hs->CleanUp();
    422         Free((ADDRESS)hs,sizeof(sleftv));
    423       }
    424       hs=sl;
    425       sl=sl->next;
    426       hs->next=NULL;
    427       hs->CleanUp();
    428       if (hs!=pn) Free((ADDRESS)hs,sizeof(sleftv));
    429     }
    430     if ((ch>1) && /*(pn!=NULL) &&*/ (!ffChar)) tmpR.ch=-tmpR.ch;
    431     if (ch==0) tmpR.ch=1;
     552    R->P=pn->listLength();
     553    if (ffChar && (R->P > 1) || ch == -1)
     554    {
     555      WerrorS("too many parameters");
     556      goto rInitError;
     557    }
     558    R->parameter=(char**)Alloc0(R->P*sizeof(char *));
     559    if (rSleftvList2StringArray(pn, R->parameter))
     560    {
     561      WerrorS("parameter expected");
     562      goto rInitError;
     563    }
     564    if (ch>1 && !ffChar) R->ch=-ch;
     565    else if (ch==0) R->ch=1;
     566  }
     567  else if (ffChar)
     568  {
     569    WerrorS("need one parameter");
     570    goto rInitError;
    432571  }
    433572
    434573  /* names and number of variables-------------------------------------*/
    435   {
    436     int i, n;
    437     sl = rv;
    438 #ifdef DRING
    439     char *tmpname=NULL;
    440 #endif
    441     n=rv->listLength();
    442     tmpR.N = n;
    443 #ifdef SDRING
    444     tmpR.partN=n+1-isDRing; // set to N+1 for SRING, N for DRING
    445       if (isDRing) n=2*n+1;
    446 #endif
    447     tmpR.N = n;
    448     tmpR.names   = (char **)Alloc(n * sizeof(char *));
    449     for (sl=rv, i=0; i<n; i++)
    450     {
    451       hs=NULL;
    452 #ifdef DRING
    453       if (sl==NULL)
    454       {
    455         if (i==tmpR.N-1)
    456           tmpname=mstrdup("");
    457         else
    458         {
    459           tmpname=(char*)AllocL(strlen(tmpR.names[i-tmpR.partN])+2);
    460           strcpy(tmpname,"d");
    461           strcat(tmpname,tmpR.names[i-tmpR.partN]);
    462         }
    463         h=tmpname;
    464       }
    465       else
    466 #endif
    467         h=sl->Name();
    468       if ((h==sNoName)&&(sl->Typ()==POLY_CMD))
    469       {
    470         hs=(leftv)Alloc(sizeof(sleftv));
    471         iiConvert(POLY_CMD,ANY_TYPE,-1,sl,hs);
    472         sl->next=hs->next;
    473         hs->next=NULL;
    474         h=hs->Name();
    475       }
    476       if (h==sNoName)
    477       {
    478         WerrorS("expected name of ring variable");
    479         return NULL;
    480       }
    481       tmpR.names[i] = mstrdup(h);
    482       if (hs!=NULL)
    483       {
    484         hs->CleanUp();
    485         Free((ADDRESS)hs,sizeof(sleftv));
    486       }
    487       hs=sl;
    488 #ifdef DRING
    489       if (sl!=NULL)
    490       {
    491 #endif
    492         sl=sl->next;
    493         hs->next=NULL;
    494         hs->CleanUp();
    495         if (hs!=rv) Free((ADDRESS)hs,sizeof(sleftv));
    496 #ifdef DRING
    497       }
    498       if (tmpname!=NULL)
    499       {
    500         FreeL((ADDRESS)tmpname);
    501         tmpname=NULL;
    502       }
    503 #endif
    504     }
    505 
    506     /* ordering -------------------------------------------------------------*/
    507     sl = ord;
    508     /* the number of orderings*/
    509     n = 1; i=0;
    510     int o=0;
    511     while (sl!=NULL)
    512     {
    513       intvec *iv = (intvec *)(sl->data);
    514       if (((*iv)[1]==ringorder_c)||((*iv)[1]==ringorder_C)) i++;
    515       else if ((*iv)[1]!=ringorder_a) o++;
    516       n++;
    517       sl=sl->next;
    518     }
    519     if (o==0)
    520     {
    521       WerrorS("invalid combination of orderings");
    522       return NULL;
    523     }
    524     if (i==0) n++;
    525     else if (i!=1)
    526       WarnS("more than one ordering c/C -- ignored");
    527 
    528     /* allocating */
    529     tmpR.order=(int *)Alloc0(n*sizeof(int));
    530     tmpR.block0=(int *)Alloc0(n*sizeof(int));
    531     tmpR.block1=(int *)Alloc0(n*sizeof(int));
    532     tmpR.wvhdl=(short**)Alloc0(n*sizeof(short*));
    533 
    534     /* init orders */
    535     sl=ord;
    536     n=0;
    537     last=0;
    538     while (sl!=NULL)
    539     {
    540       intvec *iv;
    541       iv = (intvec *)(sl->data);
    542 
    543       /* the format of an ordering:
    544        *  iv[0]: factor
    545        *  iv[1]: ordering
    546        *  iv[2..end]: weights
    547        */
    548       tmpR.order[n] = (*iv)[1];
    549       switch ((*iv)[1])
    550       {
    551       case ringorder_ws:
    552       case ringorder_Ws:
    553         typ=-1;
    554       case ringorder_wp:
    555       case ringorder_Wp:
    556         tmpR.wvhdl[n]=(short*)AllocL((iv->length()-1)*sizeof(short));
    557         for (l=2;l<iv->length();l++)
    558           tmpR.wvhdl[n][l-2]=(short)(*iv)[l];
    559         tmpR.block0[n]=last+1;
    560         last+=iv->length()-2;
    561         tmpR.block1[n]=last;
    562         break;
    563       case ringorder_ls:
    564       case ringorder_ds:
    565       case ringorder_Ds:
    566         typ=-1;
    567       case ringorder_lp:
    568       case ringorder_dp:
    569       case ringorder_Dp:
    570         tmpR.block0[n]=last+1;
    571         //last+=(*iv)[0];
    572         if (iv->length()==3) last+=(*iv)[2];
    573         else last+=(*iv)[0];
    574         tmpR.block1[n]=last;
    575         if (rCheckIV(iv)) return NULL;
    576         break;
    577       case ringorder_c:
    578       case ringorder_C:
    579         if (rCheckIV(iv)) return NULL;
    580         break;
    581       case ringorder_a:
    582         tmpR.block0[n]=last+1;
    583         tmpR.block1[n]=last+iv->length()-2;
    584         tmpR.wvhdl[n]=(short*)AllocL((iv->length()-1)*sizeof(short));
    585         for (l=2;l<iv->length();l++)
    586         {
    587           tmpR.wvhdl[n][l-2]=(short)(*iv)[l];
    588           if ((*iv)[l]<0) typ=-1;
    589         }
    590         break;
    591       case ringorder_M:
    592         {
    593           int Mtyp=rTypeOfMatrixOrder(iv);
    594           if (Mtyp==0) return NULL;
    595           if (Mtyp==-1) typ=-1;
    596           tmpR.wvhdl[n]=(short*)AllocL((iv->length()-1)*sizeof(short));
    597           for (l=2;l<iv->length();l++)
    598             tmpR.wvhdl[n][l-2]=(short)(*iv)[l];
    599           tmpR.block0[n]=last+1;
    600           last+=(int)sqrt((double)(iv->length()-2));
    601           tmpR.block1[n]=last;
    602           break;
    603         }
    604 #ifdef TEST
    605       default:
    606         Print("order ??? %d\n",(*iv)[1]);
    607         break;
    608 #endif
    609       }
    610       sl=sl->next;
    611       n++;
    612     }
    613     ord->CleanUp();
    614     if (i==0)
    615     {
    616       /*there is no c/C-ordering, so append it at the end*/
    617       tmpR.order[n]=ringorder_C;
    618     }
    619     else n--;
    620     while ((tmpR.order[n]==ringorder_c)
    621            ||(tmpR.order[n]==ringorder_C))
    622       n--;
    623     if (tmpR.block1[n]!=tmpR.N)
    624     {
    625       if ((tmpR.order[n]==ringorder_dp) ||
    626           (tmpR.order[n]==ringorder_ds) ||
    627           (tmpR.order[n]==ringorder_Dp) ||
    628           (tmpR.order[n]==ringorder_Ds) ||
    629           (tmpR.order[n]==ringorder_lp) ||
    630           (tmpR.order[n]==ringorder_ls))
    631       {
    632         tmpR.block1[n]=tmpR.N;
    633         if (tmpR.block0[n]>tmpR.N/*tmpR.block1[n]*/)
    634         {
    635           tmpR.block1[n]=tmpR.block0[n];
    636           goto ord_mismatch;
    637         }
    638       }
    639       else
    640       {
    641       ord_mismatch:
    642         Werror("mismatch of number of vars (%d) and ordering (%d vars)",
    643                tmpR.N,tmpR.block1[n]);
    644         return NULL;
    645       }
    646     }
    647   }
    648   tmpR.OrdSgn = typ;
     574  R->N = rv->listLength();
     575  R->names   = (char **)Alloc0(R->N * sizeof(char *));
     576  if (rSleftvList2StringArray(rv, R->names))
     577  {
     578    WerrorS("name of ring variable expected");
     579    goto rInitError;
     580  }
     581 
     582  /* ordering -------------------------------------------------------------*/
     583  if (rSleftvOrdering2Ordering(ord, R))
     584    goto rInitError;
     585
    649586  // Complete the initialization
    650   rComplete(&tmpR);
    651   /* try to enter the ring into the name list*/
     587  if (rComplete(R))
     588    goto rInitError;
     589 
     590  // try to enter the ring into the name list //
    652591  if ((tmp = enterid(s, myynest, RING_CMD, &IDROOT))==NULL)
    653   {
    654     return NULL;
    655   }
    656 
    657   memcpy(IDRING(tmp),&tmpR,sizeof(tmpR));
    658   if (isDRing) setFlag(tmp,FLAG_DRING);
    659   rSetHdl(tmp,TRUE);
    660 
     592    goto rInitError;
     593 
     594  memcpy(IDRING(tmp),R,sizeof(*R));
     595  // set current ring
     596  Free(R,  sizeof(ip_sring));
    661597#ifdef RDEBUG
    662598  rNumber++;
    663   currRing->no    =rNumber;
     599  R->no    =rNumber;
    664600#endif
    665 
    666   return currRingHdl;
     601  return tmp;
     602
     603  // error case:
     604  rInitError:
     605  if  (R != NULL) rDelete(R);
     606  return NULL;
    667607}
    668608
    669609// set those fields of the ring, which can be computed from other fields:
    670610// More particularly, sets r->VarOffset
    671 
    672 void rComplete(ring r, int force)
    673 {
     611BOOLEAN rComplete(ring r, int force)
     612{
     613 
    674614  int VarCompIndex, VarLowIndex, VarHighIndex;
     615  // check number of vars and number of params
     616  if (r->N + 1 > (int) MAX_EXPONENT_NUMBER)
     617  {
     618    Werror("Too many ring variables: %d is the maximum",
     619           MAX_EXPONENT_NUMBER -1);
     620    return TRUE;
     621  }
     622 
    675623
    676624  r->VarOffset = (int*) Alloc((r->N + 1)*sizeof(int));
    … …  
    680628  r->VarLowIndex = VarLowIndex;
    681629  r->VarHighIndex = VarHighIndex;
     630  return FALSE;
    682631}
    683632
    … …  
    828777}
    829778
     779static void rDelete(ring r)
     780{
     781  int i, j;
     782 
     783  if (r == NULL) return;
     784 
     785  // delete order stuff
     786  if (r->order != NULL)
     787  {
     788    i=rBlocks(r);
     789    assume(r->block0 != NULL && r->block1 != NULL && r->wvhdl != NULL);
     790    // delete order
     791    Free((ADDRESS)r->order,i*sizeof(int));
     792    Free((ADDRESS)r->block0,i*sizeof(int));
     793    Free((ADDRESS)r->block1,i*sizeof(int));
     794    // delete weights
     795    for (j=0; j<i; j++)
     796    {
     797      if (r->wvhdl[j]!=NULL)
     798        FreeL(r->wvhdl[j]);
     799    }
     800    Free((ADDRESS)r->wvhdl,i*sizeof(short *));
     801  }
     802  else
     803  {
     804    assume(r->block0 == NULL && r->block1 == NULL && r->wvhdl == NULL);
     805  }
     806 
     807  // delete varnames
     808  if(r->names!=NULL)
     809  {
     810    for (i=0; i<r->N; i++)
     811    {
     812      if (r->names[i] != NULL) FreeL((ADDRESS)r->names[i]);
     813    }
     814    Free((ADDRESS)r->names,r->N*sizeof(char *));
     815  }
     816 
     817  // delete parameter
     818  if (r->parameter!=NULL)
     819  {
     820    char **s=r->parameter;
     821    j = 0;
     822    while (j < rPar(r))
     823    {
     824      if (*s != NULL) FreeL((ADDRESS)*s);
     825      s++;
     826      j++;
     827    }
     828    Free((ADDRESS)r->parameter,rPar(r)*sizeof(char *));
     829  }
     830  if (r->VarOffset != NULL)
     831    Free((ADDRESS)r->VarOffset, (r->N +1)*sizeof(int));
     832  Free(r, sizeof(ip_sring));
     833}
     834
    830835void rKill(ring r)
    831836{
    … …  
    897902    }
    898903#endif /* USE_IILOCALRING */
    899     if (pi!=NULL)
    900     {
    901       //while(*pi!=0) { pi++;i++; }
    902       i=rBlocks(r);
    903       Free((ADDRESS)r->order,i*sizeof(int));
    904       Free((ADDRESS)r->block0,i*sizeof(int));
    905       Free((ADDRESS)r->block1,i*sizeof(int));
    906       for (j=0; j<i; j++)
    907       {
    908         if (r->wvhdl[j]!=NULL)
    909           FreeL(r->wvhdl[j]);
    910       }
    911       Free((ADDRESS)r->wvhdl,i*sizeof(short *));
    912       if(r->names!=NULL)
    913       {
    914         for (i=0; i<r->N; i++)
    915         {
    916           FreeL((ADDRESS)r->names[i]);
    917         }
    918         Free((ADDRESS)r->names,r->N*sizeof(char *));
    919       }
    920       if (r->parameter!=NULL)
    921       {
    922         int len=0;
    923         char **s=r->parameter;
    924         while (len<rPar(r))
    925         {
    926           FreeL((ADDRESS)*s);
    927           s++;
    928           len++;
    929         }
    930         Free((ADDRESS)r->parameter,rPar(r)*sizeof(char *));
    931       }
    932       Free((ADDRESS)r->VarOffset, (r->N +1)*sizeof(int));
    933     }
    934 #ifdef TEST
    935     else
    936       PrintS("internal error: ring structure destroyed\n");
    937     memset(r,0,sizeof(ip_sring));
    938 #endif
    939     Free((ADDRESS)r,sizeof(ip_sring));
     904
     905    rDelete(r);
    940906    return;
    941907  }

  • Singular/ring.h

    rd848cbc r7df2ef  
    77* ABSTRACT - the interpreter related ring operations
    88*/
    9 /* $Id: ring.h,v 1.22 1999-03-09 12:22:18 obachman Exp $ */
     9/* $Id: ring.h,v 1.23 1999-03-19 14:18:06 obachman Exp $ */
    1010
    1111/* includes */
    … …  
    1818void   rChangeCurrRing(ring r, BOOLEAN complete = TRUE);
    1919#endif
    20 void   rSetHdl(idhdl h, BOOLEAN complete);
     20void   rSetHdl(idhdl h, BOOLEAN complete = TRUE);
    2121idhdl  rInit(char *s, sleftv* pn, sleftv* rv, sleftv* ord,
    2222  BOOLEAN isDRing);
    … …  
    4444int    rIsExtension();
    4545int    rSum(ring r1, ring r2, ring &sum);
    46 void   rComplete(ring r, int force = 0);
     46BOOLEAN   rComplete(ring r, int force = 0);
    4747void   rUnComplete(ring r);
    4848int    rBlocks(ring r);
Note: See TracChangeset for help on using the changeset viewer.