path: root/src/interp/mark.boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--     - Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     - Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in
--       the documentation and/or other materials provided with the
--       distribution.
--
--     - Neither the name of The Numerical Algorithms Group Ltd. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


-- HOW THE TRANSLATOR WORKS

-- Unit of code is markedUp as follows (unit= item in a capsule pile, e.g.)
--   (WI/.. a b)            means    source code a --> markedUpCode b
--   (REPPER/.. . . a)      means    source code for a ---> (rep a) or (per a)
-- Source code is extracted, modified from markedUpCode, and stacked
-- Entire constructor is then assembled and prettyprinted


)package "BOOT"

REMPROP("and",'parseTran)
REMPROP("or",'parseTran)
REMPROP("not",'parseTran)
MAKEPROP("and",'special,'compAnd)
MAKEPROP("or",'special,'compOr)
MAKEPROP("not",'special,'compNot)
SETQ($monitorWI,nil)
SETQ($monitorCoerce,nil)
SETQ($markPrimitiveNumbers,nil)  -- '(Integer SmallInteger))
SETQ($markNumberTypes,'(Integer SmallInteger PositiveInteger NonNegativeInteger))

--======================================================================
--              Master Markup Function
--======================================================================
 

WI(a,b) == b

mkWi(fn,:r) ==            
--  if $monitorWI and r isnt ['WI,:.] and not (r is ['AUTOSUBSET,p,.,y] and(MEMQ(KAR p,'(NonNegativeInteger PositiveInteger)) or y='_$fromCoerceable_$)) then
--    if $monitorWI and r isnt ['WI,:.] then
--    sayBrightlyNT ['"From ",fn,'": "]
--    pp r
  r is ['WI,a,b] =>
    a = b => a            --don't bother
    b is ['WI,=a,.] => b
    r
  r
 
--======================================================================
--        Capsule Function Transformations
--======================================================================
tcheck T == 
  if T isnt [.,.,.] then systemError 'tcheck
  T
  
markComp(x,T) ==                                         --for comp
  tcheck T
  x ^= CAR T => [mkWi('comp,'WI,x,CAR T),:CDR T]                  
  T

markAny(key,x,T) ==
  tcheck T
  x ^= CAR T => [mkWi(key,'WI,x,CAR T),:CDR T]
  T

markConstruct(x,T) == 
  tcheck T
  markComp(x,T)

markParts(x,T) ==  --x is ['PART,n,y]                     --for compNoStacking
  tcheck T
  [mkWi('makeParts,'WI,x,CAR T),:CDR T]
   
yumyum kind == kind
markCoerce(T,T',kind) ==                                 --for coerce
  tcheck T
  tcheck T'
  if kind = 'AUTOSUBSET then yumyum(kind)
  STRINGP T.mode and T'.mode = '(String) => T'
  markKillAll T.mode = T'.mode => T'
  -- reduce (AUTOSUBSET a b (WI c (AUTOSUBSET b a c))) ==> c
  u :=
    $partExpression is [.,.,y] and T.expr = y => ['WI,y,$partExpression]
    T.expr
  res := [markCoerceChk mkWi('coerce,kind,T.mode,T'.mode,
           mkWi('coerce,'WI,u,T'.expr)),:CDR T']
  res
  
markCoerceChk x ==
  x is ['AUTOSUBSET,a,b,['WI,c,['AUTOSUBSET,=b, =a, =c]]] => c
  x

markMultipleExplicit(nameList, valList, T) ==
  tcheck T
  [mkWi('setqMultipleExplicit, 'WI,
    ['LET, ['Tuple,:nameList], ['Tuple,:valList]],
    T.expr), :CDR T]

markRetract(x,T) ==
  tcheck T
  [mkWi('smallIntegerStep,'RETRACT,nil,['REPLACE,['retract,x]],T.expr),:CDR T]

markSimpleReduce(x,T) ==
  tcheck T
  [mkWi('compreduce,'LAMBDA, nil, ["REPLACE",x], T.expr), :CDR T]

markCompAtom(x,T) ==                                     --for compAtom
  tcheck T
  BOUNDP '$convert2NewCompiler and $convert2NewCompiler =>
    [mkWi('compAtom,'ATOM,nil,['REPLACE,[x]],T.expr),:CDR T]
  T

markCase(x, tag, T) ==
  tcheck T
  [mkWi('compCase1, 'LAMBDA, nil, ["REPLACE",["case",x,tag]], T.expr), 
    :CDR T]

markCaseWas(x,T) == 
  tcheck T
  [mkWi('compCase1,'WI,x,T.expr),:CDR T]

markAutoWas(x,T) == 
  tcheck T
  [mkWi('autoCoerce,'WI,x,T.expr),:CDR T]

markCallCoerce(x,m,T) ==
  tcheck T
  [mkWi("call",'WI,["::",x,m], T.expr),: CDR T]

markCoerceByModemap(x,source,target,T, killColonColon?) == 
  tcheck T
  source is ["Union",:l] and member(target,l) =>
    tag := genCaseTag(target, l, 1) or return nil
    markAutoCoerceDown(x, tag, markAutoWas(x,T), killColonColon?)
  target is ["Union",:l] and member(source,l) =>
    markAutoCoerceUp(x,markAutoWas(x, T))
  [mkWi('markCoerceByModemap,'WI,x,T.expr),:CDR T]
   
markAutoCoerceDown(x,tag,T,killColonColon?) ==
  tcheck T
  patch := ["dot",getSourceWI x,tag]
  if killColonColon? then patch := ["REPLACE",["UNCOERCE",patch]]
  [mkWi('coerceExtraHard,'LAMBDA, nil,patch,T.expr), :CDR T]

markAutoCoerceUp(x,T) ==
--  y := getSourceWI x
--  y := 
--    STRINGP y => INTERN y
--    y   
  tcheck T  
  [mkWi('coerceExtraHard,'LAMBDA, nil,["REPLACE",['construct, "##1"]],T.expr),
     -----want to capture by ##1 what is there                ------11/2/94
    :CDR T]

markCompSymbol(x,T) ==                                   --for compSymbol
  tcheck T
  [mkWi('compSymbol,'ATOM,nil,['REPLACE,["@",x,$Symbol]],T.expr),:CDR T]

markStepSI(ostep,nstep) ==                               --for compIterator
  ['STEP,:r] := ostep
  ['ISTEP,i,:s] := nstep
--$localLoopVariables := insert(i,$localLoopVariables)
  markImport 'SmallInteger
  mkWi('markStepSI,'WI,ostep,['ISTEP,
    mkWi('markStep,'FREESI,nil,['REPLACE,          ['PAREN,['free,i]]],i),:s])
--                                    i],i),:s])
markStep(i) == mkWi('markStep,'FREE,nil,['REPLACE, ['PAREN,['free,i]]],i)
--                                    i],i)

markPretend(T,T') ==
  tcheck T
  tcheck T'
  [mkWi('pretend,'COLON,"pretend",T.mode,T.expr),:CDR T']

markAt(T) == 
  tcheck T
  [mkWi('compAtom,'COLON,"@",T.mode,T.expr),:CDR T]

markCompColonInside(op,T) ==                         --for compColonInside
  tcheck T
  BOUNDP '$convert2NewCompiler and $convert2NewCompiler =>
    [mkWi('compColonInside,'COLON,op,T.mode,T.expr),:CDR T]
  T

markLisp(T,m) ==                                     --for compForm1
  tcheck T
  BOUNDP '$convert2NewCompiler and $convert2NewCompiler =>
    [mkWi('compForm1,'COLON,'Lisp,T.mode,T.expr),:CDR T]
  T

markLambda(vl,body,mode,T) ==                       --for compWithMappingMode
  tcheck T
  if mode isnt ['Mapping,:ml] then error '"markLambda"
  args := [[":",$PerCentVariableList.i,t] for i in 0.. for t in rest ml]
  left := [":",['PAREN,:args],first ml]
  fun := ['_+_-_>,left,SUBLISLIS($PerCentVariableList,vl,body)] 
  [mkWi('compWithMappingMode,'LAMBDA,nil,['REPLACE,fun],T.expr),:CDR T]

markMacro(before,after) ==                            --for compMacro
  BOUNDP '$convert2NewCompiler and $convert2NewCompiler => 
    if before is [x] then before := x
    $def := ['MDEF,before,'(NIL),'(NIL),after]
    if $insideFunctorIfTrue 
      then $localMacroStack := [[before,:after],:$localMacroStack]
      else $globalMacroStack:= [[before,:after],:$globalMacroStack]
    mkWi('macroExpand,'MI,before,after) 
  after

markInValue(y ,e) ==
  y1 := markKillAll y
  [y', m, e] := T := comp(y1, $EmptyMode, e) or return nil
  markImport m
  m = "$" and LASSOC('value,getProplist('Rep,e)) is [a,:.] and 
         MEMQ(opOf a,'(List Vector)) => [markRepper('rep, y'), 'Rep, e]
  T

markReduceIn(it, pr)       ==   markReduceIterator("in",it,pr)
markReduceStep(it, pr)     ==   markReduceIterator("step", it, pr)
markReduceWhile(it, pr)    ==   markReduceIterator("while", it, pr)
markReduceUntil(it, pr)    ==   markReduceIterator("until", it, pr)
markReduceSuchthat(it, pr) == markReduceIterator("suchthat", it, pr)
markReduceIterator(kind, it, pr) == [mkWi(kind, 'WI, it, CAR pr), :CDR pr]
markReduceBody(body,T)     ==  
  tcheck T
  [mkWi("reduceBody",'WI,body,CAR T), :CDR T]
markReduce(form, T)        ==  
  tcheck T
  [SETQ($funk,mkWi("reduce", 'WI,form,CAR T)), :CDR T]

markRepeatBody(body,T)     ==  
  tcheck T
  [mkWi("repeatBody",'WI,body,CAR T), :CDR T]

markRepeat(form, T)        ==  
  tcheck T
  [mkWi("repeat", 'WI,form,CAR T), :CDR T]
  
markTran(form,form',[dc,:sig],env) ==  --from compElt/compFormWithModemap
  dc ^= 'Rep or ^MEMQ('_$,sig) => mkWi('markTran,'WI,form,['call,:form'])
  argl := [u for t in rest sig for arg in rest form'] where u() ==
    t='_$ => 
      argSource := getSourceWI arg
      IDENTP argSource and getmode(argSource,env) = 'Rep => arg
      markRepper('rep,arg)
    arg
  form' := ['call,CAR form',:argl]
  wi := mkWi('markTran,'WI,form,form')
  CAR sig = '_$ => markRepper('per,wi)
  wi
 
markRepper(key,form) == ['REPPER,nil,key,form]
 
markDeclaredImport d == markImport(d,true)

markImport(d,:option) ==   --from compFormWithModemap/genDeltaEntry/compImport
  if CONTAINED('PART,d) then pause d
  declared? := IFCAR option
  null d or d = $Representation => nil
  d is [op,:.] and MEMQ(op,'(Boolean Mapping Void Segment UniversalSegment)) => nil
  STRINGP d or (IDENTP d and (PNAME d).0 = char '_#) => nil
  MEMQ(d,'(_$ _$NoValueMode _$EmptyMode Void)) => nil
-------=======+> WHY DOESN'T THIS WORK????????????
--if (d' := macroExpand(d,$e)) ^= d then markImport(d',declared?)
  dom := markMacroTran d
--if IDENTP dom and dom = d and not getmode(dom,$e) then dom := ['MyENUM, d]
  categoryForm? dom => nil
  $insideCapsuleFunctionIfTrue => 
    $localImportStack := insert(dom,$localImportStack)
    if IFCAR option then $localDeclareStack := insert(dom,$localDeclareStack)
  if BOUNDP '$globalImportStack then
    $globalImportStack := insert(dom,$globalImportStack)
    if IFCAR option then $globalDeclareStack := insert(dom,$globalDeclareStack)

markMacroTran name ==     --called by markImport
  ATOM name => name
  u := or/[x for [x,:y] in $globalMacroStack | y = name] => u
  u := or/[x for [x,:y] in $localMacroStack  | y = name] => u
  [op,:argl] := name
  MEMQ(op,'(Record Union)) => 
--  pp ['"Cannot find: ",name]
    name
  [op,:[markMacroTran x for x in argl]]
   
markSetq(originalLet,T) ==                                --for compSetq
  BOUNDP '$convert2NewCompiler and $convert2NewCompiler => 
    $coerceList : local := nil
    ['LET,form,originalBody] := originalLet
    id := markLhs form
    not $insideCapsuleFunctionIfTrue =>
      $from : local := '"Setq"
      code := T.expr
      markEncodeChanges(code,nil)
      noriginalLet := markSpliceInChanges originalBody
      if IDENTP id then $domainLevelVariableList := insert(id,$domainLevelVariableList) 
      nlet := ['LET,id,noriginalLet]
      entry := [originalLet,:nlet]
      $importStack := [nil,:$importStack]
      $freeStack   := [nil,:$freeStack]
      capsuleStack('"Setq", entry)
--    [markKillMI T.expr,:CDR T]
      [code,:CDR T]
    if MEMQ(id,$domainLevelVariableList) then 
      $markFreeStack := insert(id,$markFreeStack)
    T
  T

markCapsuleExpression(originalExpr, T) ==
  $coerceList: local := nil
  $from: local := '"Capsule expression"
  code := T.expr
  markEncodeChanges(code, nil)
  noriginal := markSpliceInChanges originalExpr
  nexpr := noriginal
  entry := [originalExpr,:nexpr]
  $importStack := [nil,:$importStack]
  $freeStack   := [nil,:$freeStack]
  capsuleStack('"capsuleExpression", entry)
  [code,:CDR T]

markLhs x ==
  x is [":",a,.] => a
  atom x => x
  x                  --ignore

capsuleStack(name,entry) ==
--  if $monitorWI then
--    sayBrightlyNT ['"Stacking ",name,'": "]
--    pp entry
  $capsuleStack := [COPY entry,:$capsuleStack] 
  $predicateStack := [$predl, :$predicateStack]
  signature := 
    $insideCapsuleFunctionIfTrue => $signatureOfForm
    nil
  $signatureStack := [signature, :$signatureStack]
 
foobar(x) == x 
 
foobum(x) == x         --from doIT


--======================================================================
--        Capsule Function Transformations
--======================================================================
--called from compDefineCapsuleFunction
markChanges(originalDef,T,sig) == 
  BOUNDP '$convert2NewCompiler and $convert2NewCompiler => 
    if $insideCategoryIfTrue and $insideFunctorIfTrue then
      originalDef := markCatsub(originalDef)
      T := [markCatsub(T.expr),
             markCatsub(T.mode),T.env]
      sig := markCatsub(sig)
      $importStack := markCatsub($importStack)
--  T := coerce(T,first sig)         ---> needed to wrap a "per" around a Rep type
    code := T.expr
    $e : local := T.env
    $coerceList : local := nil
    $hoho := code
    ['DEF,form,.,.,originalBody] := originalDef
    signature := markFindOriginalSignature(form,sig)
    $from : local := '"compDefineFunctor1"
    markEncodeChanges(code,nil)
    frees := 
      null $markFreeStack => nil
      [['free,:mySort REMDUP $markFreeStack]]
    noriginalBody := markSpliceInChanges originalBody
    nbody := augmentBodyByLoopDecls noriginalBody
    ndef := ['DEF,form,signature,[nil for x in form],nbody]
    $freeStack   := [frees,:$freeStack]
    --------------------> import code <------------------
    imports      := $localImportStack
    subtractions := union($localDeclareStack,union($globalDeclareStack,
                      union($globalImportStack,signature)))
    if $insideCategoryIfTrue and $insideFunctorIfTrue then
      imports      := markCatsub imports
      subtractions := markCatsub subtractions
    imports      := [markMacroTran d for d in imports]
    subtractions := [markMacroTran d for d in subtractions]
    subtractions := union(subtractions, getImpliedImports imports)
    $importStack := [reduceImports SETDIFFERENCE(imports,subtractions),:$importStack]
    -------------------> import code <------------------
    entry := [originalDef,:ndef]
    capsuleStack('"Def",entry)
  nil

reduceImports x ==
  [k, o] := reduceImports1 x
  SETDIFFERENCE(o,k)

reduceImports1 x ==
  kills := nil
  others:= nil
  for y in x repeat 
    y is ['List,a] =>
      [k,o] := reduceImports1 [a]
      kills := union(y,union(k,kills))
      others:= union(o, others)
    rassoc(y,$globalImportDefAlist) => kills := insert(y,kills)
    others := insert(y, others)
  [kills, others]

getImpliedImports x ==
  x is [[op,:r],:y] => 
    MEMQ(op, '(List Enumeration)) => union(r, getImpliedImports y)
    getImpliedImports y
  nil  
 
augmentBodyByLoopDecls body ==
  null $localLoopVariables => body
  lhs := 
    $localLoopVariables is [.] => first $localLoopVariables
    ['LISTOF,:$localLoopVariables]
  form := [":",lhs,$SmallInteger]
  body is ['SEQ,:r] => ['SEQ,form,:r]
  ['SEQ,form,['exit,1,body]]
    
markFindOriginalSignature(form,sig) ==
  target := $originalTarget
  id     := opOf form
  n      := #form
  cat :=
    target is ['Join,:.,u] => u
    target
  target isnt ['CATEGORY,.,:v] => sig
  or/[sig' for x in v | x is ['SIGNATURE,=id,sig'] and #sig' = n 
    and markFindCompare(sig',sig)] or sig

markFindCompare(sig',sig) ==
  macroExpand(sig',$e) = sig
       
--======================================================================
--        Capsule Function: Encode Changes on $coerceList
--======================================================================
--(WI a b) mean Was a Is b
--(WI c (WI d e) b) means Was d Is b
--(AUTOxxx p q (WI a b))     means a::q for reason xxx=SUBSET or HARD
--(ATOM nil (REPLACE (x)) y) means replace y by x
--(COLON :: A B)             means rewrite as A :: B  (or A @ B or A : B)
--(LAMBDA nil (REPLACE fn) y)means replace y by fn
--(REPPER nil per form)      means replace form by per(form)
--(FREESI nil (REPLACE decl) y) means replace y by fn

markEncodeChanges(x,s) ==
--x is a piece of target code
--s is a stack [a, b, ..., c] such that a < b < ...
--calls ..markPath.. to find the location of i in a in c (the orig expression),
--  where i is derived from x (it is the source component of x);
--  if markPath fails to find a path for i in c, then x is wrong!

--first time only: put ORIGNAME on property list of operators with a ; in name
  if null s then markOrigName x
  x is [fn,a,b,c] and MEMQ(fn,$markChoices) =>
    x is ['ATOM,.,['REPLACE,[y],:.],:.] and MEMQ(y,'(false true)) => 'skip
    ---------------------------------------------------------------------- 
    if c then   ----> special case: DON'T STACK A nil!!!!
      i := getSourceWI c
      t := getTargetWI c
  --  sayBrightly ['"=> ",i,'" ---> "]
  --  sayBrightly ['" from ",a,'" to ",b]
      s := [i,:s]
--    pp '"==========="
--    pp x
    markRecord(a,b,s)
    markEncodeChanges(t,s)
  x is ['WI,p,q] or x is ['MI,p,q] =>
    i := getSourceWI p
    r := getTargetWI q
    r is [fn,a,b,c] and MEMQ(fn,$markChoices) =>
      t := getTargetWI c
--      sayBrightly ['"==> ",i,'" ---> "]
--      sayBrightly ['" from ",a,'" to ",b]
      s := [i,:s]
      markRecord(a,b,s)
      markEncodeChanges(t,s)
    i is [fn,:.] and MEMQ(fn, '(REPEAT COLLECT)) => markEncodeLoop(i,r,s)
    t := getTargetWI r
    markEncodeChanges(t,[i,:s])
  x is ['PROGN,a,:.] and s is [[op,:.],:.] and MEMQ(op,'(REPEAT COLLECT)) =>
    markEncodeChanges(a,s)
  x is ['TAGGEDreturn,a,[y,:.]] => markEncodeChanges(y,s)
  x is ['CATCH,a,y] => markEncodeChanges(y,s)
  atom x => nil
--  CAR x = IFCAR IFCAR s =>
--    for y in x for r in CAR s repeat markEncodeChanges(y,[r,:s])
  for y in x repeat markEncodeChanges(y,s)

markOrigName x ==
  x is [op,:r] =>
    op = 'TAGGEDreturn and x is [.,a,[y,:.]] => markOrigName y
    for y in r repeat markOrigName y     
    IDENTP op =>
      s := PNAME op
      k := charPosition(char '_;, s, 0)
      k > MAXINDEX s => nil
      origName := INTERN SUBSTRING(s, k + 1, nil)
      MAKEPROP(op, 'ORIGNAME, origName)
      REMPROP(op,'PNAME)
    markOrigName op
  nil

markEncodeLoop(i, r, s) ==  
  [.,:itl1, b1] := i   --op is REPEAT or COLLECT
  if r is ['LET,.,a] then r := a
  r is [op1,:itl2,b2] and MEMQ(op1, '(REPEAT COLLECT)) =>
    for it1 in itl1 for it2 in itl2 repeat markEncodeChanges(it2,[it1,:s])
    markEncodeChanges(b2, [b1,:s])
  markEncodeChanges(r, [i,:s])
  
getSourceWI x ==
--Subfunction of markEncodeChanges
  x is ['WI,a,b] or x is ['MI,a,b] =>
    a is ['WI,:.] or a is ['MI,:.] => getSourceWI a
    markRemove a
  markRemove x

markRemove x ==
  atom x => x
  x is ['WI,a,b] or x is ['MI,a,b]  => markRemove a
  x is [fn,a,b,c] and MEMQ(fn,$markChoices) => 
    markRemove c
--x is ['TAGGEDreturn,:.] => x
  x is ['TAGGEDreturn,a,[x,m,t]] => ['TAGGEDreturn,a,[markRemove x,m,t]]
  [markRemove y for y in x]
 
getTargetWI x ==
--Subfunction of markEncodeChanges
  x is ['WI,a,b] or x is ['MI,a,b] => getTargetWI b
  x is ['PART,.,a] => getTargetWI a
  x
  
markRecord(source,target,u) ==
--Record changes on $coerceList
  if source='_$ and target='Rep then 
    target := 'rep
  if source='Rep and target='_$ then
    target := 'per
  item := first u
  FIXP item or item = $One or item = $Zero => nil
  item is ["-",a] and (FIXP a or a = $One or a = $Zero) => nil
  STRINGP item => nil
  item is [op,.,t] and MEMQ(op,'( _:_: _@ _pretend)) 
    and macroExpand(t,$e) = target => nil
  $source: local := source
  $target: local := target
  path := markPath u or return nil       -----> early exit
  path := 
    path = 0 => nil     --wrap the WHOLE thing
    path
  if BOUNDP '$shout2 and $shout2 then
      pp '"========="
      pp path
      ipath := reverse path
      for x in u repeat
        pp x
        ipath => 
           pp first ipath
           ipath := rest ipath
  entry := [source,target,:path]
  if $monitorCoerce then
    sayBrightlyNT ['"From ",$from,'": "]
    pp entry
  $coerceList := [COPY entry,:$coerceList]

--======================================================================
--  Capsule Function: Find dewey decimal path across a list
--======================================================================
markPath u ==        --u has nested structure: u0 < u1 < u2 ...
  whole := LAST u
  part  := first u
  $path := u
  u is [.] => 0      --means THE WHOLE THING
  v := REVERSE markPath1 u
--  pp '"======mark path======"
--  foobar v
--  pp v
--  pp markKillAll part
--  pp markKillAll whole
--  pp $source
--  pp $target
  null v => nil
  $pathStack := [[v,:u],:$pathStack]
--  pp '"----------------------------"
--  ppFull v
--  pp '"----------------------------"
  v

markPath1 u ==   
-- u is a list [a, b, ... c]
-- This function calls markGetPath(a,b) to find the location of a in b, etc.
-- The result is the successful path from a to c
-- A error printout occurs if no such path can be found
  u is [a,b,:r] =>  -- a < b < ...
    a = b => markPath1 CDR u       ---> allow duplicates on path
    path := markGetPath(a,b) or return nil    -----> early exit
    if BOUNDP '$shout1 and $shout1 then
      pp '"========="
      pp path
      pp a
      pp b
    [:first path,:markPath1 CDR u]
  nil

markGetPath(x,y) ==    -- x < y  ---> find its location
  u := markGetPaths(x,y) 
  u is [w] => u
  $amb := [u,x,y]
  key :=
    null u => '"no match"
    '"ambiguous"
  sayBrightly ['"-----",key,'"--------"]
  if not BOUNDP '$pathErrorStack then SETQ($pathErrorStack,nil)
  SETQ($pathErrorStack,[$path,:$pathErrorStack])
  pp "CAUTION: this can cause RPLAC errors"
  pp "Paths are: "
  pp u
  for p in $path for i in 1..3 repeat pp p
  $x: local := x
  $y: local := y
  pp '"---------------------"
  pp x
  pp y
  foobar key
--  pp [key, $amb]
  null u => [1729] --return something that will surely fail if no path
  [first u]

markTryPaths() == markGetPaths($x,$y)

markPaths(x,y,s) ==    --x < y; find location s of x in y (initially s=nil)
--NOTES: This location is what it will be in the source program with
--  all PART information removed. 
  if BOUNDP '$shout and $shout then
    pp '"-----"
    pp x
    pp y
    pp s
  x = y => s         --found it!  exit
  markPathsEqual(x,y) => s
  y is [['elt,.,op],:r] and (u := markPaths(x,[op,:r],s)) => u
  x is ['elt,:r] and (u := markPaths(r,y,s)) => u
  y is ['elt,:r] and (u := markPaths(x,r,s)) => u
  x is [op,:u] and MEMQ(op,'(LIST VECTOR)) and y is ['construct,:v] and
    (p := markPaths(['construct,:u],y,s)) => p
  atom y => nil
  y is ['LET,a,b] and IDENTP a => 
    markPaths(x,b,markCons(2,s)) --and IDENTP x
  y is ['LET,a,b] and GENSYMP a => markPaths(x,b,s)     --for loops
  y is ['IF,a,b,:.] and GENSYMP a => markPaths(x,b,s)   --for loops
  y is ['IF,a,b,c] and (p := (markPathsEqual(x,b) => 2;
                              markPathsEqual(x,c) => 3;
                              nil)) => markCons(p,s)
--  x is ['exit,a,b] and y is ['exit,a,c] and (p := mymy markPathsEqual(b,c)) =>
--     markCons(p,s)
  y is ['call,:r] => markPaths(x,r,s)                 --for loops
  y is [fn,m,y1] and MEMQ(fn,'(PART CATCH THROW)) => markPaths(x,y1,s) or
    "APPEND"/[markPaths(x,u,markCons(i,s)) for u in y1 for i in 0..]
  "APPEND"/[markPaths(x,u,markCons(i,s)) for u in y for i in 0..]

mymy x == x

markCons(i,s) == [[i,:x] for x in s]

markPathsEqual(x,y) ==
  x = y => true
  x is ["::",.,a] and y is ["::",.,b] and 
    a = '(Integer) and b = '(NonNegativeInteger) => true
  y is [fn,.,z] and MEMQ(fn,'(PART CATCH THROW)) and markPathsEqual(x,z) => true
  y is ['LET,a,b] and GENSYMP a and markPathsEqual(x,b) => true
  y is ['IF,a,b,:.] and GENSYMP a => markPathsEqual(x,b)  -------> ??? 
  y is ['call,:r] => markPathsEqual(IFCDR x,r)
  x is ['REDUCE,.,.,c,:.] and c is ['COLLECT,:u] and 
    y is ['PROGN,.,repeet,:.] and repeet is ['REPEAT,:v] => markPathsEqual(u,v)
  atom y or atom x => 
    IDENTP y and IDENTP x and y = GETL(x,'ORIGNAME)  => true --> see 
--  IDENTP y and IDENTP x and anySubstring?(PNAME y,PNAME x,0) => true
    IDENTP y and (z := markPathsMacro y) => markPathsEqual(x,z)
    false
  "and"/[markPathsEqual(u,v) for u in x for v in y]

markPathsMacro y ==
  LASSOC(y,$localMacroStack) or LASSOC(y,$globalMacroStack)
--======================================================================
--      Capsule Function: DO the transformations
--======================================================================
--called by markChanges (inside capsule), markSetq (outside capsule)
markSpliceInChanges body ==
--  pp '"before---->"
--  pp $coerceList
  $coerceList := REVERSE SORTBY('CDDR,$coerceList)
--  pp '"after----->"
--  pp $coerceList
  $cl := $coerceList
--if CONTAINED('REPLACE,$cl) then hoho $cl
  body :=
    body is ['WI,:.] => 
--      hehe body
      markKillAll body
    markKillAll body
--NOTE!! Important that $coerceList be processed in this order
--since it must operate from the inside out. For example, a progression
--u --> u::Rep --> u :: Rep :: $ can only be correct. Here successive
--entries can have duplicate codes
  for [code,target,:loc] in $coerceList repeat
    $data: local := [code, target, loc]
    if BOUNDP '$hohum and $hohum then 
      pp '"---------->>>>>"
      pp $data
      pp body
      pp '"-------------------------->"
    body := markInsertNextChange body
  body

--pause() == 12
markInsertNextChange body ==
--  if BOUNDP '$sayChanges and $sayChanges then 
--    sayBrightlyNT '"Inserting change: "
--    pp $data
--    pp body
--    pause()
  [code, target, loc] := $data
  markInsertChanges(code,body,target,loc)

markInsertChanges(code,form,t,loc) ==
--RePLACe x at location "loc" in form as follows:
--  t is ['REPLACE,r]:   by r
--  t is 'rep/per:       by (rep x) or (per x)
--  code is @ : ::       by (@ x t) (: x t) (:: x t)
--  code is Lisp         by (pretend form t)
--  otherwise            by (:: form t)
  loc is [i,:r] =>
    x := form
    for j in 0..(i-1) repeat 
      if not atom x then x := CDR x
    atom x => 
        pp '"Translator RPLACA error"
        pp $data
        foobum form
        form
    if BOUNDP '$hohum and $hohum then pp [i, '" >>> ", x]
    SETQ($CHANGE,COPY x)
    if x is ['elt,:y] and r then x := y
    RPLACA(x,markInsertChanges(code,CAR x,t,rest loc))
    chk(x,100)
    form
--  pp ['"Making change: ",code,form,t]
  t is ['REPLACE,r] => SUBST(form,"##1",r)
  form is ['SEQ,:y,['exit,1,z]] => 
    ['SEQ,:[markInsertSeq(code,x,t) for x in y],
      ['exit,1,markInsertChanges(code,z,t,nil)]]
  code = '_pretend or code = '_: => 
    form is [op,a,.] and MEMQ(op,'(_@ _: _:_: _pretend)) => ['_pretend,a,t]
    [code,form,t]
  MEMQ(code,'(_@ _:_: _pretend)) =>  
    form is [op,a,b] and MEMQ(op,'(_@ _: _:_: _pretend)) =>
      MEMQ(op,'(_: _pretend)) => form
      op = code and b = t => form
      markNumCheck(code,form,t)
    FIXP form and MEMQ(opOf t,$markPrimitiveNumbers) => ['_@,form,t]
    [code,form,t]
  MEMQ(code,'(_@ _:_: _:)) and form is [op,a] and 
    (op='rep and t = 'Rep or op='per and t = "$") => form
  code = 'Lisp => 
    t = $EmptyMode => form
    ["pretend",form,t]
  MEMQ(t,'(rep per)) => 
    t = 'rep and EQCAR(form,'per) => CADR form
    t = 'per and EQCAR(form,'rep) => CADR form
    [t,form]
  code is [op,x,t1] and MEMQ(op,'(_@ _: _:_: _pretend)) and t1 = t => form
  FIXP form and MEMQ(opOf t,$markPrimitiveNumbers) => ['_@,form,t]
  markNumCheck("::",form,t)

markNumCheck(op,form,t) ==
  op = "::" and MEMQ(opOf t,'(Integer)) =>
     s := form = $One and 1 or form = $Zero and 0 => ['DOLLAR, s , t]
     FIXP form                   => ["@", form, t]
     form is ["-", =$One]        => ['DOLLAR, -1,   t]
     form is ["-", n] and FIXP n => ["@", MINUS n, t]
     [op, form, t]
  [op,form,t]

markInsertSeq(code,x,t) ==
  x is ['exit,y] => ['exit,markInsertChanges(code,y,t,nil)]
  atom x => x
  [markInsertSeq(code,y,t) for y in x]
--======================================================================
--               Prettyprint of translated program
--======================================================================
markFinish(body,T) ==
--called by compDefineCategory2, compDefineFunctor1 (early jumpout)
  SETQ($cs,$capsuleStack)
  SETQ($ps,$predicateStack)
  SETQ($ss,$signatureStack)
  SETQ($os,$originalTarget)
  SETQ($gis,$globalImportStack)
  SETQ($gds,$globalDeclareStack)
  SETQ($gms,$globalMacroStack)
  SETQ($as, $abbreviationStack)
  SETQ($lms,$localMacroStack)
  SETQ($map,$macrosAlreadyPrinted)
  SETQ($gs,$importStack)
  SETQ($fs,$freeStack)
  SETQ($b,body)
  SETQ($t,T)
  SETQ($e,T.env)
--if $categoryTranForm then SETQ($t,$categoryTranForm . 1)
  atom CDDR T => systemError()
  RPLACA(CDDR T,$EmptyEnvironment)
  chk(CDDR T,101)
  markFinish1()
  T

reFinish() ==
  $importStack := $gs
  $freeStack := $fs
  $capsuleStack := $cs
  $predicateStack := $ps
  $signatureStack := $ss
  $originalTarget := $os
  $globalMacroStack := $gms
  $abbreviationStack:= $as
  $globalImportStack := $gis
  $globalDeclareStack := $gds
  $localMacroStack := $lms
  $macrosAlreadyPrinted := $map
  $abbreviationsAlreadyPrinted := nil
  markFinish1()
 
markFinish1() ==
  body := $b
  T    := $t
  $predGensymAlist: local := nil
--$capsuleStack := $cs
--$predicateStack := $ps
  form := T. expr
  ['Mapping,:sig] := T.mode
  if $insideCategoryIfTrue and $insideFunctorIfTrue then
     $importStack       := [delete($categoryNameForDollar,x) for x in $importStack]
     $globalImportStack := delete($categoryNameForDollar,$globalImportStack)
  $commonImports : local := getCommonImports()
  globalImports := 
    REVERSE orderByContainment REMDUP [:$commonImports,:$globalImportStack]
  $finalImports: local := SETDIFFERENCE(globalImports,$globalDeclareStack)
  $capsuleStack := 
    [mkNewCapsuleItem(freepart,imports,x) for freepart in $freeStack 
       for imports in $importStack for x in $capsuleStack] 
  $extraDefinitions := combineDefinitions()
  addDomain := nil
  initbody :=
    $b is ['add,a,b] => 
      addDomain := a
      b
    $b is [op,:.] and constructor? op =>
      addDomain := $b
      nil
    $b
  body := markFinishBody initbody
  importCode := [['import,x] for x in $finalImports]
  leadingMacros := markExtractLeadingMacros(globalImports,body)
  body := markRemImportsAndLeadingMacros(leadingMacros,body)
  initcapsule := 
    body => ['CAPSULE,:leadingMacros,:importCode,:body]
    nil
  capsule := 
--  null initcapsule => addDomain
    addDomain => ['add,addDomain,initcapsule]
    initcapsule
  nsig :=
    $categoryPart => sig
    ['Type,:rest sig]
  for x in REVERSE $abbreviationStack |not member(x,$abbreviationsAlreadyPrinted) repeat 
     markPrintAbbreviation x
     $abbreviationsAlreadyPrinted := insert(x,$abbreviationsAlreadyPrinted)
  for x in REVERSE $globalMacroStack|not member(x,$macrosAlreadyPrinted) repeat
    $def := ['MDEF,first x,'(NIL),'(NIL),rest x]
    markPrint(true)
    $macrosAlreadyPrinted := insert(x,$macrosAlreadyPrinted)
  if $insideCategoryIfTrue and not $insideFunctorIfTrue then
    markPrintAttributes $b
  $def := ['DEF,form,nsig,[nil for x in form],capsule]
  markPrint()

stop x == x

getNumberTypesInScope() ==
  union([y for x in $localImportStack | MEMQ(y := opOf x,$markNumberTypes)], 
        [y for x in $globalImportStack| MEMQ(y := opOf x,$markNumberTypes)])

getCommonImports() ==
  importList := [x for x in $importStack for y in $capsuleStack |
                   KAR KAR y = 'DEF]
  hash := MAKE_-HASHTABLE 'EQUAL
  for x in importList repeat
    for y in x repeat HPUT(hash,y,1 + (HGET(hash,y) or 0))
  threshold := FLOOR (.5 * #importList)
  [x for x in HKEYS hash | HGET(hash,x) >= threshold]
  
markPrintAttributes addForm ==
  capsule :=
    addForm is ['add,a,:.] => 
      a is ['CATEGORY,:.] => a
      a is ['Join,:.] => CAR LASTNODE a
      CAR LASTNODE addForm
    addForm
  if capsule is ['CAPSULE,:r] then
    capsule := CAR LASTNODE r
  capsule isnt ['CATEGORY,.,:lst] => nil
  for x in lst | x is ['ATTRIBUTE,att] repeat
    markSay(form2String att)
    markSay('": Category == with")
    markTerpri()
    markTerpri()

getCommons u ==
  common := KAR u
  while common and u is [x,:u] repeat common := intersection(x,common)
  common

markExtractLeadingMacros(globalImports,body) ==
  [x for x in body | x is ['MDEF,[a],:.] and member(a,globalImports)]
  
markRemImportsAndLeadingMacros(leadingMacros,body) ==
  [x for x in body | x isnt ['import,:.] and not member(x,leadingMacros)]

mkNewCapsuleItem(frees,i,x) ==
  [originalDef,:ndef] := x
  imports := REVERSE orderByContainment REMDUP SETDIFFERENCE(i,$finalImports)
  importPart := [["import",d] for d in imports]
  nbody := 
    ndef is ['LET,.,x] => x
    ndef is ['DEF,.,.,.,x] => x
    ndef
  newerBody :=
    newPart := [:frees,:importPart] =>
      nbody is ['SEQ,:y] => ['SEQ,:newPart,:y]
      ['SEQ,:newPart,['exit,1,nbody]]
    nbody
  newerDef := 
    ndef is ['LET,a,x] => ['LET,a,newerBody]
    ndef is ['DEF,a,b,c,x] => ['DEF,a,b,c,newerBody]
    newerBody
  entry := [originalDef,:newerDef]
  entry

markFinishBody capsuleBody ==
  capsuleBody is ['CAPSULE,:itemlist] =>
    if $insideCategoryIfTrue and $insideFunctorIfTrue then
       itemlist := markCatsub itemlist
    [:[markFinishItem x for x in itemlist],:$extraDefinitions]
  nil

markCatsub x == SUBST("$",$categoryNameForDollar,x)
 
markFinishItem x ==
  $macroAlist : local := [:$localMacroStack,:$globalMacroStack]
  if $insideCategoryIfTrue and $insideFunctorIfTrue then
    $macroAlist := [["$",:$categoryNameForDollar],:$macroAlist]
  x is ['DEF,form,.,.,body] =>
    "or"/[new for [old,:new] in $capsuleStack |
        old is ['DEF,oform,.,.,obody] 
          and markCompare(form,oform) and markCompare(body,obody)] or
            pp '"------------MISSING----------------"
            $f := form
            $b := body
            newform := "or"/[x for [old,:new] in $capsuleStack | 
              old is ['DEF,oform,.,.,obody] and oform = $f]
            $ob:= (newform => obody; nil)
            pp $f
            pp $b
            pp $ob
            foobum x
            pp x
            x
  x is ['LET,lhs,rhs] =>
    "or"/[new for [old,:new] in $capsuleStack |
        old is ['LET,olhs,orhs]
          and markCompare(lhs,olhs) and markCompare(rhs,orhs)]
            or x
  x is ['IF,p,a,b] => ['IF,p,markFinishItem a,markFinishItem b]
  x is ['SEQ,:l,['exit,n,a]] =>
    ['SEQ,:[markFinishItem y for y in l],['exit,n,markFinishItem a]]
  "or"/[new for [old,:new] in $capsuleStack | markCompare(x,old)] =>
    new
  x
 
markCompare(x,y) == 
  markKillAll(SUBLIS($macroAlist,x)) = markKillAll(SUBLIS($macroAlist,y))

diffCompare(x,y) == diff(SUBLIS($macroAlist,x),markKillAll(SUBLIS($macroAlist,y)))
 
--======================================================================
--               Print functions
--======================================================================
markPrint(:options) ==   --print $def 
  noTrailingSemicolonIfTrue := IFCAR options
--$insideCategoryIfTrue and $insideFunctorIfTrue => nil
  $DEFdepth : local := 0
  [op,form,sig,sclist,body] := markKillAll $def
  if $insideCategoryIfTrue then
    if op = 'DEF and $insideFunctorIfTrue then
      T := $categoryTranForm . 1
      form := T . expr
      sig  := rest (T . mode)
    form := SUBLISLIS(rest markConstructorForm opOf form,
              $TriangleVariableList,form)
    sig  := SUBLISLIS(rest markConstructorForm opOf form,
              $TriangleVariableList,sig)
  nbody := body
  if $insideCategoryIfTrue then
    if $insideFunctorIfTrue then
      nbody := replaceCapsulePart body
      nbody :=
        $catAddForm => ['withDefault, $catAddForm, nbody]
        nbody
    else      
      ['add,a,:r] := $originalBody
      xtraLines := 
        "append"/[[STRCONC(name,'": Category == with"),'""] 
           for name in markCheckForAttributes a]
      nbody :=
        $originalBody is ['add,a,b] =>
          b isnt ['CAPSULE,:c] => error(false)
          [:l,x] := c
          [:markTranCategory a,['default,['SEQ,:l,['exit,1,x]]]]
        markTranCategory $originalBody      
  signature :=
    $insideFunctorIfTrue => [markTranJoin $originalTarget,:rest sig]
    $insideCategoryIfTrue => ['Category,:rest sig]
    '(NIL)
  $bootForm:= 
    op = 'MDEF => [op,form,signature,sclist,body]
    [op,form,signature,sclist,nbody]
  bootLines:= lisp2Boot $bootForm
  $bootLines:= [:xtraLines,:bootLines]
  moveAroundLines()
  markSay $bootLines
  markTerpri()
  'done

replaceCapsulePart body == 
  body isnt ['add,['CAPSULE,:c]] => body
  $categoryTranForm . 0 isnt ['add,exports,['CAPSULE,:.]] => error(false) 
  [:l,x] := c
  [:markTranCategory exports,['default,['SEQ,:l,['exit,1,x]]]]

foo(:x) == 
 arg := IFCAR x or $bootForm
 markSay lisp2Boot arg

markPrintAbbreviation [kind,a,:b] == 
  markSay '"--)abbrev "
  markSay kind
  markSay '" "
  markSay a
  markSay '" "
  markSay b
  markTerpri()

markSay s == 
  null atom s =>
    for x in s repeat
      (markSay(lispStringList2String x); markTerpri())
  PRINTEXP s
  if $outStream then PRINTEXP(s,$outStream)

markTerpri() ==
  TERPRI()
  if $outStream then TERPRI($outStream)

markTranJoin u ==                      --subfunction of markPrint
  u is ['Join,:.] => markTranCategory u
  u

markTranCategory cat ==               
  cat is ['CATEGORY,:.] => cat
  cat is ['Join,:r] =>
    r is [:s,b] and b is ['CATEGORY,k,:t] => ['CATEGORY,k,:s,:markSigTran t] 
    ['CATEGORY,'domain,:markSigTran r]
  ['CATEGORY,'domain,cat]

markSigTran t == [markElt2Apply x for x in t]

markElt2Apply x ==
  x is ["SIGNATURE", "elt", :r] => ['SIGNATURE, 'apply, :r]
  x

markCheckForAttributes cat ==          --subfunction of markPrint
  cat is ['Join,:r] => markCheckForAttributes last r
  cat is ['CATEGORY,.,:r] => [u for x in r | u := fn(x)] where fn(x) ==
    x is ['ATTRIBUTE,form,:.] => 
      name := opOf form
      MEMQ(name,$knownAttributes) => nil
      $knownAttributes := [name,:$knownAttributes]
      name
    nil
  nil

--======================================================================
--        Put in PARTs in code
--======================================================================
$partChoices := '(construct IF)
$partSkips   := '(CAPSULE with add)
unpart x ==
  x is ['PART,.,y] => y
  x

markInsertParts df ==
  $partNumber := 0
  ["DEF",form,a,b,body] := df
--if form is [op,:r] and (u := LASSOC(op,$opRenameAlist)) 
--  then form := [u,:r]
  ['DEF,form,a,b,markInsertBodyParts body]
  
markInsertBodyParts u ==
  u is ['Join,:.] or u is ['CATEGORY,:.] => u
  u is ['DEF,f,a,b,body] => ['DEF,f,a,b,markInsertBodyParts body]
  u is ['SEQ,:l,['exit,n,x]] =>
    ['SEQ,:[markInsertBodyParts y for y in l],
           ['exit,n,markInsertBodyParts x]]
  u is [op,:l] and MEMQ(op,'(REPEAT COLLECT)) => markInsertRepeat u
  u is ['LET,['Tuple,:s],b] =>
    ['LET,['Tuple,:[markWrapPart x for x in s]],markInsertBodyParts b]
--u is ['LET,a,b] and constructor? opOf b => u
  u is ['LET,a,b] and a is [op,:.] =>
    ['LET,[markWrapPart x for x in a],markInsertBodyParts b]
  u is [op,a,b] and MEMQ(op,'(_add _with IN LET)) =>
    [op,markInsertBodyParts a,markInsertBodyParts b]
  u is [op,a,b] and MEMQ(op,'(_: _:_: _pretend _@)) =>
    [op,markInsertBodyParts a,b]
  u is [op,a,:x] and MEMQ(op,'(STEP return leave exit reduce)) => 
    [op,a,:[markInsertBodyParts y for y in x]]
  u is [op,:x] and markPartOp? op => [op,:[markWrapPart y for y in x]]
  u is [op,:.] and constructor? op => u
  atom u => markWrapPart u
            ------------           <--------------94/10/11
  [markInsertBodyParts x for x in u]

markPartOp? op ==
  MEMQ(op,$partChoices) => true
  MEMQ(op,$partSkips)   => false
  if op is ['elt,.,o] then op := o
  GETL(op,'special) => false
  true

markWrapPart y ==
----------------new definition----------94/10/11
  atom y => 
    y = 'noBranch => y
    GETL(y, 'SPECIAL) => y 
    $partNumber := $partNumber + 1
    ['PART,$partNumber, y] 
  ['PART,$partNumber := $partNumber + 1,markInsertBodyParts y]

markInsertRepeat [op,:itl,body] ==
  nitl := [markInsertIterator x for x in itl]
  nbody := 
--->IDENTP body => markWrapPart body
----------------new definition----------94/10/11
    markInsertBodyParts body
  [op,:nitl,nbody]

markInsertIterator x ==
  x is ['STEP,k,:r]  => ['STEP,markWrapPart k,:[markWrapPart x for x in r]]
  x is ['IN,p,q]     => ['IN,markWrapPart p,markWrapPart q]
  x is ["|",p]       => ["|",markWrapPart p]
  x is ['WHILE,p]    => ['WHILE,markWrapPart p]
  x is ['UNTIL,p]    => ['UNTIL,markWrapPart p]
  systemError()
  
--======================================================================
--        Kill Function: MarkedUpCode --> Code
--======================================================================

markKillExpr m ==    --used to kill all but PART information for compilation
  m is [op,:.] =>
    MEMQ(op,'(MI WI)) => markKillExpr CADDR m
    MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillExpr CADDDR m
    m is ['TAGGEDreturn,a,[x,m,e]] => ['TAGGEDreturn, a, [markKillExpr x,m,e]]
    [markKillExpr x for x in m]
  m
 
markKillButIfs m ==    --used to kill all but PART information for compilation
  m is [op,:.] =>
    op = 'IF => m
    op = 'PART        => markKillButIfs CADDR m
    MEMQ(op,'(MI WI)) => markKillButIfs CADDR m
    MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillButIfs CADDDR m
    m is ['TAGGEDreturn,a,[x,m,e]] => ['TAGGEDreturn, a, [markKillButIfs x,m,e]]
    [markKillButIfs x for x in m]
  m
 
markKillAll m ==      --used to prepare code for compilation
  m is [op,:.] =>
    op = 'PART        => markKillAll CADDR m
    MEMQ(op,'(MI WI)) => markKillAll CADDR m
    MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillAll CADDDR m
    m is ['TAGGEDreturn,a,[x,m,e]] => ['TAGGEDreturn, a, [markKillAll x,m,e]]
    [markKillAll x for x in m]
  m
 
--======================================================================
--                Moving lines up/down 
--======================================================================
moveAroundLines() ==
  changeToEqualEqual $bootLines
  $bootLines := moveImportsAfterDefinitions $bootLines  

changeToEqualEqual lines ==
--rewrite A := B as A == B whenever A is an identifier and
--                                  B is a constructor name (after macro exp.)
  origLines := lines
  while lines is [x, :lines] repeat
    N := MAXINDEX x
    (n := charPosition($blank, x, 8)) > N => nil
    n = 0 => nil
    not ALPHA_-CHAR_-P (x . (n - 1)) => nil
    not substring?('":= ", x, n+1) => nil
    m := n + 3
    while (m := m + 1) <= N and ALPHA_-CHAR_-P (x . m) repeat nil
    m = n + 2 => nil
    not UPPER_-CASE_-P (x . (n + 4)) => nil
    word := INTERN SUBSTRING(x, n + 4, m - n - 4)
    expandedWord := macroExpand(word,$e)
    not (MEMQ(word, '(Record Union Mapping)) 
      or GETDATABASE(opOf expandedWord,'CONSTRUCTORFORM)) => nil
    sayMessage '"Converting input line:"
    sayMessage ['"WAS: ", x]
    x . (n + 1) := char '_= ;
    sayMessage ['"IS:  ", x]
    TERPRI()
  origLines
    
sayMessage x == 
  u := 
    ATOM x => ['">> ", x]
    ['">> ",: x]
  sayBrightly u
  
moveImportsAfterDefinitions lines ==
  al := nil
  for x in lines for i in 0.. repeat
    N := MAXINDEX x
    m := firstNonBlankPosition x
    m < 0 => nil
    ((n := charPosition($blank ,x,1 + m)) < N) and
      substring?('"== ", x, n+1) => 
        name := SUBSTRING(x, m, n - m)
        defineAlist := [[name, :i], :defineAlist]
    (k := leadingSubstring?('"import from ",x, 0)) =>
      importAlist := [[SUBSTRING(x,k + 12,nil), :i], :importAlist]
--  pp defineAlist
--  pp importAlist
  for [name, :i] in defineAlist repeat
    or/[fn for [imp, :j] in importAlist] where fn() ==
      substring?(name,imp,0) =>
        moveAlist := [[i,:j], :moveAlist]
      nil
  null moveAlist => lines
  moveLinesAfter(mySort moveAlist, lines)

leadingSubstring?(part, whole, :options) ==
  after := IFCAR options or 0
  substring?(part, whole, k := firstNonBlankPosition(whole, after)) => k
  false

stringIsWordOf?(s, t, startpos) ==
  maxindex := MAXINDEX t
  (n := stringPosition(s, t, startpos)) > maxindex => nil
  wordDelimiter? t . (n - 1)
  n = maxindex or wordDelimiter? t . (n + #s)

wordDelimiter? c == or/[CHAR_=(c,('"() ,;").i) for i in 0..4]

moveLinesAfter(alist, lines) ==
  n := #lines
  acc := nil
  for i in 0..(n - 1) for x in lines repeat
    (p :=  ASSOC(i, alist)) and STRINGP CDR p => acc := [CDR p, x, :acc]
    (p :=  lookupRight(i, alist)) and (CAR p) > i => RPLACD(p, x)
    acc := [x, :acc]
  REVERSE acc  
  
lookupRight(x, al) == 
  al is [p, :al] =>
    x = CDR p => p
    lookupRight(x, al)
  nil

--======================================================================
--                Utility Functions
--======================================================================
  
ppEnv [ce,:.] ==
  for env in ce repeat
    for contour in env repeat
      pp contour
    
diff(x,y) ==
  for [p,q] in (r := diff1(x,y)) repeat 
    pp '"------------"
    pp p
    pp q
  #r
 
diff1(x,y) ==
  x = y => nil
  ATOM x or ATOM y => [[x,y]]
  #x ^= #y => [x,y]
  "APPEND"/[diff1(u,v) for u in x for v in y]
    
markConstructorForm name ==  --------> same as getConstructorForm
  name = 'Union   => '(Union  (_: a A) (_: b B))
  name = 'UntaggedUnion => '(Union A B)
  name = 'Record  => '(Record (_: a A) (_: b B))
  name = 'Mapping => '(Mapping T S)
  GETDATABASE(name,'CONSTRUCTORFORM)

--======================================================================
--                new path functions
--======================================================================
  
markGetPaths(x,y) == 
  BOUNDP '$newPaths and $newPaths => 
--  res := reverseDown mkGetPaths(x, y)
    res := mkGetPaths(x, y)
--    oldRes := markPaths(x,y,[nil])
--    if res ^= oldRes then $badStack := [[x, :y], :$badStack]
--    oldRes
  markPaths(x,y,[nil])
 
mkCheck() ==
  for [x, :y] in REMDUP $badStack repeat
    pp '"!!-------------------------------!!"
    res := mkGetPaths(x, y)
    oldRes := markPaths(x, y, [nil])
    pp x
    pp y
    sayBrightlyNT '"new: "
    pp res
    sayBrightlyNT '"old: "
    pp oldRes

reverseDown u == [REVERSE x for x in u]

mkCheckRun() ==
  for [x, :y] in REMDUP $badStack repeat
    pp mkGetPaths(x,y)

mkGetPaths(x,y) ==
  u := REMDUP mkPaths(x,y) => getLocationsOf(u,y,nil)
  nil   

mkPaths(x,y) ==   --x < y; find location s of x in y (initially s=nil)
  markPathsEqual(x,y) => [y]
  atom y => nil
  x is [op, :u] and MEMQ(op,'(LIST VECTOR)) and y is ['construct,:v] 
    and markPathsEqual(['construct,:u],y) => [y]
  (y is ['LET,a,b] or y is ['IF,a,b,:.]) and GENSYMP a and markPathsEqual(x,b) => [y]
  y is ['call,:r] => 
--  markPathsEqual(x,y1) => [y]
    mkPaths(x,r) => [y]
  y is ['PART,.,y1] => mkPaths(x,y1)
  y is [fn,.,y1] and MEMQ(fn,'(CATCH THROW)) =>
--  markPathsEqual(x,y1) => [y]
    mkPaths(x,y1) => [y]
  y is [['elt,.,op],:r] and (u := mkPaths(x,[op,:r])) => u
  x is ['elt,:r] and (u := mkPaths(r,y)) => u
  y is ['elt,:r] and (u := mkPaths(x,r)) => u
  "APPEND"/[u for z in y | u := mkPaths(x,z)]

getLocationsOf(u,y,s) == [getLocOf(x,y,s) for x in u]

getLocOf(x,y,s) ==
  x = y or x is ['elt,:r] and r = y => s
  y is ['PART,.,y1] => getLocOf(x,y1,s)
  if y is ['elt,:r] then y := r
  atom y => nil
  or/[getLocOf(x,z,[i, :s]) for i in 0.. for z in y]

  
--======================================================================
--           Combine Multiple Definitions Into One
--======================================================================

combineDefinitions() ==
--$capsuleStack has form   (def1  def2  ..)
--$signatureStack has form (sig1  sig2  ..) where sigI = nil if not a def
--$predicateStack has form (pred1 pred2 ..)
--record in $hash: alist of form [[sig, [predl, :body],...],...] under each op
  $hash  := MAKE_-HASH_-TABLE()
  for defs in $capsuleStack 
    for sig in $signatureStack 
      for predl in $predicateStack | sig repeat
--      pp [defs, sig, predl]
        [["DEF",form,:.],:.] := defs
        item := [predl, :defs]
        op := opOf form
        oldAlist := HGET($hash,opOf form) 
        pair := ASSOC(sig, oldAlist) => RPLACD(pair, [item,:CDR pair])
        HPUT($hash, op, [[sig, item], :oldAlist])
--extract and combine multiple definitions
  Xdeflist := nil
  for op in HKEYS $hash repeat
    $acc: local := nil
    for [sig,:items] in HGET($hash,op) | (k := #items) > 1 repeat
      for i in 1.. for item in items repeat
        [predl,.,:def]    := item
        ['DEF, form, :.] := def
        ops := PNAME op
        opName := INTERN(STRCONC(ops,'"X",STRINGIMAGE i))
        RPLACA(form, opName)
--      rplacaSubst(op, opName, def)
        $acc := [[form,:predl], :$acc]
      Xdeflist := [buildNewDefinition(op,sig,$acc),:Xdeflist]
  REVERSE Xdeflist
               
rplacaSubst(x, y, u) == (fn(x, y, u); u) where fn(x,y,u) ==
  atom u => nil
  while u is [p, :q] repeat
    if EQ(p, x) then RPLACA(u, y)
    if null atom p then fn(x, y, p)
    u := q
    
buildNewDefinition(op,theSig,formPredAlist) ==
  newAlist := [fn for item in formPredAlist] where fn() ==
    [form,:predl] := item
    pred :=
      null predl => 'T
      boolBin simpHasPred markKillAll MKPF(predl,"and") 
    [pred, :form]
  --make sure that T comes as last predicate
  outerPred := boolBin simpHasPred MKPF(ASSOCLEFT newAlist,"or")
  theForm := CDAR newAlist
  alist := moveTruePred2End newAlist
  theArgl := CDR theForm
  theAlist := [[pred, CAR form, :theArgl] for [pred,:form] in alist]
  theNils := [nil for x in theForm]
  thePred :=
     member(outerPred, '(T (QUOTE T))) => nil
     outerPred
  def := ['DEF, theForm, theSig, theNils, ifize theAlist]
  value :=
    thePred => ['IF, thePred, def, 'noBranch]
    def
  stop value 
  value

boolBin x ==
  x is [op,:argl] =>
    MEMQ(op,'(AND OR)) and argl is [a, b, :c] and c => boolBin [op, boolBin [op, a, b], :c]
    [boolBin y for y in x]
  x

ifize [[pred,:value],:r] ==
  null r => value
  ['IF, pred, value, ifize r]
  
moveTruePred2End alist ==
  truthPair := or/[pair for pair in alist | pair is ["T",:.]] =>
    [:delete(truthPair, alist), truthPair]      
  [:a, [lastPair, lastValue]] := alist
  [:a, ["T", lastValue]]

PE e ==
  for x in CAAR e for i in 1.. repeat
    ppf [i, :x]

ppf x ==
  _*PRETTYPRINT_* : local := true
  PRINT_-FULL x