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--% Debugging Functions 35 36level(:l) == 37 null l => same() 38 l is [n] and INTEGERP n => displayComp ($level:= n) 39 SAY '"Correct format: (level n) where n is the level you want to go to" 40 41up() == displayComp ($level:= $level-1) 42 43same() == displayComp $level 44 45down() == displayComp ($level:= $level+1) 46 47displaySemanticErrors() == 48 n:= #($semanticErrorStack:= REMDUP $semanticErrorStack) 49 n=0 => nil 50 l:= NREVERSE $semanticErrorStack 51 $semanticErrorStack:= nil 52 sayBrightly bright '" Semantic Errors:" 53 displaySemanticError(l,CUROUTSTREAM) 54 sayBrightly '" " 55 displayWarnings() 56 57displaySemanticError(l,stream) == 58 for x in l for i in 1.. repeat 59 sayBrightly2(['" [", i, '"] ", :first x], stream) 60 61displayWarnings() == 62 n:= #($warningStack:= REMDUP $warningStack) 63 n=0 => nil 64 sayBrightly bright '" Warnings:" 65 l := NREVERSE $warningStack 66 displayWarning(l,CUROUTSTREAM) 67 $warningStack:= nil 68 sayBrightly '" " 69 70displayWarning(l,stream) == 71 for x in l for i in 1.. repeat 72 sayBrightly2(['" [", i, '"] ", :x], stream) 73 74displayComp level == 75 $bright:= " << " 76 $dim:= " >> " 77 if $insideCapsuleFunctionIfTrue=true then 78 sayBrightly ['"error in function",'%b,$op,'%d,'%l] 79 --mathprint removeZeroOne mkErrorExpr level 80 pp removeZeroOne mkErrorExpr level 81 sayBrightly ['"****** level",'%b,level,'%d,'" ******"] 82 [$x, $m, $f, $exitModeStack] := $s.(level - 1) 83 ($X:=$x;$M:=$m;$F:=$f) 84 SAY("$x:= ",$x) 85 SAY("$m:= ",$m) 86 SAY "$f:=" 87 limited_print1_stdout($f) 88 nil 89 90mkErrorExpr level == 91 bracket ASSOCLEFT DROP(level-#$s,$s) where 92 bracket l == 93 #l<2 => l 94 l is [a,b] => 95 highlight(b,a) where 96 highlight(b,a) == 97 atom b => 98 substitute(var,b,a) where 99 var:= INTERN STRCONC(STRINGIMAGE $bright,STRINGIMAGE b,STRINGIMAGE $dim) 100 highlight1(b,a) where 101 highlight1(b,a) == 102 atom a => a 103 a is [ =b,:c] => [$bright,b,$dim,:c] 104 [highlight1(b,first a),:highlight1(b,rest a)] 105 substitute(bracket rest l,first rest l,first l) 106 107errorRef s == stackWarning ['%b,s,'%d,'"has no value"] 108 109unErrorRef s == unStackWarning ['%b,s,'%d,'"has no value"] 110 111--% ENVIRONMENT FUNCTIONS 112 113consProplistOf(var,proplist,prop,val) == 114 semchkProplist(var,proplist,prop,val) 115 $InteractiveMode and (u:= assoc(prop,proplist)) => 116 RPLACD(u,val) 117 proplist 118 [[prop,:val],:proplist] 119 120warnLiteral x == 121 stackSemanticError(['%b,x,'%d, 122 '"is BOTH a variable and a literal"],nil) 123 124intersectionEnvironment(e,e') == 125 ce:= makeCommonEnvironment(e,e') 126 ic := intersectionContour(deltaContour(e, ce), deltaContour(e', ce), ce) 127 e'':= (ic => addContour(ic,ce); ce) 128 --$ie:= e'' this line is for debugging purposes only 129 130deltaContour([il1, :el],[il2, :el']) == 131 not el=el' => systemError '"deltaContour" --a cop out for now 132 n1 := #il1 133 n2 := #il2 134 dl := [] 135 for i in 1..(n1 - n2) repeat 136 dl := cons(first(il1), dl) 137 il1 := rest(il1) 138 c1 := first(il1) 139 c2 := first(il2) 140 rest(il1) ~= rest(il2) => systemError '"deltaContour 2" --a cop out for now 141 cd := [first x for x in tails c1 while (x~=c2)] 142 dl := cons(cd, dl) 143 res0 := [] 144 for l in dl repeat 145 res0 := APPEND(l, res0) 146 res := eliminateDuplicatePropertyLists res0 where 147 eliminateDuplicatePropertyLists contour == 148 contour is [[x,:.],:contour'] => 149 LASSOC(x,contour') => 150 --save some CONSing if possible 151 [first contour,:DELLASOS(x,eliminateDuplicatePropertyLists contour')] 152 [first contour,:eliminateDuplicatePropertyLists contour'] 153 nil 154 res 155 156intersectionContour(c, c', ce) == 157 $var: local := nil 158 computeIntersection(c, c', ce) where 159 computeIntersection(c, c', ce) == 160 varlist:= REMDUP ASSOCLEFT c 161 varlist':= REMDUP ASSOCLEFT c' 162 interVars:= intersection(varlist,varlist') 163 unionVars:= union(varlist,varlist') 164 diffVars:= setDifference(unionVars,interVars) 165 modeAssoc := buildModeAssoc(diffVars, c, c', ce) 166 [:modeAssoc,: 167 [[x,:proplist] 168 for [x,:y] in c | member(x,interVars) and 169 (proplist := interProplist(y, LASSOC($var := x, c'), ce))]] 170 interProplist(p, p', ce) == 171 --p is new proplist; p' is old one 172 [:modeCompare(p, p', ce), :[pair' for pair in p | 173 (pair' := compare(pair, p', ce))]] 174 buildModeAssoc(varlist, c, c', ce) == 175 [[x, :mp] for x in varlist | 176 (mp := modeCompare(LASSOC(x, c), LASSOC(x, c'), ce))] 177 compare(pair is [prop,:val], p', ce) == 178 --1. if the property-value pair are identical, accept it immediately 179 pair=(pair':= assoc(prop,p')) => pair 180 --2. if property="value" and modes are unifiable, give intersection 181 -- property="value" but value=genSomeVariable)() 182 (val':= IFCDR pair') and prop = "value" and 183 (m:= unifiable(val.mode, val'.mode, ce)) => 184 ["value",genSomeVariable(), m, nil] 185 --this tells us that an undeclared variable received 186 --two different values but with identical modes 187 --3. property="mode" is covered by modeCompare 188 prop="mode" => nil 189 modeCompare(p, p', ce) == 190 pair:= assoc("mode",p) => 191 pair':= assoc("mode",p') => 192 m'' := unifiable(rest pair, rest pair', ce) => LIST ["mode", :m''] 193 stackSemanticError(['%b,$var,'%d,"has two modes: "],nil) 194 --stackWarning ("mode for",'%b,$var,'%d,"introduced conditionally") 195 LIST ["conditionalmode",:rest pair] 196 --LIST pair 197 --stackWarning ("mode for",'%b,$var,'%d,"introduced conditionally") 198 pair':= assoc("mode",p') => LIST ["conditionalmode",:rest pair'] 199 --LIST pair' 200 unifiable(m1, m2, ce) == 201 m1=m2 => m1 202 --we may need to add code to coerce up to tagged unions 203 --but this can not be done here, but should be done by compIf 204 m:= 205 m1 is ["Union",:.] => 206 m2 is ["Union", :.] => ["Union", :set_sum(rest m1, rest m2)] 207 ["Union", :set_sum(rest m1, [m2])] 208 m2 is ["Union",:.] => ["Union", :set_sum(rest m2, [m1])] 209 ["Union",m1,m2] 210 for u in getDomainsInScope ce repeat 211 if u is ["Union",:u'] and (and/[member(v,u') for v in rest m]) then 212 return m 213 --this loop will return NIL if not satisfied 214 215addContour(c,E is [cur,:tail]) == 216 [NCONC(fn(c,E),cur),:tail] where 217 fn(c,e) == 218 for [x,:proplist] in c repeat 219 fn1(x,proplist,getProplist(x,e)) where 220 fn1(x,p,ee) == 221 for pv in p repeat fn3(x,pv,ee) where 222 fn3(x,pv,e) == 223 [p,:v]:=pv 224 if member(x,$getPutTrace) then 225 pp([x,"has",pv]) 226 if p="conditionalmode" then 227 RPLACA(pv,"mode") 228 --check for conflicts with earlier mode 229 if vv:=LASSOC("mode",e) then 230 if v ~=vv then 231 stackWarning ["The conditional modes ", 232 v," and ",vv," conflict"] 233 LIST c 234 235makeCommonEnvironment(e,e') == 236 interE makeSameLength(e,e') where --$ie:= 237 interE [e,e'] == 238 rest e=rest e' => [interLocalE makeSameLength(first e,first e'),:rest e] 239 interE [rest e,rest e'] 240 interLocalE [le,le'] == 241 rest le=rest le' => 242 [interC makeSameLength(first le,first le'),:rest le] 243 interLocalE [rest le,rest le'] 244 interC [c,c'] == 245 c=c' => c 246 interC [rest c,rest c'] 247 makeSameLength(x,y) == 248 fn(x,y,#x,#y) where 249 fn(x,y,nx,ny) == 250 nx>ny => fn(rest x,y,nx-1,ny) 251 nx<ny => fn(x,rest y,nx,ny-1) 252 [x,y] 253 254printEnv E == 255 for x in E for i in 1.. repeat 256 for y in x for j in 1.. repeat 257 SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******") 258 for z in y repeat 259 TERPRI() 260 SAY("Properties Of: ",first z) 261 for u in rest z repeat 262 PRIN0 first u 263 printString ": " 264 PRETTYPRINT tran(rest u,first u) where 265 tran(val,prop) == 266 prop="value" => DROP(-1,val) 267 val 268 269prEnv E == 270 for x in E for i in 1.. repeat 271 for y in x for j in 1.. repeat 272 SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******") 273 for z in y | not LASSOC("modemap",rest z) repeat 274 TERPRI() 275 SAY("Properties Of: ",first z) 276 for u in rest z repeat 277 PRIN0 first u 278 printString ": " 279 PRETTYPRINT tran(rest u,first u) where 280 tran(val,prop) == 281 prop="value" => DROP(-1,val) 282 val 283 284prModemaps E == 285 listOfOperatorsSeenSoFar:= nil 286 for x in E for i in 1.. repeat 287 for y in x for j in 1.. repeat 288 for z in y | null member(first z,listOfOperatorsSeenSoFar) and 289 (modemap:= LASSOC("modemap",rest z)) repeat 290 listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] 291 TERPRI() 292 PRIN0 first z 293 printString ": " 294 PRETTYPRINT modemap 295 296prTriple T == 297 SAY '"Code:" 298 pp T.0 299 SAY '"Mode:" 300 pp T.1 301 302TrimCF() == 303 new:= nil 304 old:= CAAR $CategoryFrame 305 for u in old repeat 306 if not ASSQ(first u,new) then 307 uold:= rest u 308 unew:= nil 309 for v in uold repeat if not ASSQ(first v,unew) then unew:= [v,:unew] 310 new:= [[first u,:NREVERSE unew],:new] 311 $CategoryFrame:= [[NREVERSE new]] 312 nil 313 314 315--% PREDICATES 316 317 318isConstantId(name,e) == 319 IDENTP name => 320 pl:= getProplist(name,e) => 321 (LASSOC("value",pl) or LASSOC("mode",pl) => false; true) 322 true 323 false 324 325isFalse() == nil 326 327isFluid s == atom s and "$"=(PNAME s).(0) 328 329isFunction(x,e) == 330 get(x,"modemap",e) or GETL(x,"SPECIAL") or x="case" or getmode(x,e) is [ 331 "Mapping",:.] 332 333isLiteral(x,e) == get(x,"isLiteral",e) 334 335makeLiteral(x,e) == put(x,"isLiteral","true",e) 336 337isSomeDomainVariable s == 338 IDENTP s and #(x:= PNAME s)>2 and x.(0)="#" and x.(1)="#" 339 340isSubset(x,y,e) == 341 x="$" and y="Rep" or x=y or 342 LASSOC(opOf x, GETL(opOf y,"Subsets")) or 343 LASSOC(opOf x,get(opOf y,"SubDomain",e)) or 344 opOf(y)='Type 345 346isDomainInScope(domain,e) == 347 domainList:= getDomainsInScope e 348 atom domain => 349 MEMQ(domain,domainList) => true 350 not IDENTP domain or isSomeDomainVariable domain => true 351 false 352 (name:= first domain)="Category" => true 353 ASSQ(name,domainList) => true 354-- null rest domain or domainMember(domain,domainList) => true 355-- false 356 isFunctor name => false 357 true --is not a functor 358 359isSymbol x == IDENTP x 360 361isSimple x == 362 atom x => true 363 x is [op,:argl] and 364 isSideEffectFree op and (and/[isSimple y for y in argl]) 365 366isSideEffectFree op == 367 constructor? op or member(op,$SideEffectFreeFunctionList) or 368 op is ["Sel", ., op'] and isSideEffectFree op' 369 370isAlmostSimple x == 371 --returns (<new predicate> . <list of assignments>) or nil 372 $assignmentList: local --$assigmentList is only used in this function 373 transform:= 374 fn x where 375 fn x == 376 atom x or null rest x => x 377 [op,y,:l]:= x 378 op="has" => x 379 op="is" => x 380 op = ":=" => 381 IDENTP y => (setAssignment LIST x; y) 382 true => (setAssignment [[":=", g := genVariable(), :l], 383 [":=", y, g]]; g) 384 isSideEffectFree op => [op, :mapInto(rest x, function fn)] 385 true => $assignmentList:= "failed" 386 setAssignment x == 387 $assignmentList="failed" => nil 388 $assignmentList:= [:$assignmentList,:x] 389 $assignmentList="failed" => nil 390 wrapSEQExit [:$assignmentList,transform] 391 392incExitLevel u == 393 adjExitLevel(u,1,1) 394 u 395 396decExitLevel u == 397 (adjExitLevel(u,1,-1); removeExit0 u) where 398 removeExit0 x == 399 atom x => x 400 x is ["exit",0,u] => removeExit0 u 401 [removeExit0 first x,:removeExit0 rest x] 402 403adjExitLevel(x,seqnum,inc) == 404 atom x => x 405 x is [op,:l] and MEMQ(op,'(SEQ REPEAT COLLECT)) => 406 for u in l repeat adjExitLevel(u,seqnum+1,inc) 407 x is ["exit",n,u] => 408 (adjExitLevel(u,seqnum,inc); seqnum>n => x; rplac(CADR x,n+inc)) 409 x is [op,:l] => for u in l repeat adjExitLevel(u,seqnum,inc) 410 411wrapSEQExit l == 412 null rest l => first l 413 [:c,x]:= [incExitLevel u for u in l] 414 ["SEQ",:c,["exit",1,x]] 415 416 417--% UTILITY FUNCTIONS 418 419removeEnv t == [t.expr,t.mode,$EmptyEnvironment] -- t is a triple 420 421makeNonAtomic x == 422 atom x => [x] 423 x 424 425flatten(l,key) == 426 null l => nil 427 first l is [k,:r] and k=key => [:r,:flatten(rest l,key)] 428 [first l,:flatten(rest l,key)] 429 430genDomainVar() == 431 $Index:= $Index+1 432 INTERNL1('"#D", STRINGIMAGE($Index)) 433 434genVariable() == 435 INTERNL1('"#G", STRINGIMAGE($genSDVar := $genSDVar + 1)) 436 437genSomeVariable() == 438 INTERNL1('"##", STRINGIMAGE($genSDVar := $genSDVar + 1)) 439 440listOfIdentifiersIn x == 441 IDENTP x => [x] 442 x is [op,:l] => REMDUP ("append"/[listOfIdentifiersIn y for y in l]) 443 nil 444 445mapInto(x,fn) == [FUNCALL(fn,y) for y in x] 446 447numOfOccurencesOf(x,y) == 448 fn(x,y,0) where 449 fn(x,y,n) == 450 null y => 0 451 x=y => n+1 452 atom y => n 453 fn(x,first y,n)+fn(x,rest y,n) 454 455compilerMessage x == 456 $PrintCompilerMessageIfTrue => APPLY("SAY",x) 457 458printDashedLine() == 459 SAY 460 '"--------------------------------------------------------------------------" 461 462stackSemanticError(msg,expr) == 463 if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] 464 if atom msg then msg:= LIST msg 465 entry:= [msg,expr] 466 if not member(entry,$semanticErrorStack) then $semanticErrorStack:= 467 [entry,:$semanticErrorStack] 468 $scanIfTrue and $insideCapsuleFunctionIfTrue=true and #$semanticErrorStack- 469 $initCapsuleErrorCount>3 => THROW("compCapsuleBody",nil) 470 nil 471 472stackWarning msg == 473 if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] 474 if not member(msg,$warningStack) then $warningStack:= [msg,:$warningStack] 475 nil 476 477unStackWarning msg == 478 if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] 479 $warningStack:= EFFACE(msg,$warningStack) 480 nil 481 482stackMessage msg == 483 $compErrorMessageStack:= [msg,:$compErrorMessageStack] 484 nil 485 486stackMessageIfNone msg == 487 --used in situations such as compForm where the earliest message is wanted 488 if null $compErrorMessageStack then $compErrorMessageStack:= 489 [msg,:$compErrorMessageStack] 490 nil 491 492stackAndThrow msg == 493 $compErrorMessageStack:= [msg,:$compErrorMessageStack] 494 THROW("compOrCroak",nil) 495 496printString x == PRINTEXP (STRINGP x => x; PNAME x) 497 498printAny x == if atom x then printString x else PRIN0 x 499 500printSignature(before,op,[target,:argSigList]) == 501 printString before 502 printString op 503 printString ": _(" 504 if argSigList then 505 printAny first argSigList 506 for m in rest argSigList repeat (printString ","; printAny m) 507 printString "_) -> " 508 printAny target 509 TERPRI() 510 511pmatch(s,p) == pmatchWithSl(s,p,"ok") 512 513pmatchWithSl(s,p,al) == 514 s=$EmptyMode => nil 515 s=p => al 516 v:= assoc(p,al) => s=rest v or al 517 MEMQ(p,$PatternVariableList) => [[p,:s],:al] 518 null atom p and null atom s and (al':= pmatchWithSl(first s,first p,al)) and 519 pmatchWithSl(rest s,rest p,al') 520 521elapsedTime() == 522 currentTime := get_run_time() 523 elapsedSeconds:= (currentTime-$previousTime)*1.0/$timerTicksPerSecond 524 $previousTime:= currentTime 525 elapsedSeconds 526 527addStats([a,b],[c,d]) == [a+c,b+d] 528 529printStats [byteCount,elapsedSeconds] == 530 timeString := normalizeStatAndStringify elapsedSeconds 531 if byteCount = 0 then SAY('"Time: ",timeString,'" SEC.") else 532 SAY('"Size: ",byteCount,'" BYTES Time: ",timeString,'" SEC.") 533 TERPRI() 534 nil 535 536extendsCategoryForm(domain, form, form', e) == 537 --is domain of category form also of category form'? 538 --domain is only used for ensuring that X being a Ring means that it 539 --satisfies (Algebra X) 540 form=form' => true 541 form=$Category => nil 542 form' = $Category => nil 543 form' is ["Join", :l] => and/[extendsCategoryForm(domain, form, x, e) 544 for x in l] 545 form' is ["CATEGORY",.,:l] => 546 and/[extendsCategoryForm(domain, form, x, e) for x in l] 547 form is ["Join", :l] => or/[extendsCategoryForm(domain, x, form', e) 548 for x in l] 549 form is ["CATEGORY",.,:l] => 550 member(form',l) or 551 stackWarning ["not known that ",form'," is of mode ",form] or true 552 isCategoryForm(form) => 553 --Constructs the associated vector 554 formVec := (compMakeCategoryObject(form, e)).expr 555 --Must be e to pick up locally bound domains 556 form' is ["SIGNATURE",op,args,:.] => 557 assoc([op,args],formVec.(1)) or 558 assoc(SUBSTQ(domain,"$",[op,args]), 559 SUBSTQ(domain,"$",formVec.(1))) 560 form' is ["ATTRIBUTE",at] => BREAK() 561 form' is ["IF",:.] => true --temporary hack so comp won't fail 562 -- Are we dealing with an Aldor category? If so use the "has" function ... 563 # formVec = 1 => newHasTest(form,form') 564 catvlist:= formVec.4 565 member(form',first catvlist) or 566 member(form',SUBSTQ(domain,"$",first catvlist)) or 567 (or/ 568 [extendsCategoryForm(domain, SUBSTQ(domain, "$", cat), form', e) 569 for [cat,:.] in CADR catvlist]) 570 nil 571 572getmode(x,e) == 573 prop:=getProplist(x,e) 574 u := QLASSQ("value", prop) => u.mode 575 QLASSQ("mode", prop) 576 577getmodeOrMapping(x,e) == 578 u:= getmode(x,e) => u 579 (u:= get(x,"modemap",e)) is [[[.,:map],.],:.] => ["Mapping",:map] 580 nil 581 582substituteOp(op',op,x) == 583 atom x => x 584 [(op=(f:= first x) => op'; f),:[substituteOp(op',op,y) for y in rest x]] 585 586 -- following is only intended for substituting in domains slots 1 and 4 587 -- signatures and categories 588sublisV(p,e) == 589 LIST2REFVEC [suba(p, e.i) for i in 0..MAXINDEX e] where 590 suba(p,e) == 591 STRINGP e => e 592 atom e => (y:= ASSQ(e,p) => rest y; e) 593 u:= suba(p,QCAR e) 594 v:= suba(p,QCDR e) 595 EQ(QCAR e,u) and EQ(QCDR e,v) => e 596 [u,:v] 597 598--% DEBUGGING PRINT ROUTINES used in breaks 599 600_?MODEMAPS x == _?modemaps x 601_?modemaps x == 602 env:= 603 $insideCapsuleFunctionIfTrue=true => $CapsuleModemapFrame 604 $f 605 x="all" => displayModemaps env 606 -- displayOpModemaps(x,old2NewModemaps get(x,"modemap",env)) 607 displayOpModemaps(x,get(x,"modemap",env)) 608 609 610old2NewModemaps x == 611-- [[dcSig,pred] for [dcSig,[pred,:.],:.] in x] 612 x is [dcSig,[pred,:.],:.] => [dcSig,pred] 613 x 614 615traceUp() == 616 atom $x => sayBrightly "$x is an atom" 617 for y in rest $x repeat 618 u:= comp(y,$EmptyMode,$f) => 619 sayBrightly [y,'" ==> mode",'%b,u.mode,'%d] 620 sayBrightly [y,'" does not compile"] 621 622_?m x == 623 u:= comp(x,$EmptyMode,$f) => u.mode 624 nil 625 626traceDown() == 627 mmList:= getFormModemaps($x,$f) => 628 for mm in mmList repeat if u:= qModemap mm then return u 629 sayBrightly "no modemaps for $x" 630 631qModemap mm == 632 sayBrightly ['%b,"modemap",'%d,:formatModemap mm] 633 [[dc,target,:sl],[pred,:.]]:= mm 634 and/[qArg(a,m) for a in rest $x for m in sl] => target 635 sayBrightly ['%b,"fails",'%d,'%l] 636 637qArg(a,m) == 638 yesOrNo:= 639 u:= comp(a,m,$f) => "yes" 640 "no" 641 sayBrightly [a," --> ",m,'%b,yesOrNo,'%d] 642 yesOrNo="yes" 643 644_?comp x == 645 msg:= 646 u:= comp(x,$EmptyMode,$f) => 647 [MAKESTRING "compiles to mode",'%b,u.mode,'%d] 648 nil 649 sayBrightly msg 650 651_?domains() == pp getDomainsInScope $f 652 653_?mode x == displayProplist(x,[["mode",:getmode(x,$f)]]) 654 655_?properties x == displayProplist(x,getProplist(x,$f)) 656 657_?value x == displayProplist(x,[["value",:get(x,"value",$f)]]) 658 659displayProplist(x,alist) == 660 sayBrightly ["properties of",'%b,x,'%d,":"] 661 fn alist where 662 fn alist == 663 alist is [[prop,:val],:l] => 664 if prop="value" then val:= [val.expr,val.mode,'"..."] 665 sayBrightly [" ",'%b,prop,'%d,": ",val] 666 fn deleteAssoc(prop,l) 667 668displayModemaps E == 669 listOfOperatorsSeenSoFar:= nil 670 for x in E for i in 1.. repeat 671 for y in x for j in 1.. repeat 672 for z in y | null member(first z,listOfOperatorsSeenSoFar) and 673 (modemaps:= LASSOC("modemap",rest z)) repeat 674 listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] 675 displayOpModemaps(first z,modemaps) 676