VOID WriteSetup() { int n = sizeof(setupparameters)/sizeof(SETUPPARAMETERS); SETUPPARAMETERS *sp; MesPrint(" The setup parameters are:"); for ( sp = setupparameters; n > 0; n--, sp++ ) { switch(sp->type){ case NUMERICALVALUE: MesPrint(" %s: %l",sp->parameter,sp->value); break; case PATHVALUE: if ( StrICmp(sp->parameter,(UBYTE *)"path") == 0 && AM.Path ) { MesPrint(" %s: '%s'",sp->parameter,(UBYTE *)(AM.Path)); break; } if ( StrICmp(sp->parameter,(UBYTE *)"incdir") == 0 && AM.IncDir ) { MesPrint(" %s: '%s'",sp->parameter,(UBYTE *)(AM.IncDir)); break; } case STRINGVALUE: if ( StrICmp(sp->parameter,(UBYTE *)"tempdir") == 0 && AM.TempDir ) { MesPrint(" %s: '%s'",sp->parameter,(UBYTE *)(AM.TempDir)); } else if ( StrICmp(sp->parameter,(UBYTE *)"tempsortdir") == 0 && AM.TempSortDir ) { MesPrint(" %s: '%s'",sp->parameter,(UBYTE *)(AM.TempSortDir)); } else { MesPrint(" %s: '%s'",sp->parameter,(UBYTE *)(sp->value)); } break; case ONOFFVALUE: if ( sp->value == 0 ) MesPrint(" %s: OFF",sp->parameter); else if ( sp->value == 1 ) MesPrint(" %s: ON",sp->parameter); break; case DEFINEVALUE: /* MesPrint(" %s: '%s'",sp->parameter,(UBYTE *)(sp->value)); */ break; } } AC.SetupFlag = 0; }
int ProcessOption(UBYTE *s1, UBYTE *s2, int filetype) { SETUPPARAMETERS *sp; int n, giveback = 0, error = 0; UBYTE *s, *t, *s2ret; LONG x; sp = GetSetupPar(s1); if ( sp ) { /* We check now whether there are `' variables to be looked up in the environment. This is new (30-may-2008). This is only allowed in s2. */ restart:; { UBYTE *s3,*s4,*s5,*s6, c, *start; int n1,n2,n3; s = s2; while ( *s ) { if ( *s == '\\' ) s += 2; else if ( *s == '`' ) { start = s; s++; while ( *s && *s != '\'' ) { if ( *s == '\\' ) s++; s++; } if ( *s == 0 ) { MesPrint("%s: Illegal use of ` character for parameter %s" ,proop1[filetype],s1); return(1); } c = *s; *s = 0; s3 = (UBYTE *)getenv((char *)(start+1)); if ( s3 == 0 ) { MesPrint("%s: Cannot find environment variable %s for parameter %s" ,proop1[filetype],start+1,s1); return(1); } *s = c; s++; n1 = start - s2; s4 = s3; n2 = 0; while ( *s4 ) { if ( *s4 == '\\' ) { s4++; n2++; } s4++; n2++; } s4 = s; n3 = 0; while ( *s4 ) { if ( *s4 == '\\' ) { s4++; n3++; } s4++; n3++; } s4 = (UBYTE *)Malloc1((n1+n2+n3+1)*sizeof(UBYTE),"environment in setup"); s5 = s2; s6 = s4; while ( n1-- > 0 ) *s6++ = *s5++; s5 = s3; while ( n2-- > 0 ) *s6++ = *s5++; s5 = s; while ( n3-- > 0 ) *s6++ = *s5++; *s6 = 0; if ( giveback ) M_free(s2,"environment in setup"); s2 = s4; giveback = 1; goto restart; } else s++; } } n = sp->type; s2ret = s2; switch ( n ) { case NUMERICALVALUE: ParseNumber(x,s2); if ( *s2 == 'K' ) { x = x * 1000; s2++; } else if ( *s2 == 'M' ) { x = x * 1000000; s2++; } else if ( *s2 == 'G' ) { x = x * 1000000000; s2++; } else if ( *s2 == 'T' ) { x = x * 1000000000000; s2++; } if ( *s2 && *s2 != ' ' && *s2 != '\t' ) { MesPrint("%s: Numerical value expected for parameter %s" ,proop1[filetype],s1); error = 1; break; } sp->value = x; sp->flags = USEDFLAG; break; case STRINGVALUE: if ( StrICmp(s1,(UBYTE *)"tempsortdir") == 0 ) AM.havesortdir = 1; s = s2; t = s2; while ( *s ) { if ( *s == ' ' || *s == '\t' ) break; if ( *s == '\\' ) s++; *t++ = *s++; } *t = 0; if ( sp->flags == USEDFLAG && sp->value != 0 ) M_free((VOID *)(sp->value),"Process option"); sp->value = (LONG)strDup1(s2,"Process option"); sp->flags = USEDFLAG; break; case PATHVALUE: if ( StrICmp(s1,(UBYTE *)"incdir") == 0 ) { AM.IncDir = 0; } else if ( StrICmp(s1,(UBYTE *)"path") == 0 ) { if ( AM.Path ) M_free(AM.Path,"path"); AM.Path = 0; } else { MesPrint("Setups: %s not yet implemented",s1); error = 1; break; } if ( sp->flags == USEDFLAG && sp->value != 0 ) M_free((VOID *)(sp->value),"Process option"); sp->value = (LONG)strDup1(s2,"Process option"); sp->flags = USEDFLAG; break; case ONOFFVALUE: if ( tolower(*s2) == 'o' && tolower(s2[1]) == 'n' && ( s2[2] == 0 || s2[2] == ' ' || s2[2] == '\t' ) ) sp->value = 1; else if ( tolower(*s2) == 'o' && tolower(s2[1]) == 'f' && tolower(s2[2]) == 'f' && ( s2[3] == 0 || s2[3] == ' ' || s2[3] == '\t' ) ) sp->value = 0; else { MesPrint("%s: Unrecognized option for parameter %s: %s" ,proop1[filetype],s1,s2); error = 1; break; } sp->flags = USEDFLAG; break; case DEFINEVALUE: /* if ( sp->value ) M_free((UBYTE *)(sp->value),"Process option"); sp->value = (LONG)strDup1(s2,"Process option"); */ if ( TheDefine(s2,2) ) error = 1; break; default: Error1("Error in setupparameter table for:",s1); error = 1; break; } } else { MesPrint("%s: Keyword not recognized: %s",proop1[filetype],s1); error = 1; } if ( giveback ) M_free(s2ret,"environment in setup"); return(error); }
int AllocSetups() { SETUPPARAMETERS *sp; LONG LargeSize, SmallSize, SmallEsize, TermsInSmall, IOsize; int MaxPatches, MaxFpatches, error = 0, i, size; UBYTE *s; #ifndef WITHPTHREADS int j; #endif sp = GetSetupPar((UBYTE *)"threads"); if ( sp->value > 0 ) AM.totalnumberofthreads = sp->value+1; AM.OutBuffer = (UBYTE *)Malloc1(AM.OutBufSize+1,"OutputBuffer"); AP.PreAssignStack =(LONG *)Malloc1(AP.MaxPreAssignLevel*sizeof(LONG *),"PreAssignStack"); for ( i = 0; i < AP.MaxPreAssignLevel; i++ ) AP.PreAssignStack[i] = 0; AC.iBuffer = (UBYTE *)Malloc1(AC.iBufferSize+1,"statement buffer"); AC.iStop = AC.iBuffer + AC.iBufferSize-2; AP.preStart = (UBYTE *)Malloc1(AP.pSize,"instruction buffer"); AP.preStop = AP.preStart + AP.pSize - 3; /* AP.PreIfStack is already allocated in StartPrepro(), but to be sure we "if" the freeing */ if ( AP.PreIfStack ) M_free(AP.PreIfStack,"PreIfStack"); AP.PreIfStack = (int *)Malloc1(AP.MaxPreIfLevel*sizeof(int), "Preprocessor if stack"); AP.PreIfStack[0] = EXECUTINGIF; sp = GetSetupPar((UBYTE *)"insidefirst"); AM.ginsidefirst = AC.minsidefirst = AC.insidefirst = sp->value; /* We need to consider eliminating this variable */ sp = GetSetupPar((UBYTE *)"maxtermsize"); AM.MaxTer = sp->value*sizeof(WORD); if ( AM.MaxTer < 200*(LONG)(sizeof(WORD)) ) AM.MaxTer = 200*(LONG)(sizeof(WORD)); if ( AM.MaxTer > MAXPOSITIVE - 200*(LONG)(sizeof(WORD)) ) AM.MaxTer = MAXPOSITIVE - 200*(LONG)(sizeof(WORD)); AM.MaxTer /= (LONG)sizeof(WORD); AM.MaxTer *= (LONG)sizeof(WORD); /* Allocate workspace. */ sp = GetSetupPar((UBYTE *)"workspace"); AM.WorkSize = sp->value; #ifdef WITHPTHREADS #else AT.WorkSpace = (WORD *)Malloc1(AM.WorkSize*sizeof(WORD),(char *)(sp->parameter)); AT.WorkTop = AT.WorkSpace + AM.WorkSize; AT.WorkPointer = AT.WorkSpace; #endif /* Fixed indices */ sp = GetSetupPar((UBYTE *)"constindex"); if ( ( sp->value+100+5*WILDOFFSET ) > MAXPOSITIVE ) { MesPrint("Setting of %s in setupfile too large","constindex"); AM.OffsetIndex = MAXPOSITIVE - 5*WILDOFFSET - 100; MesPrint("value corrected to maximum allowed: %d",AM.OffsetIndex); } else AM.OffsetIndex = sp->value + 1; AC.FixIndices = (WORD *)Malloc1((AM.OffsetIndex)*sizeof(WORD),(char *)(sp->parameter)); AM.WilInd = AM.OffsetIndex + WILDOFFSET; AM.DumInd = AM.OffsetIndex + 2*WILDOFFSET; AM.IndDum = AM.DumInd + WILDOFFSET; #ifndef WITHPTHREADS AR.CurDum = AN.IndDum = AM.IndDum; #endif AM.mTraceDum = AM.IndDum + 2*WILDOFFSET; sp = GetSetupPar((UBYTE *)"parentheses"); AM.MaxParLevel = sp->value+1; AC.tokenarglevel = (WORD *)Malloc1((sp->value+1)*sizeof(WORD),(char *)(sp->parameter)); /* Space during calculations */ sp = GetSetupPar((UBYTE *)"maxnumbersize"); /* size = ( sp->value + 11 ) & (-4); AM.MaxTal = size - 2; if ( AM.MaxTal > (AM.MaxTer/sizeof(WORD)-2)/2 ) AM.MaxTal = (AM.MaxTer/sizeof(WORD)-2)/2; if ( AM.MaxTal < (AM.MaxTer/sizeof(WORD)-2)/4 ) AM.MaxTal = (AM.MaxTer/sizeof(WORD)-2)/4; */ /* There is too much confusion about MaxTal cq maxnumbersize. It seems better to fix it at its maximum value. This way we only worry about maxtermsize. This can be understood better by the 'innocent' user. */ if ( sp->value == 0 ) { AM.MaxTal = (AM.MaxTer/sizeof(WORD)-2)/2; } else { size = ( sp->value + 11 ) & (-4); AM.MaxTal = size - 2; if ( (size_t)AM.MaxTal > (size_t)((AM.MaxTer/sizeof(WORD)-2)/2) ) AM.MaxTal = (AM.MaxTer/sizeof(WORD)-2)/2; } AM.MaxTal &= -sizeof(WORD)*2; sp->value = AM.MaxTal; AC.cmod = (UWORD *)Malloc1(AM.MaxTal*4*sizeof(UWORD),(char *)(sp->parameter)); AM.gcmod = AC.cmod + AM.MaxTal; AC.powmod = AM.gcmod + AM.MaxTal; AM.gpowmod = AC.powmod + AM.MaxTal; /* The IO buffers for the input and output expressions. Fscr[2] will be assigned in a later stage for hiding expressions from the regular action. That will make the program faster. */ sp = GetSetupPar((UBYTE *)"scratchsize"); AM.ScratSize = sp->value/sizeof(WORD); if ( AM.ScratSize < 4*AM.MaxTer ) AM.ScratSize = 4*AM.MaxTer; AM.HideSize = AM.ScratSize; sp = GetSetupPar((UBYTE *)"hidesize"); if ( sp->value > 0 ) { AM.HideSize = sp->value/sizeof(WORD); if ( AM.HideSize < 4*AM.MaxTer ) AM.HideSize = 4*AM.MaxTer; } sp = GetSetupPar((UBYTE *)"factorizationcache"); AM.fbuffersize = sp->value; #ifdef WITHPTHREADS sp = GetSetupPar((UBYTE *)"threadscratchsize"); AM.ThreadScratSize = sp->value/sizeof(WORD); sp = GetSetupPar((UBYTE *)"threadscratchoutsize"); AM.ThreadScratOutSize = sp->value/sizeof(WORD); #endif #ifndef WITHPTHREADS for ( j = 0; j < 2; j++ ) { WORD *ScratchBuf; ScratchBuf = (WORD *)Malloc1(AM.ScratSize*sizeof(WORD),"scratchsize"); AR.Fscr[j].POsize = AM.ScratSize * sizeof(WORD); AR.Fscr[j].POfull = AR.Fscr[j].POfill = AR.Fscr[j].PObuffer = ScratchBuf; AR.Fscr[j].POstop = AR.Fscr[j].PObuffer + AM.ScratSize; PUTZERO(AR.Fscr[j].POposition); } AR.Fscr[2].PObuffer = 0; #endif sp = GetSetupPar((UBYTE *)"threadbucketsize"); AC.ThreadBucketSize = AM.gThreadBucketSize = AM.ggThreadBucketSize = sp->value; sp = GetSetupPar((UBYTE *)"threadloadbalancing"); AC.ThreadBalancing = AM.gThreadBalancing = AM.ggThreadBalancing = sp->value; sp = GetSetupPar((UBYTE *)"threadsortfilesynch"); AC.ThreadSortFileSynch = AM.gThreadSortFileSynch = AM.ggThreadSortFileSynch = sp->value; /* The size for shared memory window for oneside MPI2 communications */ sp = GetSetupPar((UBYTE *)"shmwinsize"); AM.shmWinSize = sp->value/sizeof(WORD); if ( AM.shmWinSize < 4*AM.MaxTer ) AM.shmWinSize = 4*AM.MaxTer; /* The sort buffer */ sp = GetSetupPar((UBYTE *)"smallsize"); SmallSize = sp->value; sp = GetSetupPar((UBYTE *)"smallextension"); SmallEsize = sp->value; sp = GetSetupPar((UBYTE *)"largesize"); LargeSize = sp->value; sp = GetSetupPar((UBYTE *)"termsinsmall"); TermsInSmall = sp->value; sp = GetSetupPar((UBYTE *)"largepatches"); MaxPatches = sp->value; sp = GetSetupPar((UBYTE *)"filepatches"); MaxFpatches = sp->value; sp = GetSetupPar((UBYTE *)"sortiosize"); IOsize = sp->value; if ( IOsize < AM.MaxTer ) { IOsize = AM.MaxTer; sp->value = IOsize; } #ifndef WITHPTHREADS #ifdef WITHZLIB for ( j = 0; j < 2; j++ ) { AR.Fscr[j].ziosize = IOsize; } #endif #endif AM.S0 = 0; AM.S0 = AllocSort(LargeSize,SmallSize,SmallEsize,TermsInSmall ,MaxPatches,MaxFpatches,IOsize); #ifdef WITHZLIB AM.S0->file.ziosize = IOsize; #ifndef WITHPTHREADS AR.FoStage4[0].ziosize = IOsize; AR.FoStage4[1].ziosize = IOsize; AT.S0 = AM.S0; #endif #else #ifndef WITHPTHREADS AT.S0 = AM.S0; #endif #endif #ifndef WITHPTHREADS AR.FoStage4[0].POsize = ((IOsize+sizeof(WORD)-1)/sizeof(WORD))*sizeof(WORD); AR.FoStage4[1].POsize = ((IOsize+sizeof(WORD)-1)/sizeof(WORD))*sizeof(WORD); #endif sp = GetSetupPar((UBYTE *)"subsmallsize"); AM.SSmallSize = sp->value; sp = GetSetupPar((UBYTE *)"subsmallextension"); AM.SSmallEsize = sp->value; sp = GetSetupPar((UBYTE *)"sublargesize"); AM.SLargeSize = sp->value; sp = GetSetupPar((UBYTE *)"subtermsinsmall"); AM.STermsInSmall = sp->value; sp = GetSetupPar((UBYTE *)"sublargepatches"); AM.SMaxPatches = sp->value; sp = GetSetupPar((UBYTE *)"subfilepatches"); AM.SMaxFpatches = sp->value; sp = GetSetupPar((UBYTE *)"subsortiosize"); AM.SIOsize = sp->value; sp = GetSetupPar((UBYTE *)"spectatorsize"); AM.SpectatorSize = sp->value; /* The next code is just for the moment (26-jan-1997) because we have the new parts combined with the old. Once the old parts are gone from the program, we can eliminate this code too. */ sp = GetSetupPar((UBYTE *)"functionlevels"); AM.maxFlevels = sp->value + 1; #ifdef WITHPTHREADS #else AT.Nest = (NESTING)Malloc1((LONG)sizeof(struct NeStInG)*AM.maxFlevels,"functionlevels"); AT.NestStop = AT.Nest + AM.maxFlevels; AT.NestPoin = AT.Nest; #endif sp = GetSetupPar((UBYTE *)"maxwildcards"); AM.MaxWildcards = sp->value; #ifdef WITHPTHREADS #else AT.WildMask = (WORD *)Malloc1((LONG)AM.MaxWildcards*sizeof(WORD),"maxwildcards"); #endif sp = GetSetupPar((UBYTE *)"compresssize"); if ( sp->value < 2*AM.MaxTer ) sp->value = 2*AM.MaxTer; AM.CompressSize = sp->value; #ifndef WITHPTHREADS AR.CompressBuffer = (WORD *)Malloc1((AM.CompressSize+10)*sizeof(WORD),"compresssize"); AR.CompressPointer = AR.CompressBuffer; AR.ComprTop = AR.CompressBuffer + AM.CompressSize; #endif sp = GetSetupPar((UBYTE *)"bracketindexsize"); if ( sp->value < 20*AM.MaxTer ) sp->value = 20*AM.MaxTer; AM.MaxBracketBufferSize = sp->value/sizeof(WORD); sp = GetSetupPar((UBYTE *)"dotchar"); AO.FortDotChar = ((UBYTE *)(sp->value))[0]; sp = GetSetupPar((UBYTE *)"commentchar"); AP.cComChar = AP.ComChar = ((UBYTE *)(sp->value))[0]; sp = GetSetupPar((UBYTE *)"procedureextension"); /* Check validity first. */ s = (UBYTE *)(sp->value); if ( FG.cTable[*s] != 0 ) { MesPrint(" Illegal string for procedure extension %s",(UBYTE *)sp->value); error = -2; } else { s++; while ( *s ) { if ( *s == ' ' || *s == '\t' || *s == '\n' ) { MesPrint(" Illegal string for procedure extension %s",(UBYTE *)sp->value); error = -2; break; } s++; } } AP.cprocedureExtension = strDup1((UBYTE *)(sp->value),"procedureExtension"); AP.procedureExtension = strDup1(AP.cprocedureExtension,"procedureExtension"); sp = GetSetupPar((UBYTE *)"totalsize"); if ( sp->value != 2 ) AM.PrintTotalSize = sp->value; sp = GetSetupPar((UBYTE *)"continuationlines"); AM.FortranCont = sp->value; if ( AM.FortranCont <= 0 ) AM.FortranCont = 1; sp = GetSetupPar((UBYTE *)"oldorder"); AM.OldOrderFlag = sp->value; sp = GetSetupPar((UBYTE *)"resettimeonclear"); AM.resetTimeOnClear = sp->value; sp = GetSetupPar((UBYTE *)"nospacesinnumbers"); AO.NoSpacesInNumbers = AM.gNoSpacesInNumbers = AM.ggNoSpacesInNumbers = sp->value; sp = GetSetupPar((UBYTE *)"indentspace"); AO.IndentSpace = AM.gIndentSpace = AM.ggIndentSpace = sp->value; sp = GetSetupPar((UBYTE *)"nwritestatistics"); AC.StatsFlag = AM.gStatsFlag = AM.ggStatsFlag = 1-sp->value; sp = GetSetupPar((UBYTE *)"nwritefinalstatistics"); AC.FinalStats = AM.gFinalStats = AM.ggFinalStats = 1-sp->value; sp = GetSetupPar((UBYTE *)"nwritethreadstatistics"); AC.ThreadStats = AM.gThreadStats = AM.ggThreadStats = 1-sp->value; sp = GetSetupPar((UBYTE *)"nwriteprocessstatistics"); AC.ProcessStats = AM.gProcessStats = AM.ggProcessStats = 1-sp->value; sp = GetSetupPar((UBYTE *)"oldparallelstatistics"); AC.OldParallelStats = AM.gOldParallelStats = AM.ggOldParallelStats = sp->value; sp = GetSetupPar((UBYTE *)"oldfactarg"); AC.OldFactArgFlag = AM.gOldFactArgFlag = AM.ggOldFactArgFlag = sp->value; sp = GetSetupPar((UBYTE *)"oldgcd"); AC.OldGCDflag = AM.gOldGCDflag = AM.ggOldGCDflag = sp->value; sp = GetSetupPar((UBYTE *)"wtimestats"); if ( sp->value == 2 ) sp->value = AM.ggWTimeStatsFlag; AC.WTimeStatsFlag = AM.gWTimeStatsFlag = AM.ggWTimeStatsFlag = sp->value; sp = GetSetupPar((UBYTE *)"sorttype"); if ( StrICmp((UBYTE *)"lowfirst",(UBYTE *)sp->value) == 0 ) { AC.lSortType = SORTLOWFIRST; } else if ( StrICmp((UBYTE *)"highfirst",(UBYTE *)sp->value) == 0 ) { AC.lSortType = SORTHIGHFIRST; } else { MesPrint(" Illegal SortType specification: %s",(UBYTE *)sp->value); error = -2; } sp = GetSetupPar((UBYTE *)"processbucketsize"); AM.hProcessBucketSize = AM.gProcessBucketSize = AC.ProcessBucketSize = AC.mProcessBucketSize = sp->value; /* The store caches (code installed 15-aug-2006 JV) */ sp = GetSetupPar((UBYTE *)"numstorecaches"); AM.NumStoreCaches = sp->value; sp = GetSetupPar((UBYTE *)"sizestorecache"); AM.SizeStoreCache = sp->value; #ifndef WITHPTHREADS /* Install the store caches (15-aug-2006 JV) Note that in the case of PTHREADS this is done in InitializeOneThread */ AT.StoreCache = AT.StoreCacheAlloc = 0; if ( AM.NumStoreCaches > 0 ) { STORECACHE sa, sb; size = sizeof(struct StOrEcAcHe)+AM.SizeStoreCache; size = ((size-1)/sizeof(size_t)+1)*sizeof(size_t); AT.StoreCacheAlloc = (STORECACHE)Malloc1(size*AM.NumStoreCaches,"StoreCaches"); AT.StoreCache = AT.StoreCacheAlloc; sa = AT.StoreCache; for ( j = 0; j < AM.NumStoreCaches; j++ ) { sb = (STORECACHE)(VOID *)((UBYTE *)sa+size); if ( j == AM.NumStoreCaches-1 ) { sa->next = 0; } else { sa->next = sb; } SETBASEPOSITION(sa->position,-1); SETBASEPOSITION(sa->toppos,-1); sa = sb; } } #endif /* And now some order sensitive things */ if ( AM.Path == 0 ) { sp = GetSetupPar((UBYTE *)"path"); AM.Path = strDup1((UBYTE *)(sp->value),"path"); } if ( AM.IncDir == 0 ) { sp = GetSetupPar((UBYTE *)"incdir"); AM.IncDir = strDup1((UBYTE *)(sp->value),"incdir"); } /* if ( AM.TempDir == 0 ) { sp = GetSetupPar((UBYTE *)"tempdir"); AM.TempDir = strDup1((UBYTE *)(sp->value),"tempdir"); } */ return(error); }
WORD DoIfStatement(PHEAD WORD *ifcode, WORD *term) { GETBIDENTITY WORD *ifstop, *ifp; UWORD *coef1 = 0, *coef2, *coef3, *cc; WORD ncoef1, ncoef2, ncoef3, i = 0, first, *r, acoef, ismul1, ismul2, j; UWORD *Spac1, *Spac2; ifstop = ifcode + ifcode[1]; ifp = ifcode + 3; if ( ifp >= ifstop ) return(1); if ( ( ifp + ifp[1] ) >= ifstop ) { switch ( *ifp ) { case LONGNUMBER: if ( ifp[2] ) return(1); else return(0); case MATCH: case TYPEIF: if ( HowMany(BHEAD ifp,term) ) return(1); else return(0); case TYPEFINDLOOP: if ( Lus(term,ifp[3],ifp[4],ifp[5],ifp[6],ifp[2]) ) return(1); else return(0); case TYPECOUNT: if ( CountDo(term,ifp) ) return(1); else return(0); case COEFFI: case MULTIPLEOF: return(1); case IFDOLLAR: { DOLLARS d = Dollars + ifp[2]; #ifdef WITHPTHREADS int nummodopt, dtype = -1; if ( AS.MultiThreaded ) { for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) { if ( ifp[2] == ModOptdollars[nummodopt].number ) break; } if ( nummodopt < NumModOptdollars ) { dtype = ModOptdollars[nummodopt].type; if ( dtype == MODLOCAL ) { d = ModOptdollars[nummodopt].dstruct+AT.identity; } } } dtype = d->type; #else int dtype = d->type; /* We use dtype to make the operation atomic */ #endif if ( dtype == DOLZERO ) return(0); if ( dtype == DOLUNDEFINED ) { if ( AC.UnsureDollarMode == 0 ) { MesPrint("$%s is undefined",AC.dollarnames->namebuffer+d->name); Terminate(-1); } } } return(1); case IFEXPRESSION: r = ifp+2; j = ifp[1] - 2; while ( --j >= 0 ) { if ( *r == AR.CurExpr ) return(1); r++; } return(0); case IFISFACTORIZED: r = ifp+2; j = ifp[1] - 2; if ( j == 0 ) { if ( ( Expressions[AR.CurExpr].vflags & ISFACTORIZED ) != 0 ) return(1); else return(0); } while ( --j >= 0 ) { if ( ( Expressions[*r].vflags & ISFACTORIZED ) == 0 ) return(0); r++; } return(1); case IFOCCURS: { WORD *OccStop = ifp + ifp[1]; ifp += 2; while ( ifp < OccStop ) { if ( FindVar(ifp,term) == 1 ) return(1); if ( *ifp == DOTPRODUCT ) ifp += 3; else ifp += 2; } } return(0); default: /* Now we have a subexpression. Test first for one with a single item. */ if ( ifp[3] == ( ifp[1] + 3 ) ) return(DoIfStatement(BHEAD ifp,term)); ifstop = ifp + ifp[1]; ifp += 3; break; } } /* Here is the composite condition. */ coef3 = NumberMalloc("DoIfStatement"); Spac1 = NumberMalloc("DoIfStatement"); Spac2 = (UWORD *)(TermMalloc("DoIfStatement")); ncoef1 = 0; first = 1; ismul1 = 0; do { if ( !first ) { ifp += 2; if ( ifp[-2] == ORCOND && ncoef1 ) { coef1 = Spac1; ncoef1 = 1; coef1[0] = coef1[1] = 1; goto SkipCond; } if ( ifp[-2] == ANDCOND && !ncoef1 ) goto SkipCond; } coef2 = Spac2; ncoef2 = 1; ismul2 = 0; switch ( *ifp ) { case LONGNUMBER: ncoef2 = ifp[2]; j = 2*(ABS(ncoef2)); cc = (UWORD *)(ifp + 3); for ( i = 0; i < j; i++ ) coef2[i] = cc[i]; break; case MATCH: case TYPEIF: coef2[0] = HowMany(BHEAD ifp,term); coef2[1] = 1; if ( coef2[0] == 0 ) ncoef2 = 0; break; case TYPECOUNT: acoef = CountDo(term,ifp); coef2[0] = ABS(acoef); coef2[1] = 1; if ( acoef == 0 ) ncoef2 = 0; else if ( acoef < 0 ) ncoef2 = -1; break; case TYPEFINDLOOP: acoef = Lus(term,ifp[3],ifp[4],ifp[5],ifp[6],ifp[2]); coef2[0] = ABS(acoef); coef2[1] = 1; if ( acoef == 0 ) ncoef2 = 0; else if ( acoef < 0 ) ncoef2 = -1; break; case COEFFI: r = term + *term; ncoef2 = r[-1]; i = ABS(ncoef2); cc = (UWORD *)(r - i); if ( ncoef2 < 0 ) ncoef2 = (ncoef2+1)>>1; else ncoef2 = (ncoef2-1)>>1; i--; for ( j = 0; j < i; j++ ) coef2[j] = cc[j]; break; case SUBEXPR: ncoef2 = coef2[0] = DoIfStatement(BHEAD ifp,term); coef2[1] = 1; break; case MULTIPLEOF: ncoef2 = 1; coef2[0] = ifp[2]; coef2[1] = 1; ismul2 = 1; break; case IFDOLLAREXTRA: break; case IFDOLLAR: { /* We need to abstract a long rational in coef2 with length ncoef2. What if that cannot be done? */ DOLLARS d = Dollars + ifp[2]; #ifdef WITHPTHREADS int nummodopt, dtype = -1; if ( AS.MultiThreaded ) { for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) { if ( ifp[2] == ModOptdollars[nummodopt].number ) break; } if ( nummodopt < NumModOptdollars ) { dtype = ModOptdollars[nummodopt].type; if ( dtype == MODLOCAL ) { d = ModOptdollars[nummodopt].dstruct+AT.identity; } else { LOCK(d->pthreadslockread); } } } #endif /* We have to pick up the IFDOLLAREXTRA pieces for [1], [$y] etc. */ if ( ifp+3 < ifstop && ifp[3] == IFDOLLAREXTRA ) { if ( d->nfactors == 0 ) { MLOCK(ErrorMessageLock); MesPrint("Attempt to use a factor of an unfactored $-variable"); MUNLOCK(ErrorMessageLock); Terminate(-1); } { WORD num = GetIfDollarNum(ifp+3,ifstop); WORD *w; while ( ifp+3 < ifstop && ifp[3] == IFDOLLAREXTRA ) ifp += 3; if ( num > d->nfactors ) { MLOCK(ErrorMessageLock); MesPrint("Dollar factor number %s out of range",num); MUNLOCK(ErrorMessageLock); Terminate(-1); } if ( num == 0 ) { ncoef2 = 1; coef2[0] = d->nfactors; coef2[1] = 1; break; } w = d->factors[num-1].where; if ( w == 0 ) { if ( d->factors[num-1].value < 0 ) { ncoef2 = -1; coef2[0] = -d->factors[num-1].value; coef2[1] = 1; } else { ncoef2 = 1; coef2[0] = d->factors[num-1].value; coef2[1] = 1; } break; } if ( w[*w] == 0 ) { r = w + *w - 1; i = ABS(*r); if ( i == ( *w-1 ) ) { ncoef2 = (i-1)/2; if ( *r < 0 ) ncoef2 = -ncoef2; i--; cc = coef2; r = w + 1; while ( --i >= 0 ) *cc++ = (UWORD)(*r++); break; } } goto generic; } } else { switch ( d->type ) { case DOLUNDEFINED: if ( AC.UnsureDollarMode == 0 ) { #ifdef WITHPTHREADS if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); } #endif MLOCK(ErrorMessageLock); MesPrint("$%s is undefined",AC.dollarnames->namebuffer+d->name); MUNLOCK(ErrorMessageLock); Terminate(-1); } ncoef2 = 0; coef2[0] = 0; coef2[1] = 1; break; case DOLZERO: ncoef2 = coef2[0] = 0; coef2[1] = 1; break; case DOLSUBTERM: if ( d->where[0] != INDEX || d->where[1] != 3 || d->where[2] < 0 || d->where[2] >= AM.OffsetIndex ) { if ( AC.UnsureDollarMode == 0 ) { #ifdef WITHPTHREADS if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); } #endif MLOCK(ErrorMessageLock); MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name); MUNLOCK(ErrorMessageLock); Terminate(-1); } ncoef2 = 0; coef2[0] = 0; coef2[1] = 1; break; } d->index = d->where[2]; case DOLINDEX: if ( d->index == 0 ) { ncoef2 = coef2[0] = 0; coef2[1] = 1; } else if ( d->index > 0 && d->index < AM.OffsetIndex ) { ncoef2 = 1; coef2[0] = d->index; coef2[1] = 1; } else if ( AC.UnsureDollarMode == 0 ) { #ifdef WITHPTHREADS if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); } #endif MLOCK(ErrorMessageLock); MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name); MUNLOCK(ErrorMessageLock); Terminate(-1); } ncoef2 = coef2[0] = 0; coef2[1] = 1; break; case DOLWILDARGS: if ( d->where[0] <= -FUNCTION || ( d->where[0] < 0 && d->where[2] != 0 ) || ( d->where[0] > 0 && d->where[d->where[0]] != 0 ) ) { if ( AC.UnsureDollarMode == 0 ) { #ifdef WITHPTHREADS if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); } #endif MLOCK(ErrorMessageLock); MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name); MUNLOCK(ErrorMessageLock); Terminate(-1); } ncoef2 = coef2[0] = 0; coef2[1] = 1; break; } case DOLARGUMENT: if ( d->where[0] == -SNUMBER ) { if ( d->where[1] == 0 ) { ncoef2 = coef2[0] = 0; } else if ( d->where[1] < 0 ) { ncoef2 = -1; coef2[0] = -d->where[1]; } else { ncoef2 = 1; coef2[0] = d->where[1]; } coef2[1] = 1; } else if ( d->where[0] == -INDEX && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) { if ( d->where[1] == 0 ) { ncoef2 = coef2[0] = 0; coef2[1] = 1; } else { ncoef2 = 1; coef2[0] = d->where[1]; coef2[1] = 1; } } else if ( d->where[0] > 0 && d->where[ARGHEAD] == (d->where[0]-ARGHEAD) && ABS(d->where[d->where[0]-1]) == (d->where[0] - ARGHEAD-1) ) { i = d->where[d->where[0]-1]; ncoef2 = (ABS(i)-1)/2; if ( i < 0 ) { ncoef2 = -ncoef2; i = -i; } i--; cc = coef2; r = d->where + ARGHEAD+1; while ( --i >= 0 ) *cc++ = (UWORD)(*r++); } else { if ( AC.UnsureDollarMode == 0 ) { #ifdef WITHPTHREADS if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); } #endif MLOCK(ErrorMessageLock); MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name); MUNLOCK(ErrorMessageLock); Terminate(-1); } ncoef2 = 0; coef2[0] = 0; coef2[1] = 1; } break; case DOLNUMBER: case DOLTERMS: if ( d->where[d->where[0]] == 0 ) { r = d->where + d->where[0]-1; i = ABS(*r); if ( i == ( d->where[0]-1 ) ) { ncoef2 = (i-1)/2; if ( *r < 0 ) ncoef2 = -ncoef2; i--; cc = coef2; r = d->where + 1; while ( --i >= 0 ) *cc++ = (UWORD)(*r++); break; } } generic:; if ( AC.UnsureDollarMode == 0 ) { #ifdef WITHPTHREADS if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); } #endif MLOCK(ErrorMessageLock); MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name); MUNLOCK(ErrorMessageLock); Terminate(-1); } ncoef2 = 0; coef2[0] = 0; coef2[1] = 1; break; } } #ifdef WITHPTHREADS if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); } #endif } break; case IFEXPRESSION: r = ifp+2; j = ifp[1] - 2; ncoef2 = 0; while ( --j >= 0 ) { if ( *r == AR.CurExpr ) { ncoef2 = 1; break; } r++; } coef2[0] = ncoef2; coef2[1] = 1; break; case IFISFACTORIZED: r = ifp+2; j = ifp[1] - 2; if ( j == 0 ) { ncoef2 = 0; if ( ( Expressions[AR.CurExpr].vflags & ISFACTORIZED ) != 0 ) { ncoef2 = 1; } } else { ncoef2 = 1; while ( --j >= 0 ) { if ( ( Expressions[*r].vflags & ISFACTORIZED ) == 0 ) { ncoef2 = 0; break; } r++; } } coef2[0] = ncoef2; coef2[1] = 1; break; case IFOCCURS: { WORD *OccStop = ifp + ifp[1], *ifpp = ifp+2; ncoef2 = 0; while ( ifpp < OccStop ) { if ( FindVar(ifpp,term) == 1 ) { ncoef2 = 1; break; } if ( *ifpp == DOTPRODUCT ) ifp += 3; else ifpp += 2; } coef2[0] = ncoef2; coef2[1] = 1; } break; default: break; } if ( !first ) { if ( ifp[-2] != ORCOND && ifp[-2] != ANDCOND ) { if ( ( ifp[-2] == EQUAL || ifp[-2] == NOTEQUAL ) && ( ismul2 || ismul1 ) ) { if ( ismul1 && ismul2 ) { if ( coef1[0] == coef2[0] ) i = 1; else i = 0; } else { if ( ismul1 ) { if ( ncoef2 ) Divvy(BHEAD coef2,&ncoef2,coef1,ncoef1); cc = coef2; ncoef3 = ncoef2; } else { if ( ncoef1 ) Divvy(BHEAD coef1,&ncoef1,coef2,ncoef2); cc = coef1; ncoef3 = ncoef1; } if ( ncoef3 < 0 ) ncoef3 = -ncoef3; if ( ncoef3 == 0 ) { if ( ifp[-2] == EQUAL ) i = 1; else i = 0; } else if ( cc[ncoef3] != 1 ) { if ( ifp[-2] == EQUAL ) i = 0; else i = 1; } else { for ( j = 1; j < ncoef3; j++ ) { if ( cc[ncoef3+j] != 0 ) break; } if ( j < ncoef3 ) { if ( ifp[-2] == EQUAL ) i = 0; else i = 1; } else if ( ifp[-2] == EQUAL ) i = 1; else i = 0; } } goto donemul; } else if ( AddRat(BHEAD coef1,ncoef1,coef2,-ncoef2,coef3,&ncoef3) ) { NumberFree(coef3,"DoIfStatement"); NumberFree(Spac1,"DoIfStatement"); TermFree(Spac2,"DoIfStatement"); MesCall("DoIfStatement"); return(-1); } switch ( ifp[-2] ) { case GREATER: if ( ncoef3 > 0 ) i = 1; else i = 0; break; case GREATEREQUAL: if ( ncoef3 >= 0 ) i = 1; else i = 0; break; case LESS: if ( ncoef3 < 0 ) i = 1; else i = 0; break; case LESSEQUAL: if ( ncoef3 <= 0 ) i = 1; else i = 0; break; case EQUAL: if ( ncoef3 == 0 ) i = 1; else i = 0; break; case NOTEQUAL: if ( ncoef3 != 0 ) i = 1; else i = 0; break; } donemul: if ( i ) { ncoef2 = 1; coef2 = Spac2; coef2[0] = coef2[1] = 1; } else ncoef2 = 0; ismul1 = ismul2 = 0; } } else { first = 0; } coef1 = Spac1; i = 2*ABS(ncoef2); for ( j = 0; j < i; j++ ) coef1[j] = coef2[j]; ncoef1 = ncoef2; SkipCond: ifp += ifp[1]; } while ( ifp < ifstop );
WORD GetIfDollarNum(WORD *ifp, WORD *ifstop) { DOLLARS d; WORD num, *w; if ( ifp[2] < 0 ) { return(-ifp[2]-1); } d = Dollars+ifp[2]; if ( ifp+3 < ifstop && ifp[3] == IFDOLLAREXTRA ) { if ( d->nfactors == 0 ) { MLOCK(ErrorMessageLock); MesPrint("Attempt to use a factor of an unfactored $-variable"); MUNLOCK(ErrorMessageLock); Terminate(-1); } num = GetIfDollarNum(ifp+3,ifstop); if ( num > d->nfactors ) { MLOCK(ErrorMessageLock); MesPrint("Dollar factor number %s out of range",num); MUNLOCK(ErrorMessageLock); Terminate(-1); } if ( num == 0 ) { return(d->nfactors); } w = d->factors[num-1].where; if ( w == 0 ) return(d->factors[num].value); getnumber:; if ( *w == 0 ) return(0); if ( *w == 4 && w[3] == 3 && w[2] == 1 && w[1] < MAXPOSITIVE && w[4] == 0 ) { return(w[1]); } if ( ( w[w[0]] != 0 ) || ( ABS(w[w[0]-1]) != w[0]-1 ) ) { MLOCK(ErrorMessageLock); MesPrint("Dollar factor number expected but found expression"); MUNLOCK(ErrorMessageLock); Terminate(-1); } else { MLOCK(ErrorMessageLock); MesPrint("Dollar factor number out of range"); MUNLOCK(ErrorMessageLock); Terminate(-1); } return(0); } /* Now we have just a dollar and should evaluate that into a short number */ if ( d->type == DOLZERO ) { return(0); } else if ( d->type == DOLNUMBER || d->type == DOLTERMS ) { w = d->where; goto getnumber; } else { MLOCK(ErrorMessageLock); MesPrint("Dollar factor number is wrong type"); MUNLOCK(ErrorMessageLock); Terminate(-1); return(0); } }
int StudyPattern(WORD *lhs) { GETIDENTITY WORD *fullproto, *pat, *p, *p1, *p2, *pstop, *info, f, nn; int numfun = 0, numsym = 0, allwilds = 0, i, j, k, nc; FUN_INFO *finf, *fmin, *f1, *f2, funscratch; fullproto = lhs + IDHEAD; /* if ( *lhs == TYPEIF ) fullproto--; */ pat = fullproto + fullproto[1]; info = pat + *pat; p = pat + 1; while ( p < info ) { if ( *p >= FUNCTION ) { numfun++; nn = *p - FUNCTION; if ( nn >= WILDOFFSET ) nn -= WILDOFFSET; /* We check here for cases that are not allowed like ?a inside symmetric functions or tensors. */ if ( ( functions[nn].symmetric == SYMMETRIC ) || ( functions[nn].symmetric == ANTISYMMETRIC ) ) { p2 = p+p[1]; p1 = p+FUNHEAD; if ( functions[nn].spec ) { while ( p1 < p2 ) { if ( *p1 == FUNNYWILD ) { MesPrint("&Argument field wildcards are not allowed inside (anti)symmetric functions or tensors"); return(1); } p1++; } } else { while ( p1 < p2 ) { if ( *p1 == -ARGWILD ) { MesPrint("&Argument field wildcards are not allowed inside (anti)symmetric functions or tensors"); return(1); } NEXTARG(p1); } } } } p += p[1]; } if ( numfun == 0 ) return(0); if ( ( lhs[2] & SUBMASK ) == SUBALL ) { p = pat + 1; while ( p < info ) { if ( *p == SYMBOL || *p == VECTOR || *p == DOTPRODUCT || *p == INDEX ) { MesPrint("&id,all can have only functions and/or tensors in the lhs."); return(1); } p += p[1]; } } /* We need now some room for the information about the functions */ if ( numfun > AN.numfuninfo ) { if ( AN.FunInfo ) M_free(AN.FunInfo,"funinfo"); AN.numfuninfo = numfun + 10; AN.FunInfo = (FUN_INFO *)Malloc1(AN.numfuninfo*sizeof(FUN_INFO),"funinfo"); } /* Now collect the information. First the locations. */ p = pat + 1; i = 0; while ( p < info ) { if ( *p >= FUNCTION ) AN.FunInfo[i++].location = p; p += p[1]; } for ( i = 0, finf = AN.FunInfo; i < numfun; i++, finf++ ) { p = finf->location; pstop = p + p[1]; f = *p; if ( f > FUNCTION+WILDOFFSET ) f -= WILDOFFSET; finf->numargs = finf->numfunnies = finf->numwildcards = 0; finf->symmet = functions[f-FUNCTION].symmetric; finf->tensor = functions[f-FUNCTION].spec; finf->commute = functions[f-FUNCTION].commute; if ( finf->tensor >= TENSORFUNCTION ) { p += FUNHEAD; while ( p < pstop ) { if ( *p == FUNNYWILD ) { finf->numfunnies++; p+= 2; continue; } else if ( *p < 0 ) { if ( *p >= AM.OffsetVector + WILDOFFSET && *p < MINSPEC ) { finf->numwildcards++; } } else { if ( *p >= AM.OffsetIndex + WILDOFFSET && *p <= AM.OffsetIndex + 2*WILDOFFSET ) finf->numwildcards++; } finf->numargs++; p++; } } else { p += FUNHEAD; while ( p < pstop ) { if ( *p > 0 ) { finf->numargs++; p += *p; continue; } if ( *p <= -FUNCTION ) { if ( *p <= -FUNCTION - WILDOFFSET ) finf->numwildcards++; p++; } else if ( *p == -SYMBOL ) { if ( p[1] >= 2*MAXPOWER ) finf->numwildcards++; p += 2; } else if ( *p == -INDEX ) { if ( p[1] >= AM.OffsetIndex + WILDOFFSET && p[1] <= AM.OffsetIndex + 2*WILDOFFSET ) finf->numwildcards++; p += 2; } else if ( *p == -VECTOR || *p == -MINVECTOR ) { if ( p[1] >= AM.OffsetVector + WILDOFFSET && p[1] < MINSPEC ) { finf->numwildcards++; } p += 2; } else if ( *p == -ARGWILD ) { finf->numfunnies++; p += 2; } else { p += 2; } finf->numargs++; } } if ( finf->symmet ) { numsym++; allwilds += finf->numwildcards + finf->numfunnies; } } if ( numsym == 0 ) return(0); if ( allwilds == 0 ) return(0); /* We have the information in the array AN.FunInfo. We sort things and then write the sorted pattern. Of course we may not play with the order of the noncommuting functions. Of course we have to become even smarter in the future and look during the sorting which wildcards are asigned when. But for now this should do. */ for ( nc = numfun-1; nc >= 0; nc-- ) { if ( AN.FunInfo[nc].commute ) break; } finf = AN.FunInfo; for ( i = nc+2; i < numfun; i++ ) { fmin = finf; finf++; if ( ( finf->symmet < fmin->symmet ) || ( ( finf->symmet == fmin->symmet ) && ( ( finf->numwildcards+finf->numfunnies < fmin->numwildcards+fmin->numfunnies ) || ( ( finf->numwildcards+finf->numfunnies == fmin->numwildcards+fmin->numfunnies ) && ( finf->numwildcards < fmin->numfunnies ) ) ) ) ) { funscratch = AN.FunInfo[i]; AN.FunInfo[i] = AN.FunInfo[i-1]; AN.FunInfo[i-1] = funscratch; for ( j = i-1; j > nc && j > 0; j-- ) { f1 = AN.FunInfo+j; f2 = f1-1; if ( ( f1->symmet < f2->symmet ) || ( ( f1->symmet == f2->symmet ) && ( ( f1->numwildcards+f1->numfunnies < f2->numwildcards+f2->numfunnies ) || ( ( f1->numwildcards+f1->numfunnies == f2->numwildcards+f2->numfunnies ) && ( f1->numwildcards < f2->numfunnies ) ) ) ) ) { funscratch = AN.FunInfo[j]; AN.FunInfo[j] = AN.FunInfo[j-1]; AN.FunInfo[j-1] = funscratch; } else break; } } } /* Now we rewrite the pattern. First into the space after it and then we copy it back. Be careful with the non-commutative functions. There the worst one should decide. */ p = pat + 1; p2 = info; for ( i = 0; i < numfun; i++ ) { if ( i == nc ) { for ( k = 0; k <= nc; k++ ) { if ( AN.FunInfo[k].commute ) { p1 = AN.FunInfo[k].location; j = p1[1]; NCOPY(p2,p1,j) } } } else if ( AN.FunInfo[i].commute == 0 ) {
/* #] Includes : #[ FactorIn : This routine tests for a factor in a dollar expression. Note that unlike with regular active or hidden expressions we cannot add memory as easily as dollars are rather volatile. */ int FactorIn(PHEAD WORD *term, WORD level) { GETBIDENTITY WORD *t, *tstop, *m, *mm, *oldwork, *mstop, *n1, *n2, *n3, *n4, *n1stop, *n2stop; WORD *r1, *r2, *r3, *r4, j, k, kGCD, kGCD2, kLCM, jGCD, kkLCM, jLCM, size; UWORD *GCDbuffer, *GCDbuffer2, *LCMbuffer, *LCMb, *LCMc; int fromwhere = 0, i; DOLLARS d; t = term; GETSTOP(t,tstop); t++; while ( ( t < tstop ) && ( *t != FACTORIN || ( ( *t == FACTORIN ) && ( t[FUNHEAD] != -DOLLAREXPRESSION || t[1] != FUNHEAD+2 ) ) ) ) t += t[1]; if ( t >= tstop ) { MLOCK(ErrorMessageLock); MesPrint("Internal error. Could not find proper factorin_ function."); MUNLOCK(ErrorMessageLock); return(-1); } oldwork = AT.WorkPointer; d = Dollars + t[FUNHEAD+1]; #ifdef WITHPTHREADS { int nummodopt, dtype = -1; if ( AS.MultiThreaded ) { for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) { if ( t[FUNHEAD+1] == ModOptdollars[nummodopt].number ) break; } if ( nummodopt < NumModOptdollars ) { dtype = ModOptdollars[nummodopt].type; if ( dtype == MODLOCAL ) { d = ModOptdollars[nummodopt].dstruct+AT.identity; } } } } #endif if ( d->type == DOLTERMS ) { fromwhere = 1; } else if ( ( d = DolToTerms(BHEAD t[FUNHEAD+1]) ) == 0 ) { /* The variable cannot convert to an expression We replace the function by 1. */ m = oldwork; n1 = term; while ( n1 < t ) *m++ = *n1++; n1 = t + t[1]; tstop = term + *term; while ( n1 < tstop ) *m++ = *n1++; *oldwork = m - oldwork; AT.WorkPointer = m; if ( Generator(BHEAD oldwork,level) ) return(-1); AT.WorkPointer = oldwork; return(0); } if ( d->where[0] == 0 ) { if ( fromwhere == 0 ) { if ( d->factors ) M_free(d->factors,"Dollar factors"); M_free(d,"Dollar in FactorIn_"); } return(0); } /* Now we have an expression in d->where. Find the symbolic factor that divides the expression and the numerical factor that makes all coefficients integer. For the symbolic factor we make a copy of the first term, and then go through all terms, scratching in the copy the objects that do not occur in the terms. */ m = oldwork; mm = d->where; k = *mm - ABS((mm[*mm-1])); for ( j = 0; j < k; j++ ) *m++ = *mm++; mstop = m; *oldwork = k; /* The copy is in place. Now search through the terms. Start at the second term */ mm = d->where + d->where[0]; while ( *mm ) { m = oldwork+1; r2 = mm+*mm; r2 -= ABS(r2[-1]); r1 = mm+1; while ( m < mstop ) { while ( r1 < r2 ) { if ( *r1 != *m ) { r1 += r1[1]; continue; } /* Now the various cases #[ SYMBOL : */ if ( *m == SYMBOL ) { n1 = m+2; n1stop = m+m[1]; n2stop = r1+r1[1]; while ( n1 < n1stop ) { n2 = r1+2; while ( n2 < n2stop ) { if ( *n1 != *n2 ) { n2 += 2; continue; } if ( n1[1] > 0 ) { if ( n2[1] < 0 ) { n2 += 2; continue; } if ( n2[1] < n1[1] ) n1[1] = n2[1]; } else { if ( n2[1] > 0 ) { n2 += 2; continue; } if ( n2[1] > n1[1] ) n1[1] = n2[1]; } break; } if ( n2 >= n2stop ) { /* scratch symbol */ if ( m[1] == 4 ) goto scratch; m[1] -= 2; n3 = n1; n4 = n1+2; while ( n4 < mstop ) *n3++ = *n4++; *oldwork = n3 - oldwork; mstop -= 2; n1stop -= 2; continue; } n1 += 2; } break; } /* #] SYMBOL : #[ DOTPRODUCT : */ else if ( *m == DOTPRODUCT ) { n1 = m+2; n1stop = m+m[1]; n2stop = r1+r1[1]; while ( n1 < n1stop ) { n2 = r1+2; while ( n2 < n2stop ) { if ( *n1 != *n2 || n1[1] != n2[1] ) { n2 += 3; continue; } if ( n1[2] > 0 ) { if ( n2[2] < 0 ) { n2 += 3; continue; } if ( n2[2] < n1[2] ) n1[2] = n2[2]; } else { if ( n2[2] > 0 ) { n2 += 3; continue; } if ( n2[2] > n1[2] ) n1[2] = n2[2]; } break; } if ( n2 >= n2stop ) { /* scratch symbol */ if ( m[1] == 5 ) goto scratch; m[1] -= 3; n3 = n1; n4 = n1+3; while ( n4 < mstop ) *n3++ = *n4++; *oldwork = n3 - oldwork; mstop -= 3; n1stop -= 3; continue; } n1 += 3; } break; } /* #] DOTPRODUCT : #[ VECTOR : */ else if ( *m == VECTOR ) { /* Here we have to be careful if there is more than one of the same */ n1 = m+2; n1stop = m+m[1]; n2 = r1+2;n2stop = r1+r1[1]; while ( n1 < n1stop ) { while ( n2 < n2stop ) { if ( *n1 == *n2 && n1[1] == n2[1] ) { n2 += 2; goto nextn1; } n2 += 2; } if ( n2 >= n2stop ) { /* scratch symbol */ if ( m[1] == 4 ) goto scratch; m[1] -= 2; n3 = n1; n4 = n1+2; while ( n4 < mstop ) *n3++ = *n4++; *oldwork = n3 - oldwork; mstop -= 2; n1stop -= 2; continue; } n2 = r1+2; nextn1: n1 += 2; } break; } /* #] VECTOR : #[ REMAINDER : */ else { /* Again: watch for multiple occurrences of the same object */ if ( m[1] != r1[1] ) { r1 += r1[1]; continue; } for ( j = 2; j < m[1]; j++ ) { if ( m[j] != r1[j] ) break; } if ( j < m[1] ) { r1 += r1[1]; continue; } r1 += r1[1]; /* to restart at the next potential match */ goto nextm; /* match */ } /* #] REMAINDER : */ } if ( r1 >= r2 ) { /* no factor! */ scratch:; r3 = m + m[1]; r4 = m; while ( r3 < mstop ) *r4++ = *r3++; *oldwork = r4 - oldwork; if ( *oldwork == 1 ) goto nofactor; mstop = r4; r1 = mm + 1; continue; } r1 = mm + 1; nextm: m += m[1]; } mm = mm + *mm; } nofactor:; /* For the coefficient we have to determine the LCM of the denominators and the GCD of the numerators. */ GCDbuffer = NumberMalloc("FactorIn"); GCDbuffer2 = NumberMalloc("FactorIn"); LCMbuffer = NumberMalloc("FactorIn"); LCMb = NumberMalloc("FactorIn"); LCMc = NumberMalloc("FactorIn"); r1 = d->where; /* First take the first term to load up the LCM and the GCD */ r2 = r1 + *r1; j = r2[-1]; r3 = r2 - ABS(j); k = REDLENG(j); if ( k < 0 ) k = -k; while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--; for ( kGCD = 0; kGCD < k; kGCD++ ) GCDbuffer[kGCD] = r3[kGCD]; k = REDLENG(j); if ( k < 0 ) k = -k; r3 += k; while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--; for ( kLCM = 0; kLCM < k; kLCM++ ) LCMbuffer[kLCM] = r3[kLCM]; r1 = r2; /* Now go through the rest of the terms in this dollar buffer. */ while ( *r1 ) { r2 = r1 + *r1; j = r2[-1]; r3 = r2 - ABS(j); k = REDLENG(j); if ( k < 0 ) k = -k; while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--; if ( ( ( GCDbuffer[0] == 1 ) && ( kGCD == 1 ) ) ) { /* GCD is already 1 */ } else if ( ( ( k != 1 ) || ( r3[0] != 1 ) ) ) { if ( GcdLong(BHEAD GCDbuffer,kGCD,(UWORD *)r3,k,GCDbuffer2,&kGCD2) ) { goto onerror; } kGCD = kGCD2; for ( i = 0; i < kGCD; i++ ) GCDbuffer[i] = GCDbuffer2[i]; } else { kGCD = 1; GCDbuffer[0] = 1; } k = REDLENG(j); if ( k < 0 ) k = -k; r3 += k; while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--; if ( ( ( LCMbuffer[0] == 1 ) && ( kLCM == 1 ) ) ) { for ( kLCM = 0; kLCM < k; kLCM++ ) LCMbuffer[kLCM] = r3[kLCM]; } else if ( ( k != 1 ) || ( r3[0] != 1 ) ) { if ( GcdLong(BHEAD LCMbuffer,kLCM,(UWORD *)r3,k,LCMb,&kkLCM) ) { goto onerror; } DivLong((UWORD *)r3,k,LCMb,kkLCM,LCMb,&kkLCM,LCMc,&jLCM); MulLong(LCMbuffer,kLCM,LCMb,kkLCM,LCMc,&jLCM); for ( kLCM = 0; kLCM < jLCM; kLCM++ ) LCMbuffer[kLCM] = LCMc[kLCM]; } else {} /* LCM doesn't change */ r1 = r2; } /* Now put the factor together: GCD/LCM */ r3 = (WORD *)(GCDbuffer); if ( kGCD == kLCM ) { for ( jGCD = 0; jGCD < kGCD; jGCD++ ) r3[jGCD+kGCD] = LCMbuffer[jGCD]; k = kGCD; } else if ( kGCD > kLCM ) { for ( jGCD = 0; jGCD < kLCM; jGCD++ ) r3[jGCD+kGCD] = LCMbuffer[jGCD]; for ( jGCD = kLCM; jGCD < kGCD; jGCD++ ) r3[jGCD+kGCD] = 0; k = kGCD; } else { for ( jGCD = kGCD; jGCD < kLCM; jGCD++ ) r3[jGCD] = 0; for ( jGCD = 0; jGCD < kLCM; jGCD++ ) r3[jGCD+kLCM] = LCMbuffer[jGCD]; k = kLCM; } j = 2*k+1; mm = m = oldwork + oldwork[0]; /* Now compose the new term */ n1 = term; while ( n1 < t ) *m++ = *n1++; n1 += n1[1]; n2 = oldwork+1; while ( n2 < mm ) *m++ = *n2++; while ( n1 < tstop ) *m++ = *n1++; /* And the coefficient */ size = term[*term-1]; size = REDLENG(size); if ( MulRat(BHEAD (UWORD *)tstop,size,(UWORD *)r3,k, (UWORD *)m,&size) ) goto onerror; size = INCLENG(size); k = size < 0 ? -size: size; m[k-1] = size; m += k; *mm = (WORD)(m - mm); AT.WorkPointer = m; if ( Generator(BHEAD mm,level) ) goto onerror; AT.WorkPointer = oldwork; if ( fromwhere == 0 ) { if ( d->factors ) M_free(d->factors,"Dollar factors"); M_free(d,"Dollar in FactorIn"); } NumberFree(GCDbuffer,"FactorIn"); NumberFree(GCDbuffer2,"FactorIn"); NumberFree(LCMbuffer,"FactorIn"); NumberFree(LCMb,"FactorIn"); NumberFree(LCMc,"FactorIn"); return(0); onerror: AT.WorkPointer = oldwork; MLOCK(ErrorMessageLock); MesCall("FactorIn"); MUNLOCK(ErrorMessageLock); NumberFree(GCDbuffer,"FactorIn"); NumberFree(GCDbuffer2,"FactorIn"); NumberFree(LCMbuffer,"FactorIn"); NumberFree(LCMb,"FactorIn"); NumberFree(LCMc,"FactorIn"); return(-1); }
int FactorInExpr(PHEAD WORD *term, WORD level) { GETBIDENTITY WORD *t, *tstop, *m, *oldwork, *mstop, *n1, *n2, *n3, *n4, *n1stop, *n2stop; WORD *r1, *r2, *r3, *r4, j, k, kGCD, kGCD2, kLCM, jGCD, kkLCM, jLCM, size, sign; WORD *newterm, expr = 0; WORD olddeferflag = AR.DeferFlag, oldgetfile = AR.GetFile, oldhold = AR.KeptInHold; WORD newgetfile, newhold; int i; EXPRESSIONS e; FILEHANDLE *file = 0; POSITION position, oldposition, startposition; WORD *oldcpointer = AR.CompressPointer; UWORD *GCDbuffer, *GCDbuffer2, *LCMbuffer, *LCMb, *LCMc; GCDbuffer = NumberMalloc("FactorInExpr"); GCDbuffer2 = NumberMalloc("FactorInExpr"); LCMbuffer = NumberMalloc("FactorInExpr"); LCMb = NumberMalloc("FactorInExpr"); LCMc = NumberMalloc("FactorInExpr"); t = term; GETSTOP(t,tstop); t++; while ( t < tstop ) { if ( *t == FACTORIN && t[1] == FUNHEAD+2 && t[FUNHEAD] == -EXPRESSION ) { expr = t[FUNHEAD+1]; break; } t += t[1]; } if ( t >= tstop ) { MLOCK(ErrorMessageLock); MesPrint("Internal error. Could not find proper factorin_ function."); MUNLOCK(ErrorMessageLock); NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr"); NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr"); return(-1); } oldwork = AT.WorkPointer; if ( AT.previousEfactor && ( expr == AT.previousEfactor[0] ) ) { /* We have a hit in the cache. Construct the new term. At the moment AT.previousEfactor[1] is reserved for future flags */ goto PutTheFactor; } /* No hit. We have to do the work. We start with constructing the factor in the WorkSpace. Later we will move it to the cache. Finally we will jump to PutTheFactor. */ e = Expressions + expr; switch ( e->status ) { case LOCALEXPRESSION: case SKIPLEXPRESSION: case DROPLEXPRESSION: case GLOBALEXPRESSION: case SKIPGEXPRESSION: case DROPGEXPRESSION: /* Expression is to be found in the input Scratch file. Set the file handle and the position. The rest is done by GetTerm. */ newhold = 0; newgetfile = 1; file = AR.infile; break; case HIDDENLEXPRESSION: case HIDDENGEXPRESSION: case HIDELEXPRESSION: case HIDEGEXPRESSION: case DROPHLEXPRESSION: case DROPHGEXPRESSION: case UNHIDELEXPRESSION: case UNHIDEGEXPRESSION: /* Expression is to be found in the hide Scratch file. Set the file handle and the position. The rest is done by GetTerm. */ newhold = 0; newgetfile = 2; file = AR.hidefile; break; case STOREDEXPRESSION: /* This is an 'illegal' case */ MLOCK(ErrorMessageLock); MesPrint("Error: factorin_ cannot determine factors in stored expressions."); MUNLOCK(ErrorMessageLock); NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr"); NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr"); return(-1); case DROPPEDEXPRESSION: /* We replace the function by 1. */ m = oldwork; n1 = term; while ( n1 < t ) *m++ = *n1++; n1 = t + t[1]; tstop = term + *term; while ( n1 < tstop ) *m++ = *n1++; *oldwork = m - oldwork; AT.WorkPointer = m; if ( Generator(BHEAD oldwork,level) ) { NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr"); NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr"); return(-1); } AT.WorkPointer = oldwork; NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr"); NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr"); return(0); default: MLOCK(ErrorMessageLock); MesPrint("Error: Illegal expression in factorinexpr."); MUNLOCK(ErrorMessageLock); NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr"); NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr"); return(-1); } /* Before we start with the file we set the buffers for the coefficient For the coefficient we have to determine the LCM of the denominators and the GCD of the numerators. */ position = AS.OldOnFile[expr]; AR.DeferFlag = 0; AR.KeptInHold = newhold; AR.GetFile = newgetfile; SeekScratch(file,&oldposition); SetScratch(file,&position); if ( GetTerm(BHEAD oldwork) <= 0 ) { MLOCK(ErrorMessageLock); MesPrint("(5) Expression %d has problems in scratchfile",expr); MUNLOCK(ErrorMessageLock); NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr"); NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr"); return(-1); } SeekScratch(file,&startposition); SeekScratch(file,&position); /* Load the first term in the workspace */ if ( GetTerm(BHEAD oldwork) == 0 ) { SetScratch(file,&oldposition); /* We still need this untill Processor is clean */ AR.DeferFlag = olddeferflag; oldwork[0] = 4; oldwork[1] = 1; oldwork[2] = 1; oldwork[3] = 3; goto Complete; } SeekScratch(file,&position); AR.DeferFlag = olddeferflag; AR.KeptInHold = oldhold; AR.GetFile = oldgetfile; r2 = m = oldwork + *oldwork; j = m[-1]; m -= ABS(j); *oldwork = (WORD)(m-oldwork); AT.WorkPointer = newterm = mstop = m; /* Now take the coefficient of the first term to load up the LCM and the GCD */ r3 = m; k = REDLENG(j); if ( k < 0 ) { k = -k; sign = -1; } else { sign = 1; } while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--; for ( kGCD = 0; kGCD < k; kGCD++ ) GCDbuffer[kGCD] = r3[kGCD]; k = REDLENG(j); if ( k < 0 ) k = -k; r3 += k; while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--; for ( kLCM = 0; kLCM < k; kLCM++ ) LCMbuffer[kLCM] = r3[kLCM]; /* The copy and the coefficient are in place. Now search through the terms. */ for (;;) { AR.DeferFlag = 0; AR.KeptInHold = newhold; AR.GetFile = newgetfile; SetScratch(file,&position); size = GetTerm(BHEAD newterm); SeekScratch(file,&position); AR.DeferFlag = olddeferflag; AR.KeptInHold = oldhold; AR.GetFile = oldgetfile; if ( size == 0 ) break; m = oldwork+1; r2 = newterm + *newterm; r2 -= ABS(r2[-1]); r1 = newterm+1; while ( m < mstop ) { while ( r1 < r2 ) { if ( *r1 != *m ) { r1 += r1[1]; continue; } /* Now the various cases #[ SYMBOL : */ if ( *m == SYMBOL ) { n1 = m+2; n1stop = m+m[1]; n2stop = r1+r1[1]; while ( n1 < n1stop ) { n2 = r1+2; while ( n2 < n2stop ) { if ( *n1 != *n2 ) { n2 += 2; continue; } if ( n1[1] > 0 ) { if ( n2[1] < 0 ) { n2 += 2; continue; } if ( n2[1] < n1[1] ) n1[1] = n2[1]; } else { if ( n2[1] > 0 ) { n2 += 2; continue; } if ( n2[1] > n1[1] ) n1[1] = n2[1]; } break; } if ( n2 >= n2stop ) { /* scratch symbol */ if ( m[1] == 4 ) goto scratch; m[1] -= 2; n3 = n1; n4 = n1+2; while ( n4 < mstop ) *n3++ = *n4++; *oldwork = n3 - oldwork; mstop -= 2; n1stop -= 2; continue; } n1 += 2; } break; } /* #] SYMBOL : #[ DOTPRODUCT : */ else if ( *m == DOTPRODUCT ) { n1 = m+2; n1stop = m+m[1]; n2stop = r1+r1[1]; while ( n1 < n1stop ) { n2 = r1+2; while ( n2 < n2stop ) { if ( *n1 != *n2 || n1[1] != n2[1] ) { n2 += 3; continue; } if ( n1[2] > 0 ) { if ( n2[2] < 0 ) { n2 += 3; continue; } if ( n2[2] < n1[2] ) n1[2] = n2[2]; } else { if ( n2[2] > 0 ) { n2 += 3; continue; } if ( n2[2] > n1[2] ) n1[2] = n2[2]; } break; } if ( n2 >= n2stop ) { /* scratch dotproduct */ if ( m[1] == 5 ) goto scratch; m[1] -= 3; n3 = n1; n4 = n1+3; while ( n4 < mstop ) *n3++ = *n4++; *oldwork = n3 - oldwork; mstop -= 3; n1stop -= 3; continue; } n1 += 3; } break; } /* #] DOTPRODUCT : #[ VECTOR : */ else if ( *m == VECTOR ) { /* Here we have to be careful if there is more than one of the same */ n1 = m+2; n1stop = m+m[1]; n2 = r1+2;n2stop = r1+r1[1]; while ( n1 < n1stop ) { while ( n2 < n2stop ) { if ( *n1 == *n2 && n1[1] == n2[1] ) { n2 += 2; goto nextn1; } n2 += 2; } if ( n2 >= n2stop ) { /* scratch vector */ if ( m[1] == 4 ) goto scratch; m[1] -= 2; n3 = n1; n4 = n1+2; while ( n4 < mstop ) *n3++ = *n4++; *oldwork = n3 - oldwork; mstop -= 2; n1stop -= 2; continue; } n2 = r1+2; nextn1: n1 += 2; } break; } /* #] VECTOR : #[ REMAINDER : */ else { /* Again: watch for multiple occurrences of the same object */ if ( m[1] != r1[1] ) { r1 += r1[1]; continue; } for ( j = 2; j < m[1]; j++ ) { if ( m[j] != r1[j] ) break; } if ( j < m[1] ) { r1 += r1[1]; continue; } r1 += r1[1]; /* to restart at the next potential match */ goto nextm; /* match */ } /* #] REMAINDER : */ } if ( r1 >= r2 ) { /* no factor! */ scratch:; r3 = m + m[1]; r4 = m; while ( r3 < mstop ) *r4++ = *r3++; *oldwork = r4 - oldwork; if ( *oldwork == 1 ) goto nofactor; mstop = r4; r1 = newterm + 1; continue; } r1 = newterm + 1; nextm: m += m[1]; } nofactor:; /* Now the coefficient */ r2 = newterm + *newterm; j = r2[-1]; r3 = r2 - ABS(j); k = REDLENG(j); if ( k < 0 ) k = -k; while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--; if ( ( ( GCDbuffer[0] == 1 ) && ( kGCD == 1 ) ) ) { /* GCD is already 1 */ } else if ( ( ( k != 1 ) || ( r3[0] != 1 ) ) ) { if ( GcdLong(BHEAD GCDbuffer,kGCD,(UWORD *)r3,k,GCDbuffer2,&kGCD2) ) { goto onerror; } kGCD = kGCD2; for ( i = 0; i < kGCD; i++ ) GCDbuffer[i] = GCDbuffer2[i]; } else { kGCD = 1; GCDbuffer[0] = 1; } k = REDLENG(j); if ( k < 0 ) k = -k; r3 += k; while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--; if ( ( ( LCMbuffer[0] == 1 ) && ( kLCM == 1 ) ) ) { for ( kLCM = 0; kLCM < k; kLCM++ ) LCMbuffer[kLCM] = r3[kLCM]; } else if ( ( k != 1 ) || ( r3[0] != 1 ) ) { if ( GcdLong(BHEAD LCMbuffer,kLCM,(UWORD *)r3,k,LCMb,&kkLCM) ) { goto onerror; } DivLong((UWORD *)r3,k,LCMb,kkLCM,LCMb,&kkLCM,LCMc,&jLCM); MulLong(LCMbuffer,kLCM,LCMb,kkLCM,LCMc,&jLCM); for ( kLCM = 0; kLCM < jLCM; kLCM++ ) LCMbuffer[kLCM] = LCMc[kLCM]; } else {} /* LCM doesn't change */ } SetScratch(file,&oldposition); /* Needed until Processor is thread safe */ AR.DeferFlag = olddeferflag; /* Now put the term together in oldwork: GCD/LCM We have already the algebraic contents there. */ r3 = (WORD *)(GCDbuffer); r4 = (WORD *)(LCMbuffer); r1 = oldwork + *oldwork; if ( kGCD == kLCM ) { for ( jGCD = 0; jGCD < kGCD; jGCD++ ) *r1++ = *r3++; for ( jGCD = 0; jGCD < kGCD; jGCD++ ) *r1++ = *r4++; k = 2*kGCD+1; } else if ( kGCD > kLCM ) { for ( jGCD = 0; jGCD < kGCD; jGCD++ ) *r1++ = *r3++; for ( jGCD = 0; jGCD < kLCM; jGCD++ ) *r1++ = *r4++; for ( jGCD = kLCM; jGCD < kGCD; jGCD++ ) *r1++ = 0; k = 2*kGCD+1; } else { for ( jGCD = 0; jGCD < kGCD; jGCD++ ) *r1++ = *r3++; for ( jGCD = kGCD; jGCD < kLCM; jGCD++ ) *r1++ = 0; for ( jGCD = 0; jGCD < kLCM; jGCD++ ) *r1++ = *r4++; k = 2*kLCM+1; } if ( sign < 0 ) *r1++ = -k; else *r1++ = k; *oldwork = (WORD)(r1-oldwork); /* Now put the new term in the cache */ Complete:; if ( AT.previousEfactor ) M_free(AT.previousEfactor,"Efactor cache"); AT.previousEfactor = (WORD *)Malloc1((*oldwork+2)*sizeof(WORD),"Efactor cache"); AT.previousEfactor[0] = expr; r1 = oldwork; r2 = AT.previousEfactor + 2; k = *oldwork; NCOPY(r2,r1,k) AT.previousEfactor[1] = 0; /* Now we construct the new term in the workspace. */ PutTheFactor:; if ( AT.WorkPointer + AT.previousEfactor[2] >= AT.WorkTop ) { MLOCK(ErrorMessageLock); MesWork(); MesPrint("Called from factorin_"); MUNLOCK(ErrorMessageLock); NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr"); NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr"); return(-1); } n1 = oldwork; n2 = term; while ( n2 < t ) *n1++ = *n2++; n2 = AT.previousEfactor+2; GETSTOP(n2,n2stop); n3 = n2 + *n2; n2++; while ( n2 < n2stop ) *n1++ = *n2++; n2 = t + t[1]; while ( n2 < tstop ) *n1++ = *n2++; size = term[*term-1]; size = REDLENG(size); k = n3[-1]; k = REDLENG(k); if ( MulRat(BHEAD (UWORD *)tstop,size,(UWORD *)n2stop,k, (UWORD *)n1,&size) ) goto onerror; size = INCLENG(size); k = size < 0 ? -size: size; n1 += k; n1[-1] = size; *oldwork = n1 - oldwork; AT.WorkPointer = n1; if ( Generator(BHEAD oldwork,level) ) { NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr"); NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr"); return(-1); } AT.WorkPointer = oldwork; AR.CompressPointer = oldcpointer; NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr"); NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr"); return(0); onerror: AT.WorkPointer = oldwork; AR.CompressPointer = oldcpointer; MLOCK(ErrorMessageLock); MesCall("FactorInExpr"); MUNLOCK(ErrorMessageLock); NumberFree(GCDbuffer,"FactorInExpr"); NumberFree(GCDbuffer2,"FactorInExpr"); NumberFree(LCMbuffer,"FactorInExpr"); NumberFree(LCMb,"FactorInExpr"); NumberFree(LCMc,"FactorInExpr"); return(-1); }