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