diff --git a/changelog b/changelog index b4dd635..1db9b1d 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090817 tpd src/axiom-website/patches.html 20090817.02.tpd.patch +20090817 tpd src/interp/Makefile move i-analy.boot to i-analy.lisp +20090817 tpd src/interp/i-analy.lisp added, rewritten from i-analy.boot +20090817 tpd src/interp/i-analy.boot removed, rewritten to i-analy.lisp 20090817 tpd src/axiom-website/patches.html 20090817.01.tpd.patch 20090817 tpd src/interp/Makefile move hypertex.boot to hypertex.lisp 20090817 tpd src/interp/hypertex.lisp added, rewritten from hypertex.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index efbc9c6..97d8bdd 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1814,6 +1814,8 @@ g-timer.lisp rewrite from boot to lisp
g-util.lisp rewrite from boot to lisp
20090817.01.tpd.patch hypertex.lisp rewrite from boot to lisp
+20090817.02.tpd.patch +i-analy.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index b73bc31..6e470d8 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -427,7 +427,7 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/hashcode.boot.dvi \ ${DOC}/htcheck.boot.dvi \ ${DOC}/ht-util.boot.dvi \ - ${DOC}/i-analy.boot.dvi ${DOC}/i-code.boot.dvi \ + ${DOC}/i-code.boot.dvi \ ${DOC}/i-coerce.boot.dvi ${DOC}/i-coerfn.boot.dvi \ ${DOC}/i-eval.boot.dvi ${DOC}/i-funsel.boot.dvi \ ${DOC}/i-intern.boot.dvi \ @@ -3029,46 +3029,26 @@ ${MID}/http.lisp: ${IN}/http.lisp @ -\subsection{i-analy.boot} +\subsection{i-analy.lisp} <>= -${OUT}/i-analy.${O}: ${MID}/i-analy.clisp - @ echo 279 making ${OUT}/i-analy.${O} from ${MID}/i-analy.clisp - @ (cd ${MID} ; \ +${OUT}/i-analy.${O}: ${MID}/i-analy.lisp + @ echo 136 making ${OUT}/i-analy.${O} from ${MID}/i-analy.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/i-analy.clisp"' \ + echo '(progn (compile-file "${MID}/i-analy.lisp"' \ ':output-file "${OUT}/i-analy.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/i-analy.clisp"' \ + echo '(progn (compile-file "${MID}/i-analy.lisp"' \ ':output-file "${OUT}/i-analy.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/i-analy.clisp: ${IN}/i-analy.boot.pamphlet - @ echo 280 making ${MID}/i-analy.clisp from ${IN}/i-analy.boot.pamphlet +<>= +${MID}/i-analy.lisp: ${IN}/i-analy.lisp.pamphlet + @ echo 137 making ${MID}/i-analy.lisp from ${IN}/i-analy.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/i-analy.boot.pamphlet >i-analy.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "i-analy.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "i-analy.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm i-analy.boot ) - -@ -<>= -${DOC}/i-analy.boot.dvi: ${IN}/i-analy.boot.pamphlet - @echo 281 making ${DOC}/i-analy.boot.dvi \ - from ${IN}/i-analy.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/i-analy.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} i-analy.boot ; \ - rm -f ${DOC}/i-analy.boot.pamphlet ; \ - rm -f ${DOC}/i-analy.boot.tex ; \ - rm -f ${DOC}/i-analy.boot ) + ${TANGLE} ${IN}/i-analy.lisp.pamphlet >i-analy.lisp ) @ @@ -6633,8 +6613,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/i-analy.boot.pamphlet b/src/interp/i-analy.boot.pamphlet deleted file mode 100644 index 4f17602..0000000 --- a/src/interp/i-analy.boot.pamphlet +++ /dev/null @@ -1,832 +0,0 @@ -\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. - -@ -<<*>>= -<> - ---% 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:= GET(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} diff --git a/src/interp/i-analy.lisp.pamphlet b/src/interp/i-analy.lisp.pamphlet new file mode 100644 index 0000000..e46d539 --- /dev/null +++ b/src/interp/i-analy.lisp.pamphlet @@ -0,0 +1,2293 @@ +\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} +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;--% Interpreter Analysis Functions +;--% Basic Object Type Identification +;getBasicMode x == getBasicMode0(x,$useIntegerSubdomain) + +(DEFUN |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 + +(DEFUN |getBasicMode0| (|x| |useIntegerSubdomain|) + (COND + ((NULL |x|) |$EmptyMode|) + ((STRINGP |x|) |$String|) + ((INTEGERP |x|) + (COND + (|useIntegerSubdomain| + (COND + ((> |x| 0) |$PositiveInteger|) + ((EQL |x| 0) |$NonNegativeInteger|) + ((QUOTE T) |$Integer|))) + ((QUOTE T) |$Integer|))) + ((FLOATP |x|) |$DoubleFloat|) + ((OR (BOOT-EQUAL |x| (QUOTE |noBranch|)) (BOOT-EQUAL |x| (QUOTE |noValue|))) + |$NoValueMode|) + ((QUOTE T) 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 + +(DEFUN |getBasicObject| (|x|) + (PROG (|t|) + (RETURN + (COND + ((INTEGERP |x|) + (SPADLET |t| + (COND + ((NULL |$useIntegerSubdomain|) |$Integer|) + ((> |x| 0) |$PositiveInteger|) + ((EQL |x| 0) |$NonNegativeInteger|) + ((QUOTE T) |$Integer|))) + (|objNewWrap| |x| |t|)) + ((STRINGP |x|) (|objNewWrap| |x| |$String|)) + ((FLOATP |x|) (|objNewWrap| |x| |$DoubleFloat|)) + ((QUOTE T) 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') + +(DEFUN |getMinimalVariableTower| (|var| |t|) + (PROG (D |ISTMP#3| |up| |mp| |ISTMP#1| |u| |ISTMP#2| |t'|) + (RETURN + (COND + ((OR (STRINGP |t|) (IDENTP |t|)) NIL) + ((BOOT-EQUAL |t| |$Symbol|) |t|) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |u| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND ((BOOT-EQUAL |u| |var|) |t|) ((QUOTE T) NIL))) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |Polynomial|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + |t|) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |RationalFunction|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) + (CONS (QUOTE |Polynomial|) (CONS D NIL))) + ((AND (PAIRP |t|) + (PROGN + (SPADLET |up| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |t'| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |u| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL))))))) + (MEMQ |up| |$univariateDomains|)) + (COND + ((BOOT-EQUAL |u| |var|) |t|) + ((QUOTE T) (|getMinimalVariableTower| |var| |t'|)))) + ((AND (PAIRP |t|) + (PROGN + (SPADLET |up| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |u| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |t'| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (MEMQ |up| |$univariateDomains|)) + (COND + ((BOOT-EQUAL |u| |var|) |t|) + ((QUOTE T) (|getMinimalVariableTower| |var| |t'|)))) + ((AND (PAIRP |t|) + (PROGN + (SPADLET |mp| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |u| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |t'| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (MEMQ |mp| |$multivariateDomains|)) + (COND + ((|member| |var| |u|) |t|) + ((QUOTE T) (|getMinimalVariableTower| |var| |t'|)))) + ((NULL (SPADLET |t'| (|underDomainOf| |t|))) NIL) + ((QUOTE T) (|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 + +(DEFUN |getMinimalVarMode| (|id| |m|) + (PROG (|defaultMode| |vl| |um|) + (RETURN + (COND + ((AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Mapping|))) |m|) + ((QUOTE T) + (SPADLET |defaultMode| |$Symbol|) + (COND + ((NULL |m|) |defaultMode|) + ((AND (SPADLET |vl| (|polyVarlist| |m|)) + (OR + (|member| |id| |vl|) + (|member| (QUOTE |all|) |vl|))) + (SUBSTQ (QUOTE (|Integer|)) |$EmptyMode| |m|)) + ((SPADLET |um| (|underDomainOf| |m|)) (|getMinimalVarMode| |id| |um|)) + ((QUOTE T) |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 + +(DEFUN |polyVarlist| (|m|) + (PROG (|op| |ISTMP#1| |a|) + (RETURN + (COND + ((AND (PAIRP |m|) + (EQUAL (QCAR |m|) |$QuotientField|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |op| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|polyVarlist| |op|)) + ((AND (PAIRP |m|) + (PROGN + (SPADLET |op| (QCAR |m|)) + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((|member| |op| + (QUOTE (|UnivariateTaylorSeries| + |UnivariateLaurentSeries| + |UnivariatePuiseuxSeries|))) + (SPADLET |a| (CADDR |m|)) + (SPADLET |a| (|removeQuote| |a|)) (CONS |a| NIL)) + ((|member| |op| (QUOTE (|Polynomial| |RationalFunction| |Expression|))) + (QUOTE (|all|))) + ((QUOTE T) + (SPADLET |a| (|removeQuote| |a|)) + (COND + ((|member| |op| (QUOTE (|UnivariatePolynomial|))) (CONS |a| NIL)) + ((|member| |op| |$multivariateDomains|) |a|))))) + ((QUOTE T) 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 + +(DEFUN |pushDownTargetInfo| (|op| |target| |arglist|) + (PROG (|n| |pdArgs| |nargs| |x| |targ| |ISTMP#1| S) + (RETURN + (SEQ + (COND + ((BOOT-EQUAL |target| |$OutputForm|) NIL) + ((BOOT-EQUAL |target| |$Any|) NIL) + ((QUOTE T) + (SPADLET |n| (LENGTH |arglist|)) + (|pushDownOnArithmeticVariables| |op| |target| |arglist|) + (COND + ((SPADLET |pdArgs| (|pushDownOp?| |op| |n|)) + (DO ((#0=#:G166265 |pdArgs| (CDR #0#)) (|i| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |i| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |x| (ELT |arglist| |i|)) + (COND + ((NULL (|getTarget| |x|)) (|putTarget| |x| |target|)) + ((QUOTE T) NIL))))))) + ((QUOTE T) + (SPADLET |nargs| (|#| |arglist|)) + (SEQ + (COND + ((EQL 1 |nargs|) + (COND + ((AND + (BOOT-EQUAL |op| (QUOTE SEGMENT)) + (PAIRP |target|) + (EQ (QCAR |target|) (QUOTE |UniversalSegment|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) + (EXIT + (DO ((#1=#:G166274 |arglist| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((NULL (|getTarget| |x|)) (|putTarget| |x| S)) + ((QUOTE T) NIL))))))))) + ((EQL 2 |nargs|) + (COND + ((BOOT-EQUAL |op| (QUOTE *)) + (COND + ((NULL (|getTarget| (CADR |arglist|))) + (|putTarget| (CADR |arglist|) |target|))) + (COND + ((|getTarget| (SPADLET |x| (CAR |arglist|))) NIL) + ((NEQUAL (|getUnname| |x|) |$immediateDataSymbol|) + (|putTarget| |x| |target|)) + ((QUOTE T) NIL))) + ((OR (BOOT-EQUAL |op| (QUOTE **)) (BOOT-EQUAL |op| (QUOTE ^))) + (COND + ((NULL (|getTarget| (CAR |arglist|))) + (|putTarget| (CAR |arglist|) |target|)) + ((QUOTE T) NIL))) + ((AND + (BOOT-EQUAL |op| (QUOTE |equation|)) + (PAIRP |target|) + (EQ (QCAR |target|) (QUOTE |Equation|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) + (DO ((#2=#:G166283 |arglist| (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((NULL (|getTarget| |x|)) (|putTarget| |x| S)) + ((QUOTE T) NIL)))))) + ((AND + (BOOT-EQUAL |op| (QUOTE |gauss|)) + (PAIRP |target|) + (EQ (QCAR |target|) (QUOTE |Gaussian|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) + (DO ((#3=#:G166292 |arglist| (CDR #3#)) (|x| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |x| (CAR #3#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((NULL (|getTarget| |x|)) (|putTarget| |x| S)) + ((QUOTE T) NIL)))))) + ((BOOT-EQUAL |op| (QUOTE /)) + (SPADLET |targ| + (COND + ((AND + (PAIRP |target|) + (EQ (QCAR |target|) (QUOTE |Fraction|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) + S) + ((QUOTE T) |target|))) + (DO ((#4=#:G166301 |arglist| (CDR #4#)) (|x| NIL)) + ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((NULL (|getTarget| |x|)) (|putTarget| |x| |targ|)) + ((QUOTE T) NIL)))))) + ((AND + (BOOT-EQUAL |op| (QUOTE SEGMENT)) + (PAIRP |target|) + (EQ (QCAR |target|) (QUOTE |Segment|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) + (DO ((#5=#:G166310 |arglist| (CDR #5#)) (|x| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((NULL (|getTarget| |x|)) (|putTarget| |x| S)) + ((QUOTE T) NIL)))))) + ((AND + (BOOT-EQUAL |op| (QUOTE SEGMENT)) + (PAIRP |target|) + (EQ (QCAR |target|) (QUOTE |UniversalSegment|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) + (DO ((#6=#:G166319 |arglist| (CDR #6#)) (|x| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |x| (CAR #6#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((NULL (|getTarget| |x|)) (|putTarget| |x| S)) + ((QUOTE T) NIL)))))) + ((QUOTE T) NIL))) + ((QUOTE T) 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 + +(DEFUN |pushDownOnArithmeticVariables| (|op| |target| |arglist|) + (PROG (|xn| |t| |op'| |arglist'|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |target|) (BOOT-EQUAL (CAR |target|) (QUOTE |Variable|))) + NIL) + ((NULL (MEMQ |op| (QUOTE (+ - * ** /)))) NIL) + ((NULL (|containsPolynomial| |target|)) NIL) + ((QUOTE T) + (DO ((#0=#:G166357 |arglist| (CDR #0#)) (|x| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((VECP |x|) + (|transferPropsToNode| (SPADLET |xn| (|getUnname| |x|)) |x|) + (COND + ((OR (|getValue| |x|) (BOOT-EQUAL |xn| |$immediateDataSymbol|)) + NIL) + ((QUOTE T) + (SPADLET |t| + (OR (|getMinimalVariableTower| |xn| |target|) |target|)) + (COND + ((NULL (|getTarget| |x|)) (|putTarget| |x| |t|)) + ((QUOTE T) NIL))))) + ((PAIRP |x|) + (SPADLET |op'| (CAR |x|)) + (SPADLET |arglist'| (CDR |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 + +(DEFUN |pushDownOp?| (|op| |n|) + (PROG (|sig| |ops| |sameAsTarg| |numMms| |targ| |argl| |ok|) + (RETURN + (SEQ + (PROGN + (SPADLET |ops| + (PROG (#0=#:G166383) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166389 (|getModemapsFromDatabase| |op| |n|) (CDR #1#)) + (#2=#:G166370 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN (PROGN (SPADLET |sig| (CAR #2#)) #2#) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS |sig| #0#)))))))) + (COND + ((NULL |ops|) NIL) + ((|member| |op| (QUOTE (+ * - |exquo|))) + (PROG (#3=#:G166400) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G166405 (SPADDIFFERENCE |n| 1)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #4#) (NREVERSE0 #3#)) + (SEQ (EXIT (SETQ #3# (CONS |i| #3#)))))))) + ((QUOTE T) + (SPADLET |sameAsTarg| (GETZEROVEC |n|)) + (SPADLET |numMms| (LENGTH |ops|)) + (SEQ + (DO ((#5=#:G166413 |ops| (CDR #5#)) (#6=#:G166373 NIL)) + ((OR (ATOM #5#) + (PROGN (SETQ #6# (CAR #5#)) NIL) + (PROGN + (PROGN + (SPADLET |targ| (CADR #6#)) + (SPADLET |argl| (CDDR #6#)) + #6#) + NIL)) + NIL) + (SEQ + (EXIT + (DO ((#7=#:G166424 |argl| (CDR #7#)) + (|arg| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM #7#) (PROGN (SETQ |arg| (CAR #7#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |targ| |arg|) + (EXIT + (SETELT |sameAsTarg| |i| + (PLUS 1 (ELT |sameAsTarg| |i|)))))))))))) + (SPADLET |ok| NIL) + (DO ((#8=#:G166433 (SPADDIFFERENCE |n| 1)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| #8#) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |numMms| (ELT |sameAsTarg| |i|)) + (SPADLET |ok| (CONS |i| |ok|))) + ((QUOTE T) NIL))))) + (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:= GET(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"]) + +(DEFUN |bottomUp| (|t|) + (PROG (|argl| |v| |om| |r| |opName| |opVal| |dol| |fn| |u| |nargs| |ISTMP#1| + |t1| |t2| |tar| |argModeSetList| |ms| |op| |val| |bm| |m| |id|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |argl| (QCDR |t|)) + (QUOTE T))) + (SPADLET |tar| (|getTarget| |op|)) + (COND + ((AND (NEQUAL (|getUnname| |op|) |$immediateDataSymbol|) + (SPADLET |v| (|getValue| |op|))) + (SPADLET |om| (|objMode| |v|)) + (COND + ((NULL |tar|) (CONS |om| NIL)) + ((SPADLET |r| (|resolveTM| |om| |tar|)) (CONS |r| NIL)) + ((QUOTE T) (CONS |om| NIL)))) + ((QUOTE T) + (COND + ((ATOM |op|) + (SPADLET |opName| (|getUnname| |op|)) + (COND + ((|member| |opName| |$localVars|) + (|putModeSet| |op| (|bottomUpIdentifier| |op| |opName|))) + ((QUOTE T) (|transferPropsToNode| |opName| |op|)))) + ((QUOTE T) (SPADLET |opName| NIL) (|bottomUp| |op|))) + (SPADLET |opVal| (|getValue| |op|)) + (SPADLET |dol| + (AND (|getAtree| |op| (QUOTE |dollar|)) + (NEQUAL |opName| (QUOTE |construct|)))) + (COND + ((AND (NULL |dol|) + (SPADLET |fn| (GETL |opName| (QUOTE |up|))) + (SPADLET |u| (FUNCALL |fn| |t|))) + |u|) + ((QUOTE T) + (SPADLET |nargs| (|#| |argl|)) + (COND + (|opName| + (DO ((#0=#:G166479 |argl| (CDR #0#)) + (|x| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (|putAtree| |x| (QUOTE |callingFunction|) |opName|) + (|putAtree| |x| (QUOTE |argumentNumber|) |i|) + (|putAtree| |x| (QUOTE |totalArgs|) |nargs|))))))) + (COND (|tar| (|pushDownTargetInfo| |opName| |tar| |argl|))) + (COND + ((AND + |opVal| + (PROGN + (SPADLET |ISTMP#1| (|objVal| |opVal|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE MAP)))) + (PROGN + (SPADLET |ISTMP#1| (|getMode| |op|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) + (PROGN (SPADLET |ms| (QCDR |ISTMP#1|)) (QUOTE T)))) + (BOOT-EQUAL (PLUS |nargs| 1) (|#| |ms|))) + (DO ((#1=#:G166489 (CDR |ms|) (CDR #1#)) + (|m| NIL) + (#2=#:G166490 |argl| (CDR #2#)) + (|x| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |m| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |x| (CAR #2#)) NIL)) + NIL) + (SEQ (EXIT (|putTarget| |x| |m|)))))) + (SPADLET |argModeSetList| + (PROG (#3=#:G166503) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G166508 |argl| (CDR #4#)) (|x| NIL)) + ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) + (NREVERSE0 #3#)) + (SEQ (EXIT (SETQ #3# (CONS (|bottomUp| |x|) #3#)))))))) + (COND + ((AND (NULL |tar|) (BOOT-EQUAL |opName| (QUOTE *)) (EQL |nargs| 2)) + (SPADLET |t1| (CAAR |argModeSetList|)) + (SPADLET |t2| (CAADR |argModeSetList|)) + (SPADLET |tar| (|computeTypeWithVariablesTarget| |t1| |t2|)) + (COND + (|tar| + (PROGN + (|pushDownTargetInfo| |opName| |tar| |argl|) + (SPADLET |argModeSetList| + (PROG (#5=#:G166518) + (SPADLET #5# NIL) + (RETURN + (DO ((#6=#:G166523 |argl| (CDR #6#)) (|x| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |x| (CAR #6#)) NIL)) + (NREVERSE0 #5#)) + (SEQ + (EXIT + (SETQ #5# (CONS (|bottomUp| |x|) #5#))))))))))))) + (SPADLET |ms| + (|bottomUpForm| |t| |op| |opName| |argl| |argModeSetList|)) + (SPADLET |op| (CAR |t|)) + (COND + ((AND |$useIntegerSubdomain| + (NULL |tar|) + (NULL |dol|) + (|isEqualOrSubDomain| (CAR |ms|) |$Integer|)) + (SPADLET |val| (|objVal| (|getValue| |op|))) + (COND + ((|isWrapped| |val|) + (SPADLET |val| (|unwrap| |val|)) + (SPADLET |bm| (|getBasicMode| |val|)) + (|putValue| |op| (|objNewWrap| |val| |bm|)) + (|putModeSet| |op| (CONS |bm| NIL))) + ((QUOTE T) |ms|))) + ((QUOTE T) |ms|))))))) + ((SPADLET |m| (|getBasicMode| |t|)) (CONS |m| NIL)) + ((IDENTP (SPADLET |id| (|getUnname| |t|))) + (|putModeSet| |t| (|bottomUpIdentifier| |t| |id|))) + ((QUOTE T) + (|keyedSystemError| 'S2GE0016 + (CONS "bottomUp" (CONS "unknown object form" NIL))))))))) + +;computeTypeWithVariablesTarget(p, q) == +; polyVarlist(p) or polyVarlist(q) => +; t := resolveTT(p, q) +; polyVarlist(t) => t +; NIL +; NIL + +(DEFUN |computeTypeWithVariablesTarget| (|p| |q|) + (PROG (|t|) + (RETURN + (COND + ((OR (|polyVarlist| |p|) (|polyVarlist| |q|)) + (SPADLET |t| (|resolveTT| |p| |q|)) + (COND + ((|polyVarlist| |t|) |t|) + ((QUOTE T) NIL))) + ((QUOTE T) NIL))))) + +;bottomUpCompile t == +; $genValue:local := false +; ms := bottomUp t +; COMP_-TRAN_-1 objVal getValue t +; ms + +(DEFUN |bottomUpCompile| (|t|) + (PROG (|$genValue| |ms|) + (DECLARE (SPECIAL |$genValue|)) + (RETURN + (PROGN + (SPADLET |$genValue| NIL) + (SPADLET |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 + +(DEFUN |bottomUpUseSubdomain| (|t|) + (PROG (|$useIntegerSubdomain| |num| |o| |ms|) + (DECLARE (SPECIAL |$useIntegerSubdomain|)) + (RETURN + (PROGN + (SPADLET |$useIntegerSubdomain| (QUOTE T)) + (SPADLET |ms| (|bottomUp| |t|)) + (COND + ((OR (NEQUAL |$immediateDataSymbol| (|getUnname| |t|)) + (NEQUAL |$Integer| (CAR |ms|))) + |ms|) + ((NULL (INTEGERP (SPADLET |num| (|objValUnwrap| (|getValue| |t|))))) |ms|) + ((QUOTE T) + (SPADLET |o| (|getBasicObject| |num|)) + (|putValue| |t| |o|) + (SPADLET |ms| (CONS (|objMode| |o|) NIL)) + (|putModeSet| |t| |ms|) |ms|)))))) + +;bottomUpPredicate(pred, name) == +; putTarget(pred,$Boolean) +; ms := bottomUp pred +; $Boolean ^= first ms => throwKeyedMsg('"S2IB0001",[name]) +; ms + +(DEFUN |bottomUpPredicate| (|pred| |name|) + (PROG (|ms|) + (RETURN + (PROGN + (|putTarget| |pred| |$Boolean|) + (SPADLET |ms| (|bottomUp| |pred|)) + (COND + ((NEQUAL |$Boolean| (CAR |ms|)) + (|throwKeyedMsg| (MAKESTRING "S2IB0001") (CONS |name| NIL))) + ((QUOTE T) |ms|)))))) + +;bottomUpCompilePredicate(pred, name) == +; $genValue:local := false +; bottomUpPredicate(pred,name) + +(DEFUN |bottomUpCompilePredicate| (|pred| |name|) + (PROG (|$genValue|) + (DECLARE (SPECIAL |$genValue|)) + (RETURN + (PROGN + (SPADLET |$genValue| NIL) + (|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) + +(DEFUN |bottomUpIdentifier| (|t| |id|) + (PROG (|m| |defaultType| |u| |tar| |expr| |om| |ISTMP#1| |r|) + (RETURN + (COND + ((SPADLET |m| (|isType| |t|)) (|bottomUpType| |t| |m|)) + ((EQ |id| (QUOTE |noMapVal|)) + (|throwKeyedMsg| (MAKESTRING "S2IB0002") NIL)) + ((EQ |id| (QUOTE |noBranch|)) + (|keyedSystemError| 'S2GE0016 + (CONS "bottomUpIdentifier" (CONS "trying to evaluate noBranch" NIL)))) + ((QUOTE T) + (|transferPropsToNode| |id| |t|) + (SPADLET |defaultType| (CONS (QUOTE |Variable|) (CONS |id| NIL))) + (COND + ((SPADLET |u| (|getValue| |t|)) + (SPADLET |tar| (|getTarget| |t|)) + (SPADLET |expr| (|objVal| |u|)) + (SPADLET |om| (|objMode| |u|)) + (COND + ((AND + (NEQUAL |om| |$EmptyMode|) + (NULL + (AND + (PAIRP |om|) + (EQ (QCAR |om|) (QUOTE |RuleCalled|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |om|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))))) + (COND + ((OR |$genValue| (GENSYMP |id|)) + (COND + ((NULL |tar|) (CONS |om| NIL)) + ((SPADLET |r| (|resolveTM| |om| |tar|)) (CONS |r| NIL)) + ((QUOTE T) (CONS |om| NIL)))) + ((QUOTE T) + (|bottomUpDefault| |t| |id| |defaultType| (|getTarget| |t|))))) + ((QUOTE T) + (OR + (|interpRewriteRule| |t| |id| |expr|) + (AND (|isMapExpr| |expr|) (CONS (|objMode| |u|) NIL)) + (|keyedSystemError| 'S2GE0016 + (CONS "bottomUpIdentifier" + (CONS "cannot evaluate identifier" NIL))))))) + ((QUOTE T) + (|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) + +(DEFUN |bottomUpDefault| (|t| |id| |defaultMode| |target|) + (COND + (|$genValue| (|bottomUpDefaultEval| |t| |id| |defaultMode| |target| NIL)) + ((QUOTE T) (|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] + +(DEFUN |bottomUpDefaultEval| (|t| |id| |defaultMode| |target| |isSub|) + (PROG (|m| D |ISTMP#1| |x| |ISTMP#2| |dmode| |val| |tm| |val'|) + (RETURN + (COND + ((SPADLET |m| (|getMode| |t|)) + (COND + ((AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Mapping|))) + (|throwKeyedMsg| (MAKESTRING "S2IB0003") (CONS (|getUnname| |t|) NIL))) + ((QUOTE T) + (COND + ((|isPartialMode| |m|) + (SPADLET |m| + (|resolveTM| (CONS (QUOTE |Variable|) (CONS |id| NIL)) |m|)))) + (COND + ((AND |target| + (NULL |isSub|) + (SPADLET |val| + (|coerceInteractive| + (|objNewWrap| |id| + (CONS (QUOTE |Variable|) (CONS |id| NIL))) |target|))) + (|putValue| |t| |val|) (CONS |target| NIL)) + ((AND (NULL |target|) + (NULL |isSub|) + |m| + (SPADLET |val| + (|coerceInteractive| + (|objNewWrap| |id| + (CONS (QUOTE |Variable|) (CONS |id| NIL))) |m|))) + (|putValue| |t| |val|) (CONS |m| NIL)) + ((QUOTE T) + (|throwKeyedMsg| "S2IB0004" (CONS |id| (CONS |m| NIL)))))))) + ((QUOTE T) + (SPADLET |val| (|objNewWrap| |id| |defaultMode|)) + (COND + ((OR (NULL |target|) (BOOT-EQUAL |defaultMode| |target|)) + (|putValue| |t| |val|) (CONS |defaultMode| NIL)) + ((QUOTE T) + (COND + ((|isPartialMode| |target|) + (COND + ((AND (BOOT-EQUAL |defaultMode| |$Symbol|) + (PAIRP |target|) + (PROGN + (SPADLET D (QCAR |target|)) + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) + (COND + ((OR + (AND (|member| D |$univariateDomains|) (BOOT-EQUAL |x| |id|)) + (AND (|member| D |$multivariateDomains|) (|member| |id| |x|))) + (SPADLET |dmode| (CONS D (CONS |x| (CONS |$Integer| NIL)))) + (COND + ((SPADLET |val'| + (|coerceInteractive| + (|objNewWrap| |id| + (CONS (QUOTE |Variable|) (CONS |id| NIL))) |dmode|)) + (PROGN + (SPADLET |defaultMode| |dmode|) + (SPADLET |val| |val'|))))) + ((QUOTE T) NIL)))) + (SPADLET |target| (|resolveTM| |defaultMode| |target|)))) + (COND + ((AND |target| (SPADLET |tm| (|getMinimalVarMode| |id| |target|))) + (SPADLET |target| |tm|))) + (COND + ((OR (NULL |target|) + (NULL (SPADLET |val'| (|coerceInteractive| |val| |target|)))) + (|putValue| |t| |val|) (CONS |defaultMode| NIL)) + ((QUOTE T) (|putValue| |t| |val'|) (CONS |target| NIL)))))))))) + +;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] + +(DEFUN |bottomUpDefaultCompile| (|t| |id| |defaultMode| |target| |isSub|) + (PROG (|tval| |envMode| |expr| |mdv| |tmode| |obj| |obj'|) + (RETURN + (SEQ + (PROGN + (SPADLET |tmode| (|getMode| |t|)) + (SPADLET |tval| (|getValue| |t|)) + (SPADLET |expr| + (COND + ((|member| |id| |$localVars|) |id|) + ((OR |tmode| |tval|) + (SPADLET |envMode| (OR |tmode| (|objMode| |tval|))) + (COND + ((AND (PAIRP |envMode|) (EQ (QCAR |envMode|) (QUOTE |Variable|))) + (|objVal| |tval|)) + ((BOOT-EQUAL |id| |$immediateDataSymbol|) + (|objVal| |tval|)) + ((QUOTE T) + (CONS + (QUOTE |getValueFromEnvironment|) + (CONS (MKQ |id|) (CONS (MKQ |envMode|) NIL)))))) + ((QUOTE T) (|wrap| |id|)))) + (COND + ((AND |tmode| |tval| (SPADLET |mdv| (|objMode| |tval|))) + (SEQ + (COND + ((|isPartialMode| |tmode|) + (COND + ((NULL (SPADLET |tmode| (|resolveTM| |mdv| |tmode|))) + (EXIT (|keyedMsgCompFailure| (QUOTE S2IB0010) NIL)))))) + (|putValue| |t| (|objNew| |expr| |tmode|)) + (CONS |tmode| NIL))) + ((OR |tmode| (AND |tval| (SPADLET |tmode| (|objMode| |tval|)))) + (|putValue| |t| (|objNew| |expr| |tmode|)) + (CONS |tmode| NIL)) + ((QUOTE T) + (SPADLET |obj| (|objNew| |expr| |defaultMode|)) + (COND + ((AND (|canCoerceFrom| |defaultMode| |target|) + (SPADLET |obj'| (|coerceInteractive| |obj| |target|))) + (|putValue| |t| |obj'|) (CONS |target| NIL)) + ((QUOTE T) (|putValue| |t| |obj|) (CONS |defaultMode| NIL)))))))))) + +;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 + +(DEFUN |interpRewriteRule| (|t| |id| |expr|) + (PROG (|ms|) + (RETURN + (COND + ((NULL (|get| |id| (QUOTE |isInterpreterRule|) |$e|)) NIL) + ((AND (SPADLET |ms| (|selectLocalMms| |t| |id| NIL NIL)) + (SPADLET |ms| (|evalForm| |t| |id| NIL |ms|))) + |ms|) + ((QUOTE T) NIL))))) + +;bottomUpForm(t,op,opName,argl,argModeSetList) == +; not($inRetract) => +; bottomUpForm3(t,op,opName,argl,argModeSetList) +; bottomUpForm2(t,op,opName,argl,argModeSetList) + +(DEFUN |bottomUpForm| (|t| |op| |opName| |argl| |argModeSetList|) + (COND + ((NULL |$inRetract|) + (|bottomUpForm3| |t| |op| |opName| |argl| |argModeSetList|)) + ((QUOTE T) + (|bottomUpForm2| |t| |op| |opName| |argl| |argModeSetList|)))) + +;bottomUpForm3(t,op,opName,argl,argModeSetList) == +; $origArgModeSetList:local := COPY argModeSetList +; bottomUpForm2(t,op,opName,argl,argModeSetList) + +(DEFUN |bottomUpForm3| (|t| |op| |opName| |argl| |argModeSetList|) + (PROG (|$origArgModeSetList|) + (DECLARE (SPECIAL |$origArgModeSetList|)) + (RETURN + (PROGN + (SPADLET |$origArgModeSetList| (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) + +(DEFUN |bottomUpForm2| (|t| |op| |opName| |argl| |argModeSetList|) + (PROG (|opVal| |opMode| |opModeTop| |lookForIt| |ISTMP#1| |m| |ISTMP#2| + |ISTMP#3| |u| |mmS| |mS|) + (RETURN + (COND + ((AND (NULL (ATOM |t|)) (EQ |opName| (QUOTE %%))) (|bottomUpPercent| |t|)) + ((QUOTE T) + (SPADLET |opVal| (|getValue| |op|)) + (SPADLET |lookForIt| + (COND + ((|getAtree| |op| (QUOTE |dollar|)) (QUOTE T)) + ((NULL |opVal|) (QUOTE T)) + ((QUOTE T) + (SPADLET |opMode| (|objMode| |opVal|)) + (COND + ((NULL (SPADLET |opModeTop| (IFCAR |opMode|))) (QUOTE T)) + ((|member| |opModeTop| (QUOTE (|Record| |Union|))) NIL) + ((|member| |opModeTop| + (QUOTE (|Variable| |Mapping| |FunctionCalled| + |RuleCalled| |AnonymousFunction|))) + (QUOTE T)) + ((QUOTE T) NIL))))) + (COND + ((AND |$genValue| + (NULL + (AND + (BOOT-EQUAL |opName| (QUOTE =)) + (PAIRP |argModeSetList|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |argModeSetList|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |m| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PROGN + (SPADLET |ISTMP#2| (QCDR |argModeSetList|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (EQUAL (QCAR |ISTMP#3|) |m|))))) + (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Union|)))) + (SPADLET |u| + (|bottomUpFormUntaggedUnionRetract| |t| |op| + |opName| |argl| |argModeSetList|))) + |u|) + ((AND |lookForIt| + (SPADLET |u| + (|bottomUpFormTuple| |t| |op| |opName| |argl| |argModeSetList|))) + |u|) + ((AND |lookForIt| + (SPADLET |mmS| (|selectMms| |op| |argl| (|getTarget| |op|))) + (SPADLET |mS| + (|evalForm| |op| + (SPADLET |opName| (|getUnname| |op|)) |argl| |mmS|))) + (|putModeSet| |op| |mS|)) + ((QUOTE T) + (|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] + +(DEFUN |bottomUpFormTuple| (|t| |op| |opName| |args| |argModeSetList|) + (PROG (|singles| |haveTuple| |nargs| |ms| |ISTMP#1| |ISTMP#2| |newArg|) + (RETURN + (SEQ + (COND + ((|getAtree| |op| (QUOTE |dollar|)) NIL) + ((NULL (SPADLET |singles| (|getModemapsFromDatabase| |opName| 1))) NIL) + ((QUOTE T) + (SPADLET |haveTuple| NIL) + (DO ((#0=#:G166755 |singles| (CDR #0#)) (|mm| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |mm| (CAR #0#)) NIL) + (NULL (NULL |haveTuple|))) + NIL) + (SEQ + (EXIT + (COND + ((PROGN + (SPADLET |ISTMP#1| (|getFirstArgTypeFromMm| |mm|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Tuple|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL))))) + (SPADLET |haveTuple| (QUOTE T))) + ((QUOTE T) NIL))))) + (COND + ((NULL |haveTuple|) NIL) + ((QUOTE T) + (SPADLET |nargs| (|#| |args|)) + (COND + ((AND (EQL |nargs| 1) + (BOOT-EQUAL (|getUnname| (CAR |args|)) (QUOTE |Tuple|))) + NIL) + ((AND + (EQL |nargs| 1) + (SPADLET |ms| (|bottomUp| (CAR |args|))) + (OR + (AND + (PAIRP |ms|) + (EQ (QCDR |ms|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |ms|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Tuple|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) + (AND (PAIRP |ms|) + (EQ (QCDR |ms|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |ms|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |List|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))))) + NIL) + ((QUOTE T) + (SPADLET |newArg| (CONS (|mkAtreeNode| (QUOTE |Tuple|)) |args|)) + (|bottomUp| (CONS |op| (CONS |newArg| NIL))))))))))))) + +;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 + +(DEFUN |removeUnionsAtStart| (|argl| |modeSets|) + (PROG (|v| |m| |val| |val'| |m'|) + (RETURN + (SEQ + (COND + ((NULL |$genValue|) |modeSets|) + ((QUOTE T) + (DO ((#0=#:G166783 |argl| (CDR #0#)) + (|arg| NIL) + (#1=#:G166784 |modeSets| (CDR #1#)) + (|ms| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |arg| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |ms| (CAR #1#)) NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL (SPADLET |v| (|getValue| |arg|))) NIL) + ((QUOTE T) + (SPADLET |m| (|objMode| |v|)) + (COND + ((NULL (AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Union|)))) NIL) + ((QUOTE T) + (SPADLET |val| (|objVal| |v|)) + (COND + ((NULL (|isWrapped| |val|)) NIL) + ((QUOTE T) + (SPADLET |val'| (|retract| |v|)) + (SPADLET |m'| (|objMode| |val'|)) + (|putValue| |arg| |val'|) + (|putModeSet| |arg| (CONS |m'| NIL)) + (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 + +(DEFUN |printableArgModeSetList| () + (PROG (|b| |amsl|) + (RETURN + (SEQ + (PROGN + (SPADLET |amsl| NIL) + (DO ((#0=#:G166809 (REVERSE |$origArgModeSetList|) (CDR #0#)) (|a| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |a| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |b| (|prefix2String| (CAR |a|))) + (COND ((ATOM |b|) (SPADLET |b| (CONS |b| NIL)))) + (SPADLET |amsl| (CONS (QUOTE |%l|) (APPEND |b| |amsl|))))))) + (COND (|amsl| (SPADLET |amsl| (CDR |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) + +(DEFUN |bottomUpForm0| (|t| |op| |opName| |argl| |argModeSetList|) + (PROG (|op0| |opName0| |rargs| |rtype| |code| |val| |m| |ISTMP#3| |x| + |object| |ISTMP#1| |ISTMP#2| |var| |u| |amsl| |o| |n| + |opName1| |msgKey|) + (RETURN + (PROGN + (SPADLET |op0| |op|) + (SPADLET |opName0| |opName|) + (COND + ((SPADLET |m| (|isType| |t|)) (|bottomUpType| |t| |m|)) + ((AND (BOOT-EQUAL |opName| (QUOTE |copy|)) + (PAIRP |argModeSetList|) + (EQ (QCDR |argModeSetList|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |argModeSetList|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE |Record|)) + (PROGN (SPADLET |rargs| (QCDR |ISTMP#2|)) (QUOTE T))))))) + (SPADLET |rtype| (CONS (QUOTE |Record|) |rargs|)) + (SPADLET |code| + (|optRECORDCOPY| + (CONS + (QUOTE RECORDCOPY) + (CONS (|getArgValue| (CAR |argl|) |rtype|) (CONS (|#| |rargs|) NIL))))) + (COND (|$genValue| (SPADLET |code| (|wrap| (|timedEVALFUN| |code|))))) + (SPADLET |val| (|objNew| |code| |rtype|)) + (|putValue| |t| |val|) (|putModeSet| |t| (CONS |rtype| NIL))) + ((QUOTE T) + (SPADLET |m| (|getModeOrFirstModeSetIfThere| |op|)) + (COND + ((AND (PAIRP |m|) + (EQ (QCAR |m|) (QUOTE |Record|)) + (PAIRP |argModeSetList|) + (EQ (QCDR |argModeSetList|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |argModeSetList|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |x| (QCAR |ISTMP#3|)) (QUOTE T)))))))) + (|member| |x| (|getUnionOrRecordTags| |m|)) + (SPADLET |u| (|bottomUpElt| |t|))) + |u|) + ((AND (PAIRP |m|) + (EQ (QCAR |m|) (QUOTE |Union|)) + (PAIRP |argModeSetList|) + (EQ (QCDR |argModeSetList|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |argModeSetList|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |x| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (COND + ((AND (|member| |x| (|getUnionOrRecordTags| |m|)) + (SPADLET |u| (|bottomUpElt| |t|))) + |u|) + ((NULL |$genValue|) + (SPADLET |amsl| (|printableArgModeSetList|)) + (|throwKeyedMsgSP| (QUOTE S2IB0008) + (CONS (MAKESTRING "the union object") (CONS |amsl| NIL)) |op|)) + ((QUOTE T) + (SPADLET |object| (|retract| (|getValue| |op|))) + (COND + ((BOOT-EQUAL |object| (QUOTE |failed|)) + (|throwKeyedMsgSP| (QUOTE S2IB0008) + (CONS (MAKESTRING "the union object") (CONS |amsl| NIL)) |op|)) + ((QUOTE T) + (|putModeSet| |op| (CONS (|objMode| |object|) NIL)) + (|putValue| |op| |object|) + (COND + ((SPADLET |u| (|bottomUpElt| |t|)) |u|) + ((QUOTE T) + (|bottomUpForm0| |t| |op| |opName| |argl| |argModeSetList|)))))))) + ((AND (NEQUAL |opName| (QUOTE |elt|)) + (NEQUAL |opName| (QUOTE |apply|)) + (EQL (|#| |argl|) 1) + (PROGN + (SPADLET |ISTMP#1| (CAR (CAR |argModeSetList|))) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |var| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (|member| |var| (QUOTE (|first| |last| |rest|))) + (|isEltable| |op| |argl| (|#| |argl|)) + (SPADLET |u| (|bottomUpElt| |t|))) + |u|) + ((AND |$genValue| + (SPADLET |u| + (|bottomUpFormRetract| |t| |op| |opName| |argl| |argModeSetList|))) + |u|) + ((AND (NEQUAL |opName| (QUOTE |elt|)) + (NEQUAL |opName| (QUOTE |apply|)) + (|isEltable| |op| |argl| (|#| |argl|)) + (SPADLET |u| (|bottomUpElt| |t|))) + |u|) + ((QUOTE T) + (COND + ((FIXP |$HTCompanionWindowID|) + (|mkCompanionPage| (QUOTE |operationError|) |t|))) + (SPADLET |amsl| (|printableArgModeSetList|)) + (SPADLET |opName1| + (COND + ((BOOT-EQUAL |opName0| |$immediateDataSymbol|) + (COND + ((SPADLET |o| + (|coerceInteractive| (|getValue| |op0|) |$OutputForm|)) + (|outputTran| (|objValUnwrap| |o|))) + ((QUOTE T) NIL))) + ((QUOTE T) |opName0|))) + (COND + ((NULL |opName1|) + (SPADLET |opName1| + (COND + ((SPADLET |o| (|getValue| |op0|)) (|prefix2String| (|objMode| |o|))) + ((QUOTE T) (MAKESTRING "")))) + (SPADLET |msgKey| + (COND + ((NULL |amsl|) (QUOTE S2IB0013)) + ((QUOTE T) (QUOTE S2IB0012))))) + ((QUOTE T) + (SPADLET |msgKey| + (COND + ((NULL |amsl|) (QUOTE S2IB0011)) + ((SPADLET |n| (|isSharpVarWithNum| |opName1|)) + (SPADLET |opName1| |n|) (QUOTE |S2IB0008g|)) + ((QUOTE T) (QUOTE S2IB0008)))))) + (|sayIntelligentMessageAboutOpAvailability| |opName1| (|#| |argl|)) + (COND + ((NULL |$genValue|) + (|keyedMsgCompFailureSP| |msgKey| + (CONS |opName1| (CONS |amsl| NIL)) |op0|)) + ((QUOTE T) + (|throwKeyedMsgSP| |msgKey| + (CONS |opName1| (CONS |amsl| NIL)) |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 + +(DEFUN |sayIntelligentMessageAboutOpAvailability| (|opName| |nArgs|) + (PROG (|oo| |nAllExposedMmsWithName| |nAllMmsWithName| + |nAllExposedMmsWithNameAndArgs| |nAllMmsWithNameAndArgs|) + (RETURN + (COND + ((NUMBERP |opName|) NIL) + ((QUOTE T) + (SPADLET |oo| (|object2Identifier| (|opOf| |opName|))) + (COND + ((OR (BOOT-EQUAL |oo| (QUOTE %)) + (BOOT-EQUAL |oo| (QUOTE |Domain|)) + (|domainForm?| |opName|)) + (SPADLET |opName| (QUOTE |elt|)))) + (SPADLET |nAllExposedMmsWithName| + (|#| (|getModemapsFromDatabase| |opName| NIL))) + (SPADLET |nAllMmsWithName| + (|#| (|getAllModemapsFromDatabase| |opName| NIL))) + (COND + ((EQL |nAllMmsWithName| 0) + (|sayKeyedMsg| (QUOTE |S2IB0008a|) (CONS |opName| NIL))) + ((EQL |nAllExposedMmsWithName| 0) + (COND + ((EQL |nAllMmsWithName| 1) + (|sayKeyedMsg| (QUOTE |S2IB0008b|) (CONS |opName| NIL))) + ((QUOTE T) + (|sayKeyedMsg| (QUOTE |S2IB0008c|) + (CONS |opName| (CONS |nAllMmsWithName| NIL)))))) + ((QUOTE T) + (SPADLET |nAllExposedMmsWithNameAndArgs| + (|#| (|getModemapsFromDatabase| |opName| |nArgs|))) + (SPADLET |nAllMmsWithNameAndArgs| + (|#| (|getAllModemapsFromDatabase| |opName| |nArgs|))) + (COND + ((EQL |nAllMmsWithNameAndArgs| 0) + (|sayKeyedMsg| (QUOTE |S2IB0008d|) + (CONS + |opName| + (CONS + |nArgs| + (CONS + |nAllExposedMmsWithName| + (CONS + (SPADDIFFERENCE |nAllMmsWithName| |nAllExposedMmsWithName|) + NIL)))))) + ((EQL |nAllExposedMmsWithNameAndArgs| 0) + (|sayKeyedMsg| (QUOTE |S2IB0008e|) + (CONS + |opName| + (CONS + |nArgs| + (CONS + (SPADDIFFERENCE |nAllMmsWithNameAndArgs| + |nAllExposedMmsWithNameAndArgs|) + NIL))))) + ((QUOTE T) + (|sayKeyedMsg| (QUOTE |S2IB0008f|) + (CONS + |opName| + (CONS + |nArgs| + (CONS + |nAllExposedMmsWithNameAndArgs| + (CONS + (SPADDIFFERENCE |nAllMmsWithNameAndArgs| + |nAllExposedMmsWithNameAndArgs|) + NIL))))))))) + 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]) + +(DEFUN |bottomUpType| (|t| |type|) + (PROG (|mode| |val|) + (RETURN + (PROGN + (SPADLET |mode| + (COND + ((|isPartialMode| |type|) (QUOTE (|Mode|))) + ((|categoryForm?| |type|) (QUOTE (|SubDomain| (|Domain|)))) + ((QUOTE T) (QUOTE (|Domain|))))) + (SPADLET |val| (|objNew| |type| |mode|)) + (|putValue| |t| |val|) + (|putModeSet| |t| (CONS |mode| NIL)))))) + +;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) + +(DEFUN |bottomUpPercent| (|tree|) + (PROG (|op| |argl| |t| |i| |val|) + (RETURN + (PROGN + (SPADLET |op| (CAR |tree|)) + (SPADLET |argl| (CDR |tree|)) + (COND + ((NULL |argl|) + (SPADLET |val| (|fetchOutput| (SPADDIFFERENCE 1))) + (|putValue| |op| |val|) + (|putModeSet| |op| (CONS (|objMode| |val|) NIL))) + ((AND (PAIRP |argl|) + (EQ (QCDR |argl|) NIL) + (PROGN (SPADLET |t| (QCAR |argl|)) (QUOTE T))) + (COND + ((SPADLET |i| (|getArgValue| |t| |$Integer|)) + (SPADLET |val| (|fetchOutput| |i|)) + (|putValue| |op| |val|) + (|putModeSet| |op| (CONS (|objMode| |val|) NIL))) + ((QUOTE T) + (|throwKeyedMsgSP| (MAKESTRING "S2IB0006") NIL |t|)))) + ((QUOTE T) + (|throwKeyedMsgSP| (MAKESTRING "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) + +(DEFUN |bottomUpFormRetract| (|t| |op| |opName| |argl| |amsl|) + (PROG (|$inRetract| |u| |object| |a| |ms| |typesHad| |b|) + (DECLARE (SPECIAL |$inRetract|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$inRetract| (QUOTE T)) + (COND + ((NULL (|getAllModemapsFromDatabase| (|getUnname| |op|) (|#| |argl|))) + NIL) + ((SPADLET |u| + (|bottomUpFormAnyUnionRetract| |t| |op| |opName| |argl| |amsl|)) + |u|) + ((QUOTE T) + (SPADLET |a| NIL) + (SPADLET |b| NIL) + (SPADLET |ms| NIL) + (DO ((#0=#:G166983 |argl| (CDR #0#)) + (|x| NIL) + (#1=#:G166984 |amsl| (CDR #1#)) + (|m| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM #0#) + (PROGN (SETQ |x| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |m| (CAR #1#)) NIL)) + NIL) + (SEQ + (EXIT + (COND + ((AND (EQL |i| 1) (BOOT-EQUAL |opName| (QUOTE |setelt|))) + (SPADLET |a| (CONS |x| |a|)) (SPADLET |ms| (CONS |m| |ms|))) + ((AND (EQL |i| 1) (BOOT-EQUAL |opName| (QUOTE |set!|))) + (SPADLET |a| (CONS |x| |a|)) (SPADLET |ms| (CONS |m| |ms|))) + ((QUOTE T) + (COND + ((AND (PAIRP |m|) (BOOT-EQUAL (CAR |m|) |$EmptyMode|)) + (RETURN NIL))) + (SPADLET |object| (|retract| (|getValue| |x|))) + (SPADLET |a| (CONS |x| |a|)) + (COND + ((EQ |object| (QUOTE |failed|)) + (|putAtree| |x| (QUOTE |retracted|) NIL) + (SPADLET |ms| (CONS |m| |ms|))) + ((QUOTE T) + (SPADLET |b| (QUOTE T)) + (RPLACA |m| (|objMode| |object|)) + (SPADLET |ms| (CONS (COPY-TREE |m|) |ms|)) + (|putAtree| |x| (QUOTE |retracted|) (QUOTE T)) + (|putValue| |x| |object|) + (|putModeSet| |x| (CONS (|objMode| |object|) NIL))))))))) + (SPADLET |a| (NREVERSE |a|)) + (SPADLET |ms| (NREVERSE |ms|)) + (SPADLET |typesHad| (|getAtree| |t| (QUOTE |typesHad|))) + (COND + ((|member| |ms| |typesHad|) (SPADLET |b| NIL)) + ((QUOTE T) (|putAtree| |t| (QUOTE |typesHad|) (CONS |ms| |typesHad|)))) + (AND |b| (|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 + +(DEFUN |retractAtree| (|atr|) + (PROG (|object|) + (RETURN + (PROGN + (SPADLET |object| (|retract| (|getValue| |atr|))) + (COND + ((EQ |object| (QUOTE |failed|)) + (|putAtree| |atr| (QUOTE |retracted|) NIL) + NIL) + ((QUOTE T) + (|putAtree| |atr| (QUOTE |retracted|) (QUOTE T)) + (|putValue| |atr| |object|) + (|putModeSet| |atr| (CONS (|objMode| |object|) NIL)) + (QUOTE T))))))) + +;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) + +(DEFUN |bottomUpFormAnyUnionRetract| (|t| |op| |opName| |argl| |amsl|) + (PROG (|ok| |m0| |object| |b| |a|) + (RETURN + (SEQ + (PROGN + (SPADLET |ok| NIL) + (DO ((#0=#:G167032 |amsl| (CDR #0#)) (|m| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |m| (CAR #0#)) NIL) (NULL (NULL |ok|))) + NIL) + (SEQ + (EXIT + (PROGN + (COND ((ATOM (CAR |m|)) (RETURN NIL))) + (COND + ((BOOT-EQUAL (CAR |m|) |$Any|) + (SPADLET |ok| (QUOTE T))) + ((BOOT-EQUAL (CAR (CAR |m|)) (QUOTE |Union|)) + (SPADLET |ok| (QUOTE T)))))))) + (COND + ((NULL |ok|) NIL) + ((QUOTE T) + (SPADLET |a| NIL) + (SPADLET |b| NIL) + (DO ((#1=#:G167047 |argl| (CDR #1#)) + (|x| NIL) + (#2=#:G167048 |amsl| (CDR #2#)) + (|m| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM #1#) + (PROGN (SETQ |x| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |m| (CAR #2#)) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |m0| (CAR |m|)) + (COND + ((AND + (OR + (BOOT-EQUAL |m0| |$Any|) + (BOOT-EQUAL (CAR |m0|) (QUOTE |Union|))) + (NEQUAL + (QUOTE |failed|) + (SPADLET |object| (|retract| (|getValue| |x|))))) + (SPADLET |b| (QUOTE T)) + (RPLACA |m| (|objMode| |object|)) + (|putModeSet| |x| (CONS (|objMode| |object|) NIL)) + (|putValue| |x| |object|))) + (SPADLET |a| (CONS |x| |a|)))))) + (AND + |b| + (|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) + +(DEFUN |bottomUpFormUntaggedUnionRetract| (|t| |op| |opName| |argl| |amsl|) + (PROG (|m| |ok| |m0| |object| |b| |a|) + (RETURN + (SEQ + (PROGN + (SPADLET |ok| NIL) + (DO ((#0=#:G167083 |amsl| (CDR #0#)) (#1=#:G167070 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN (PROGN (SPADLET |m| (CAR #1#)) #1#) NIL) + (NULL (NULL |ok|))) + NIL) + (SEQ + (EXIT + (PROGN + (COND ((ATOM |m|) (RETURN NIL))) + (COND + ((AND (PAIRP |m|) + (EQ (QCAR |m|) (QUOTE |Union|)) + (NULL (|getUnionOrRecordTags| |m|))) + (SPADLET |ok| (QUOTE T))) + ((QUOTE T) NIL)))))) + (COND + ((NULL |ok|) NIL) + ((QUOTE T) + (SPADLET |a| NIL) + (SPADLET |b| NIL) + (DO ((#2=#:G167099 |argl| (CDR #2#)) + (|x| NIL) + (#3=#:G167100 |amsl| (CDR #3#)) + (|m| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM #2#) + (PROGN (SETQ |x| (CAR #2#)) NIL) + (ATOM #3#) + (PROGN (SETQ |m| (CAR #3#)) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |m0| (CAR |m|)) + (COND + ((AND (PAIRP |m0|) + (EQ (QCAR |m0|) (QUOTE |Union|)) + (NULL (|getUnionOrRecordTags| |m0|)) + (NEQUAL + (QUOTE |failed|) + (SPADLET |object| (|retract| (|getValue| |x|))))) + (SPADLET |b| (QUOTE T)) + (RPLACA |m| (|objMode| |object|)) + (|putModeSet| |x| (CONS (|objMode| |object|) NIL)) + (|putValue| |x| |object|))) + (SPADLET |a| (CONS |x| |a|)))))) + (AND |b| + (|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 + +(DEFUN |bottomUpElt| (|form|) + (PROG (|op| |argl| |ms| |ISTMP#1| |target| |newOps| |newArgs| |u|) + (RETURN + (SEQ + (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |ms| (|bottomUp| |op|)) + (COND + ((AND |ms| + (OR + (AND + (PAIRP |ms|) + (EQ (QCDR |ms|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |ms|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE |Union|))))) + (AND + (PAIRP |ms|) + (EQ (QCDR |ms|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |ms|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Record|))))))) + (RPLAC (CDR |form|) (CONS |op| |argl|)) + (RPLAC (CAR |form|) (|mkAtreeNode| (QUOTE |elt|))) + (|bottomUp| |form|)) + ((QUOTE T) + (SPADLET |target| (|getTarget| |form|)) + (SPADLET |newOps| + (CONS + (|mkAtreeNode| (QUOTE |elt|)) + (CONS (|mkAtreeNode| (QUOTE |apply|)) NIL))) + (SPADLET |u| NIL) + (DO ((#0=#:G167149 |newOps| (CDR #0#)) (|newOp| NIL)) + ((OR (NULL (NULL |u|)) + (ATOM #0#) + (PROGN (SETQ |newOp| (CAR #0#)) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |newArgs| (CONS |op| |argl|)) + (COND + ((|selectMms| |newOp| |newArgs| |target|) + (RPLAC (CDR |form|) |newArgs|) + (RPLAC (CAR |form|) |newOp|) + (SPADLET |u| (|bottomUp| |form|))) + ((QUOTE T) NIL)))))) + (DO () + ((NULL + (AND + (NULL |u|) + (PROG (#1=#:G167164) + (SPADLET #1# (QUOTE T)) + (RETURN + (DO ((#2=#:G167170 NIL (NULL #1#)) + (#3=#:G167171 |newArgs| (CDR #3#)) + (|a| NIL)) + ((OR #2# (ATOM #3#) (PROGN (SETQ |a| (CAR #3#)) NIL)) #1#) + (SEQ (EXIT (SETQ #1# (AND #1# (|retractAtree| |a|)))))))))) + NIL) + (SEQ + (EXIT + (DO ((#4=#:G167184 |newOps| (CDR #4#)) (|newOp| NIL)) + ((OR (NULL (NULL |u|)) + (ATOM #4#) + (PROGN (SETQ |newOp| (CAR #4#)) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |newArgs| (CONS |op| |argl|)) + (COND + ((|selectMms| |newOp| |newArgs| |target|) + (RPLAC (CDR |form|) |newArgs|) + (RPLAC (CAR |form|) |newOp|) + (SPADLET |u| (|bottomUp| |form|))) + ((QUOTE T) NIL))))))))) + |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 + +(DEFUN |isEltable| (|op| |argl| |numArgs|) + (PROG (|v| |ISTMP#1| |mapDef| |m| |name| |arg|) + (RETURN + (COND + ((SPADLET |v| (|getValue| |op|)) + (COND + ((ZEROP |numArgs|) + (QUOTE T)) + ((NULL (SPADLET |m| (|objMode| |v|))) + NIL) + ((AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Mapping|))) + NIL) + ((AND + (PROGN + (SPADLET |ISTMP#1| (|objVal| |v|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) + (PROGN (SPADLET |mapDef| (QCDR |ISTMP#1|)) (QUOTE T)))) + (> (|numMapArgs| |mapDef|) 0)) + NIL) + ((QUOTE T) (QUOTE T)))) + ((SPADLET |m| (|getMode| |op|)) + (COND + ((ZEROP |numArgs|) (QUOTE T)) + ((AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Mapping|))) NIL) + ((QUOTE T) (QUOTE T)))) + ((NEQUAL |numArgs| 1) NIL) + ((QUOTE T) + (SPADLET |name| (|getUnname| |op|)) + (COND + ((BOOT-EQUAL |name| (QUOTE SEQ)) NIL) + ((QUOTE T) + (SPADLET |arg| (CAR |argl|)) + (COND + ((NEQUAL (|getUnname| |arg|) (QUOTE |construct|)) NIL) + ((QUOTE T) (QUOTE T)))))))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}