diff options
Diffstat (limited to 'src/interp/i-analy.boot')
| -rw-r--r-- | src/interp/i-analy.boot | 810 |
1 files changed, 810 insertions, 0 deletions
diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot new file mode 100644 index 00000000..00e62a44 --- /dev/null +++ b/src/interp/i-analy.boot @@ -0,0 +1,810 @@ +-- 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. + + +--% Interpreter Analysis Functions + +--% Basic Object Type Identification + +getBasicMode x == getBasicMode0(x,$useIntegerSubdomain) + +getBasicMode0(x,useIntegerSubdomain) == + -- if x is one of the basic types (Integer String Float Boolean) then + -- this function returns its type, and nil otherwise + x is nil => $EmptyMode + STRINGP x => $String + INTEGERP x => + useIntegerSubdomain => + x > 0 => $PositiveInteger + x = 0 => $NonNegativeInteger + $Integer + $Integer + FLOATP x => $DoubleFloat + (x='noBranch) or (x='noValue) => $NoValueMode + nil + +getBasicObject x == + INTEGERP x => + t := + not $useIntegerSubdomain => $Integer + x > 0 => $PositiveInteger + x = 0 => $NonNegativeInteger + $Integer + objNewWrap(x,t) + STRINGP x => objNewWrap(x,$String) + FLOATP x => objNewWrap(x,$DoubleFloat) + NIL + +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 + '"<unknown type>" + 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 + |