\documentclass{article} \usepackage{axiom} \begin{document} \title{\$SPAD/src/interp i-analy.boot} \author{The Axiom Team} \maketitle \begin{abstract} \end{abstract} \eject \tableofcontents \eject \section{License} <>= -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical ALgorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. @ <<*>>= <> import '"i-object" )package "BOOT" --% Interpreter Analysis Functions getMinimalVariableTower(var,t) == -- gets the minimal polynomial subtower of t that contains the -- given variable. Returns NIL if none. STRINGP(t) or IDENTP(t) => NIL t = $Symbol => t t is ['Variable,u] => (u = var) => t NIL t is ['Polynomial,.] => t t is ['RationalFunction,D] => ['Polynomial,D] t is [up,t',u,.] and MEMQ(up,$univariateDomains) => -- power series have one more arg and different ordering u = var => t getMinimalVariableTower(var,t') t is [up,u,t'] and MEMQ(up,$univariateDomains) => u = var => t getMinimalVariableTower(var,t') t is [mp,u,t'] and MEMQ(mp,$multivariateDomains) => var in u => t getMinimalVariableTower(var,t') null (t' := underDomainOf t) => NIL getMinimalVariableTower(var,t') getMinimalVarMode(id,m) == -- This function finds the minimum polynomial subtower type of the -- polynomial domain tower m which id to which can be coerced -- It includes all polys above the found level if they are -- contiguous. -- E.g.: x and G P[y] P[x] I ---> P[y] P[x] I -- x and P[y] G P[x] I ---> P[x] I m is ['Mapping, :.] => m defaultMode := $Symbol null m => defaultMode (vl := polyVarlist m) and ((id in vl) or 'all in vl) => SUBSTQ('(Integer),$EmptyMode,m) (um := underDomainOf m) => getMinimalVarMode(id,um) defaultMode polyVarlist m == -- If m is a polynomial type this function returns a list of its -- top level variables, and nil otherwise -- ignore any QuotientFields that may separate poly types m is [=$QuotientField,op] => polyVarlist op m is [op,a,:.] => op in '(UnivariateTaylorSeries UnivariateLaurentSeries UnivariatePuiseuxSeries) => [., ., a, :.] := m a := removeQuote a [a] op in '(Polynomial RationalFunction Expression) => '(all) a := removeQuote a op in '(UnivariatePolynomial) => [a] op in $multivariateDomains => a nil --% Pushing Down Target Information pushDownTargetInfo(op,target,arglist) == -- put target info on args for certain operations target = $OutputForm => NIL target = $Any => NIL n := LENGTH arglist pushDownOnArithmeticVariables(op,target,arglist) (pdArgs := pushDownOp?(op,n)) => for i in pdArgs repeat x := arglist.i if not getTarget(x) then putTarget(x,target) nargs := #arglist 1 = nargs => (op = 'SEGMENT) and (target is ['UniversalSegment,S]) => for x in arglist repeat if not getTarget(x) then putTarget(x,S) 2 = nargs => op = "*" => -- only push down on 1st arg if not immed if not getTarget CADR arglist then putTarget(CADR arglist,target) getTarget(x := CAR arglist) => NIL if getUnname(x) ^= $immediateDataSymbol then putTarget(x,target) op = "**" or op = "^" => -- push down on base if not getTarget CAR arglist then putTarget(CAR arglist,target) (op = 'equation) and (target is ['Equation,S]) => for x in arglist repeat if not getTarget(x) then putTarget(x,S) (op = 'gauss) and (target is ['Gaussian,S]) => for x in arglist repeat if not getTarget(x) then putTarget(x,S) (op = '_/) => targ := target is ['Fraction,S] => S target for x in arglist repeat if not getTarget(x) then putTarget(x,targ) (op = 'SEGMENT) and (target is ['Segment,S]) => for x in arglist repeat if not getTarget(x) then putTarget(x,S) (op = 'SEGMENT) and (target is ['UniversalSegment,S]) => for x in arglist repeat if not getTarget(x) then putTarget(x,S) NIL NIL pushDownOnArithmeticVariables(op,target,arglist) == -- tries to push appropriate target information onto variable -- occurring in arithmetic expressions PAIRP(target) and CAR(target) = 'Variable => NIL not MEMQ(op,'(_+ _- _* _*_* _/)) => NIL not containsPolynomial(target) => NIL for x in arglist for i in 1.. repeat VECP(x) => -- leaf transferPropsToNode(xn := getUnname(x),x) getValue(x) or (xn = $immediateDataSymbol) => NIL t := getMinimalVariableTower(xn,target) or target if not getTarget(x) then putTarget(x,t) PAIRP(x) => -- node [op',:arglist'] := x pushDownOnArithmeticVariables(getUnname op',target,arglist') arglist pushDownOp?(op,n) == -- determine if for op with n arguments whether for all modemaps -- the target type is equal to one or more arguments. If so, a list -- of the appropriate arguments is returned. ops := [sig for [sig,:.] in getModemapsFromDatabase(op,n)] null ops => NIL op in '(_+ _* _- _exquo) => [i for i in 0..(n-1)] -- each signature has form -- [domain of implementation, target, arg1, arg2, ...] -- sameAsTarg is a vector that counts the number of modemaps that -- have the corresponding argument equal to the target type sameAsTarg := GETZEROVEC n numMms := LENGTH ops for [.,targ,:argl] in ops repeat for arg in argl for i in 0.. repeat targ = arg => SETELT(sameAsTarg,i,1 + sameAsTarg.i) -- now see which args have their count = numMms ok := NIL for i in 0..(n-1) repeat if numMms = sameAsTarg.i then ok := cons(i,ok) reverse ok --% Bottom Up Processing -- Also see I-SPEC BOOT for special handlers and I-MAP BOOT for -- user function processing. bottomUp t == -- bottomUp takes an attributed tree, and returns the modeSet for it. -- As a side-effect it also evaluates the tree. t is [op,:argl] => tar := getTarget op getUnname(op) ^= $immediateDataSymbol and (v := getValue op) => om := objMode(v) null tar => [om] (r := resolveTM(om,tar)) => [r] [om] if atom op then opName:= getUnname op if opName in $localVars then putModeSet(op,bottomUpIdentifier(op,opName)) else transferPropsToNode(opName,op) else opName := NIL bottomUp op opVal := getValue op -- call a special handler if we are not being package called dol := getAtree(op,'dollar) and (opName ^= 'construct) (null dol) and (fn:= GETL(opName,"up")) and (u:= FUNCALL(fn, t)) => u nargs := #argl if opName then for x in argl for i in 1.. repeat putAtree(x,'callingFunction,opName) putAtree(x,'argumentNumber,i) putAtree(x,'totalArgs,nargs) if tar then pushDownTargetInfo(opName,tar,argl) -- see if we are calling a declared user map -- if so, push down the declared types as targets on the args if opVal and (objVal opVal is ['MAP,:.]) and (getMode op is ['Mapping,:ms]) and (nargs + 1= #ms) then for m in rest ms for x in argl repeat putTarget(x,m) argModeSetList:= [bottomUp x for x in argl] if ^tar and opName = "*" and nargs = 2 then [[t1],[t2]] := argModeSetList tar := computeTypeWithVariablesTarget(t1, t2) tar => pushDownTargetInfo(opName,tar,argl) argModeSetList:= [bottomUp x for x in argl] ms := bottomUpForm(t,op,opName,argl,argModeSetList) -- given no target or package calling, force integer constants to -- belong to tightest possible subdomain op := CAR t -- may have changed in bottomUpElt $useIntegerSubdomain and null tar and null dol and isEqualOrSubDomain(first ms,$Integer) => val := objVal getValue op isWrapped val => -- constant if wrapped val := unwrap val bm := getBasicMode val putValue(op,objNewWrap(val,bm)) putModeSet(op,[bm]) ms ms m := getBasicMode t => [m] IDENTP (id := getUnname t) => putModeSet(t,bottomUpIdentifier(t,id)) keyedSystemError("S2GE0016",['"bottomUp",'"unknown object form"]) computeTypeWithVariablesTarget(p, q) == polyVarlist(p) or polyVarlist(q) => t := resolveTT(p, q) polyVarlist(t) => t NIL NIL bottomUpCompile t == $genValue:local := false ms := bottomUp t COMP_-TRAN_-1 objVal getValue t ms bottomUpUseSubdomain t == $useIntegerSubdomain : local := true ms := bottomUp t ($immediateDataSymbol ^= getUnname(t)) or ($Integer ^= CAR(ms)) => ms null INTEGERP(num := objValUnwrap getValue t) => ms o := getBasicObject(num) putValue(t,o) ms := [objMode o] putModeSet(t,ms) ms bottomUpPredicate(pred, name) == putTarget(pred,$Boolean) ms := bottomUp pred $Boolean ^= first ms => throwKeyedMsg('"S2IB0001",[name]) ms bottomUpCompilePredicate(pred, name) == $genValue:local := false bottomUpPredicate(pred,name) bottomUpIdentifier(t,id) == m := isType t => bottomUpType(t, m) EQ(id,'noMapVal) => throwKeyedMsg('"S2IB0002",NIL) EQ(id,'noBranch) => keyedSystemError("S2GE0016", ['"bottomUpIdentifier",'"trying to evaluate noBranch"]) transferPropsToNode(id,t) defaultType := ['Variable,id] -- This was meant to stop building silly symbols but had some unfortunate -- side effects, like not being able to say e:=foo in the interpreter. MCD -- defaultType := -- getModemapsFromDatabase(id,1) => -- userError ['"Cannot use operation name as a variable: ", id] -- ['Variable, id] u := getValue t => --non-cached values MAY be re-evaluated tar := getTarget t expr:= objVal u om := objMode(u) (om ^= $EmptyMode) and (om isnt ['RuleCalled,.]) => $genValue or GENSYMP(id) => null tar => [om] (r := resolveTM(om,tar)) => [r] [om] bottomUpDefault(t,id,defaultType,getTarget t) interpRewriteRule(t,id,expr) or (isMapExpr expr and [objMode(u)]) or keyedSystemError("S2GE0016", ['"bottomUpIdentifier",'"cannot evaluate identifier"]) bottomUpDefault(t,id,defaultType,getTarget t) bottomUpDefault(t,id,defaultMode,target) == if $genValue then bottomUpDefaultEval(t,id,defaultMode,target,nil) else bottomUpDefaultCompile(t,id,defaultMode,target,nil) bottomUpDefaultEval(t,id,defaultMode,target,isSub) == -- try to get value case. -- 1. declared mode but no value case (m := getMode t) => m is ['Mapping,:.] => throwKeyedMsg('"S2IB0003",[getUnname t]) -- hmm, try to treat it like target mode or declared mode if isPartialMode(m) then m := resolveTM(['Variable,id],m) -- if there is a target, probably want it to be that way and not -- declared mode. Like "x" in second line: -- x : P[x] I -- y : P[x] I target and not isSub and (val := coerceInteractive(objNewWrap(id,['Variable,id]),target))=> putValue(t,val) [target] -- Ok, see if we can make it into declared mode from symbolic form -- For example, (x : P[x] I; x + 1) not target and not isSub and m and (val := coerceInteractive(objNewWrap(id,['Variable,id]),m)) => putValue(t,val) [m] -- give up throwKeyedMsg('"S2IB0004",[id,m]) -- 2. no value and no mode case val := objNewWrap(id,defaultMode) (null target) or (defaultMode = target) => putValue(t,val) [defaultMode] if isPartialMode target then -- this hackery will go away when Symbol is not the default type if defaultMode = $Symbol and (target is [D,x,.]) then (D in $univariateDomains and (x = id)) or (D in $multivariateDomains and (id in x)) => dmode := [D,x,$Integer] (val' := coerceInteractive(objNewWrap(id, ['Variable,id]),dmode)) => defaultMode := dmode val := val' NIL target := resolveTM(defaultMode,target) -- The following is experimental. SCM 10/11/90 if target and (tm := getMinimalVarMode(id, target)) then target := tm (null target) or null (val' := coerceInteractive(val,target)) => putValue(t,val) [defaultMode] putValue(t,val') [target] bottomUpDefaultCompile(t,id,defaultMode,target,isSub) == tmode := getMode t tval := getValue t expr:= id in $localVars => id tmode or tval => envMode := tmode or objMode tval envMode is ['Variable, :.] => objVal tval id = $immediateDataSymbol => objVal tval ['getValueFromEnvironment,MKQ id,MKQ envMode] wrap id tmode and tval and (mdv := objMode tval) => if isPartialMode tmode then null (tmode := resolveTM(mdv,tmode)) => keyedMsgCompFailure("S2IB0010",NIL) putValue(t,objNew(expr,tmode)) [tmode] tmode or (tval and (tmode := objMode tval)) => putValue(t,objNew(expr,tmode)) [tmode] obj := objNew(expr,defaultMode) canCoerceFrom(defaultMode, target) and (obj' := coerceInteractive(obj, target)) => putValue(t, obj') [target] putValue(t,obj) [defaultMode] interpRewriteRule(t,id,expr) == null get(id,'isInterpreterRule,$e) => NIL (ms:= selectLocalMms(t,id,nil,nil)) and (ms:=evalForm(t,id,nil,ms)) => ms nil bottomUpForm(t,op,opName,argl,argModeSetList) == not($inRetract) => bottomUpForm3(t,op,opName,argl,argModeSetList) bottomUpForm2(t,op,opName,argl,argModeSetList) bottomUpForm3(t,op,opName,argl,argModeSetList) == $origArgModeSetList:local := COPY argModeSetList bottomUpForm2(t,op,opName,argl,argModeSetList) bottomUpForm2(t,op,opName,argl,argModeSetList) == not atom t and EQ(opName,"%%") => bottomUpPercent t opVal := getValue op -- for things with objects in operator position, be careful before -- we enter general modemap selection lookForIt := getAtree(op,'dollar) => true not opVal => true opMode := objMode opVal not (opModeTop := IFCAR opMode) => true opModeTop in '(Record Union) => false opModeTop in '(Variable Mapping FunctionCalled RuleCalled AnonymousFunction) => true false -- get rid of Union($, "failed") except when op is "=" and all -- modesets are the same $genValue and ^(opName = "=" and argModeSetList is [[m],[=m]] and m is ['Union,:.]) and (u := bottomUpFormUntaggedUnionRetract(t,op,opName,argl,argModeSetList)) => u lookForIt and (u := bottomUpFormTuple(t, op, opName, argl, argModeSetList)) => u -- opName can change in the call to selectMms (lookForIt and (mmS := selectMms(op,argl,getTarget op))) and (mS := evalForm(op,opName := getUnname op,argl,mmS)) => putModeSet(op,mS) bottomUpForm0(t,op,opName,argl,argModeSetList) bottomUpFormTuple(t, op, opName, args, argModeSetList) == getAtree(op,'dollar) => NIL null (singles := getModemapsFromDatabase(opName, 1)) => NIL -- see if any of the modemaps have Tuple arguments haveTuple := false for mm in singles while not haveTuple repeat if getFirstArgTypeFromMm(mm) is ["Tuple",.] then haveTuple := true not haveTuple => nil nargs := #args nargs = 1 and getUnname first args = "Tuple" => NIL nargs = 1 and (ms := bottomUp first args) and (ms is [["Tuple",.]] or ms is [["List",.]]) => NIL -- now make the args into a tuple newArg := [mkAtreeNode "Tuple",:args] bottomUp [op, newArg] removeUnionsAtStart(argl,modeSets) == null $genValue => modeSets for arg in argl for ms in modeSets repeat null (v := getValue arg) => nil m := objMode(v) m isnt ['Union,:.] => nil val := objVal(v) null isWrapped val => nil val' := retract v m' := objMode val' putValue(arg,val') putModeSet(arg,[m']) RPLACA(ms,m') modeSets printableArgModeSetList() == amsl := nil for a in reverse $origArgModeSetList repeat b := prefix2String first a if ATOM b then b := [b] amsl := ['%l,:b,:amsl] if amsl then amsl := rest amsl amsl bottomUpForm0(t,op,opName,argl,argModeSetList) == op0 := op opName0 := opName m := isType t => bottomUpType(t, m) opName = 'copy and argModeSetList is [[['Record,:rargs]]] => -- this is a hack until Records go through the normal -- modemap selection process rtype := ['Record,:rargs] code := optRECORDCOPY(['RECORDCOPY,getArgValue(CAR argl, rtype),#rargs]) if $genValue then code := wrap timedEVALFUN code val := objNew(code,rtype) putValue(t,val) putModeSet(t,[rtype]) m := getModeOrFirstModeSetIfThere op m is ['Record,:.] and argModeSetList is [[['Variable,x]]] and member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u m is ['Union,:.] and argModeSetList is [[['Variable,x]]] => member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u not $genValue => amsl := printableArgModeSetList() throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op) object := retract getValue op object = 'failed => throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op) putModeSet(op,[objMode(object)]) putValue(op,object) (u := bottomUpElt t) => u bottomUpForm0(t,op,opName,argl,argModeSetList) (opName ^= "elt") and (opName ^= "apply") and #argl = 1 and first first argModeSetList is ['Variable, var] and var in '(first last rest) and isEltable(op, argl, #argl) and (u := bottomUpElt t) => u $genValue and ( u:= bottomUpFormRetract(t,op,opName,argl,argModeSetList) ) => u (opName ^= "elt") and (opName ^= "apply") and isEltable(op, argl, #argl) and (u := bottomUpElt t) => u if FIXP $HTCompanionWindowID then mkCompanionPage('operationError, t) amsl := printableArgModeSetList() opName1 := opName0 = $immediateDataSymbol => (o := coerceInteractive(getValue op0,$OutputForm)) => outputTran objValUnwrap o NIL opName0 if null(opName1) then opName1 := (o := getValue op0) => prefix2String objMode o '"" msgKey := null amsl => "S2IB0013" "S2IB0012" else msgKey := null amsl => "S2IB0011" (n := isSharpVarWithNum opName1) => opName1 := n "S2IB0008g" "S2IB0008" sayIntelligentMessageAboutOpAvailability(opName1, #argl) not $genValue => keyedMsgCompFailureSP(msgKey,[opName1, amsl], op0) throwKeyedMsgSP(msgKey,[opName1, amsl], op0) sayIntelligentMessageAboutOpAvailability(opName, nArgs) == -- see if we can give some decent messages about the availability if -- library messages NUMBERP opName => NIL oo := object2Identifier opOf opName if ( oo = "%" ) or ( oo = "Domain" ) or ( domainForm? opName ) then opName := "elt" nAllExposedMmsWithName := #getModemapsFromDatabase(opName, NIL) nAllMmsWithName := #getAllModemapsFromDatabase(opName, NIL) -- first see if there are ANY ops with this name if nAllMmsWithName = 0 then sayKeyedMsg("S2IB0008a", [opName]) else if nAllExposedMmsWithName = 0 then nAllMmsWithName = 1 => sayKeyedMsg("S2IB0008b", [opName]) sayKeyedMsg("S2IB0008c", [opName, nAllMmsWithName]) else -- now talk about specific arguments nAllExposedMmsWithNameAndArgs := #getModemapsFromDatabase(opName, nArgs) nAllMmsWithNameAndArgs := #getAllModemapsFromDatabase(opName, nArgs) nAllMmsWithNameAndArgs = 0 => sayKeyedMsg("S2IB0008d", [opName, nArgs, nAllExposedMmsWithName, nAllMmsWithName - nAllExposedMmsWithName]) nAllExposedMmsWithNameAndArgs = 0 => sayKeyedMsg("S2IB0008e", [opName, nArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs]) sayKeyedMsg("S2IB0008f", [opName, nArgs, nAllExposedMmsWithNameAndArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs]) nil bottomUpType(t, type) == mode := if isPartialMode type then '(Mode) else if categoryForm?(type) then '(SubDomain (Domain)) else '(Domain) val:= objNew(type,mode) putValue(t,val) -- have to fix the following putModeSet(t,[mode]) bottomUpPercent(tree is [op,:argl]) == -- handles a call %%(5), which means the output of step 5 -- %%() is the same as %%(-1) null argl => val:= fetchOutput(-1) putValue(op,val) putModeSet(op,[objMode(val)]) argl is [t] => i:= getArgValue(t,$Integer) => val:= fetchOutput i putValue(op,val) putModeSet(op,[objMode(val)]) throwKeyedMsgSP('"S2IB0006",NIL,t) throwKeyedMsgSP('"S2IB0006",NIL,op) bottomUpFormRetract(t,op,opName,argl,amsl) == -- tries to find one argument, which can be pulled back, and calls -- bottomUpForm again. We do not retract the first argument to a -- setelt, because this is presumably a destructive operation and -- the retract can create a new object. -- if no such operation exists in the database, don't bother $inRetract: local := true null getAllModemapsFromDatabase(getUnname op,#argl) => NIL u := bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) => u a := NIL b := NIL ms := NIL for x in argl for m in amsl for i in 1.. repeat -- do not retract first arg of a setelt (i = 1) and (opName = "setelt") => a := [x,:a] ms := [m,:ms] (i = 1) and (opName = "set!") => a := [x,:a] ms := [m,:ms] if PAIRP(m) and CAR(m) = $EmptyMode then return NIL object:= retract getValue x a:= [x,:a] EQ(object,'failed) => putAtree(x,'retracted,nil) ms := [m, :ms] b:= true RPLACA(m,objMode(object)) ms := [COPY_-TREE m, :ms] putAtree(x,'retracted,true) putValue(x,object) putModeSet(x,[objMode(object)]) --insert pulled-back items a := nreverse a ms := nreverse ms -- check that we haven't seen these types before typesHad := getAtree(t, 'typesHad) if member(ms, typesHad) then b := nil else putAtree(t, 'typesHad, cons(ms, typesHad)) b and bottomUpForm(t,op,opName,a,amsl) retractAtree atr == object:= retract getValue atr EQ(object,'failed) => putAtree(atr,'retracted,nil) nil putAtree(atr,'retracted,true) putValue(atr,object) putModeSet(atr,[objMode(object)]) true bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) == -- see if we have a Union ok := NIL for m in amsl while not ok repeat if atom first(m) then return NIL first m = $Any => ok := true (first first m = 'Union) => ok := true not ok => NIL a:= NIL b:= NIL for x in argl for m in amsl for i in 0.. repeat m0 := first m if ( (m0 = $Any) or (first m0 = 'Union) ) and ('failed^=(object:=retract getValue x)) then b := true RPLACA(m,objMode(object)) putModeSet(x,[objMode(object)]) putValue(x,object) a := cons(x,a) b and bottomUpForm(t,op,opName,nreverse a,amsl) bottomUpFormUntaggedUnionRetract(t,op,opName,argl,amsl) == -- see if we have a Union with no tags, if so retract all such guys ok := NIL for [m] in amsl while not ok repeat if atom m then return NIL if m is ['Union, :.] and null getUnionOrRecordTags m then ok := true not ok => NIL a:= NIL b:= NIL for x in argl for m in amsl for i in 0.. repeat m0 := first m if (m0 is ['Union, :.] and null getUnionOrRecordTags m0) and ('failed ^= (object:=retract getValue x)) then b := true RPLACA(m,objMode(object)) putModeSet(x,[objMode(object)]) putValue(x,object) a := cons(x,a) b and bottomUpForm(t,op,opName,nreverse a,amsl) bottomUpElt (form:=[op,:argl]) == -- this transfers expressions that look like function calls into -- forms with elt or apply. ms := bottomUp op ms and (ms is [['Union,:.]] or ms is [['Record,:.]]) => RPLAC(CDR form, [op,:argl]) RPLAC(CAR form, mkAtreeNode "elt") bottomUp form target := getTarget form newOps := [mkAtreeNode "elt", mkAtreeNode "apply"] u := nil while ^u for newOp in newOps repeat newArgs := [op,:argl] if selectMms(newOp, newArgs, target) then RPLAC(CDR form, newArgs) RPLAC(CAR form, newOp) u := bottomUp form while ^u and ( "and"/[retractAtree(a) for a in newArgs] ) repeat while ^u for newOp in newOps repeat newArgs := [op,:argl] if selectMms(newOp, newArgs, target) then RPLAC(CDR form, newArgs) RPLAC(CAR form, newOp) u := bottomUp form u isEltable(op,argl,numArgs) == -- determines if the object might possible have an elt function -- we exclude Mapping and Variable types explicitly v := getValue op => ZEROP numArgs => true not(m := objMode(v)) => nil m is ['Mapping, :.] => nil objVal(v) is ['MAP, :mapDef] and numMapArgs(mapDef) > 0 => nil true m := getMode op => ZEROP numArgs => true m is ['Mapping, :.] => nil true numArgs ^= 1 => nil name := getUnname op name = 'SEQ => nil --not (name in '(a e h s)) and getAllModemapsFromDatabase(name, nil) => nil arg := first argl (getUnname arg) ^= 'construct => nil true @ \eject \begin{thebibliography}{99} \bibitem{1} nothing \end{thebibliography} \end{document}