1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34--% Interpreter Analysis Functions
35
36--% Basic Object Type Identification
37
38getBasicMode x ==  getBasicMode0(x,$useIntegerSubdomain)
39
40getBasicMode0(x,useIntegerSubdomain) ==
41  --  if x is one of the basic types (Integer String Float Boolean) then
42  --  this function returns its type, and nil otherwise
43  x is nil => $EmptyMode
44  STRINGP x => $String
45  INTEGERP x =>
46    useIntegerSubdomain =>
47      x > 0 => $PositiveInteger
48      x = 0 => $NonNegativeInteger
49      $Integer
50    $Integer
51  FLOATP x => $DoubleFloat
52  (x='noBranch) or (x='noValue) => $NoValueMode
53  nil
54
55getBasicObject x ==
56  INTEGERP    x =>
57    t :=
58      not $useIntegerSubdomain => $Integer
59      x > 0 => $PositiveInteger
60      x = 0 => $NonNegativeInteger
61      $Integer
62    objNewWrap(x,t)
63  STRINGP x => objNewWrap(x,$String)
64  FLOATP  x => objNewWrap(x,$DoubleFloat)
65  NIL
66
67getMinimalVariableTower(var,t) ==
68  -- gets the minimal polynomial subtower of t that contains the
69  -- given variable. Returns NIL if none.
70  STRINGP(t) or IDENTP(t) => NIL
71  t = $Symbol => t
72  t is ['Variable,u] =>
73    (u = var) => t
74    NIL
75  t is ['Polynomial,.] => t
76  t is [up,t',u,.] and MEMQ(up,$univariateDomains) =>
77    -- power series have one more arg and different ordering
78    u = var => t
79    getMinimalVariableTower(var,t')
80  t is [up,u,t'] and MEMQ(up,$univariateDomains) =>
81    u = var => t
82    getMinimalVariableTower(var,t')
83  t is [mp,u,t'] and MEMQ(mp,$multivariateDomains) =>
84    var in u => t
85    getMinimalVariableTower(var,t')
86  null (t' := underDomainOf t) => NIL
87  getMinimalVariableTower(var,t')
88
89getMinimalVarMode(id,m) ==
90  --  This function finds the minimum polynomial subtower type of the
91  --  polynomial domain tower m which id to which can be coerced
92  --  It includes all polys above the found level if they are
93  --  contiguous.
94  --  E.g.:    x and G P[y] P[x] I ---> P[y] P[x] I
95  --           x and P[y] G P[x] I ---> P[x] I
96  m is ['Mapping, :.] => m
97  defaultMode :=
98    $Symbol
99  null m => defaultMode
100  (vl := polyVarlist m) and ((id in vl) or 'all in vl) =>
101    SUBSTQ('(Integer),$EmptyMode,m)
102  (um := underDomainOf m) => getMinimalVarMode(id,um)
103  defaultMode
104
105polyVarlist m ==
106  --  If m is a polynomial type this function returns a list of its
107  --  top level variables, and nil otherwise
108  -- ignore any QuotientFields that may separate poly types
109  m is [=$QuotientField,op] => polyVarlist op
110  m is [op,a,:.] =>
111    op in '(UnivariateTaylorSeries UnivariateLaurentSeries
112      UnivariatePuiseuxSeries) =>
113        [., ., a, :.] := m
114        a := removeQuote a
115        [a]
116    op in '(Polynomial Expression) =>
117      '(all)
118    a := removeQuote a
119    op in '(UnivariatePolynomial) =>
120      [a]
121    op in $multivariateDomains =>
122          a
123  nil
124
125--% Pushing Down Target Information
126
127pushDownTargetInfo(op,target,arglist) ==
128  -- put target info on args for certain operations
129  target = $OutputForm => NIL
130  target = $Any        => NIL
131  target is ['Union, dom, tag] and tag = '"failed" => NIL
132  n := LENGTH arglist
133  pushDownOnArithmeticVariables(op,target,arglist)
134  (pdArgs := pushDownOp?(op,n)) =>
135    for i in pdArgs repeat
136      x := arglist.i
137      if not getTarget(x) then putTarget(x,target)
138  nargs := #arglist
139  1 = nargs =>
140    (op = 'SEGMENT) and (target is ['UniversalSegment,S]) =>
141      for x in arglist repeat
142        if not getTarget(x) then putTarget(x,S)
143  2 = nargs =>
144    op = "*" =>            -- only push down on 1st arg if not immed
145      if not getTarget CADR arglist then putTarget(CADR arglist,target)
146      getTarget(x := first arglist) => NIL
147      if getUnname(x) ~= $immediateDataSymbol then putTarget(x,target)
148    op = "**" or op = "^" =>           -- push down on base
149      if not getTarget first arglist then putTarget(first arglist, target)
150    (op = 'equation) and (target is ['Equation,S]) =>
151      for x in arglist repeat
152        if not getTarget(x) then putTarget(x,S)
153    (op = '_/) =>
154      targ :=
155        target is ['Fraction,S] => S
156        target
157      for x in arglist repeat
158        if not getTarget(x) then putTarget(x,targ)
159    (op = 'SEGMENT) and (target is ['Segment,S]) =>
160      for x in arglist repeat
161        if not getTarget(x) then putTarget(x,S)
162    (op = 'SEGMENT) and (target is ['UniversalSegment,S]) =>
163      for x in arglist repeat
164        if not getTarget(x) then putTarget(x,S)
165    NIL
166  NIL
167
168pushDownOnArithmeticVariables(op,target,arglist) ==
169  -- tries to push appropriate target information onto variable
170  -- occurring in arithmetic expressions
171  PAIRP(target) and first(target) = 'Variable => NIL
172  not MEMQ(op,'(_+ _- _* _*_* _/)) => NIL
173  not containsPolynomial(target)   => NIL
174  for x in arglist for i in 1.. repeat
175    VECP(x) =>   -- leaf
176      transferPropsToNode(xn := getUnname(x),x)
177      getValue(x) or (xn = $immediateDataSymbol) => NIL
178      t := getMinimalVariableTower(xn,target) or target
179      if not getTarget(x) then putTarget(x,t)
180    PAIRP(x) =>  -- node
181      [op',:arglist'] := x
182      pushDownOnArithmeticVariables(getUnname op',target,arglist')
183  arglist
184
185pushDownOp?(op,n) ==
186  -- determine if for op with n arguments whether for all modemaps
187  -- the target type is equal to one or more arguments. If so, a list
188  -- of the appropriate arguments is returned.
189  ops := [sig for [sig,:.] in getModemapsFromDatabase(op,n)]
190  null ops => NIL
191  op in '(_+ _* _- _exquo) => [i for i in 0..(n-1)]
192  -- each signature has form
193  -- [domain of implementation, target, arg1, arg2, ...]
194  -- sameAsTarg is a vector that counts the number of modemaps that
195  -- have the corresponding argument equal to the target type
196  sameAsTarg := GETZEROVEC n
197  numMms := LENGTH ops
198  for [.,targ,:argl] in ops repeat
199    for arg in argl for i in 0.. repeat
200      targ = arg => SETELT(sameAsTarg,i,1 + sameAsTarg.i)
201  -- now see which args have their count = numMms
202  ok := NIL
203  for i in 0..(n-1) repeat
204    if numMms = sameAsTarg.i then ok := cons(i,ok)
205  reverse ok
206
207--% Bottom Up Processing
208
209-- Also see I-SPEC BOOT for special handlers and I-MAP BOOT for
210-- user function processing.
211
212bottomUp t ==
213  -- bottomUp takes an attributed tree, and returns the modeSet for it.
214  -- As a side-effect it also evaluates the tree.
215  t is [op,:argl] =>
216    tar := getTarget op
217    getUnname(op) ~= $immediateDataSymbol and (v := getValue op) =>
218      om := objMode(v)
219      null tar => [om]
220      (r := resolveTM(om,tar)) => [r]
221      [om]
222    if atom op then
223      opName:= getUnname op
224      if opName in $localVars then
225        putModeSet(op,bottomUpIdentifier(op,opName))
226      else
227        transferPropsToNode(opName,op)
228    else
229      opName := NIL
230      bottomUp op
231
232    opVal := getValue op
233
234    -- call a special handler if we are not being package called
235    dol := getAtree(op,'dollar) and (opName ~= 'construct)
236
237    (null dol) and (fn := GET(opName, "up")) and (u := FUNCALL(fn, t)) => u
238    nargs := #argl
239    if opName then for x in argl for i in 1.. repeat
240      putAtree(x,'callingFunction,opName)
241      putAtree(x,'argumentNumber,i)
242      putAtree(x,'totalArgs,nargs)
243
244    if tar then pushDownTargetInfo(opName,tar,argl)
245
246    -- see if we are calling a declared user map
247    -- if so, push down the declared types as targets on the args
248    if opVal and (objVal opVal  is ['SPADMAP,:.]) and
249      (getMode op is ['Mapping,:ms]) and (nargs + 1= #ms) then
250        for m in rest ms for x in argl repeat putTarget(x,m)
251
252    argModeSetList:= [bottomUp x for x in argl]
253
254    if not tar and opName = "*" and nargs = 2 then
255        [[t1],[t2]] := argModeSetList
256        tar := computeTypeWithVariablesTarget(t1, t2)
257        tar =>
258            pushDownTargetInfo(opName,tar,argl)
259            argModeSetList:= [bottomUp x for x in argl]
260
261    ms := bottomUpForm(t,op,opName,argl,argModeSetList)
262    -- If this is a type producing form, then we don't want
263    -- to store the representation object in the environment.
264    -- Rather, we want to record the reified canonical form.
265    if ms is [m] and (m is ["Mode"] or isCategoryForm(m))
266    then putValue(t,objNew(devaluate objValUnwrap getValue t, m))
267
268    -- given no target or package calling, force integer constants to
269    -- belong to tightest possible subdomain
270
271    op := first t                -- may have changed in bottomUpElt
272    $useIntegerSubdomain and null tar and null dol and
273      isEqualOrSubDomain(first ms,$Integer) =>
274        val := objVal getValue op
275        isWrapped val =>       -- constant if wrapped
276          val := unwrap val
277          bm := getBasicMode val
278          putValue(op,objNewWrap(val,bm))
279          putModeSet(op,[bm])
280        ms
281    ms
282  m := getBasicMode t => [m]
283  IDENTP (id := getUnname t) =>
284    putModeSet(t,bottomUpIdentifier(t,id))
285  keyedSystemError("S2GE0016",['"bottomUp",'"unknown object form"])
286
287computeTypeWithVariablesTarget(p, q) ==
288    polyVarlist(p) or polyVarlist(q) =>
289        t := resolveTT(p, q)
290        polyVarlist(t) => t
291        NIL
292    NIL
293
294bottomUpCompile t ==
295  $genValue:local := false
296  ms := bottomUp t
297  compTran1 objVal getValue t
298  ms
299
300bottomUpUseSubdomain t ==
301  $useIntegerSubdomain : local := true
302  ms := bottomUp t
303  ($immediateDataSymbol ~= getUnname(t)) or ($Integer ~= first(ms)) => ms
304  null INTEGERP(num := objValUnwrap getValue t) => ms
305  o := getBasicObject(num)
306  putValue(t,o)
307  ms := [objMode o]
308  putModeSet(t,ms)
309  ms
310
311bottomUpPredicate(pred, name) ==
312  putTarget(pred,$Boolean)
313  ms := bottomUp pred
314  $Boolean ~= first ms => throwKeyedMsg("S2IB0001", [name])
315  ms
316
317bottomUpCompilePredicate(pred, name) ==
318  $genValue:local := false
319  bottomUpPredicate(pred,name)
320
321bottomUpIdentifier(t,id) ==
322  m := isType t => bottomUpType(t, m)
323  EQ(id,'noMapVal) => throwKeyedMsg("S2IB0002", NIL)
324  EQ(id,'noBranch) =>
325    keyedSystemError("S2GE0016",
326      ['"bottomUpIdentifier",'"trying to evaluate noBranch"])
327  transferPropsToNode(id,t)
328  defaultType := ['Variable,id]
329  -- This was meant to stop building silly symbols but had some unfortunate
330  -- side effects, like not being able to say e:=foo in the interpreter.  MCD
331--  defaultType :=
332--    getModemapsFromDatabase(id,1) =>
333--      userError ['"Cannot use operation name as a variable: ", id]
334--    ['Variable, id]
335  u := getValue t => --non-cached values MAY be re-evaluated
336    tar := getTarget t
337    expr:= objVal u
338    om := objMode(u)
339    (om ~= $EmptyMode) and (om isnt ['RuleCalled,.]) =>
340      $genValue or GENSYMP(id) =>
341        null tar => [om]
342        (r := resolveTM(om,tar)) => [r]
343        [om]
344      bottomUpDefault(t,id,defaultType,getTarget t)
345    interpRewriteRule(t,id,expr) or
346      (isMapExpr expr and [objMode(u)]) or
347        keyedSystemError("S2GE0016",
348          ['"bottomUpIdentifier",'"cannot evaluate identifier"])
349  bottomUpDefault(t,id,defaultType,getTarget t)
350
351bottomUpDefault(t,id,defaultMode,target) ==
352  if $genValue
353    then bottomUpDefaultEval(t,id,defaultMode,target,nil)
354    else bottomUpDefaultCompile(t,id,defaultMode,target,nil)
355
356bottomUpDefaultEval(t,id,defaultMode,target,isSub) ==
357  -- try to get value case.
358
359  -- 1. declared mode but no value case
360  (m := getMode t) =>
361    m is ['Mapping,:.] => throwKeyedMsg("S2IB0003",[getUnname t])
362
363    -- hmm, try to treat it like target mode or declared mode
364    if isPartialMode(m) then m := resolveTM(['Variable,id],m)
365    -- if there is a target, probably want it to be that way and not
366    -- declared mode. Like "x" in second line:
367    --   x : P[x] I
368    --   y : P[x] I
369    target and not isSub and
370      (val := coerceInteractive(objNewWrap(id,['Variable,id]),target))=>
371        putValue(t,val)
372        [target]
373    -- Ok, see if we can make it into declared mode from symbolic form
374    -- For example, (x : P[x] I; x + 1)
375    not target and not isSub and m and
376      (val := coerceInteractive(objNewWrap(id,['Variable,id]),m)) =>
377        putValue(t,val)
378        [m]
379    -- give up
380    throwKeyedMsg("S2IB0004", [id, m])
381
382  -- 2. no value and no mode case
383  val := objNewWrap(id,defaultMode)
384  (null target) or (defaultMode = target) =>
385    putValue(t,val)
386    [defaultMode]
387  if isPartialMode target then
388    -- this hackery will go away when Symbol is not the default type
389    if defaultMode = $Symbol and (target is [D,x,.]) then
390      (D in $univariateDomains and (x = id)) or
391        (D in $multivariateDomains and (id in x)) =>
392           dmode := [D,x,$Integer]
393           (val' := coerceInteractive(objNewWrap(id,
394             ['Variable,id]),dmode)) =>
395               defaultMode := dmode
396               val := val'
397      NIL
398    target := resolveTM(defaultMode,target)
399  -- The following is experimental.  SCM 10/11/90
400  if target and (tm := getMinimalVarMode(id, target)) then
401    target := tm
402  (null target) or null (val' := coerceInteractive(val,target)) =>
403    putValue(t,val)
404    [defaultMode]
405  putValue(t,val')
406  [target]
407
408bottomUpDefaultCompile(t,id,defaultMode,target,isSub) ==
409  tmode := getMode t
410  tval  := getValue t
411  expr:=
412    id in $localVars => id
413    tmode or tval =>
414      envMode := tmode or objMode tval
415      envMode is ['Variable, :.] => objVal tval
416      id = $immediateDataSymbol => objVal tval
417      ['getValueFromEnvironment,MKQ id,MKQ envMode]
418    wrap id
419  tmode and tval and (mdv := objMode tval) =>
420    if isPartialMode tmode then
421      null (tmode := resolveTM(mdv,tmode)) =>
422        keyedMsgCompFailure("S2IB0010",NIL)
423    putValue(t,objNew(expr,tmode))
424    [tmode]
425  tmode or (tval and (tmode := objMode tval)) =>
426    putValue(t,objNew(expr,tmode))
427    [tmode]
428  obj := objNew(expr,defaultMode)
429  canCoerceFrom(defaultMode, target) and
430    (obj' := coerceInteractive(obj, target)) =>
431        putValue(t, obj')
432        [target]
433  putValue(t,obj)
434  [defaultMode]
435
436interpRewriteRule(t,id,expr) ==
437  null get(id,'isInterpreterRule,$e) => NIL
438  (ms:= selectLocalMms(t,id,nil,nil)) and (ms:=evalForm(t,id,nil,ms)) =>
439    ms
440  nil
441
442bottomUpForm(t,op,opName,argl,argModeSetList) ==
443  not($inRetract) =>
444    bottomUpForm3(t,op,opName,argl,argModeSetList)
445  bottomUpForm2(t,op,opName,argl,argModeSetList)
446
447bottomUpForm3(t,op,opName,argl,argModeSetList) ==
448  $origArgModeSetList:local  := COPY argModeSetList
449  bottomUpForm2(t,op,opName,argl,argModeSetList)
450
451bottomUpForm2(t,op,opName,argl,argModeSetList) ==
452  not atom t and EQ(opName,"%%") => bottomUpPercent t
453  opVal := getValue op
454
455  -- for things with objects in operator position, be careful before
456  -- we enter general modemap selection
457
458  lookForIt :=
459    getAtree(op,'dollar) => true
460    not opVal => true
461    opMode := objMode opVal
462    not (opModeTop := IFCAR opMode) => true
463    opModeTop in '(Record Union) => false
464    opModeTop in '(Variable Mapping FunctionCalled RuleCalled AnonymousFunction) => true
465    false
466
467  -- get rid of Union($, "failed") except when op is "=" and all
468  -- modesets are the same
469
470  $genValue and
471    not (opName = "=" and argModeSetList is [[m],[=m]] and m is ['Union,:.]) and
472      (u := bottomUpFormUntaggedUnionRetract(t,op,opName,argl,argModeSetList)) => u
473
474  lookForIt and (u := bottomUpFormTuple(t, op, opName, argl, argModeSetList)) => u
475
476  -- opName can change in the call to selectMms
477
478  (lookForIt and (mmS := selectMms(op,argl,getTarget op))) and
479    (mS := evalForm(op,opName := getUnname op,argl,mmS)) =>
480      putModeSet(op,mS)
481  bottomUpForm0(t,op,opName,argl,argModeSetList)
482
483bottomUpFormTuple(t, op, opName, args, argModeSetList) ==
484  getAtree(op,'dollar) => NIL
485  null (singles := getModemapsFromDatabase(opName, 1)) => NIL
486
487  -- see if any of the modemaps have Tuple arguments
488  haveTuple := false
489  for mm in singles while not haveTuple repeat
490    if getFirstArgTypeFromMm(mm) is ["Tuple",.] then haveTuple := true
491  not haveTuple => nil
492  nargs := #args
493  nargs = 1 and getUnname first args = "Tuple" => NIL
494  nargs = 1 and (ms := bottomUp first args) and
495    (ms is [["Tuple",.]] or ms is [["List",.]]) => NIL
496
497  -- now make the args into a tuple
498
499  newArg := [mkAtreeNode "Tuple",:args]
500  bottomUp [op, newArg]
501
502printableArgModeSetList() ==
503  amsl := nil
504  for a in reverse $origArgModeSetList repeat
505    b := prefix2String first a
506    if ATOM b then b := [b]
507    amsl := ['%l,:b,:amsl]
508  if amsl then amsl := rest amsl
509  amsl
510
511bottomUpForm0(t,op,opName,argl,argModeSetList) ==
512  op0 := op
513  opName0 := opName
514
515  m := isType t =>
516    bottomUpType(t, m)
517
518  opName = 'copy and argModeSetList is [[['Record,:rargs]]] =>
519    -- this is a hack until Records go through the normal
520    -- modemap selection process
521    rtype := ['Record,:rargs]
522    code := optRECORDCOPY(['RECORDCOPY, getArgValue(first argl, rtype),
523                           #rargs])
524    if $genValue then code := wrap timedEVALFUN code
525    val := objNew(code,rtype)
526    putValue(t,val)
527    putModeSet(t,[rtype])
528
529  m := getModeOrFirstModeSetIfThere op
530  m is ['Record,:.] and argModeSetList is [[['Variable,x]]] and
531      member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u
532  m is ['Union,:.] and argModeSetList is [[['Variable,x]]] =>
533      member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u
534      not $genValue =>
535        amsl := printableArgModeSetList()
536        throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op)
537      object := retract getValue op
538      object = 'failed =>
539        throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op)
540      putModeSet(op,[objMode(object)])
541      putValue(op,object)
542      (u := bottomUpElt t) => u
543      bottomUpForm0(t,op,opName,argl,argModeSetList)
544
545  (opName ~= "elt") and (opName ~= "apply") and
546    #argl = 1 and first first argModeSetList is ['Variable, var]
547      and var in '(first last rest) and
548        isEltable(op, argl, #argl) and (u := bottomUpElt t) => u
549
550  $genValue and
551    ( u:= bottomUpFormRetract(t,op,opName,argl,argModeSetList) ) => u
552
553  (opName ~= "elt") and (opName ~= "apply") and
554    isEltable(op, argl, #argl) and (u := bottomUpElt t) => u
555
556  amsl := printableArgModeSetList()
557  opName1 :=
558    opName0 = $immediateDataSymbol =>
559        (o := coerceInteractive(getValue op0,$OutputForm)) =>
560            outputTran2 objValUnwrap o
561        NIL
562    opName0
563
564  if null(opName1) then
565    opName1 :=
566        (o := getValue op0) => prefix2String objMode o
567        '"<unknown type>"
568    msgKey :=
569        null amsl => "S2IB0013"
570        "S2IB0012"
571  else
572    msgKey :=
573        null amsl => "S2IB0011"
574        (n := isSharpVarWithNum opName1) =>
575            opName1 := n
576            "S2IB0008g"
577        "S2IB0008"
578
579  sayIntelligentMessageAboutOpAvailability(opName1, #argl)
580
581  not $genValue =>
582    keyedMsgCompFailureSP(msgKey,[opName1, amsl], op0)
583  throwKeyedMsgSP(msgKey,[opName1, amsl], op0)
584
585sayIntelligentMessageAboutOpAvailability(opName, nArgs) ==
586  -- see if we can give some decent messages about the availability if
587  -- library messages
588
589  NUMBERP opName => NIL
590
591  oo :=  object2Identifier opOf opName
592  if ( oo = "%" ) or ( domainForm? opName ) then
593    opName := "elt"
594
595  nAllExposedMmsWithName := #getModemapsFromDatabase(opName, NIL)
596  nAllMmsWithName        := #getAllModemapsFromDatabase(opName, NIL)
597
598  -- first see if there are ANY ops with this name
599
600  if nAllMmsWithName = 0 then
601    sayKeyedMsg("S2IB0008a", [opName])
602  else if nAllExposedMmsWithName = 0 then
603    nAllMmsWithName = 1 => sayKeyedMsg("S2IB0008b", [opName])
604    sayKeyedMsg("S2IB0008c", [opName, nAllMmsWithName])
605  else
606    -- now talk about specific arguments
607    nAllExposedMmsWithNameAndArgs   := #getModemapsFromDatabase(opName, nArgs)
608    nAllMmsWithNameAndArgs          := #getAllModemapsFromDatabase(opName, nArgs)
609    nAllMmsWithNameAndArgs = 0 =>
610        sayKeyedMsg("S2IB0008d", [opName, nArgs, nAllExposedMmsWithName, nAllMmsWithName - nAllExposedMmsWithName])
611    nAllExposedMmsWithNameAndArgs = 0 =>
612        sayKeyedMsg("S2IB0008e", [opName, nArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs])
613    sayKeyedMsg("S2IB0008f", [opName, nArgs, nAllExposedMmsWithNameAndArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs])
614  nil
615
616bottomUpType(t, type) ==
617  mode :=
618    if isPartialMode type then '(Mode)
619    else if categoryForm?(type) then '(Category)
620         else '(Type)
621  val:= objNew(type,mode)
622  putValue(t,val)
623  -- have to fix the following
624  putModeSet(t,[mode])
625
626bottomUpPercent(tree is [op,:argl]) ==
627  -- handles a call %%(5), which means the output of step 5
628  -- %%() is the same as %%(-1)
629  null argl =>
630    val:= fetchOutput(-1)
631    putValue(op,val)
632    putModeSet(op,[objMode(val)])
633  argl is [t] =>
634    i:= getArgValue(t,$Integer) =>
635      val:= fetchOutput i
636      putValue(op,val)
637      putModeSet(op,[objMode(val)])
638    throwKeyedMsgSP("S2IB0006", NIL, t)
639  throwKeyedMsgSP("S2IB0006", NIL, op)
640
641bottomUpFormRetract(t,op,opName,argl,amsl) ==
642  -- tries to find one argument, which can be pulled back, and calls
643  -- bottomUpForm again. We do not retract the first argument to a
644  -- setelt, because this is presumably a destructive operation and
645  -- the retract can create a new object.
646
647  -- if no such operation exists in the database, don't bother
648  $inRetract: local := true
649  null getAllModemapsFromDatabase(getUnname op,#argl) => NIL
650
651  u := bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) => u
652
653  a  := NIL
654  b  := NIL
655  ms := NIL
656  for x in argl for m in amsl for i in 1.. repeat
657    -- do not retract first arg of a setelt
658    (i = 1) and (opName = "setelt!") =>
659        a := [x,:a]
660        ms := [m,:ms]
661    (i = 1) and (opName = "set!") =>
662        a := [x,:a]
663        ms := [m,:ms]
664    if PAIRP(m) and first(m) = $EmptyMode then return NIL
665    object:= retract getValue x
666    a:= [x,:a]
667    EQ(object,'failed) =>
668        putAtree(x,'retracted,nil)
669        ms := [m, :ms]
670    b:= true
671    RPLACA(m,objMode(object))
672    ms := [COPY_-TREE m, :ms]
673    putAtree(x,'retracted,true)
674    putValue(x,object)
675    putModeSet(x,[objMode(object)])
676  --insert pulled-back items
677  a := nreverse a
678  ms := nreverse ms
679
680  -- check that we haven't seen these types before
681  typesHad := getAtree(t, 'typesHad)
682  if member(ms, typesHad) then b := nil
683  else putAtree(t, 'typesHad, cons(ms, typesHad))
684
685  b and bottomUpForm(t,op,opName,a,amsl)
686
687retractAtree atr ==
688    object:= retract getValue atr
689    EQ(object,'failed) =>
690        putAtree(atr,'retracted,nil)
691        nil
692    putAtree(atr,'retracted,true)
693    putValue(atr,object)
694    putModeSet(atr,[objMode(object)])
695    true
696
697bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) ==
698  -- see if we have a Union
699
700  ok := NIL
701  for m in amsl while not ok repeat
702    if atom first(m) then return NIL
703    first m = $Any => ok := true
704    (first first m = 'Union) => ok := true
705  not ok => NIL
706
707  a:= NIL
708  b:= NIL
709
710  for x in argl for m in amsl for i in 0.. repeat
711    m0 := first m
712    if ( (m0 = $Any) or (first m0 = 'Union) ) and
713      ('failed~=(object:=retract getValue x)) then
714        b := true
715        RPLACA(m,objMode(object))
716        putModeSet(x,[objMode(object)])
717        putValue(x,object)
718    a := cons(x,a)
719  b and bottomUpForm(t,op,opName,nreverse a,amsl)
720
721bottomUpFormUntaggedUnionRetract(t,op,opName,argl,amsl) ==
722  -- see if we have a Union with no tags, if so retract all such guys
723
724  ok := NIL
725  for [m] in amsl while not ok repeat
726    if atom m then return NIL
727    if m is ['Union, :.] and null getUnionOrRecordTags m then ok := true
728  not ok => NIL
729
730  a:= NIL
731  b:= NIL
732
733  for x in argl for m in amsl for i in 0.. repeat
734    m0 := first m
735    if (m0 is ['Union, :.] and null getUnionOrRecordTags m0) and
736      ('failed ~= (object:=retract getValue x)) then
737        b := true
738        RPLACA(m,objMode(object))
739        putModeSet(x,[objMode(object)])
740        putValue(x,object)
741    a := cons(x,a)
742  b and bottomUpForm(t,op,opName,nreverse a,amsl)
743
744bottomUpElt (form:=[op,:argl]) ==
745  -- this transfers expressions that look like function calls into
746  -- forms with elt or apply.
747
748    ms := bottomUp op
749    ms and (ms is [['Union,:.]] or ms is [['Record,:.]]) =>
750        rplac(rest form, [op, :argl])
751        rplac(first form, mkAtreeNode "elt")
752        bottomUp form
753
754    target  := getTarget form
755
756    newOps := [mkAtreeNode "elt", mkAtreeNode "apply"]
757    u := nil
758
759    while not u for newOp in newOps repeat
760        newArgs := [op,:argl]
761        if selectMms(newOp, newArgs, target) then
762            rplac(rest form, newArgs)
763            rplac(first form, newOp)
764            u := bottomUp form
765
766    while not u and ( "and"/[retractAtree(a) for a in newArgs] ) repeat
767        while not u for newOp in newOps repeat
768            newArgs := [op,:argl]
769            if selectMms(newOp, newArgs, target) then
770                rplac(rest form, newArgs)
771                rplac(first form, newOp)
772                u := bottomUp form
773    u
774
775isEltable(op,argl,numArgs) ==
776  -- determines if the object might possible have an elt function
777  -- we exclude Mapping and Variable types explicitly
778  v := getValue op =>
779    ZEROP numArgs => true
780    not(m := objMode(v)) => nil
781    m is ['Mapping, :.] => nil
782    objVal(v) is ['SPADMAP, :mapDef] and numMapArgs(mapDef) > 0 => nil
783    true
784  m := getMode op =>
785    ZEROP numArgs => true
786    m is ['Mapping, :.] => nil
787    true
788  numArgs ~= 1 => nil
789  name := getUnname op
790  name = 'SEQ => nil
791  arg := first argl
792  (getUnname arg) ~= 'construct => nil
793  true
794