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(pvl,reverse prevlst)
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;