aboutsummaryrefslogtreecommitdiff
path: root/src/interp/i-analy.boot.pamphlet
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2007-11-07 20:54:59 +0000
committerdos-reis <gdr@axiomatics.org>2007-11-07 20:54:59 +0000
commit4edaea6cff2d604009b8f2723a9436b0fc97895d (patch)
treeeb5d3765b2e4f131610571cf5f15eef53419fca0 /src/interp/i-analy.boot.pamphlet
parent45ce0071c30e84b72e4c603660285fa6a462e7f7 (diff)
downloadopen-axiom-4edaea6cff2d604009b8f2723a9436b0fc97895d.tar.gz
remove more pamphlets
Diffstat (limited to 'src/interp/i-analy.boot.pamphlet')
-rw-r--r--src/interp/i-analy.boot.pamphlet804
1 files changed, 0 insertions, 804 deletions
diff --git a/src/interp/i-analy.boot.pamphlet b/src/interp/i-analy.boot.pamphlet
deleted file mode 100644
index b89b1df8..00000000
--- a/src/interp/i-analy.boot.pamphlet
+++ /dev/null
@@ -1,804 +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}
-<<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.
-
-@
-<<*>>=
-<<license>>
-
-import '"i-object"
-)package "BOOT"
-
---% Interpreter Analysis Functions
-
-getMinimalVariableTower(var,t) ==
- -- gets the minimal polynomial subtower of t that contains the
- -- given variable. Returns NIL if none.
- STRINGP(t) or IDENTP(t) => NIL
- t = $Symbol => t
- t is ['Variable,u] =>
- (u = var) => t
- NIL
- t is ['Polynomial,.] => t
- t is ['RationalFunction,D] => ['Polynomial,D]
- t is [up,t',u,.] and MEMQ(up,$univariateDomains) =>
- -- power series have one more arg and different ordering
- u = var => t
- getMinimalVariableTower(var,t')
- t is [up,u,t'] and MEMQ(up,$univariateDomains) =>
- u = var => t
- getMinimalVariableTower(var,t')
- t is [mp,u,t'] and MEMQ(mp,$multivariateDomains) =>
- var in u => t
- getMinimalVariableTower(var,t')
- null (t' := underDomainOf t) => NIL
- getMinimalVariableTower(var,t')
-
-getMinimalVarMode(id,m) ==
- -- This function finds the minimum polynomial subtower type of the
- -- polynomial domain tower m which id to which can be coerced
- -- It includes all polys above the found level if they are
- -- contiguous.
- -- E.g.: x and G P[y] P[x] I ---> P[y] P[x] I
- -- x and P[y] G P[x] I ---> P[x] I
- m is ['Mapping, :.] => m
- defaultMode :=
- $Symbol
- null m => defaultMode
- (vl := polyVarlist m) and ((id in vl) or 'all in vl) =>
- SUBSTQ('(Integer),$EmptyMode,m)
- (um := underDomainOf m) => getMinimalVarMode(id,um)
- defaultMode
-
-polyVarlist m ==
- -- If m is a polynomial type this function returns a list of its
- -- top level variables, and nil otherwise
- -- ignore any QuotientFields that may separate poly types
- m is [=$QuotientField,op] => polyVarlist op
- m is [op,a,:.] =>
- op in '(UnivariateTaylorSeries UnivariateLaurentSeries
- UnivariatePuiseuxSeries) =>
- [., ., a, :.] := m
- a := removeQuote a
- [a]
- op in '(Polynomial RationalFunction Expression) =>
- '(all)
- a := removeQuote a
- op in '(UnivariatePolynomial) =>
- [a]
- op in $multivariateDomains =>
- a
- nil
-
---% Pushing Down Target Information
-
-pushDownTargetInfo(op,target,arglist) ==
- -- put target info on args for certain operations
- target = $OutputForm => NIL
- target = $Any => NIL
- n := LENGTH arglist
- pushDownOnArithmeticVariables(op,target,arglist)
- (pdArgs := pushDownOp?(op,n)) =>
- for i in pdArgs repeat
- x := arglist.i
- if not getTarget(x) then putTarget(x,target)
- nargs := #arglist
- 1 = nargs =>
- (op = 'SEGMENT) and (target is ['UniversalSegment,S]) =>
- for x in arglist repeat
- if not getTarget(x) then putTarget(x,S)
- 2 = nargs =>
- op = "*" => -- only push down on 1st arg if not immed
- if not getTarget CADR arglist then putTarget(CADR arglist,target)
- getTarget(x := CAR arglist) => NIL
- if getUnname(x) ^= $immediateDataSymbol then putTarget(x,target)
- op = "**" or op = "^" => -- push down on base
- if not getTarget CAR arglist then putTarget(CAR arglist,target)
- (op = 'equation) and (target is ['Equation,S]) =>
- for x in arglist repeat
- if not getTarget(x) then putTarget(x,S)
- (op = 'gauss) and (target is ['Gaussian,S]) =>
- for x in arglist repeat
- if not getTarget(x) then putTarget(x,S)
- (op = '_/) =>
- targ :=
- target is ['Fraction,S] => S
- target
- for x in arglist repeat
- if not getTarget(x) then putTarget(x,targ)
- (op = 'SEGMENT) and (target is ['Segment,S]) =>
- for x in arglist repeat
- if not getTarget(x) then putTarget(x,S)
- (op = 'SEGMENT) and (target is ['UniversalSegment,S]) =>
- for x in arglist repeat
- if not getTarget(x) then putTarget(x,S)
- NIL
- NIL
-
-pushDownOnArithmeticVariables(op,target,arglist) ==
- -- tries to push appropriate target information onto variable
- -- occurring in arithmetic expressions
- PAIRP(target) and CAR(target) = 'Variable => NIL
- not MEMQ(op,'(_+ _- _* _*_* _/)) => NIL
- not containsPolynomial(target) => NIL
- for x in arglist for i in 1.. repeat
- VECP(x) => -- leaf
- transferPropsToNode(xn := getUnname(x),x)
- getValue(x) or (xn = $immediateDataSymbol) => NIL
- t := getMinimalVariableTower(xn,target) or target
- if not getTarget(x) then putTarget(x,t)
- PAIRP(x) => -- node
- [op',:arglist'] := x
- pushDownOnArithmeticVariables(getUnname op',target,arglist')
- arglist
-
-pushDownOp?(op,n) ==
- -- determine if for op with n arguments whether for all modemaps
- -- the target type is equal to one or more arguments. If so, a list
- -- of the appropriate arguments is returned.
- ops := [sig for [sig,:.] in getModemapsFromDatabase(op,n)]
- null ops => NIL
- op in '(_+ _* _- _exquo) => [i for i in 0..(n-1)]
- -- each signature has form
- -- [domain of implementation, target, arg1, arg2, ...]
- -- sameAsTarg is a vector that counts the number of modemaps that
- -- have the corresponding argument equal to the target type
- sameAsTarg := GETZEROVEC n
- numMms := LENGTH ops
- for [.,targ,:argl] in ops repeat
- for arg in argl for i in 0.. repeat
- targ = arg => SETELT(sameAsTarg,i,1 + sameAsTarg.i)
- -- now see which args have their count = numMms
- ok := NIL
- for i in 0..(n-1) repeat
- if numMms = sameAsTarg.i then ok := cons(i,ok)
- reverse ok
-
---% Bottom Up Processing
-
--- Also see I-SPEC BOOT for special handlers and I-MAP BOOT for
--- user function processing.
-
-bottomUp t ==
- -- bottomUp takes an attributed tree, and returns the modeSet for it.
- -- As a side-effect it also evaluates the tree.
- t is [op,:argl] =>
- tar := getTarget op
- getUnname(op) ^= $immediateDataSymbol and (v := getValue op) =>
- om := objMode(v)
- null tar => [om]
- (r := resolveTM(om,tar)) => [r]
- [om]
- if atom op then
- opName:= getUnname op
- if opName in $localVars then
- putModeSet(op,bottomUpIdentifier(op,opName))
- else
- transferPropsToNode(opName,op)
- else
- opName := NIL
- bottomUp op
-
- opVal := getValue op
-
- -- call a special handler if we are not being package called
- dol := getAtree(op,'dollar) and (opName ^= 'construct)
-
- (null dol) and (fn:= GETL(opName,"up")) and (u:= FUNCALL(fn, t)) => u
- nargs := #argl
- if opName then for x in argl for i in 1.. repeat
- putAtree(x,'callingFunction,opName)
- putAtree(x,'argumentNumber,i)
- putAtree(x,'totalArgs,nargs)
-
- if tar then pushDownTargetInfo(opName,tar,argl)
-
- -- see if we are calling a declared user map
- -- if so, push down the declared types as targets on the args
- if opVal and (objVal opVal is ['MAP,:.]) and
- (getMode op is ['Mapping,:ms]) and (nargs + 1= #ms) then
- for m in rest ms for x in argl repeat putTarget(x,m)
-
- argModeSetList:= [bottomUp x for x in argl]
-
- if ^tar and opName = "*" and nargs = 2 then
- [[t1],[t2]] := argModeSetList
- tar := computeTypeWithVariablesTarget(t1, t2)
- tar =>
- pushDownTargetInfo(opName,tar,argl)
- argModeSetList:= [bottomUp x for x in argl]
-
- ms := bottomUpForm(t,op,opName,argl,argModeSetList)
-
- -- given no target or package calling, force integer constants to
- -- belong to tightest possible subdomain
-
- op := CAR t -- may have changed in bottomUpElt
- $useIntegerSubdomain and null tar and null dol and
- isEqualOrSubDomain(first ms,$Integer) =>
- val := objVal getValue op
- isWrapped val => -- constant if wrapped
- val := unwrap val
- bm := getBasicMode val
- putValue(op,objNewWrap(val,bm))
- putModeSet(op,[bm])
- ms
- ms
- m := getBasicMode t => [m]
- IDENTP (id := getUnname t) =>
- putModeSet(t,bottomUpIdentifier(t,id))
- keyedSystemError("S2GE0016",['"bottomUp",'"unknown object form"])
-
-computeTypeWithVariablesTarget(p, q) ==
- polyVarlist(p) or polyVarlist(q) =>
- t := resolveTT(p, q)
- polyVarlist(t) => t
- NIL
- NIL
-
-bottomUpCompile t ==
- $genValue:local := false
- ms := bottomUp t
- COMP_-TRAN_-1 objVal getValue t
- ms
-
-bottomUpUseSubdomain t ==
- $useIntegerSubdomain : local := true
- ms := bottomUp t
- ($immediateDataSymbol ^= getUnname(t)) or ($Integer ^= CAR(ms)) => ms
- null INTEGERP(num := objValUnwrap getValue t) => ms
- o := getBasicObject(num)
- putValue(t,o)
- ms := [objMode o]
- putModeSet(t,ms)
- ms
-
-bottomUpPredicate(pred, name) ==
- putTarget(pred,$Boolean)
- ms := bottomUp pred
- $Boolean ^= first ms => throwKeyedMsg('"S2IB0001",[name])
- ms
-
-bottomUpCompilePredicate(pred, name) ==
- $genValue:local := false
- bottomUpPredicate(pred,name)
-
-bottomUpIdentifier(t,id) ==
- m := isType t => bottomUpType(t, m)
- EQ(id,'noMapVal) => throwKeyedMsg('"S2IB0002",NIL)
- EQ(id,'noBranch) =>
- keyedSystemError("S2GE0016",
- ['"bottomUpIdentifier",'"trying to evaluate noBranch"])
- transferPropsToNode(id,t)
- defaultType := ['Variable,id]
- -- This was meant to stop building silly symbols but had some unfortunate
- -- side effects, like not being able to say e:=foo in the interpreter. MCD
--- defaultType :=
--- getModemapsFromDatabase(id,1) =>
--- userError ['"Cannot use operation name as a variable: ", id]
--- ['Variable, id]
- u := getValue t => --non-cached values MAY be re-evaluated
- tar := getTarget t
- expr:= objVal u
- om := objMode(u)
- (om ^= $EmptyMode) and (om isnt ['RuleCalled,.]) =>
- $genValue or GENSYMP(id) =>
- null tar => [om]
- (r := resolveTM(om,tar)) => [r]
- [om]
- bottomUpDefault(t,id,defaultType,getTarget t)
- interpRewriteRule(t,id,expr) or
- (isMapExpr expr and [objMode(u)]) or
- keyedSystemError("S2GE0016",
- ['"bottomUpIdentifier",'"cannot evaluate identifier"])
- bottomUpDefault(t,id,defaultType,getTarget t)
-
-bottomUpDefault(t,id,defaultMode,target) ==
- if $genValue
- then bottomUpDefaultEval(t,id,defaultMode,target,nil)
- else bottomUpDefaultCompile(t,id,defaultMode,target,nil)
-
-bottomUpDefaultEval(t,id,defaultMode,target,isSub) ==
- -- try to get value case.
-
- -- 1. declared mode but no value case
- (m := getMode t) =>
- m is ['Mapping,:.] => throwKeyedMsg('"S2IB0003",[getUnname t])
-
- -- hmm, try to treat it like target mode or declared mode
- if isPartialMode(m) then m := resolveTM(['Variable,id],m)
- -- if there is a target, probably want it to be that way and not
- -- declared mode. Like "x" in second line:
- -- x : P[x] I
- -- y : P[x] I
- target and not isSub and
- (val := coerceInteractive(objNewWrap(id,['Variable,id]),target))=>
- putValue(t,val)
- [target]
- -- Ok, see if we can make it into declared mode from symbolic form
- -- For example, (x : P[x] I; x + 1)
- not target and not isSub and m and
- (val := coerceInteractive(objNewWrap(id,['Variable,id]),m)) =>
- putValue(t,val)
- [m]
- -- give up
- throwKeyedMsg('"S2IB0004",[id,m])
-
- -- 2. no value and no mode case
- val := objNewWrap(id,defaultMode)
- (null target) or (defaultMode = target) =>
- putValue(t,val)
- [defaultMode]
- if isPartialMode target then
- -- this hackery will go away when Symbol is not the default type
- if defaultMode = $Symbol and (target is [D,x,.]) then
- (D in $univariateDomains and (x = id)) or
- (D in $multivariateDomains and (id in x)) =>
- dmode := [D,x,$Integer]
- (val' := coerceInteractive(objNewWrap(id,
- ['Variable,id]),dmode)) =>
- defaultMode := dmode
- val := val'
- NIL
- target := resolveTM(defaultMode,target)
- -- The following is experimental. SCM 10/11/90
- if target and (tm := getMinimalVarMode(id, target)) then
- target := tm
- (null target) or null (val' := coerceInteractive(val,target)) =>
- putValue(t,val)
- [defaultMode]
- putValue(t,val')
- [target]
-
-bottomUpDefaultCompile(t,id,defaultMode,target,isSub) ==
- tmode := getMode t
- tval := getValue t
- expr:=
- id in $localVars => id
- tmode or tval =>
- envMode := tmode or objMode tval
- envMode is ['Variable, :.] => objVal tval
- id = $immediateDataSymbol => objVal tval
- ['getValueFromEnvironment,MKQ id,MKQ envMode]
- wrap id
- tmode and tval and (mdv := objMode tval) =>
- if isPartialMode tmode then
- null (tmode := resolveTM(mdv,tmode)) =>
- keyedMsgCompFailure("S2IB0010",NIL)
- putValue(t,objNew(expr,tmode))
- [tmode]
- tmode or (tval and (tmode := objMode tval)) =>
- putValue(t,objNew(expr,tmode))
- [tmode]
- obj := objNew(expr,defaultMode)
- canCoerceFrom(defaultMode, target) and
- (obj' := coerceInteractive(obj, target)) =>
- putValue(t, obj')
- [target]
- putValue(t,obj)
- [defaultMode]
-
-interpRewriteRule(t,id,expr) ==
- null get(id,'isInterpreterRule,$e) => NIL
- (ms:= selectLocalMms(t,id,nil,nil)) and (ms:=evalForm(t,id,nil,ms)) =>
- ms
- nil
-
-bottomUpForm(t,op,opName,argl,argModeSetList) ==
- not($inRetract) =>
- bottomUpForm3(t,op,opName,argl,argModeSetList)
- bottomUpForm2(t,op,opName,argl,argModeSetList)
-
-bottomUpForm3(t,op,opName,argl,argModeSetList) ==
- $origArgModeSetList:local := COPY argModeSetList
- bottomUpForm2(t,op,opName,argl,argModeSetList)
-
-bottomUpForm2(t,op,opName,argl,argModeSetList) ==
- not atom t and EQ(opName,"%%") => bottomUpPercent t
- opVal := getValue op
-
- -- for things with objects in operator position, be careful before
- -- we enter general modemap selection
-
- lookForIt :=
- getAtree(op,'dollar) => true
- not opVal => true
- opMode := objMode opVal
- not (opModeTop := IFCAR opMode) => true
- opModeTop in '(Record Union) => false
- opModeTop in '(Variable Mapping FunctionCalled RuleCalled AnonymousFunction) => true
- false
-
- -- get rid of Union($, "failed") except when op is "=" and all
- -- modesets are the same
-
- $genValue and
- ^(opName = "=" and argModeSetList is [[m],[=m]] and m is ['Union,:.]) and
- (u := bottomUpFormUntaggedUnionRetract(t,op,opName,argl,argModeSetList)) => u
-
- lookForIt and (u := bottomUpFormTuple(t, op, opName, argl, argModeSetList)) => u
-
- -- opName can change in the call to selectMms
-
- (lookForIt and (mmS := selectMms(op,argl,getTarget op))) and
- (mS := evalForm(op,opName := getUnname op,argl,mmS)) =>
- putModeSet(op,mS)
- bottomUpForm0(t,op,opName,argl,argModeSetList)
-
-bottomUpFormTuple(t, op, opName, args, argModeSetList) ==
- getAtree(op,'dollar) => NIL
- null (singles := getModemapsFromDatabase(opName, 1)) => NIL
-
- -- see if any of the modemaps have Tuple arguments
- haveTuple := false
- for mm in singles while not haveTuple repeat
- if getFirstArgTypeFromMm(mm) is ["Tuple",.] then haveTuple := true
- not haveTuple => nil
- nargs := #args
- nargs = 1 and getUnname first args = "Tuple" => NIL
- nargs = 1 and (ms := bottomUp first args) and
- (ms is [["Tuple",.]] or ms is [["List",.]]) => NIL
-
- -- now make the args into a tuple
-
- newArg := [mkAtreeNode "Tuple",:args]
- bottomUp [op, newArg]
-
-removeUnionsAtStart(argl,modeSets) ==
- null $genValue => modeSets
- for arg in argl for ms in modeSets repeat
- null (v := getValue arg) => nil
- m := objMode(v)
- m isnt ['Union,:.] => nil
- val := objVal(v)
- null isWrapped val => nil
- val' := retract v
- m' := objMode val'
- putValue(arg,val')
- putModeSet(arg,[m'])
- RPLACA(ms,m')
- modeSets
-
-printableArgModeSetList() ==
- amsl := nil
- for a in reverse $origArgModeSetList repeat
- b := prefix2String first a
- if ATOM b then b := [b]
- amsl := ['%l,:b,:amsl]
- if amsl then amsl := rest amsl
- amsl
-
-bottomUpForm0(t,op,opName,argl,argModeSetList) ==
- op0 := op
- opName0 := opName
-
- m := isType t =>
- bottomUpType(t, m)
-
- opName = 'copy and argModeSetList is [[['Record,:rargs]]] =>
- -- this is a hack until Records go through the normal
- -- modemap selection process
- rtype := ['Record,:rargs]
- code := optRECORDCOPY(['RECORDCOPY,getArgValue(CAR argl, rtype),#rargs])
-
- if $genValue then code := wrap timedEVALFUN code
- val := objNew(code,rtype)
- putValue(t,val)
- putModeSet(t,[rtype])
-
- m := getModeOrFirstModeSetIfThere op
- m is ['Record,:.] and argModeSetList is [[['Variable,x]]] and
- member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u
- m is ['Union,:.] and argModeSetList is [[['Variable,x]]] =>
- member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u
- not $genValue =>
- amsl := printableArgModeSetList()
- throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op)
- object := retract getValue op
- object = 'failed =>
- throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op)
- putModeSet(op,[objMode(object)])
- putValue(op,object)
- (u := bottomUpElt t) => u
- bottomUpForm0(t,op,opName,argl,argModeSetList)
-
- (opName ^= "elt") and (opName ^= "apply") and
- #argl = 1 and first first argModeSetList is ['Variable, var]
- and var in '(first last rest) and
- isEltable(op, argl, #argl) and (u := bottomUpElt t) => u
-
- $genValue and
- ( u:= bottomUpFormRetract(t,op,opName,argl,argModeSetList) ) => u
-
- (opName ^= "elt") and (opName ^= "apply") and
- isEltable(op, argl, #argl) and (u := bottomUpElt t) => u
-
- if FIXP $HTCompanionWindowID then
- mkCompanionPage('operationError, t)
-
- amsl := printableArgModeSetList()
- opName1 :=
- opName0 = $immediateDataSymbol =>
- (o := coerceInteractive(getValue op0,$OutputForm)) =>
- outputTran objValUnwrap o
- NIL
- opName0
-
- if null(opName1) then
- opName1 :=
- (o := getValue op0) => prefix2String objMode o
- '"<unknown type>"
- msgKey :=
- null amsl => "S2IB0013"
- "S2IB0012"
- else
- msgKey :=
- null amsl => "S2IB0011"
- (n := isSharpVarWithNum opName1) =>
- opName1 := n
- "S2IB0008g"
- "S2IB0008"
-
- sayIntelligentMessageAboutOpAvailability(opName1, #argl)
-
- not $genValue =>
- keyedMsgCompFailureSP(msgKey,[opName1, amsl], op0)
- throwKeyedMsgSP(msgKey,[opName1, amsl], op0)
-
-sayIntelligentMessageAboutOpAvailability(opName, nArgs) ==
- -- see if we can give some decent messages about the availability if
- -- library messages
-
- NUMBERP opName => NIL
-
- oo := object2Identifier opOf opName
- if ( oo = "%" ) or ( oo = "Domain" ) or ( domainForm? opName ) then
- opName := "elt"
-
- nAllExposedMmsWithName := #getModemapsFromDatabase(opName, NIL)
- nAllMmsWithName := #getAllModemapsFromDatabase(opName, NIL)
-
- -- first see if there are ANY ops with this name
-
- if nAllMmsWithName = 0 then
- sayKeyedMsg("S2IB0008a", [opName])
- else if nAllExposedMmsWithName = 0 then
- nAllMmsWithName = 1 => sayKeyedMsg("S2IB0008b", [opName])
- sayKeyedMsg("S2IB0008c", [opName, nAllMmsWithName])
- else
- -- now talk about specific arguments
- nAllExposedMmsWithNameAndArgs := #getModemapsFromDatabase(opName, nArgs)
- nAllMmsWithNameAndArgs := #getAllModemapsFromDatabase(opName, nArgs)
- nAllMmsWithNameAndArgs = 0 =>
- sayKeyedMsg("S2IB0008d", [opName, nArgs, nAllExposedMmsWithName, nAllMmsWithName - nAllExposedMmsWithName])
- nAllExposedMmsWithNameAndArgs = 0 =>
- sayKeyedMsg("S2IB0008e", [opName, nArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs])
- sayKeyedMsg("S2IB0008f", [opName, nArgs, nAllExposedMmsWithNameAndArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs])
- nil
-
-bottomUpType(t, type) ==
- mode :=
- if isPartialMode type then '(Mode)
- else if categoryForm?(type) then '(SubDomain (Domain))
- else '(Domain)
- val:= objNew(type,mode)
- putValue(t,val)
- -- have to fix the following
- putModeSet(t,[mode])
-
-bottomUpPercent(tree is [op,:argl]) ==
- -- handles a call %%(5), which means the output of step 5
- -- %%() is the same as %%(-1)
- null argl =>
- val:= fetchOutput(-1)
- putValue(op,val)
- putModeSet(op,[objMode(val)])
- argl is [t] =>
- i:= getArgValue(t,$Integer) =>
- val:= fetchOutput i
- putValue(op,val)
- putModeSet(op,[objMode(val)])
- throwKeyedMsgSP('"S2IB0006",NIL,t)
- throwKeyedMsgSP('"S2IB0006",NIL,op)
-
-bottomUpFormRetract(t,op,opName,argl,amsl) ==
- -- tries to find one argument, which can be pulled back, and calls
- -- bottomUpForm again. We do not retract the first argument to a
- -- setelt, because this is presumably a destructive operation and
- -- the retract can create a new object.
-
- -- if no such operation exists in the database, don't bother
- $inRetract: local := true
- null getAllModemapsFromDatabase(getUnname op,#argl) => NIL
-
- u := bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) => u
-
- a := NIL
- b := NIL
- ms := NIL
- for x in argl for m in amsl for i in 1.. repeat
- -- do not retract first arg of a setelt
- (i = 1) and (opName = "setelt") =>
- a := [x,:a]
- ms := [m,:ms]
- (i = 1) and (opName = "set!") =>
- a := [x,:a]
- ms := [m,:ms]
- if PAIRP(m) and CAR(m) = $EmptyMode then return NIL
- object:= retract getValue x
- a:= [x,:a]
- EQ(object,'failed) =>
- putAtree(x,'retracted,nil)
- ms := [m, :ms]
- b:= true
- RPLACA(m,objMode(object))
- ms := [COPY_-TREE m, :ms]
- putAtree(x,'retracted,true)
- putValue(x,object)
- putModeSet(x,[objMode(object)])
- --insert pulled-back items
- a := nreverse a
- ms := nreverse ms
-
- -- check that we haven't seen these types before
- typesHad := getAtree(t, 'typesHad)
- if member(ms, typesHad) then b := nil
- else putAtree(t, 'typesHad, cons(ms, typesHad))
-
- b and bottomUpForm(t,op,opName,a,amsl)
-
-retractAtree atr ==
- object:= retract getValue atr
- EQ(object,'failed) =>
- putAtree(atr,'retracted,nil)
- nil
- putAtree(atr,'retracted,true)
- putValue(atr,object)
- putModeSet(atr,[objMode(object)])
- true
-
-bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) ==
- -- see if we have a Union
-
- ok := NIL
- for m in amsl while not ok repeat
- if atom first(m) then return NIL
- first m = $Any => ok := true
- (first first m = 'Union) => ok := true
- not ok => NIL
-
- a:= NIL
- b:= NIL
-
- for x in argl for m in amsl for i in 0.. repeat
- m0 := first m
- if ( (m0 = $Any) or (first m0 = 'Union) ) and
- ('failed^=(object:=retract getValue x)) then
- b := true
- RPLACA(m,objMode(object))
- putModeSet(x,[objMode(object)])
- putValue(x,object)
- a := cons(x,a)
- b and bottomUpForm(t,op,opName,nreverse a,amsl)
-
-bottomUpFormUntaggedUnionRetract(t,op,opName,argl,amsl) ==
- -- see if we have a Union with no tags, if so retract all such guys
-
- ok := NIL
- for [m] in amsl while not ok repeat
- if atom m then return NIL
- if m is ['Union, :.] and null getUnionOrRecordTags m then ok := true
- not ok => NIL
-
- a:= NIL
- b:= NIL
-
- for x in argl for m in amsl for i in 0.. repeat
- m0 := first m
- if (m0 is ['Union, :.] and null getUnionOrRecordTags m0) and
- ('failed ^= (object:=retract getValue x)) then
- b := true
- RPLACA(m,objMode(object))
- putModeSet(x,[objMode(object)])
- putValue(x,object)
- a := cons(x,a)
- b and bottomUpForm(t,op,opName,nreverse a,amsl)
-
-bottomUpElt (form:=[op,:argl]) ==
- -- this transfers expressions that look like function calls into
- -- forms with elt or apply.
-
- ms := bottomUp op
- ms and (ms is [['Union,:.]] or ms is [['Record,:.]]) =>
- RPLAC(CDR form, [op,:argl])
- RPLAC(CAR form, mkAtreeNode "elt")
- bottomUp form
-
- target := getTarget form
-
- newOps := [mkAtreeNode "elt", mkAtreeNode "apply"]
- u := nil
-
- while ^u for newOp in newOps repeat
- newArgs := [op,:argl]
- if selectMms(newOp, newArgs, target) then
- RPLAC(CDR form, newArgs)
- RPLAC(CAR form, newOp)
- u := bottomUp form
-
- while ^u and ( "and"/[retractAtree(a) for a in newArgs] ) repeat
- while ^u for newOp in newOps repeat
- newArgs := [op,:argl]
- if selectMms(newOp, newArgs, target) then
- RPLAC(CDR form, newArgs)
- RPLAC(CAR form, newOp)
- u := bottomUp form
- u
-
-isEltable(op,argl,numArgs) ==
- -- determines if the object might possible have an elt function
- -- we exclude Mapping and Variable types explicitly
- v := getValue op =>
- ZEROP numArgs => true
- not(m := objMode(v)) => nil
- m is ['Mapping, :.] => nil
- objVal(v) is ['MAP, :mapDef] and numMapArgs(mapDef) > 0 => nil
- true
- m := getMode op =>
- ZEROP numArgs => true
- m is ['Mapping, :.] => nil
- true
- numArgs ^= 1 => nil
- name := getUnname op
- name = 'SEQ => nil
---not (name in '(a e h s)) and getAllModemapsFromDatabase(name, nil) => nil
- arg := first argl
- (getUnname arg) ^= 'construct => nil
- true
-
-@
-\eject
-\begin{thebibliography}{99}
-\bibitem{1} nothing
-\end{thebibliography}
-\end{document}