Artifact d1f9095d585224c8c20c0f8623853e8da368a3a25f612cef6b54e2e0e44ad595:
- Executable file
r38/packages/scope/codmat.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 74587) [annotate] [blame] [check-ins using] [more...]
module codmat; % Support for matrix optimization. % -------------------------------------------------------------------- ; % Copyright : J.A. van Hulzen, Twente University, Dept. of Computer ; % Science, P.O.Box 217, 7500 AE Enschede, the Netherlands. ; % Authors : J.A. van Hulzen, B.J.A. Hulshof, M.C. van Heerwaarden, ; % J.C.A. Smit, W.N. Borst. ; % -------------------------------------------------------------------- ; % -------------------------------------------------------------------- ; % The module CODMAT consists of two parts: ; % 1 - A collection of Extended Access Functions to the CODMAT-matrix ; % and the associated hashvector CODHISTO. ; % 2 - Routines for constructing the incidence matrix CODMAT via par- ; % sing and storage of a set of input expressions. ; % 3 - Routines for removing gcd's from quotients. ; % -------------------------------------------------------------------- ; % ; % -------------------------------------------------------------------- ; % PART 1 : EXTENDED ACCESS FUNCTIONS ; % -------------------------------------------------------------------- ; % ; % These functions allow to STORE,RETRIEVE or MODIFY information stored ; % in CODMAT and CODHISTO, used for hashing. ; % Remark:A detailed description of the vectors CODMAT and CODHISTO and ; % their DIRECT ACCESS FUNCTIONS, heavily used here, is given in the ; % module COSYMP. ; % ; % ------ A CLASSIFICATION OF THE EXTENDED ACCESS FUNCTIONS ------ ; % ; % - STORAGE : SetRow,InsZZZ,InsZZZn,InsZZZr,PnthXZZ. ; % - HISTOGRAM OPERATIONS : InsHisto,DelHisto,Downwght,Downwght1,Upwght,; % Upwght1,Initwght. ; % - MODIFICATION : Rowdel,Rowins,RemZZZZ,Chdel,DelYZZ,Clearrow. ; % - PRINTING TESTRUNS : ChkCodMat. ; % ; % ------ TERMINOLOGY USED ------ ; % ZZ stands for a Zstrt and Z for a single item in ZZ. A Zstrt is a ; % list of pairs (row(column)index . coeff(exponent)information).Hence a; % double linked list representation is used. Both X and Y denote indi- ; % ces.The Cdr-part of a Z-element is in fact again a dotted pair (IVal.; % BVal). The BValue however is only used in CODPRI.RED for printing ; % purposes,related to the finishing touch. Therefore we only take IVal ; % as Cdr-part in the ; % Example : +| a b c d ; % Let -+--------- ; % f = a + 2*b + 3*c f| 1 2 3 ; % g =2*a + 4*b + 5*d g| 2 4 5 ; % ; % Taking MaxVar=4 results in : ; % ; % CODMAT index=|I| |Zstrt ZZ | ; % -------------+-+-+--------------------+----------------------------- ; % ....... | | | |Rows: Structure created by ; % ....... | | | |Fvar or FFvar using I=MaxVar+ ; % ....... | | | |RowMax (See Row and FillRow, ; % Rowmax= 1 |5|g|((-4.5)(-2.4)(-1.2))|defined in module COSYMP ; % Rowmax= 0 |4|f|((-3.3)(-2.2)(-1.1))|and used in SETROW). ; % -------------+-+-+--------------------+----------------------------- ; % Rowmin=-1 |3|a|((1.2)(0.1)) |Columns:Created by SSetVars( ; % Rowmin=-2 |2|b|((1.4)(0.2)) |part 2 of this module) : I= ; % Rowmin=-3 |1|c|((0.3)) |Maxvar+Rowmin. The Zstrts of ; % Rowmin=-4 |0|d|((1.5)) | the rows are also completed ; % ....... | | | | by SSetvars. ; % -------------------------------------------------------------------- ; % ; % Remarks : ; % -1- The CODMAT index I used in the above example is thus the physical; % value of the subscript. This in contrast to the indices used when; % calling routines like SETROW, which operate on Rowmax or Rowmin ; % values (details are given in CODCTL.RED and in the routine ROW in; % COSYMP.RED). ; % -2- A similar picture is produced for f=a*b^2*c^3 and g=a^2*b^4*d^5. ; % When introducing monomials as terms or sum as factors also the ; % Child-facilities have to be used like done for operators other ; % than + or *. ; % -------------------------------------------------------------------- ; symbolic$ global '(codmat maxvar rowmin rowmax endmat codhisto headhisto !*vectorc !*inputc known rhsaliases); fluid '(preprefixlist prefixlist); switch vectorc$ !*vectorc := nil$ % ____________________________________________________________________ ; % A description of these globals is given in the module CODCTL ; % -------------------------------------------------------------------- ; symbolic procedure setrow(n,op,fa,s,zz); % -------------------------------------------------------------------- ; % arg : N : Row(column)index of the row(column) of which the value has ; % to be (re)set. Physically we need MaxVar + N(see ROW in ; % COSYMP.RED). ; % Op: Operator value to be stored in Opval,i.e. 'PLUS,'TIMES or ; % some other operator. ; % Fa: For a row the name (toplevel) or index (subexpression) of ; % the father.For a column the template of the column variable; % S : Compiled code demands atmost 5 parameters,atleast for some ; % REDUCE implementations. Therefore S stands for a list of ; % Chrow information,if necessary extended with the monomial ; % coefficient(Opval='TIMES) or the exponent of a linear ex- ; % pression(Opval='PLUS),to be stored in the CofExp-field. ; % ZZ: The Z-street. ; % eff : Row(column) N is created and set. If necessary,i.e. if N>MaxVar; % then CODMAT is doubled in size. ; % -------------------------------------------------------------------- ; begin scalar codmat1; if abs(n)>maxvar then % Double the size of CODMAT. <<codmat1:=mkvect(4*maxvar); for x:=max(rowmin,-maxvar):min(rowmax,maxvar) do putv(codmat1,x+2*maxvar,row x); codmat:=codmat1; maxvar:=2*maxvar; >>; % --------------------------------------------------------------------; % Now the values are set,using LenCol=4 and LenRow=8,i.e. the fields ; % Chrow,CofExp,HiR and Ordr are not in use for columns because: ; % - Chrow and CofExp are irrelevant for storing information about ; % variable occurrences. ; % - Hashing(HiR) and CSE-insertion(Ordr) are based on row-information ; % only. ; % --------------------------------------------------------------------; if n<0 then fillrow(n,mkvect lencol) else <<fillrow(n,mkvect lenrow); setchrow(n,car s); if cdr s then setexpcof(n,cadr s) else setexpcof(n,1)>>; setfree(n); setopval(n,op); setfarvar(n,fa); setzstrt(n,zz) end; symbolic procedure inszzz(z,zz); % -------------------------------------------------------------------- ; % arg : Z : A matrix element. ; % ZZ: A set of matrix elements with indices in descending order. ; % eff : A set of matrix elements including Z and ZZ,again in ascending ; % order,such that in case Z's index already exists the Ival- ; % parts of both elements are added together. ; % -------------------------------------------------------------------- ; if null zz or xind(car zz)<xind(z) then z.zz else if xind(car zz)=xind(z) then <<setival(car zz,dm!-plus(ival(car zz),ival(z))); if zeropp(ival car zz) then cdr(zz) else zz>> else car(zz).inszzz(z,cdr zz); symbolic procedure inszzzn(z,zz); % -------------------------------------------------------------------- ; % eff : Similar to InsZZZ.However,Z is only inserted if its index is ; % not occuring as car-part of one of the elements of ZZ. ; % -------------------------------------------------------------------- ; if null(zz) or xind(car zz)<xind(z) then z.zz else if xind(car zz)=xind(z) then zz else car(zz).inszzzn(z,cdr zz); symbolic procedure inszzzr(z,zz); % -------------------------------------------------------------------- ; % eff : Similar to InsZZZ,but the indices of ZZ are now given in as- ; % cending order. ; % -------------------------------------------------------------------- ; if null(zz) or xind(car zz)>xind(z) then z.zz else if xind(car zz)=xind(z) then <<setival(car zz,dm!-plus(ival(car zz),ival(z))); % We have to test whether the result of dm!-plus was zero. % Storing a zero leads to errors. Hvh 06-04-95. if zeropp(ival car zz) then cdr(zz) else zz>> else car(zz).inszzzr(z,cdr zz); symbolic procedure pnthxzz(x,zz); % -------------------------------------------------------------------- ; % arg : X is a row(column)index and ZZ a Z-street. ; % res : A sublist of ZZ such that Caar ZZ = X. ; % -------------------------------------------------------------------- ; if null(zz) or xind(car zz)=x then zz else pnthxzz(x,cdr zz); symbolic procedure inshisto(x); % -------------------------------------------------------------------- ; % arg : Rowindex X. ; % eff : X is inserted in the Histogram-hierarchy. ; % ; % The insertion can be vizualized in the following way : ; % ; % CODHISTO CODMAT ; % ; % index value Row Hwght HiR ; % 200 +---+ index (PHiR . NHiR) ; % | | . . . ; % : : : : : ; % | | : : : ; % +---+ | | | ; % i | k | <--> +---+---+---------------+ ; % +---+ | k | i | Nil . m | ; % | | +---+---+---------------+ ; % : : | | | | ; % | | : : : : ; % +---+ | | | | ; % 0 | | +---+---+---------------+ ; % +---+ | m | i | k . p | ; % +---+---+---------------+ ; % | | | | ; % : : : : ; % | | | | ; % +---+---+---------------+ ; % | p | i | m . Nil | ; % +---+---+---------------+ ; % : : : : ; % ; % -------------------------------------------------------------------- ; if free(x) and x>=0 then begin scalar y,hv; if y:=histo(hv:=min(hwght x,histolen)) then setphir(y,x) else if hv>headhisto then headhisto:=hv; sethir(x,nil.y); sethisto(hv,x) end; symbolic procedure delhisto(x); % -------------------------------------------------------------------- ; % arg : Rowindex X. ; % eff : Removes X from the histogram-hierarchy. ; % -------------------------------------------------------------------- ; if free(x) and x>=0 then begin scalar y,z,hv; y:=phir x; z:=nhir x; hv:=min(hwght(x),histolen); if y then setnhir(y,z) else sethisto(hv,z); if z then setphir(z,y); end; symbolic procedure rowdel x; % -------------------------------------------------------------------- ; % arg : Row(column)index X. ; % eff : Row X is deleted from CODMAT. SetOccup ensures that row X is ; % disregarded until further notice. Although the Zstrt remains, ; % the weights of the corresponding columns are reset like the ; % Histogram info. ; % -------------------------------------------------------------------- ; <<delhisto(x); setoccup(x); foreach z in zstrt(x) do downwght(yind z,ival z)>>; symbolic procedure rowins x; % -------------------------------------------------------------------- ; % arg : Row(column)index X. ; % eff : Reverse of the Rowdel operations. ; % -------------------------------------------------------------------- ; <<setfree(x); inshisto(x); foreach z in zstrt(x) do upwght(yind z,ival z)>>; symbolic procedure downwght(x,iv); % -------------------------------------------------------------------- ; % arg : Row(column)index X. Value IV. ; % eff : The weight of row X is adapted because an element with value IV; % has been deleted. ; % -------------------------------------------------------------------- ; <<delhisto(x); downwght1(x,iv); inshisto(x)>>; symbolic procedure downwght1(x,iv); % -------------------------------------------------------------------- ; % eff : Weight values reset in accordance with defining rules given in; % COSYMP.RED and further argumented in CODOPT.RED. ; % -------------------------------------------------------------------- ; if not(!:onep dm!-abs(iv)) then setwght(x,((awght(x)-1).(mwght(x)-1)).(hwght(x)-4)) else setwght(x,((awght(x)-1).mwght(x)).(hwght(x)-1)); symbolic procedure upwght(x,iv); % -------------------------------------------------------------------- ; % arg : Row(column)index X. value IV. ; % eff : The weight of row X is adapted because an element with value IV; % is brought into the matrix. ; % -------------------------------------------------------------------- ; <<delhisto(x); upwght1(x,iv); inshisto(x)>>; symbolic procedure upwght1(x,iv); % -------------------------------------------------------------------- ; % eff : Functioning similar to Downwght1. ; % -------------------------------------------------------------------- ; if not(!:onep dm!-abs(iv)) then setwght(x,((awght(x)+1).(mwght(x)+1)).min(hwght(x)+4,histolen)) else setwght(x,((awght(x)+1).mwght(x)).min(hwght(x)+1,histolen)); symbolic procedure initwght(x); % -------------------------------------------------------------------- ; % arg : Row(column)index X. ; % eff : The weight of row(column) X is initialized. ; % -------------------------------------------------------------------- ; begin scalar an,mn; an:=mn:=0; foreach z in zstrt(x) do if free(xind z) then << if not(!:onep dm!-abs(ival z)) then mn:=mn+1; an:=an+1>>; setwght(x,(an.mn).(an+3*mn)); end; symbolic procedure remzzzz(zz1,zz2); % -------------------------------------------------------------------- ; % arg : Zstrt ZZ1 and ZZ2, where ZZ1 is a part of ZZ2. ; % res : All elements of ZZ2, without the elements of ZZ2. ; % -------------------------------------------------------------------- ; if null(zz1) then zz2 else if yind(car zz1)=yind(car zz2) then remzzzz(cdr zz1,cdr zz2) else car(zz2).remzzzz(zz1,cdr zz2); symbolic procedure chdel(fa,x); % -------------------------------------------------------------------- ; % arg : Father Fa of child X. ; % eff : Child X is removed from the Chrow of Fa. ; % -------------------------------------------------------------------- ; setchrow(fa,delete(x,chrow fa)); symbolic procedure delyzz(y,zz); % -------------------------------------------------------------------- ; % arg : Column(row)index Y. Zstrt ZZ. ; % res : Zstrt without the element corresponding with Y. ; % -------------------------------------------------------------------- ; if y=yind(car zz) then cdr(zz) else car(zz).delyzz(y,cdr zz); symbolic procedure clearrow(x); % -------------------------------------------------------------------- ; % arg : Rowindex X. ; % eff : Row X is cleared. This can be recognized since the father is ; % set to -1. ; % -------------------------------------------------------------------- ; <<setzstrt(x,nil); if x>=0 then <<setchrow(x,nil); if not numberp(farvar x) then remprop(farvar x,'rowindex) >>; setwght(x,nil); setfarvar(x,-1) >>; % -------------------------------------------------------------------- ; % PART 2 : PROCEDURES FOR THE CONSTRUCTION OF THE MATRIX CODMAT,i.e. ; % FOR INPUT PARSING ; % -------------------------------------------------------------------- ; % ; % ------ GENERAL STRATEGY ------ ; % REDUCE assignment statements of the form "Nex:=Expression" are trans-; % formed into pairs (Nex,Ex(= prefixform of the Expression)), using ; % GENTRAN-facilities.The assignment operator := defines a literal trans; % lation of both Nex and Ex. Replacing this operator by :=: results in; % translation of the simplified form of Ex. When taking ::=: or ::= the; % Nex is evaluated before translation, i.e. the subscripts occurring in; % Nex are evaluated before the translation is performed. ; % Once input reading is completed(i.e. when calling CALC) the data- ; % structures can and have to be completed (column info and the like) ; % using SSETVARS (called in OPTIMIZE (see CODCTL.RED)) before the CSE- ; % search actually starts. ; % ; % ------ PRESUMED EXPRESSION STRUCTURE ------ ; % Each expression is considered to be an (exponentiated) sum,a product ; % or something else and to consist of an (eventually empty) primitive ; % part and an (also eventually empty) composite part. The primitive ; % part of a sum is a linear combination of atoms(variables) and its ; % composite part consists of terms which are products or functions. The; % primitive part of a product is a monomial in atoms and its composite ; % part is formed by factors which are again expressions(Think of OFF ; % EXP).Primitive parts are stored in Zstrts as lists of pairs (RCindex.; % COFEXP). Composite parts are stored in and via Chrows. ; % The RCindex denotes a Row(Column)index in CODMAT if the Zstrt defines; % a column(row). Rows describe primitive parts. Due to the assumption ; % that the commutative law holds column information is not completely ; % available as long as input processing is not finished. ; % Conclusion : Zstrts cannot be completed (by SSETVARS in CALC or in ; % HUGE (see CODCTL.RED)) before input processing is completed,i.e.tools; % to temporarily store Zstrt info are required. They consist of certain; % lists,which are built up during parsing, being : ; % The identifiers Varlst!+, Varlst!* and Kvarlst play a double role. ; % They are used as indicators in certain propertylists and also as glo-; % bal variables carrying information during parsing and optimization. ; % To distinguish between these two roles we quote the indicator name ; % in the comment given below. ; % -- Varlst!+ : A list of atoms occuring in primitive sum parts of the; % input expressions,i.e. variables used to construct the; % sum part of CODMAT. ; % -- 'Varlst!+ : The value of this indicator,associated with each atom ; % of Varlst!+, is a list of dotted pairs (X,IV),where X ; % is a rowindex and IV a coefficient,i.e.IV*atom occurs ; % as term of a primitive part of some input expression ; % defined by row X. ; % -- Varlst!* : Similar to Varlst!+ when replacing the word sum by mo-; % nomial and the word coefficient by exponent. ; % -- 'Varlst!* : The value of this indicator,occuring on the property ; % list of each element of Varlst!*, is a list of dotted; % pairs of the form (X.IV),where X is a rowindex and IV ; % an exponent,i.e. atom^IV occurs as factor in a mono- ; % mial,being a primitive (sub)product,defined through ; % row X. ; % Remark : Observe that it is possible that an atom possesses both ; % 'Varlst!+ and 'Varlst!*,i.e. plays a role in the + - and in the * - ; % part of CODMAT. ; % -- Kvarlst : A list of dotted pairs (var.F),where var is an identi-; % fier (system selected via FNEWSYM,if necessary) and ; % where F is a list of the form (Functionname . (First ; % argument ... Last argument)). The arguments are either; % atoms or composite,and in the latter case replaced by ; % a system selected identifier. This identifier is asso-; % ciated with the CODMAT-row which is used to define the; % composite argument. ; % Remark : Kvarlst is also used in CODPRI.RED to guaran-; % tee the F's to be printed in due time,i.e.directly ; % after all its composite arguments. ; % -- 'Kvarlst : This indicator is associated with each operator name ; % during input processing. Its value consists of a list ; % of pairs os the form (F.var). To avoid needless name- ; % selections this list if values is consulted whenever ; % necessary to see of an expression of the form F is ; % already associated with a system selected identifier. ; % As soon as input processing is completed the 'Kvarlst ; % values are removed. ; % -- Prevlst : This list is also constructed during input processing.; % It is a list of dotted pairs (Father.Child),where ; % Child is like Father a rowindex or a system selected ; % identifier name. Prevlst is employed,using SETPREV,to ; % store in the ORDR-field of CODMAT-rows relevant info ; % about the structure of the input expressions. During ; % the iterative CSE-search the ORDR-info is updated when; % ever necessary. ; % -- CodBexpl!*: A list consisting of CODMAT-row indices associated ; % with input expression toplevel(i.e. the FarVar-field ; % contains the expression name). ; % This list is used on output to obtain a correct input ; % reflection (see procedures MAKEPREFIXL and PRIRESULT ; % in CODCTL.RED). ; % ; % ------ PARSING PATHS and PROCEDURE CLASSIFICATION ------ ; % A prefix-form parsing is performed via FFVAR!!,FFVAR!* and FFVAR!+. ; % During parsing,entered via FFVAR!!, the procedure FVAROP is used to ; % analyse and transform functions( Operators in the REDUCE terminology); % and thus also to construct Kvarlst and Prevlst. FVAROP is indirectly ; % activated through the routines PVARLST!* and PVARLST!+, which assist ; % in preparing (')Varlst!* and (')Varlst!+,respectively. ; % FCOFTRM ,assisting in detecting prim.parts, is used in FFVAR!!2. ; % PPRINTF is used (in FFVAR!!) to obtain an input echo on the terminal ; % (when ON ACINFO, the default setting, holds). ; % RESTORECSEINFO serves to restore the CSE-info when combining the re- ; % sult of a previous session with the present one( see also CODCTL.RED); % SSETVARS,and thus SSETVARS1, serves to complete CODMAT once input ; % processing is finished. PREPMULTMAT is used to preprocess *-columns ; % if one of the exponents, occuring in it, is rational, i.e. when the ; % with this column corresponding indentifier has the flag Ratexp. ; % SETPREV is used for maintaining consistency in input expression orde-; % ring and thus for consequent information retrieval at a later stage, ; % such as during printing. ; % -------------------------------------------------------------------- ; global '(varlst!+ varlst!* kvarlst prevlst codbexl!* )$ fluid '(preprefixlist prefixlist); varlst!+:=varlst!*:=kvarlst:=nil; % -------------------------------------------------------------------- ; % ------ THE PREFIX FORM PARSING ------ ; % FFvar!! is the main procedure activating parsing. Besides some house-; % keeping,information is send to either FFvar!* (either a product (but ; % not a prim. term) or a 'EXPT-application) or FFvar!+(a sum or a ; % function application). ; % The parsing is based on the following Prefix-Form syntax: ; % -------------------------------------------------------------------- ; % This syntax needs some revision!!! ; % -------------------------------------------------------------------- ; % <expression> ::= <sumform>|<productform> ; % <sumform> ::= <sum>|('EXPT <sum> <exponent>) ; % <productform> ::= <product>| ; % ('TIMES <constant> <factor>)| ; % ('TIMES <constant> <list of factors>)| ; % ('MINUS <productform>) ; % <sum> ::= <term>|('PLUS.<list of terms>) ; % <list of terms> ::= (<term> <term>)|(<term> <list of terms>) ; % <term> ::= <primitive term>|<productform>|<sumform> ; % <primitive term> ::= <constant>|<variable>| ; % ('TIMES <constant> <variable>)| ; % <function application> ; % <product> ::= <factor>|('TIMES.<list of factors>) ; % <list of factors> ::= (<factor> <factor>)|(<factor> <list of ; % factors>); % <factor> ::= <primitive factor>|<sumform>|<productform>; % <primitive factor> ::= <variable>|('EXPT <variable> <exponent>)| ; % <function application> ; % <function application> ::= <function symbol>.<list of expressions> ; % <function symbol> ::= identifier, where identifier is not ; % in {'PLUS,'TIMES,'EXPT,'MINUS,'DIFFERENCE,; % 'SQRT,dmode!*}. ; % Obvious elements are sin,cos,tan,etc. ; % The function applications are further ; % analyzed in FvarOp. ; % <list of expressions> ::= (<expression>)|<expression>.<list of ; % expressions>; % <variable> ::= element of the set of variable names, ; % either delivered as input or produced by ; % the Optimizer when the need to introduce : % cse-names exists. This is done with the ; % procedure FNewSym(see CODCTL.RED) which is; % initiated either using the result of the ; % procedure INAME(see CODCTL.RED) or simply ; % by using GENSYM(). ; % <constant> ::= element of the set of integers ; % representable by REDUCE | domain element ; % <exponent> ::= element of the set of integer an rational ; % numbers representable by REDUCE. ; % -------------------------------------------------------------------- ; symbolic procedure ffvar!!(nex,ex,prefixlist); % -------------------------------------------------------------------- ; % arg : An expression Ex in Prefix-Form, and its associated name NEx. ; % eff : The expression Ex is added to the incidence matrix CODMAT. ; % Parsing is based on the above given syntax. ; % -------------------------------------------------------------------- ; begin scalar n, nnex, argtype, var, s; prefixlist:=cons(nex,ex).prefixlist; % if nex memq '(cses gsym) % deleted : binf no more used. JB 13/4/94 % then restorecseinfo(nex,ex) n:=rowmax:=rowmax+1; codbexl!*:=n.codbexl!*; if flagp(nex,'newsym) then put(nex,'rowindex,n); put(nex,'rowocc, list n); ffvar!!2(n,nex,remdiff ex); return prefixlist end; symbolic procedure restorecseinfo(nex,ex); % -------------------------------------------------------------------- ; % arg : Nex is an element of the set {CSES,GSYM,BINF} and Ex a corres- ; % pondig information carrier. ; % eff : RestoreCseInfo is called in FFvar!! when during input parsing ; % name Nex belongs to the above given set. In this case the input; % is coming from a file which is prepared during a previous run. ; % It contains all output from this previous run, preceded by ; % system prepared cse-info stored as value of the 4 system ; % variables CSES,GSYM and BINF (see the function SaveCseInfo in ; % CODCTL.RED for further information). ; % -------------------------------------------------------------------- ; begin scalar inb,nb,s; if nex eq 'cses then (if atom(ex) then flag(list ex,'newsym) else foreach el in cdr(ex) do flag(list el,'newsym)) % Ammendments to increase robustness: % More strict control over what cse-name is going to be used, % starting from which index. % This prevents scope from generating a cse twice, thus overwriting % earlier occurrences and introducing strange erronous output. % JB 13/4/94 else if eq(letterpart(ex),'g) then if eq((s:=letterpart fnewsym()),'g) then iname s else<< nb:=digitpart(ex); inb:=digitpart(fnewsym()); for j:=inb:nb do gensym() >> else if eq(letterpart(ex), letterpart(s:= fnewsym())) and digitpart(ex) > digitpart(s) then iname ex else iname s end; symbolic procedure remdiff f; % -------------------------------------------------------------------- ; % Replace all occurrences of (DIFFERENCE A B) in F for arbitrary A and ; % B by (PLUS A (MINUS B)). ; % -------------------------------------------------------------------- ; if idp(f) or constp(f) then f else << if car(f) eq 'difference then f:=list('plus,remdiff cadr f,list('minus,remdiff caddr f)) else car(f) . (foreach op in cdr(f) collect remdiff(op)) >>; symbolic procedure ffvar!!2(n, nex, ex); % -------------------------------------------------------------------- ; % Serviceroutine used in FFvar!!. ; % -------------------------------------------------------------------- ; if eqcar(ex, 'times) and not fcoftrm ex then setrow(n, 'times, nex, ffvar!*(cdr ex, n), nil) else if eqcar(ex, 'expt) and (integerp(caddr ex) or rationalexponent(ex)) then setrow(n, 'times, nex, ffvar!*(list ex, n), nil) else setrow(n, 'plus, nex, ffvar!+(list ex, n), nil); symbolic procedure fcoftrm f; % -------------------------------------------------------------------- ; % arg : A prefix form F. ; % res : T if F is a (simple) term with an integer coefficient, NIL ; % otherwise. ; % -------------------------------------------------------------------- ; (null(cdddr f) and cddr f) and (constp(cadr f) and not (pairp(caddr f) and caaddr(f) memq '(expt times plus difference minus))); symbolic procedure rationalexponent(f); % -------------------------------------------------------------------- ; % arg : F is an atom or a prefixform. ; % res : T if F is an 'EXPT with a rational exponent. ; % -------------------------------------------------------------------- ; rationalp caddr f; %(pairp caddr f) and (caaddr f eq 'quotient) and (integerp(cadr caddr f) % and integerp(caddr caddr f)); symbolic procedure rationalp f; eqcar(f,'quotient) and integerp(cadr f) and integerp(caddr f); symbolic procedure ffvar!+(f,ri); % -------------------------------------------------------------------- ; % arg : F is a list of terms,i.e. th sum SF='PLUS.F is parsed. Info ; % storage starts in row RI resulting in ; % res : a list (CH) formed by all the indices of rows where the descrip; % tion of children(composite terms) starts. As a by product(via ; % eff : PVARLST!+) the required Zstrt info is made. ; % N.B.: Possible forms for the terms of SF( the elements of F) are: ; % -a sum - which is recursively managed after minus-symbol ; % distribution. ; % -a product - of the form constant*atom : which is as term of a ; % prim. sum treated by PVARLST!+. ; % of another form : which is managed via FFVAR!*. ; % -a constant ; % power - of a product of atoms : is transformed into a prim; % product and then treated as such. ; % of something else : is always parsed via FFVAR!*. ; % -a function- application is managed via PVARLST!+,i.e. via ; % FVAROP with additional Varlst!+ storage of system ; % selected subexpression names. ; % -------------------------------------------------------------------- ; begin scalar ch,n,s,b,s1,nn; foreach trm in f do <<b:=s:=nil; while pairp(trm) and (s:=car trm) eq 'minus do <<trm:=cadr trm; b:=not b>>; if s eq 'difference then <<trm:=list('plus,cadr trm,list('minus,caddr trm)); s:='plus>>; if s eq 'plus then <<s1:=ffvar!+(if b then foreach el in cdr(trm) collect list('minus,el) else cdr trm,ri); ch:=append(ch,car s1)>> else if s eq 'times then <<% ------------------------------------------------------------ ; % Trm is a <productform>, which might have the form ; % ('TIMES <constant> <function application>). Here the ; % <function application> can be ('SQRT <expression>) , i.e. has; % to be changed into : ; % ('TIMES <constant> ('EXPT <expression> ('QUOTIENT 1 2))) ; % ------------------------------------------------------------ ; if pairp caddr trm and caaddr trm eq 'sqrt and null cdddr trm then trm := list('times,cadr trm,list('expt,cadr caddr trm, list('quotient,1,2))); if fcoftrm trm % ---------------------------------------------------------- ; % Trm is ('TIMES <constant> <variable>) ; % ---------------------------------------------------------- ; then pvarlst!+(caddr trm,ri,if b then dm!-minus(cadr trm) else cadr trm) else % ---------------------------------------------------------- ; % Trm is a <productform> ; % ---------------------------------------------------------- ; <<n:=rowmax:=rowmax+1; s1:=ffvar!*(cdr trm,n); if b then setrow(n,'times,ri,list(car s1,dm!-minus cadr s1),nil) else setrow(n,'times,ri,s1,nil); ch:=n.ch>> >> else <<if s eq 'sqrt then % ---------------------------------------------------------- ; % Trm is a <primitive term> which is a <function application>; % which is ('SQRT <expression>) which is of course ; % ('EXPT <expression> <exponent>) ; % ---------------------------------------------------------- ; <<trm := cons('expt,cons(cadr trm,list list('quotient,1,2))); s := 'expt >>; if s eq 'expt and eqcar(caddr trm,'minus) and (integerp(cadr caddr trm) or rationalp(cadr caddr trm)) then << trm:=list('quotient,1,list('expt,cadr trm,cadr caddr trm)); s:='quotient >>; if s eq 'expt and (integerp(caddr trm) or rationalexponent(trm)) then <<n:=rowmax:=rowmax+1; s1:=ffvar!*(list trm,n); if b then setrow(n,'times,ri,list(car s1,-1),nil) else setrow(n,'times,ri,s1,nil); ch:=n.ch >> else pvarlst!+(trm,ri,if b then -1 else 1) >>; >>; return list(ch) end; symbolic procedure pvarlst!+(var,x,iv); % -------------------------------------------------------------------- ; % arg : Var is one of the first 2 alternatives for a kernel,i.e. a vari; % able or an operator with a simplified list of arguments (like ; % sin(x)) with a coefficient IV,belonging to a Zstrt which will ; % be stored in row X. ; % eff : If the variable happens to be a constant a special internal var; % !+ONE is introduced to assist in defining the constant contribu; % tions to primitive sumparts in accordance with the chosen data-; % structures. ; % When Var is an operator(etc.) Fvarop is used for a further ana-; % lysis and a system selected name for var is returned. Then this; % name,!+ONE or the variable name Var are used to eventually ; % extend Varlst!+ with a new name.The pair (rowindex.coeff.value); % is stored on the property list of this var as pair of the list ; % 'Varlst!+,which is used in SSETVARS1 to built the Zstrts associ; % ated with this variable. ; % -------------------------------------------------------------------- ; begin scalar l,s,nvar; if constp var then <<iv:=dm!-times(iv,var); var:='!+one>>; if not (idp(var) or constp(var)) then var:=fvarop(var,x); if null(s:=get(var,'varlst!+)) then varlst!+:=var.varlst!+; put(var,'varlst!+,(x.iv).s) end; symbolic procedure ffvar!*(f,ri); % -------------------------------------------------------------------- ; % arg : F is a list of factors,i.e. the product PF='TIMES.F is parsed. ; % Info storage starts in row RI,resulting in ; % res : a list (CH COF),where CH is a list of all the indices of rows ; % where the description of children of PF(composite factors) ; % eff : starts. As a by product(via the procedure PVARLST!*) Zstrt info; % is made. ; % N.B.: Possible forms for the factors of PF( the elements of F) are: ; % -a constant- contributing as factor to COF. ; % -a variable- contributing as factor to a prim.product,stored in; % a Zstrt(via SSETVARS) after initial management via; % PVARLST!* and storage in Varlst!* and 'Varlst!*'s.; % -a product - Recursively managed via FFVAR!*,implying that CH:=; % Append(CH,latest version created via FFVAR!* and ; % denoted by Car S). ; % -a sum - (or difference or negation) contributing as comp. ; % factor and demanding a subexpression row N to ; % start its description. Storage management is done ; % via FFVAR!+,implying that CH:=N.CH. ; % -a power - of the form sum^integer : and managed like a sum. ; % of the form atom^integer: and managed like single ; % atom as part of a prim. product. ; % -a function- application,which is managed via PVARLST!*,i.e.via; % FVAROP with additional Varlst!* storage of system ; % selected subexpression names. ; % -------------------------------------------------------------------- ; begin scalar cof,ch,n,s,b,rownr,pr,nr,dm; cof:=1; foreach fac in f do if constp fac then cof:=dm!-times(fac,cof) else if atom fac then pvarlst!*(fac,ri,1) else if (s:=car fac) eq 'times then <<s:=ffvar!*(cdr fac,ri); ch:=append(ch,car s); cof:=dm!-times(cof,cadr(s)) >> else if s memq '(plus difference minus) then << if s eq 'minus and constp(cadr fac) and null cddr fac then cof:=dm!-minus dm!-times(cof,cadr(fac)) else <<n:=rowmax:=rowmax+1; if (not b) then <<b:=t; rownr:=n>>; setrow(n,'plus,ri,ffvar!+(list fac,n),nil); ch:=n.ch >> >> else <<if s eq 'sqrt then % -------------------------------------------------------- ; % The primitive factor is a <function application>. In this; % case a ('SQRT <expression>) which is of course ; % ('EXPT <expression> ('QUOTIENT 1 2)). ; % -------------------------------------------------------- ; <<fac:=cons('expt,cons(cadr fac,list list('quotient,1,2))); s:='expt >>; if s eq 'expt and eqcar(caddr fac,'minus) and (integerp(cadr caddr fac) or rationalp(cadr caddr fac)) then <<fac:=list('quotient,1, list('expt,cadr fac,cadr caddr fac)); s:='quotient >>; if s eq 'expt and (integerp(caddr fac) or (nr:=rationalexponent(fac))) then % --------------------------------------------------- ; % Fac = (EXPT <expression or variable> ; % <integer or rational number>) ; % --------------------------------------------------- ; (if pairp(cadr fac) and caadr(fac) eq 'sqrt then << if nr then <<nr:=cadr caddr fac; dm:=2*(caddr caddr fac)>> else <<nr:=1; dm:=2>>; pvarlst!*(cadr cadr fac,ri,cons(nr,dm)) >> else pvarlst!*(cadr fac,ri, if integerp(caddr fac) then caddr fac else (cadr caddr fac . caddr caddr fac))) else pvarlst!*(fac,ri,1) >>; if b and not(!:onep dm!-abs(cof)) then % ---------------------------------------------------------------- ; % The product Cof*....*(c1*a+....+cn*z) is replaced by ; % the product ....*({Cof*c1}*a+...+{Cof*cn}*z), assuming Cof, c1,..; % ..,cn are numerical constants. ; % ---------------------------------------------------------------- ; << foreach el in chrow(rownr) do setexpcof(el,dm!-times(cof,expcof(el))); foreach var in varlst!+ do if (pr:=assoc(rownr,get(var,'varlst!+))) then rplacd(pr,dm!-times(cdr(pr),cof)); cof:=1; >>; return list(ch,cof) end; symbolic procedure pvarlst!*(var,x,iv); % -------------------------------------------------------------------- ; % eff : Similar to Pvarlst!+. ; % : The flag Ratexp is associated with Var if one of its exponents; % is rational. This flag is used in the function PrepMultMat. ; % -------------------------------------------------------------------- ; begin scalar l,s,bvar,bval; if constp(var) then << var:=fvarop(if iv='(1 . 2) then list('sqrt,var) else list('expt,var, if pairp iv then list('quotient,car iv,cdr iv) else iv),x); iv:=1 >>; if not(atom(var) or constp(var)) then << s:=get('!*bases!*,'kvarlst); if s then bvar:=assoc(bval:=reval var,s); if bvar then var:=cdr bvar else << var:=fvarop(var,x); put('!*bases!*,'kvarlst,(bval.var).s) >> >>; if null(s:=get(var,'varlst!*)) then varlst!*:=var.varlst!*; if pairp(iv) and not(constp iv) then flag(list(var),'ratexp); put(var,'varlst!*,(x.iv).s) end; symbolic procedure fvarop(f,x); % ------------------------------------------------------------------- ; % arg : F is a prefixform, being <operator>.<list of arguments>. X is ; % the index of the CODMAT row where the description of F has to ; % start. ; % ------------------------------------------------------------------- ; begin scalar svp,varf,valf,n,fargl,s,b; if eqcar(f,'sqrt) and not(constp(cadr f)) then f:=list('expt,cadr f,list('quotient,1,2)); b:=(not (car f memq '(plus minus times expt))) or (car(f) eq 'expt and (not (numberp(caddr f) or rationalexponent(f)) or ((cadr(f) eq 'e) or constp(cadr(f))))); svp:=subscriptedvarp car f; s:=get(car f, 'kvarlst); %------------------------------------------------------------ % b tells us whether f is a regular function (NIL) or % not (T). So b=T for everything but ye ordinary expressions. % We've got to check whether we deal with an array variable % and if so, whether there is a valid cse-name for this % variable. % We also want to recognize a valid index-expression, for % wich `not b' holds. %------------------------------------------------------------ varf := if svp then assoc(ireval(f),s) else assoc(f,s); if (varf and svp) or (b and varf and allconst(cdr f, cdr varf)) %--------------------------------------------------------- % This condition states that in order to allow the current % and a previous expression to be regarded as equal, the % expression should denote a subscripted variable, or a % use of an function with constant parameters, i.e. % numerical parameters. %--------------------------------------------------------- then varf:=cdr varf else << varf:=fnewsym(); put(car f,'kvarlst,((if svp then ireval f else f).varf).s); if not b then << put(varf,'rowindex,n:=rowmax:=rowmax+1); if not(eqcar(f,'expt) and rationalexponent(f) or flagp(cadr f,'ratexp)) then prevlst:=(x.n).prevlst; ffvar!!2(n,varf,f) >> else << if not (!*vectorc and svp) then << foreach arg in cdr(f) do if not(constp(arg) or atom(arg)) then fargl:=fvarop(if svp then reval arg else arg,x).fargl else fargl:=arg.fargl; f:=car(f).reverse(fargl); >>; kvarlst:=(varf.f).kvarlst >> >>; prevlst:=(x.varf).prevlst; return varf end; symbolic procedure allconst (l,f); not (nil member foreach el in l collect jbconstp (el,f)); symbolic procedure jbconstp (item,ref); if constp item then % some numerical value T else if atom item then % some id if get(item,'rowocc) then % item parsed as lefthandside. if (car(get(item,'rowocc))< findvardef(ref)) then % This use and the previous are in the % scope of one definition of item. T else % This use and the previous are in % scopes of diferent definitions of % item. NIL else % some input id used twice ore more on rhs. T else not(NIL member foreach el in cdr item collect jbconstp(el,ref)); symbolic procedure findvardef v; begin scalar r,vp,vt; r:=get(v,'rowocc); vt:=get(v,'varlst!*); vp:=get(v,'varlst!+); if r then r:= car r else if vt then if vp then if ((vt := caar reverse vt) > (vp := caar reverse vp)) then r:= vt else r:= vp else r:= caar reverse vt else r:= caar reverse vp; return r; end; symbolic procedure ssetvars(preprefixlist); % -------------------------------------------------------------------- ; % eff : The information stored on the property lists of the elements of; % the lists Varlst!+ and Varlst!* is stored in the matrix CODMAT,; % i.e.the Z-streets are produced via the SSetvars1 calls. ; % Before doing so PrepMultMat is used to modify, if necessary,the; % Varlst!* information by incorporating information about ratio- ; % nal exponents. ; % Furthermore the elements of Prevlst are used to store the hier-; % archy information in the ORDR-fields in the matrix CODMAT. In ; % addition some bookkeeping activities are performed: Needless ; % information is removed from property lists and not longer need-; % ed lists are cleared. EndMat is also initialized. ; % -------------------------------------------------------------------- ; << preprefixlist:=prepmultmat(preprefixlist); %-------------------------------------------------------------------- % From now on preprefixlist has the following structure : % % ((var1 aliases )(var2 aliases )...) % %-------------------------------------------------------------------- ssetvars1('varlst!+,'plus); ssetvars1('varlst!*,'times); varlst!+:=varlst!*:=nil; foreach el in reverse(prevlst) do setprev(car el,cdr el); foreach el in kvarlst do remprop(cadr el,'kvarlst); foreach el in '(plus minus difference times sqrt expt) do remprop(el,'kvarlst); remprop('!*bases!*,'kvarlst); endmat:=rowmax; preprefixlist >>; symbolic procedure revise2 (f,d); begin scalar res; if atom f then if constp f then return f else if get(f,'aliaslist) then return get(f,'finalalias) else << if not(member(f,known)) then known:=f . known; return f; >> else if not constp f then % car f is operator or indexed var if subscriptedvarp car f then % We have to search d to rewrite f. % Then we check `known' for an alias. if get(car f,'aliaslist) then <<f:= car f . foreach el in cdr ireval f collect revise2 (el,d); if (res:=assoc(f,get(car f,'finalalias))) then return cadr res else if !*vectorc then % rhs-alias introduction. <<rhsaliases := (introduce!-alias f . f) . rhsaliases; return caar rhsaliases>> else return f >> else if !*vectorc then % rhs-alias introduction. <<rhsaliases := (introduce!-alias f . f) . rhsaliases; return caar rhsaliases>> else return f else if res:=assoc(f,d) then return cadr res else return car f . foreach el in cdr f collect revise2 (el,d) else return f; end; symbolic procedure revise (f,d); car f . (cadr f . foreach l in cddr f collect revise2 (l,d)); symbolic procedure preremdep forms; %---------------------------------------------------------------------- % We remove dependencies and indexed variables in forms by introducing % aliases. % ABOUT ALIASES. % % In search for common subexpressions, scope does not, ironically, % bother for rules of scope. This means that : % % a:=x+y % .. % a:=cos(x) % z:=x+y % % is going to be optimized into: % % a:=x+y, % .. % a:=cos(x), % z:=a. % % We solve this anomaly by replacing every occurrence of `a', starting % from the second definition, by a generated name; so % % a := ... % := ... a ... % a := ... a ... % a := ... % := ... a ... % % becomes : % % a := ... % := ... a ... % a1:= ... a ... % a2:= ... % := ... a2 ... % % This prevents scope from finding c.s.e.'s where there aren't any. At % the end of the optimization process, these aliases are backsubstitu- % ted, with their original values, (provided these are atomic!) % Secondly the aliasmechanism is usefull in the storage process: % When dealing with nonatomic, i.e. subscripted variables, problems % arise in storing these variables in codmat, and putting all kind of % info as properties on them. A variable is subscripted when declared % as such by the option `declare' or `vectorcode', or when encountered % as lhs of an assignment. % We alias subscripted variables by an atomic, generated variable: % % a(i) := ... % ... := ... a(i) ... % % becomes: % % g1 := ... % ... := ... g1 ... % % When the indexexpressions are not atomic, i.e. they could be or con- % tain c.s.e.'s, we put an assignment right in front of their first % use (when the switch VECTORC is off!!!): % % a(x+y):= ... % ... := ... a(x+y) ... % % becomes: % % g0 := x+y % g1 := ... % ... := ... g1 ... % % We only backsubstitute the output-definition of a sub'ted variable, % i.e. the last definition, thus saving some memorymanagementoverhead. % Atomic originals are all backsubstituted, for economy in allocation % of variables. % % TECHNICAL DETAILS ALIASMECHANISM % % Aliasing is performed by a double linking mechanism: % The original has properties `aliaslist'(a list of all aliases for % this variable) and `finalalias' (the alias to be used in the current % or final scope). % % Original ------[finalalias]--------> Aliasxx % | <-----[alias ]---------/ ^ % | | % [aliaslist] | % | | % *------------------------------------/ % | % *-------------------------------> Aliasyy % | . % . . % | . % *-------------------------------> Aliaszz % % All aliases of the original are linked to the original by their % property `alias' with value Original. (This is left out of above pic. % for Aliasyy .. Aliaszz.) % Finally, all generated assignments, stemming from indexexpressions, % have the property `inalias', which links them to the variable they % arose from. This property can be updated during optimization, or even % be copied onto other variables, due to finding of c.s.e.'s. % % Generated Assignment: % Aliasxx := indexexpression. % | % [ inalias ] % | % V % Original: <----[alias]---Aliasyy % A(.., Aliasxx, ..) % % All variables generated in the aliasing process obtain a flag % `aliasnewsym'. % All aliasinfo is removed after the optimization process. %---------------------------------------------------------------------- begin scalar defs,var,alias,res,currall; known:=nil; foreach f in forms do <<if !*inputc then pprintf(caddr f,cadr f); if !*complex then f := remcomplex f; if not(cadr f member '(cses gsym)) then if car f member '(equal setq) then << f:=revise(f,defs); if atom(var:=cadr f) then <<if member(var,known) then % This is a redefinition. % Introduce an alias << alias:=introduce!-alias var; rplaca(cdr f,alias); %remflag(list alias,'newsym); >> else known:= var . known; res:=f . res; >> else if !*vectorc or flagp(car var, 'vectorvar) then % Switch vectorc is set,or this is just % `vectorcode-marked' variable. % No further analization of var needed. % For output purposes we apply remdiff to % the subscripts. % Then just introduce aliases. <<flag(list car var,'subscripted); var :=(car var). foreach idx in cdr var collect remdiff idx; alias:=introduce!-alias var; rplaca(cdr f,alias); res:= f . res; >> else % Introduce cse's for the non-atomic % index-expressions, % prepend this to current assignment and % introduce its alias. <<flag(list car var, 'subscripted); var:= car var . foreach ie in cdr var collect if not atom ie then<<if assoc((ie:=ireval ie),defs) then alias:= cadr assoc(ie,defs) else <<alias:=fnewsym(); res:= list('setq,alias,ie) . res; defs:=list(ie,alias) . defs; currall:= alias . currall; flag(list alias,'aliasnewsym); %remflag(list alias,'newsym); >>; alias >> else ie; alias:=introduce!-alias ireval var; foreach a in currall do put(a,'inalias, alias . get(a,'inalias)); rplaca(cdr f,alias); res:= f . res; >> >> else res:= f . res else restorecseinfo(cadr forms, caddr forms) >>; restoreall; return reverse res; end; symbolic procedure introduce!-alias var; % Introduce an alias for var; begin scalar alias,v2; alias:=fnewsym(); remflag(list alias,'newsym); flag(list alias, 'aliasnewsym); v2:= if atom var then var else car var; put(v2,'aliaslist, alias . get(v2,'aliaslist)); if atom var then put(var,'finalalias,alias) else %----------------------------------------------------------- % An subscripted var can have a finalalias for several % entries. %----------------------------------------------------------- put(v2,'finalalias, list(var,alias) . delete(assoc(var, get(v2,'finalalias)), get(v2,'finalalias))); put(alias,'alias,var); known:=alias . known; return alias; end; symbolic procedure ssetvars1(varlst,opv); % -------------------------------------------------------------------- ; % eff : Zstrt's are completed via a double loop and association of ; % column indices(if necessary for both the + and the * part of ; % CODMAT) with the var's via storage on the var property lists. ; % -------------------------------------------------------------------- ; begin scalar z,zz,zzel; %foreach var in lispeval(varlst) do foreach var in eval(varlst) do <<zz:=nil; rowmin:=rowmin-1; foreach el in get(var,varlst) do <<z:=mkzel(rowmin,cdr el); if null(zzel:=zstrt car el) or not(xind(car zzel)=rowmin) % To deal with X*X OR X+X; then setzstrt(car el,z.zzel); zz:=inszzz(mkzel(car el,val z),zz) >>; put(var,varlst,rowmin); % Save column index for later use; setrow(rowmin,opv,var,nil,zz) >>; end; symbolic procedure prepmultmat(preprefixlist); % -------------------------------------------------------------------- ; % eff : The information concerning rational exponents and stored in the; % Varlst!* lists is used to produce exact integer exponents,to be; % stored in the Z-streets of the matrix Codmat: ; % For all elements in Varlst!* the Least Common Multiplier (LCM) ; % of their exponent-denominators is computed. ; % If LCM > 1 the element has a rational exponent. The exponent of; % each element is re-calculated to obtain LCM * the orig. exp. ; % Modulo LCM arithmetic is used to spread information over 2 ; % varlst!*'s, one for the original var(iable) and another for the; % fraction-part left. ; % Renaming is adequately introduced when necessary. ; % -------------------------------------------------------------------- ; begin scalar tlcm,var,varexp,kvl,kfound,pvl,pfound,tel,ratval,ratlst, newvarlst,hvarlst; hvarlst:= nil; while not null (varlst!*) do <<var := car varlst!*; varlst!* := cdr varlst!*; if flagp(var,'ratexp) then <<tlcm:=1; remflag(list var,'ratexp); foreach elem in get(var,'varlst!*) do if pairp cdr elem then tlcm := lcm2(tlcm,cddr elem); varexp:=fnewsym(); tel:=(varexp.(if tlcm = 2 then list('sqrt,var) else list('expt,var, if onep cdr(tel:=simpquot list(1,tlcm)) then car tel else list('quotient,car tel,cdr tel)))); if assoc(var,kvarlst) then <<kvl:=kfound:=nil; while kvarlst and not(kfound) do if caar(kvarlst) eq var then << kvl:=tel.kvl; kfound:=t; pvl:=pfound:=nil; prevlst:=reverse(prevlst); while prevlst and not(pfound) do if cdar(prevlst) eq var then << pvl:=cons(caar prevlst,varexp).pvl; pfound:=t >> else << pvl:=car(prevlst).pvl; prevlst:=cdr(prevlst) >>; if pvl then if prevlst then prevlst:=append(reverse prevlst,pvl) else prevlst:=pvl >> else << kvl:=car(kvarlst).kvl; kvarlst:=cdr kvarlst>>; if kvl then if kvarlst then kvarlst:=append(reverse kvl,kvarlst) else kvarlst:=reverse kvl >> else preprefixlist:=tel.preprefixlist; ratlst:=newvarlst:=nil; foreach elem in get(var,'varlst!*) do if pairp cdr elem then << ratval:=divide((tlcm * cadr elem)/(cddr elem),tlcm); ratlst:=cons(car elem,cdr ratval).ratlst; if car(ratval)>0 then newvarlst:=cons(car elem,car ratval).newvarlst >> else newvarlst:=elem.newvarlst; if ratlst then << put(varexp,'varlst!*,reverse ratlst); hvarlst:=varexp.hvarlst >>; if newvarlst then << put(var,'varlst!*,reverse newvarlst); hvarlst:=var.hvarlst >> else remprop(var,'varlst!*) >> else hvarlst:=var.hvarlst >>; varlst!* := hvarlst; return preprefixlist end; symbolic procedure lcm2(a,b); % --- % Switch rounded off before calling lcm. % lcm doesn't seem to work in rounded mode % for lcm % --- begin scalar g, res; g := gcd2(a,b); res := a*b; return res/g; end; % -------------------------------------------------------------------- ; % ORDERING OF (SUB)EXPRESSIONS : ; % -------------------------------------------------------------------- ; % It is based op the presumption that the ordering of the input expres-; % sions has to remain unchanged when attempting to optimize their des- ; % cription. This ordering is stored in the list CodBexl!* via FFVAR ; % and used in the procedure MAKEPREFIXL( via PRIRESULT and also given ; % in CODCTL.RED) for managing output. Hence any subexpression found by ; % whatever means has to be inserted in the latest version of the ; % description of the set ahead of the first expression in which it ; % occurs and assuming its occurences are replaced by a system selected ; % name which is also used as subexpression recognizer(i.e., as assigned; % var). We distinguish between different types of subexpressions: ; % Some are directly recognizable : sin(x),a(1,1) and the like. Others ; % need optimizer searches to be found: sin(a+2*b),f(a,c,d+g(a)),etc. ; % Via FVAROP an expression like sin(x) is replaced by a system selected; % name(g001,for instance),the pair (g001.sin(x)) is added to the ; % Kvarlst, the pair (sin(x).g001) is added to the 'Kvarlst of sin,thus ; % allowing a test to be able to uniquely use the name g001 for sin(x). ; % Finally the pair (rowindex of father of this occurence of sin(x) . ; % g001) is added to Prevlst. However if the argument of a sin applica- ; % tion is not directly recognizable(a*b+a*c or a*(b+c),etc) the argu- ; % ment is replaced by a system selected name(g002,for instance),which ; % then needs incorporation in the administration. This is also done in ; % FVAROP: The index of the CODMAT-row used to start the description of ; % this argument is stored on the property list of g002 as value of the ; % indicator Rowindex and the Prevlist is now extended with the pair ; % (father indx. g002 indx).When storing nested expressions in CODMAT ; % the father-child relations based on interchanges of + and * symbols ; % are treated in a similar way.So the Prevlst consists of two types of ; % pairs: (row number.row number) and (row number.subexpression name). ; % The CODMAT-row, where the description of this subexpression starts ; % can be found on the property list of the subexpression name as value ; % of the indicator Rowindex. All function applications are stored uni- ; % quely in Kvarlst. This list is consulted in CODPRI.RED when construc-; % ting PREFIXLIST,which represents the result as a list of dotted pairs; % of the form ((sub)expr.name . (sub)expr.value) as to guarantee a cor-; % rect insertion of the function appl.,i.e. directly ahead of the first; % (sub)expr. it is part of.After inserting the pair (subexpression name; % . function application) the corresponding description is removed from; % the Kvarlst,thus avoiding a multiple insertion. This demands for a ; % tool to know when to consult the Kvarlst.This is provided by the ORDR; % field of the CODMAT-rows.It contains a list of row indices and func- ; % tion application recognizers, which is recursively built up when ; % searching for subexpressions,after its initialization in SSETVARS, ; % using the subexpression recognizers introduced during parsing. ; % -------------------------------------------------------------------- ; symbolic procedure setprev(x,y); % -------------------------------------------------------------------- ; % arg : Both X and Y are rowindices. ; % eff : Y is the index of a row where the description of a subexpr. ; % starts. If X is the index of the row where the description of a; % toplevel expression starts( an input expression recognizable by; % the father-field Farvar) Y is put on top of the list of indices; % of subexpressions which have to be printed ahead of this top- ; % level expression.Otherwise we continue searching for this top- ; % level father via a recursive call of SetPrev. ; % -------------------------------------------------------------------- ; if numberp(farvar x) then setprev(farvar x,y) else setordr(x,y.ordr(x)); endmodule; end;