aboutsummaryrefslogtreecommitdiff
path: root/src/interp/mark.boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/mark.boot')
-rw-r--r--src/interp/mark.boot1496
1 files changed, 1496 insertions, 0 deletions
diff --git a/src/interp/mark.boot b/src/interp/mark.boot
new file mode 100644
index 00000000..333beb67
--- /dev/null
+++ b/src/interp/mark.boot
@@ -0,0 +1,1496 @@
+-- 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
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-17 15:10:57 +0000