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