diff --git a/changelog b/changelog index ddea8b0..8655d09 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,9 @@ +20090906 tpd src/axiom-website/patches.html 20090906.01.tpd.patch +20090906 tpd src/interp/Makefile move nruncomp.boot to nruncomp.lisp +20090906 tpd src/interp/nruncomp.lisp added, rewritten from nruncomp.boot +20090906 tpd src/interp/nruncomp.boot removed, rewritten to nruncomp.lisp +20090906 tpd src/interp/mark.lisp added, rewritten from mark.boot +20090906 tpd src/interp/mark.boot removed, rewritten to mark.lisp 20090905 tpd src/axiom-website/patches.html 20090905.03.tpd.patch 20090905 tpd src/interp/Makefile move ht-util.boot to ht-util.lisp 20090905 tpd src/interp/ht-util.lisp added, rewritten from ht-util.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index b074076..31170b7 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1994,5 +1994,7 @@ src/interp/wi2.lisp rewrite from boot to lisp
src/interp/ax.lisp fix typo
20090905.03.tpd.patch src/interp/ht-util.lisp rewrite from boot to lisp
+20090906.01.tpd.patch +src/interp/mark.lisp, nruncomp.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 000de15..6bc6b0c 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -2823,41 +2823,27 @@ ${MID}/newfort.lisp: ${IN}/newfort.lisp.pamphlet @ -\subsection{nruncomp.boot} -<>= -${AUTO}/nruncomp.${O}: ${OUT}/nruncomp.${O} - @ echo 351 making ${AUTO}/nruncomp.${O} from ${OUT}/nruncomp.${O} - @ cp ${OUT}/nruncomp.${O} ${AUTO} - -@ +\subsection{nruncomp.lisp} <>= -${OUT}/nruncomp.${O}: ${MID}/nruncomp.clisp - @ echo 352 making ${OUT}/nruncomp.${O} from ${MID}/nruncomp.clisp - @ (cd ${MID} ; \ +${OUT}/nruncomp.${O}: ${MID}/nruncomp.lisp + @ echo 136 making ${OUT}/nruncomp.${O} from ${MID}/nruncomp.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/nruncomp.clisp"' \ - ':output-file "${OUT}/nruncomp.${O}") (${BYE}))' | ${DEPSYS} ; \ + echo '(progn (compile-file "${MID}/nruncomp.lisp"' \ + ':output-file "${OUT}/nruncomp.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/nruncomp.clisp"' \ - ':output-file "${OUT}/nruncomp.${O}") (${BYE}))' | ${DEPSYS} \ + echo '(progn (compile-file "${MID}/nruncomp.lisp"' \ + ':output-file "${OUT}/nruncomp.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/nruncomp.clisp: ${IN}/nruncomp.boot.pamphlet - @ echo 353 making ${MID}/nruncomp.clisp \ - from ${IN}/nruncomp.boot.pamphlet +<>= +${MID}/nruncomp.lisp: ${IN}/nruncomp.lisp.pamphlet + @ echo 137 making ${MID}/nruncomp.lisp from \ + ${IN}/nruncomp.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/nruncomp.boot.pamphlet >nruncomp.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "nruncomp.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "nruncomp.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm nruncomp.boot ) + ${TANGLE} ${IN}/nruncomp.lisp.pamphlet >nruncomp.lisp ) @ @@ -4121,32 +4107,23 @@ ${MID}/pspad2.lisp: ${IN}/pspad2.lisp.pamphlet \subsection{mark.boot} <>= -${AUTO}/mark.${O}: ${MID}/mark.clisp - @ echo 604 making ${AUTO}/mark.${O} from ${MID}/mark.clisp +${AUTO}/mark.${O}: ${MID}/mark.lisp + @ echo 598 making ${AUTO}/mark.${O} from ${MID}/mark.lisp @ (cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/mark.clisp"' \ + echo '(progn (compile-file "${MID}/mark.lisp"' \ ':output-file "${AUTO}/mark.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/mark.clisp"' \ + echo '(progn (compile-file "${MID}/mark.lisp"' \ ':output-file "${AUTO}/mark.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/mark.clisp: ${IN}/mark.boot.pamphlet - @ echo 605 making ${MID}/mark.clisp from ${IN}/mark.boot.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/mark.boot.pamphlet >mark.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "mark.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "mark.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm mark.boot ) +<>= +${MID}/mark.lisp: ${IN}/mark.lisp.pamphlet + @ echo 599 making ${MID}/mark.lisp from ${IN}/mark.lisp.pamphlet + @ ${TANGLE} ${IN}/mark.lisp.pamphlet >${MID}/mark.lisp @ @@ -4492,7 +4469,7 @@ clean: <> <> -<> +<> <> <> @@ -4578,9 +4555,8 @@ clean: <> <> -<> <> -<> +<> <> <> diff --git a/src/interp/mark.boot.pamphlet b/src/interp/mark.boot.pamphlet deleted file mode 100644 index 89fce1b..0000000 --- a/src/interp/mark.boot.pamphlet +++ /dev/null @@ -1,1516 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp mark.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} - -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 - -\end{verbatim} -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- 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. - -@ -<<*>>= -<> - -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 = GET(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 - GET(op,'special) => false - true - -markWrapPart y == -----------------new definition----------94/10/11 - atom y => - y = 'noBranch => y - GET(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 - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/mark.lisp.pamphlet b/src/interp/mark.lisp.pamphlet new file mode 100644 index 0000000..9d176df --- /dev/null +++ b/src/interp/mark.lisp.pamphlet @@ -0,0 +1,6589 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp mark.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\begin{verbatim} + +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 + +\end{verbatim} +<<*>>= +(IN-PACKAGE "BOOT" ) + +;REMPROP("and",'parseTran) + +(REMPROP '|and| '|parseTran|) + +;REMPROP("or",'parseTran) + +(REMPROP '|or| '|parseTran|) + +;REMPROP("not",'parseTran) + +(REMPROP '|not| '|parseTran|) + +;MAKEPROP("and",'special,'compAnd) + +(MAKEPROP '|and| '|special| '|compAnd|) + +;MAKEPROP("or",'special,'compOr) + +(MAKEPROP '|or| '|special| '|compOr|) + +;MAKEPROP("not",'special,'compNot) + +(MAKEPROP '|not| '|special| '|compNot|) + +;SETQ($monitorWI,nil) + +(SETQ |$monitorWI| NIL) + +;SETQ($monitorCoerce,nil) + +(SETQ |$monitorCoerce| NIL) + +;SETQ($markPrimitiveNumbers,nil) -- '(Integer SmallInteger)) + +(SETQ |$markPrimitiveNumbers| NIL) + +;SETQ($markNumberTypes,'(Integer SmallInteger PositiveInteger NonNegativeInteger)) + +(SETQ |$markNumberTypes| + '(|Integer| |SmallInteger| |PositiveInteger| + |NonNegativeInteger|)) + +;--====================================================================== +;-- Master Markup Function +;--====================================================================== +; +;WI(a,b) == b + +;;; *** WI REDEFINED + +(DEFUN WI (|a| |b|) + (declare (ignore |a|)) + |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 + +(DEFUN |mkWi| (&REST G166093 &AUX |r| |fn|) + (DSETQ (|fn| . |r|) G166093) + (PROG (|a| |b| |ISTMP#1| |ISTMP#2|) + (RETURN + (COND + ((AND (PAIRP |r|) (EQ (QCAR |r|) 'WI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) 'T)))))) + (COND + ((BOOT-EQUAL |a| |b|) |a|) + ((AND (PAIRP |b|) (EQ (QCAR |b|) 'WI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |a|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + |b|) + ('T |r|))) + ('T |r|))))) + +;--====================================================================== +;-- Capsule Function Transformations +;--====================================================================== +;tcheck T == +; if T isnt [.,.,.] then systemError 'tcheck +; T + +(DEFUN |tcheck| (T$) + (PROG (|ISTMP#1| |ISTMP#2|) + (RETURN + (PROGN + (COND + ((NULL (AND (PAIRP T$) + (PROGN + (SPADLET |ISTMP#1| (QCDR T$)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL))))))) + (|systemError| '|tcheck|))) + T$)))) + +;markComp(x,T) == --for comp +; tcheck T +; x ^= CAR T => [mkWi('comp,'WI,x,CAR T),:CDR T] +; T + +(DEFUN |markComp| (|x| T$) + (PROGN + (|tcheck| T$) + (COND + ((NEQUAL |x| (CAR T$)) + (CONS (|mkWi| '|comp| 'WI |x| (CAR T$)) (CDR T$))) + ('T T$)))) + +;markAny(key,x,T) == +; tcheck T +; x ^= CAR T => [mkWi(key,'WI,x,CAR T),:CDR T] +; T + +(DEFUN |markAny| (|key| |x| T$) + (PROGN + (|tcheck| T$) + (COND + ((NEQUAL |x| (CAR T$)) + (CONS (|mkWi| |key| 'WI |x| (CAR T$)) (CDR T$))) + ('T T$)))) + +;markConstruct(x,T) == +; tcheck T +; markComp(x,T) + +(DEFUN |markConstruct| (|x| T$) + (PROGN (|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] + +(DEFUN |markParts| (|x| T$) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|makeParts| 'WI |x| (CAR T$)) (CDR T$)))) + +;yumyum kind == kind + +(DEFUN |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 + +(DEFUN |markCoerce| (T$ |T'| |kind|) + (PROG (|ISTMP#1| |ISTMP#2| |y| |u| |res|) + (declare (special |$partExpression|)) + (RETURN + (PROGN + (|tcheck| T$) + (|tcheck| |T'|) + (COND ((BOOT-EQUAL |kind| 'AUTOSUBSET) (|yumyum| |kind|))) + (COND + ((AND (STRINGP (CADR T$)) + (BOOT-EQUAL (CADR |T'|) '(|String|))) + |T'|) + ((BOOT-EQUAL (|markKillAll| (CADR T$)) (CADR |T'|)) |T'|) + ('T + (SPADLET |u| + (COND + ((AND (PAIRP |$partExpression|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |$partExpression|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y| (QCAR |ISTMP#2|)) + 'T))))) + (BOOT-EQUAL (CAR T$) |y|)) + (CONS 'WI + (CONS |y| (CONS |$partExpression| NIL)))) + ('T (CAR T$)))) + (SPADLET |res| + (CONS (|markCoerceChk| + (|mkWi| '|coerce| |kind| (CADR T$) + (CADR |T'|) + (|mkWi| '|coerce| 'WI |u| + (CAR |T'|)))) + (CDR |T'|))) + |res|)))))) + +;markCoerceChk x == +; x is ['AUTOSUBSET,a,b,['WI,c,['AUTOSUBSET,=b, =a, =c]]] => c +; x + +(DEFUN |markCoerceChk| (|x|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |ISTMP#4| |ISTMP#5| |c| + |ISTMP#6| |ISTMP#7| |ISTMP#8| |ISTMP#9| |ISTMP#10|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'AUTOSUBSET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |ISTMP#4| + (QCAR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCAR |ISTMP#4|) 'WI) + (PROGN + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (PROGN + (SPADLET |c| + (QCAR |ISTMP#5|)) + (SPADLET |ISTMP#6| + (QCDR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) + (EQ (QCDR |ISTMP#6|) NIL) + (PROGN + (SPADLET |ISTMP#7| + (QCAR |ISTMP#6|)) + (AND (PAIRP |ISTMP#7|) + (EQ (QCAR |ISTMP#7|) + 'AUTOSUBSET) + (PROGN + (SPADLET |ISTMP#8| + (QCDR |ISTMP#7|)) + (AND (PAIRP |ISTMP#8|) + (EQUAL + (QCAR |ISTMP#8|) + |b|) + (PROGN + (SPADLET |ISTMP#9| + (QCDR |ISTMP#8|)) + (AND + (PAIRP |ISTMP#9|) + (EQUAL + (QCAR |ISTMP#9|) + |a|) + (PROGN + (SPADLET + |ISTMP#10| + (QCDR + |ISTMP#9|)) + (AND + (PAIRP + |ISTMP#10|) + (EQ + (QCDR + |ISTMP#10|) + NIL) + (EQUAL + (QCAR + |ISTMP#10|) + |c|)))))))))))))))))))))) + |c|) + ('T |x|))))) + +;markMultipleExplicit(nameList, valList, T) == +; tcheck T +; [mkWi('setqMultipleExplicit, 'WI, +; ['LET, ['Tuple,:nameList], ['Tuple,:valList]], +; T.expr), :CDR T] + +(DEFUN |markMultipleExplicit| (|nameList| |valList| T$) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|setqMultipleExplicit| 'WI + (CONS 'LET + (CONS (CONS '|Tuple| |nameList|) + (CONS (CONS '|Tuple| |valList|) NIL))) + (CAR T$)) + (CDR T$)))) + +;markRetract(x,T) == +; tcheck T +; [mkWi('smallIntegerStep,'RETRACT,nil,['REPLACE,['retract,x]],T.expr),:CDR T] + +(DEFUN |markRetract| (|x| T$) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|smallIntegerStep| 'RETRACT NIL + (CONS 'REPLACE + (CONS (CONS '|retract| (CONS |x| NIL)) NIL)) + (CAR T$)) + (CDR T$)))) + +;markSimpleReduce(x,T) == +; tcheck T +; [mkWi('compreduce,'LAMBDA, nil, ["REPLACE",x], T.expr), :CDR T] + +(DEFUN |markSimpleReduce| (|x| T$) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|compreduce| 'LAMBDA NIL + (CONS 'REPLACE (CONS |x| NIL)) (CAR T$)) + (CDR T$)))) + +;markCompAtom(x,T) == --for compAtom +; tcheck T +; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => +; [mkWi('compAtom,'ATOM,nil,['REPLACE,[x]],T.expr),:CDR T] +; T + +(DEFUN |markCompAtom| (|x| T$) + (declare (special |$convert2NewCompiler|)) + (PROGN + (|tcheck| T$) + (COND + ((AND (BOUNDP '|$convert2NewCompiler|) |$convert2NewCompiler|) + (CONS (|mkWi| '|compAtom| 'ATOM NIL + (CONS 'REPLACE (CONS (CONS |x| NIL) NIL)) + (CAR T$)) + (CDR T$))) + ('T T$)))) + +;markCase(x, tag, T) == +; tcheck T +; [mkWi('compCase1, 'LAMBDA, nil, ["REPLACE",["case",x,tag]], T.expr), +; :CDR T] + +(DEFUN |markCase| (|x| |tag| T$) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|compCase1| 'LAMBDA NIL + (CONS 'REPLACE + (CONS (CONS '|case| + (CONS |x| (CONS |tag| NIL))) + NIL)) + (CAR T$)) + (CDR T$)))) + +;markCaseWas(x,T) == +; tcheck T +; [mkWi('compCase1,'WI,x,T.expr),:CDR T] + +(DEFUN |markCaseWas| (|x| T$) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|compCase1| 'WI |x| (CAR T$)) (CDR T$)))) + +;markAutoWas(x,T) == +; tcheck T +; [mkWi('autoCoerce,'WI,x,T.expr),:CDR T] + +(DEFUN |markAutoWas| (|x| T$) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|autoCoerce| 'WI |x| (CAR T$)) (CDR T$)))) + +;markCallCoerce(x,m,T) == +; tcheck T +; [mkWi("call",'WI,["::",x,m], T.expr),: CDR T] + +(DEFUN |markCallCoerce| (|x| |m| T$) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|call| 'WI (CONS '|::| (CONS |x| (CONS |m| NIL))) + (CAR T$)) + (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] + +(DEFUN |markCoerceByModemap| + (|x| |source| |target| T$ |killColonColon?|) + (PROG (|tag| |l|) + (RETURN + (PROGN + (|tcheck| T$) + (COND + ((AND (PAIRP |source|) (EQ (QCAR |source|) '|Union|) + (PROGN (SPADLET |l| (QCDR |source|)) 'T) + (|member| |target| |l|)) + (SPADLET |tag| + (OR (|genCaseTag| |target| |l| 1) (RETURN NIL))) + (|markAutoCoerceDown| |x| |tag| (|markAutoWas| |x| T$) + |killColonColon?|)) + ((AND (PAIRP |target|) (EQ (QCAR |target|) '|Union|) + (PROGN (SPADLET |l| (QCDR |target|)) 'T) + (|member| |source| |l|)) + (|markAutoCoerceUp| |x| (|markAutoWas| |x| T$))) + ('T + (CONS (|mkWi| '|markCoerceByModemap| 'WI |x| (CAR T$)) + (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] + +(DEFUN |markAutoCoerceDown| (|x| |tag| T$ |killColonColon?|) + (PROG (|patch|) + (RETURN + (PROGN + (|tcheck| T$) + (SPADLET |patch| + (CONS '|dot| + (CONS (|getSourceWI| |x|) (CONS |tag| NIL)))) + (COND + (|killColonColon?| + (SPADLET |patch| + (CONS 'REPLACE + (CONS (CONS 'UNCOERCE (CONS |patch| NIL)) + NIL))))) + (CONS (|mkWi| '|coerceExtraHard| 'LAMBDA NIL |patch| (CAR T$)) + (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] + +(DEFUN |markAutoCoerceUp| (|x| T$) + (declare (ignore |x|)) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|coerceExtraHard| 'LAMBDA NIL + (CONS 'REPLACE + (CONS (CONS '|construct| (CONS '|##1| NIL)) + NIL)) + (CAR T$)) + (CDR T$)))) + +;markCompSymbol(x,T) == --for compSymbol +; tcheck T +; [mkWi('compSymbol,'ATOM,nil,['REPLACE,["@",x,$Symbol]],T.expr),:CDR T] + +(DEFUN |markCompSymbol| (|x| T$) + (declare (special |$Symbol|)) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|compSymbol| 'ATOM NIL + (CONS 'REPLACE + (CONS (CONS '@ (CONS |x| (CONS |$Symbol| NIL))) + NIL)) + (CAR T$)) + (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]) + +(DEFUN |markStepSI| (|ostep| |nstep|) + (PROG (|r| |i| |s|) + (RETURN + (PROGN + (SPADLET |r| (CDR |ostep|)) + (SPADLET |i| (CADR |nstep|)) + (SPADLET |s| (CDDR |nstep|)) + (|markImport| '|SmallInteger|) + (|mkWi| '|markStepSI| 'WI |ostep| + (CONS 'ISTEP + (CONS (|mkWi| '|markStep| 'FREESI NIL + (CONS 'REPLACE + (CONS + (CONS 'PAREN + (CONS + (CONS '|free| (CONS |i| NIL)) + NIL)) + NIL)) + |i|) + |s|))))))) + +;-- i],i),:s]) +;markStep(i) == mkWi('markStep,'FREE,nil,['REPLACE, ['PAREN,['free,i]]],i) + +(DEFUN |markStep| (|i|) + (|mkWi| '|markStep| 'FREE NIL + (CONS 'REPLACE + (CONS (CONS 'PAREN + (CONS (CONS '|free| (CONS |i| NIL)) NIL)) + NIL)) + |i|)) + +;-- i],i) +;markPretend(T,T') == +; tcheck T +; tcheck T' +; [mkWi('pretend,'COLON,"pretend",T.mode,T.expr),:CDR T'] + +(DEFUN |markPretend| (T$ |T'|) + (PROGN + (|tcheck| T$) + (|tcheck| |T'|) + (CONS (|mkWi| '|pretend| 'COLON '|pretend| (CADR T$) (CAR T$)) + (CDR |T'|)))) + +;markAt(T) == +; tcheck T +; [mkWi('compAtom,'COLON,"@",T.mode,T.expr),:CDR T] + +(DEFUN |markAt| (T$) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|compAtom| 'COLON '@ (CADR T$) (CAR T$)) (CDR T$)))) + +;markCompColonInside(op,T) == --for compColonInside +; tcheck T +; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => +; [mkWi('compColonInside,'COLON,op,T.mode,T.expr),:CDR T] +; T + +(DEFUN |markCompColonInside| (|op| T$) + (declare (special |$convert2NewCompiler|)) + (PROGN + (|tcheck| T$) + (COND + ((AND (BOUNDP '|$convert2NewCompiler|) |$convert2NewCompiler|) + (CONS (|mkWi| '|compColonInside| 'COLON |op| (CADR T$) (CAR T$)) + (CDR T$))) + ('T T$)))) + +;markLisp(T,m) == --for compForm1 +; tcheck T +; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => +; [mkWi('compForm1,'COLON,'Lisp,T.mode,T.expr),:CDR T] +; T + +(DEFUN |markLisp| (T$ |m|) + (declare (special |$convert2NewCompiler|) (ignore |m|)) + (PROGN + (|tcheck| T$) + (COND + ((AND (BOUNDP '|$convert2NewCompiler|) |$convert2NewCompiler|) + (CONS (|mkWi| '|compForm1| 'COLON '|Lisp| (CADR T$) (CAR T$)) + (CDR T$))) + ('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] + +(DEFUN |markLambda| (|vl| |body| |mode| T$) + (PROG (|ml| |args| |left| |fun|) + (declare (special |$PerCentVariableList|)) + (RETURN + (SEQ (PROGN + (|tcheck| T$) + (COND + ((NULL (AND (PAIRP |mode|) (EQ (QCAR |mode|) '|Mapping|) + (PROGN (SPADLET |ml| (QCDR |mode|)) 'T))) + (|error| (MAKESTRING "markLambda")))) + (SPADLET |args| + (PROG (G166421) + (SPADLET G166421 NIL) + (RETURN + (DO ((|i| 0 (QSADD1 |i|)) + (G166427 (CDR |ml|) (CDR G166427)) + (|t| NIL)) + ((OR (ATOM G166427) + (PROGN + (SETQ |t| (CAR G166427)) + NIL)) + (NREVERSE0 G166421)) + (SEQ (EXIT (SETQ G166421 + (CONS + (CONS '|:| + (CONS + (ELT |$PerCentVariableList| + |i|) + (CONS |t| NIL))) + G166421)))))))) + (SPADLET |left| + (CONS '|:| + (CONS (CONS 'PAREN |args|) + (CONS (CAR |ml|) NIL)))) + (SPADLET |fun| + (CONS '+-> + (CONS |left| + (CONS (SUBLISLIS + |$PerCentVariableList| |vl| + |body|) + NIL)))) + (CONS (|mkWi| '|compWithMappingMode| 'LAMBDA NIL + (CONS 'REPLACE (CONS |fun| NIL)) (CAR T$)) + (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 + +(DEFUN |markMacro| (|before| |after|) + (PROG (|x|) + (declare (special |$globalMacroStack| |$localMacroStack| |$def| + |$insideFunctorIfTrue| |$convert2NewCompiler|)) + (RETURN + (COND + ((AND (BOUNDP '|$convert2NewCompiler|) |$convert2NewCompiler|) + (COND + ((AND (PAIRP |before|) (EQ (QCDR |before|) NIL) + (PROGN (SPADLET |x| (QCAR |before|)) 'T)) + (SPADLET |before| |x|))) + (SPADLET |$def| + (CONS 'MDEF + (CONS |before| + (CONS '(NIL) + (CONS '(NIL) (CONS |after| NIL)))))) + (COND + (|$insideFunctorIfTrue| + (SPADLET |$localMacroStack| + (CONS (CONS |before| |after|) + |$localMacroStack|))) + ('T + (SPADLET |$globalMacroStack| + (CONS (CONS |before| |after|) |$globalMacroStack|)))) + (|mkWi| '|macroExpand| 'MI |before| |after|)) + ('T |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 + +(DEFUN |markInValue| (|y| |e|) + (PROG (|y1| T$ |y'| |m| |ISTMP#1| |a|) + (declare (special |$EmptyMode|)) + (RETURN + (PROGN + (SPADLET |y1| (|markKillAll| |y|)) + (SPADLET T$ (OR (|comp| |y1| |$EmptyMode| |e|) (RETURN NIL))) + (SPADLET |y'| (CAR T$)) + (SPADLET |m| (CADR T$)) + (SPADLET |e| (CADDR T$)) + (|markImport| |m|) + (COND + ((AND (BOOT-EQUAL |m| '$) + (PROGN + (SPADLET |ISTMP#1| + (LASSOC '|value| (|getProplist| '|Rep| |e|))) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T))) + (MEMQ (|opOf| |a|) '(|List| |Vector|))) + (CONS (|markRepper| '|rep| |y'|) + (CONS '|Rep| (CONS |e| NIL)))) + ('T T$)))))) + +;markReduceIn(it, pr) == markReduceIterator("in",it,pr) + +(DEFUN |markReduceIn| (|it| |pr|) + (|markReduceIterator| '|in| |it| |pr|)) + +;markReduceStep(it, pr) == markReduceIterator("step", it, pr) + +(DEFUN |markReduceStep| (|it| |pr|) + (|markReduceIterator| '|step| |it| |pr|)) + +;markReduceWhile(it, pr) == markReduceIterator("while", it, pr) + +(DEFUN |markReduceWhile| (|it| |pr|) + (|markReduceIterator| '|while| |it| |pr|)) + +;markReduceUntil(it, pr) == markReduceIterator("until", it, pr) + +(DEFUN |markReduceUntil| (|it| |pr|) + (|markReduceIterator| '|until| |it| |pr|)) + +;markReduceSuchthat(it, pr) == markReduceIterator("suchthat", it, pr) + +(DEFUN |markReduceSuchthat| (|it| |pr|) + (|markReduceIterator| '|suchthat| |it| |pr|)) + +;markReduceIterator(kind, it, pr) == [mkWi(kind, 'WI, it, CAR pr), :CDR pr] + +(DEFUN |markReduceIterator| (|kind| |it| |pr|) + (CONS (|mkWi| |kind| 'WI |it| (CAR |pr|)) (CDR |pr|))) + +;markReduceBody(body,T) == +; tcheck T +; [mkWi("reduceBody",'WI,body,CAR T), :CDR T] + +(DEFUN |markReduceBody| (|body| T$) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|reduceBody| 'WI |body| (CAR T$)) (CDR T$)))) + +;markReduce(form, T) == +; tcheck T +; [SETQ($funk,mkWi("reduce", 'WI,form,CAR T)), :CDR T] + +(DEFUN |markReduce| (|form| T$) + (declare (special |$funk|)) + (PROGN + (|tcheck| T$) + (CONS (SETQ |$funk| (|mkWi| '|reduce| 'WI |form| (CAR T$))) + (CDR T$)))) + +;markRepeatBody(body,T) == +; tcheck T +; [mkWi("repeatBody",'WI,body,CAR T), :CDR T] + +(DEFUN |markRepeatBody| (|body| T$) + (PROGN + (|tcheck| T$) + (CONS (|mkWi| '|repeatBody| 'WI |body| (CAR T$)) (CDR T$)))) + +;markRepeat(form, T) == +; tcheck T +; [mkWi("repeat", 'WI,form,CAR T), :CDR T] + +(DEFUN |markRepeat| (|form| T$) + (PROGN + (|tcheck| T$) + (CONS (|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 + +(DEFUN |markTran| (|form| |form'| G166513 |env|) + (PROG (|dc| |sig| |argSource| |argl| |wi|) + (RETURN + (SEQ (PROGN + (SPADLET |dc| (CAR G166513)) + (SPADLET |sig| (CDR G166513)) + (COND + ((OR (NEQUAL |dc| '|Rep|) (NULL (MEMQ '$ |sig|))) + (|mkWi| '|markTran| 'WI |form| (CONS '|call| |form'|))) + ('T + (SPADLET |argl| + (PROG (G166527) + (SPADLET G166527 NIL) + (RETURN + (DO ((G166533 (CDR |sig|) + (CDR G166533)) + (|t| NIL) + (G166534 (CDR |form'|) + (CDR G166534)) + (|arg| NIL)) + ((OR (ATOM G166533) + (PROGN + (SETQ |t| (CAR G166533)) + NIL) + (ATOM G166534) + (PROGN + (SETQ |arg| (CAR G166534)) + NIL)) + (NREVERSE0 G166527)) + (SEQ (EXIT + (SETQ G166527 + (CONS + (COND + ((BOOT-EQUAL |t| '$) + (SPADLET |argSource| + (|getSourceWI| |arg|)) + (COND + ((AND (IDENTP |argSource|) + (BOOT-EQUAL + (|getmode| |argSource| + |env|) + '|Rep|)) + |arg|) + ('T + (|markRepper| '|rep| + |arg|)))) + ('T |arg|)) + G166527)))))))) + (SPADLET |form'| + (CONS '|call| (CONS (CAR |form'|) |argl|))) + (SPADLET |wi| (|mkWi| '|markTran| 'WI |form| |form'|)) + (COND + ((BOOT-EQUAL (CAR |sig|) '$) + (|markRepper| '|per| |wi|)) + ('T |wi|))))))))) + +;markRepper(key,form) == ['REPPER,nil,key,form] + +(DEFUN |markRepper| (|key| |form|) + (CONS 'REPPER (CONS NIL (CONS |key| (CONS |form| NIL))))) + +;markDeclaredImport d == markImport(d,true) + +(DEFUN |markDeclaredImport| (|d|) (|markImport| |d| 'T)) + +;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) + +(DEFUN |markImport| (&REST G166572 &AUX |option| |d|) + (DSETQ (|d| . |option|) G166572) + (PROG (|declared?| |op| |dom|) + (declare (special |$globalDeclareStack| |$globalImportStack| + |$localDeclareStack| |$localImportStack| + |$insideCapsuleFunctionIfTrue| |$Representation|)) + (RETURN + (PROGN + (COND ((CONTAINED 'PART |d|) (|pause| |d|))) + (SPADLET |declared?| (IFCAR |option|)) + (COND + ((OR (NULL |d|) (BOOT-EQUAL |d| |$Representation|)) NIL) + ((AND (PAIRP |d|) (PROGN (SPADLET |op| (QCAR |d|)) 'T) + (MEMQ |op| + '(|Boolean| |Mapping| |Void| |Segment| + |UniversalSegment|))) + NIL) + ((OR (STRINGP |d|) + (AND (IDENTP |d|) + (BOOT-EQUAL (ELT (PNAME |d|) 0) (|char| '|#|)))) + NIL) + ((MEMQ |d| '($ |$NoValueMode| |$EmptyMode| |Void|)) NIL) + ('T (SPADLET |dom| (|markMacroTran| |d|)) + (COND + ((|categoryForm?| |dom|) NIL) + (|$insideCapsuleFunctionIfTrue| + (SPADLET |$localImportStack| + (|insert| |dom| |$localImportStack|)) + (COND + ((IFCAR |option|) + (SPADLET |$localDeclareStack| + (|insert| |dom| |$localDeclareStack|))) + ('T NIL))) + ((BOUNDP '|$globalImportStack|) + (SPADLET |$globalImportStack| + (|insert| |dom| |$globalImportStack|)) + (COND + ((IFCAR |option|) + (SPADLET |$globalDeclareStack| + (|insert| |dom| |$globalDeclareStack|))) + ('T NIL))) + ('T NIL)))))))) + +;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]] + +(DEFUN |markMacroTran| (|name|) + (PROG (|x| |y| |u| |op| |argl|) + (declare (special |$localMacroStack| |$globalMacroStack|)) + (RETURN + (SEQ (COND + ((ATOM |name|) |name|) + ((SPADLET |u| + (PROG (G166585) + (SPADLET G166585 NIL) + (RETURN + (DO ((G166593 NIL G166585) + (G166594 |$globalMacroStack| + (CDR G166594)) + (G166573 NIL)) + ((OR G166593 (ATOM G166594) + (PROGN + (SETQ G166573 (CAR G166594)) + NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G166573)) + (SPADLET |y| (CDR G166573)) + G166573) + NIL)) + G166585) + (SEQ (EXIT (COND + ((BOOT-EQUAL |y| |name|) + (SETQ G166585 + (OR G166585 |x|)))))))))) + |u|) + ((SPADLET |u| + (PROG (G166602) + (SPADLET G166602 NIL) + (RETURN + (DO ((G166610 NIL G166602) + (G166611 |$localMacroStack| + (CDR G166611)) + (G166577 NIL)) + ((OR G166610 (ATOM G166611) + (PROGN + (SETQ G166577 (CAR G166611)) + NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G166577)) + (SPADLET |y| (CDR G166577)) + G166577) + NIL)) + G166602) + (SEQ (EXIT (COND + ((BOOT-EQUAL |y| |name|) + (SETQ G166602 + (OR G166602 |x|)))))))))) + |u|) + ('T (SPADLET |op| (CAR |name|)) + (SPADLET |argl| (CDR |name|)) + (COND + ((MEMQ |op| '(|Record| |Union|)) |name|) + ('T + (CONS |op| + (PROG (G166623) + (SPADLET G166623 NIL) + (RETURN + (DO ((G166628 |argl| (CDR G166628)) + (|x| NIL)) + ((OR (ATOM G166628) + (PROGN + (SETQ |x| (CAR G166628)) + NIL)) + (NREVERSE0 G166623)) + (SEQ (EXIT (SETQ G166623 + (CONS (|markMacroTran| |x|) + G166623)))))))))))))))) + +;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 + +(DEFUN |markSetq| (|originalLet| T$) + (PROG (|$coerceList| |$from| |form| |originalBody| |id| |code| + |noriginalLet| |nlet| |entry|) + (DECLARE (SPECIAL |$coerceList| |$from| |$markFreeStack| |$importStack| + |$domainLevelVariableList| |$freeStack| + |$insideCapsuleFunctionIfTrue| |$convert2NewCompiler|)) + (RETURN + (COND + ((AND (BOUNDP '|$convert2NewCompiler|) |$convert2NewCompiler|) + (SPADLET |$coerceList| NIL) + (SPADLET |form| (CADR |originalLet|)) + (SPADLET |originalBody| (CADDR |originalLet|)) + (SPADLET |id| (|markLhs| |form|)) + (COND + ((NULL |$insideCapsuleFunctionIfTrue|) + (SPADLET |$from| (MAKESTRING "Setq")) + (SPADLET |code| (CAR T$)) (|markEncodeChanges| |code| NIL) + (SPADLET |noriginalLet| + (|markSpliceInChanges| |originalBody|)) + (COND + ((IDENTP |id|) + (SPADLET |$domainLevelVariableList| + (|insert| |id| |$domainLevelVariableList|)))) + (SPADLET |nlet| + (CONS 'LET (CONS |id| (CONS |noriginalLet| NIL)))) + (SPADLET |entry| (CONS |originalLet| |nlet|)) + (SPADLET |$importStack| (CONS NIL |$importStack|)) + (SPADLET |$freeStack| (CONS NIL |$freeStack|)) + (|capsuleStack| (MAKESTRING "Setq") |entry|) + (CONS |code| (CDR T$))) + ('T + (COND + ((MEMQ |id| |$domainLevelVariableList|) + (SPADLET |$markFreeStack| + (|insert| |id| |$markFreeStack|)))) + T$))) + ('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] + +(DEFUN |markCapsuleExpression| (|originalExpr| T$) + (PROG (|$coerceList| |$from| |code| |noriginal| |nexpr| |entry|) + (DECLARE (SPECIAL |$coerceList| |$from| |$freeStack| |$importStack|)) + (RETURN + (PROGN + (SPADLET |$coerceList| NIL) + (SPADLET |$from| (MAKESTRING "Capsule expression")) + (SPADLET |code| (CAR T$)) + (|markEncodeChanges| |code| NIL) + (SPADLET |noriginal| (|markSpliceInChanges| |originalExpr|)) + (SPADLET |nexpr| |noriginal|) + (SPADLET |entry| (CONS |originalExpr| |nexpr|)) + (SPADLET |$importStack| (CONS NIL |$importStack|)) + (SPADLET |$freeStack| (CONS NIL |$freeStack|)) + (|capsuleStack| (MAKESTRING "capsuleExpression") |entry|) + (CONS |code| (CDR T$)))))) + +;markLhs x == +; x is [":",a,.] => a +; atom x => x +; x --ignore + +(DEFUN |markLhs| (|x|) + (PROG (|ISTMP#1| |a| |ISTMP#2|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + |a|) + ((ATOM |x|) |x|) + ('T |x|))))) + +;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] + +(DEFUN |capsuleStack| (|name| |entry|) + (declare (ignore |name|)) + (PROG (|signature|) + (declare (special |$signatureStack| |$signatureOfForm| |$capsuleStack| + |$insideCapsuleFunctionIfTrue| |$predicateStack| |$predl|)) + (RETURN + (PROGN + (SPADLET |$capsuleStack| (CONS (COPY |entry|) |$capsuleStack|)) + (SPADLET |$predicateStack| (CONS |$predl| |$predicateStack|)) + (SPADLET |signature| + (COND + (|$insideCapsuleFunctionIfTrue| |$signatureOfForm|) + ('T NIL))) + (SPADLET |$signatureStack| + (CONS |signature| |$signatureStack|)))))) + +;foobar(x) == x + +(DEFUN |foobar| (|x|) |x|) + +;foobum(x) == x --from doIT + +(DEFUN |foobum| (|x|) |x|) + +;--====================================================================== +;-- 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 + +(DEFUN |markChanges| (|originalDef| T$ |sig|) + (PROG (|$e| |$coerceList| |$from| |code| |form| |originalBody| + |signature| |frees| |noriginalBody| |nbody| |ndef| + |imports| |subtractions| |entry|) + (DECLARE (SPECIAL |$e| |$coerceList| |$from| |$importStack| |$hoho| + |$insideCategoryIfTrue| |$insideFunctorIfTrue| + |$globalImportStack| |$globalDeclareStack| + |$localDeclareStack| |$localImportStack| |$freeStack| + |$markFreeStack| |$convert2NewCompiler|)) + (RETURN + (SEQ (COND + ((AND (BOUNDP '|$convert2NewCompiler|) + |$convert2NewCompiler|) + (COND + ((AND |$insideCategoryIfTrue| |$insideFunctorIfTrue|) + (SPADLET |originalDef| (|markCatsub| |originalDef|)) + (SPADLET T$ + (CONS (|markCatsub| (CAR T$)) + (CONS (|markCatsub| (CADR T$)) + (CONS (CADDR T$) NIL)))) + (SPADLET |sig| (|markCatsub| |sig|)) + (SPADLET |$importStack| (|markCatsub| |$importStack|)))) + (SPADLET |code| (CAR T$)) (SPADLET |$e| (CADDR T$)) + (SPADLET |$coerceList| NIL) (SPADLET |$hoho| |code|) + (SPADLET |form| (CADR |originalDef|)) + (SPADLET |originalBody| (CAR (CDDDDR |originalDef|))) + (SPADLET |signature| + (|markFindOriginalSignature| |form| |sig|)) + (SPADLET |$from| (MAKESTRING "compDefineFunctor1")) + (|markEncodeChanges| |code| NIL) + (SPADLET |frees| + (COND + ((NULL |$markFreeStack|) NIL) + ('T + (CONS (CONS '|free| + (|mySort| + (REMDUP |$markFreeStack|))) + NIL)))) + (SPADLET |noriginalBody| + (|markSpliceInChanges| |originalBody|)) + (SPADLET |nbody| + (|augmentBodyByLoopDecls| |noriginalBody|)) + (SPADLET |ndef| + (CONS 'DEF + (CONS |form| + (CONS |signature| + (CONS + (PROG (G166734) + (SPADLET G166734 NIL) + (RETURN + (DO + ((G166739 |form| + (CDR G166739)) + (|x| NIL)) + ((OR (ATOM G166739) + (PROGN + (SETQ |x| + (CAR G166739)) + NIL)) + (NREVERSE0 G166734)) + (SEQ + (EXIT + (SETQ G166734 + (CONS NIL G166734))))))) + (CONS |nbody| NIL)))))) + (SPADLET |$freeStack| (CONS |frees| |$freeStack|)) + (SPADLET |imports| |$localImportStack|) + (SPADLET |subtractions| + (|union| |$localDeclareStack| + (|union| |$globalDeclareStack| + (|union| |$globalImportStack| + |signature|)))) + (COND + ((AND |$insideCategoryIfTrue| |$insideFunctorIfTrue|) + (SPADLET |imports| (|markCatsub| |imports|)) + (SPADLET |subtractions| (|markCatsub| |subtractions|)))) + (SPADLET |imports| + (PROG (G166749) + (SPADLET G166749 NIL) + (RETURN + (DO ((G166754 |imports| (CDR G166754)) + (|d| NIL)) + ((OR (ATOM G166754) + (PROGN + (SETQ |d| (CAR G166754)) + NIL)) + (NREVERSE0 G166749)) + (SEQ (EXIT (SETQ G166749 + (CONS (|markMacroTran| |d|) + G166749)))))))) + (SPADLET |subtractions| + (PROG (G166764) + (SPADLET G166764 NIL) + (RETURN + (DO ((G166769 |subtractions| + (CDR G166769)) + (|d| NIL)) + ((OR (ATOM G166769) + (PROGN + (SETQ |d| (CAR G166769)) + NIL)) + (NREVERSE0 G166764)) + (SEQ (EXIT (SETQ G166764 + (CONS (|markMacroTran| |d|) + G166764)))))))) + (SPADLET |subtractions| + (|union| |subtractions| + (|getImpliedImports| |imports|))) + (SPADLET |$importStack| + (CONS (|reduceImports| + (SETDIFFERENCE |imports| + |subtractions|)) + |$importStack|)) + (SPADLET |entry| (CONS |originalDef| |ndef|)) + (|capsuleStack| (MAKESTRING "Def") |entry|)) + ('T NIL)))))) + +;reduceImports x == +; [k, o] := reduceImports1 x +; SETDIFFERENCE(o,k) + +(DEFUN |reduceImports| (|x|) + (PROG (|LETTMP#1| |k| |o|) + (RETURN + (PROGN + (SPADLET |LETTMP#1| (|reduceImports1| |x|)) + (SPADLET |k| (CAR |LETTMP#1|)) + (SPADLET |o| (CADR |LETTMP#1|)) + (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] + +(DEFUN |reduceImports1| (|x|) + (PROG (|ISTMP#1| |a| |LETTMP#1| |k| |o| |kills| |others|) + (declare (special |$globalImportDefAlist|)) + (RETURN + (SEQ (PROGN + (SPADLET |kills| NIL) + (SPADLET |others| NIL) + (DO ((G166848 |x| (CDR G166848)) (|y| NIL)) + ((OR (ATOM G166848) + (PROGN (SETQ |y| (CAR G166848)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |y|) (EQ (QCAR |y|) '|List|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |LETTMP#1| + (|reduceImports1| (CONS |a| NIL))) + (SPADLET |k| (CAR |LETTMP#1|)) + (SPADLET |o| (CADR |LETTMP#1|)) + (SPADLET |kills| + (|union| |y| + (|union| |k| |kills|))) + (SPADLET |others| (|union| |o| |others|))) + ((|rassoc| |y| |$globalImportDefAlist|) + (SPADLET |kills| (|insert| |y| |kills|))) + ('T + (SPADLET |others| (|insert| |y| |others|))))))) + (CONS |kills| (CONS |others| NIL))))))) + +;getImpliedImports x == +; x is [[op,:r],:y] => +; MEMQ(op, '(List Enumeration)) => UNION(r, getImpliedImports y) +; getImpliedImports y +; nil + +(DEFUN |getImpliedImports| (|x|) + (PROG (|ISTMP#1| |op| |r| |y|) + (RETURN + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T))) + (PROGN (SPADLET |y| (QCDR |x|)) 'T)) + (COND + ((MEMQ |op| '(|List| |Enumeration|)) + (|union| |r| (|getImpliedImports| |y|))) + ('T (|getImpliedImports| |y|)))) + ('T 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]] + +(DEFUN |augmentBodyByLoopDecls| (|body|) + (PROG (|lhs| |form| |r|) + (declare (special |$SmallInteger| |$localLoopVariables|)) + (RETURN + (COND + ((NULL |$localLoopVariables|) |body|) + ('T + (SPADLET |lhs| + (COND + ((AND (PAIRP |$localLoopVariables|) + (EQ (QCDR |$localLoopVariables|) NIL)) + (CAR |$localLoopVariables|)) + ('T (CONS 'LISTOF |$localLoopVariables|)))) + (SPADLET |form| + (CONS '|:| (CONS |lhs| (CONS |$SmallInteger| NIL)))) + (COND + ((AND (PAIRP |body|) (EQ (QCAR |body|) 'SEQ) + (PROGN (SPADLET |r| (QCDR |body|)) 'T)) + (CONS 'SEQ (CONS |form| |r|))) + ('T + (CONS 'SEQ + (CONS |form| + (CONS (CONS '|exit| (CONS 1 (CONS |body| NIL))) + NIL)))))))))) + +;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 + +(DEFUN |markFindOriginalSignature| (|form| |sig|) + (PROG (|target| |id| |n| |u| |cat| |v| |ISTMP#1| |ISTMP#2| |sig'|) + (declare (special |$originalTarget|)) + (RETURN + (SEQ (PROGN + (SPADLET |target| |$originalTarget|) + (SPADLET |id| (|opOf| |form|)) + (SPADLET |n| (|#| |form|)) + (SPADLET |cat| + (COND + ((AND (PAIRP |target|) + (EQ (QCAR |target|) '|Join|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |u| (QCAR |ISTMP#2|)) + 'T)))) + |u|) + ('T |target|))) + (COND + ((NULL (AND (PAIRP |target|) + (EQ (QCAR |target|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCDR |ISTMP#1|)) + 'T))))) + |sig|) + ('T + (OR (PROG (G166915) + (SPADLET G166915 NIL) + (RETURN + (DO ((G166922 NIL G166915) + (G166923 |v| (CDR G166923)) (|x| NIL)) + ((OR G166922 (ATOM G166923) + (PROGN + (SETQ |x| (CAR G166923)) + NIL)) + G166915) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) 'SIGNATURE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |id|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |sig'| + (QCAR |ISTMP#2|)) + 'T))))) + (BOOT-EQUAL (|#| |sig'|) |n|) + (|markFindCompare| |sig'| + |sig|)) + (SETQ G166915 + (OR G166915 |sig'|))))))))) + |sig|)))))))) + +;markFindCompare(sig',sig) == +; macroExpand(sig',$e) = sig + +(DEFUN |markFindCompare| (|sig'| |sig|) + (declare (special |$e|)) + (BOOT-EQUAL (|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) + +(DEFUN |markEncodeChanges| (|x| |s|) + (PROG (|ISTMP#4| |ISTMP#5| |p| |q| |i| |r| |b| |c| |fn| |t| |op| + |ISTMP#3| |ISTMP#1| |a| |ISTMP#2| |y|) + (declare (special |$markChoices|)) + (RETURN + (SEQ (PROGN + (COND ((NULL |s|) (|markOrigName| |x|))) + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |fn| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#3|)) + 'T))))))) + (MEMQ |fn| |$markChoices|)) + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'ATOM) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) 'REPLACE) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |ISTMP#5| + (QCAR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) + NIL) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#5|)) + 'T))))))))))) + (MEMQ |y| '(|false| |true|))) + '|skip|) + ('T + (COND + (|c| (SPADLET |i| (|getSourceWI| |c|)) + (SPADLET |t| (|getTargetWI| |c|)) + (SPADLET |s| (CONS |i| |s|)))) + (|markRecord| |a| |b| |s|) + (|markEncodeChanges| |t| |s|)))) + ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'WI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |q| (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |x|) (EQ (QCAR |x|) 'MI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |q| (QCAR |ISTMP#2|)) + 'T))))))) + (SPADLET |i| (|getSourceWI| |p|)) + (SPADLET |r| (|getTargetWI| |q|)) + (COND + ((AND (PAIRP |r|) + (PROGN + (SPADLET |fn| (QCAR |r|)) + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |c| + (QCAR |ISTMP#3|)) + 'T))))))) + (MEMQ |fn| |$markChoices|)) + (SPADLET |t| (|getTargetWI| |c|)) + (SPADLET |s| (CONS |i| |s|)) + (|markRecord| |a| |b| |s|) + (|markEncodeChanges| |t| |s|)) + ((AND (PAIRP |i|) + (PROGN (SPADLET |fn| (QCAR |i|)) 'T) + (MEMQ |fn| '(REPEAT COLLECT))) + (|markEncodeLoop| |i| |r| |s|)) + ('T (SPADLET |t| (|getTargetWI| |r|)) + (|markEncodeChanges| |t| (CONS |i| |s|))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PROGN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T))) + (PAIRP |s|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |s|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |op| (QCAR |ISTMP#1|)) 'T))) + (MEMQ |op| '(REPEAT COLLECT))) + (|markEncodeChanges| |a| |s|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|TAGGEDreturn|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#3|)) + 'T)))))))) + (|markEncodeChanges| |y| |s|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'CATCH) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y| (QCAR |ISTMP#2|)) + 'T)))))) + (|markEncodeChanges| |y| |s|)) + ((ATOM |x|) NIL) + ('T + (DO ((G167169 |x| (CDR G167169)) (|y| NIL)) + ((OR (ATOM G167169) + (PROGN (SETQ |y| (CAR G167169)) NIL)) + NIL) + (SEQ (EXIT (|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 + +(DEFUN |markOrigName| (|x|) + (PROG (|op| |r| |ISTMP#1| |a| |ISTMP#2| |ISTMP#3| |y| |s| |k| + |origName|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |r| (QCDR |x|)) + 'T)) + (COND + ((AND (BOOT-EQUAL |op| '|TAGGEDreturn|) (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#3|)) + 'T)))))))) + (|markOrigName| |y|)) + ('T + (DO ((G167263 |r| (CDR G167263)) (|y| NIL)) + ((OR (ATOM G167263) + (PROGN (SETQ |y| (CAR G167263)) NIL)) + NIL) + (SEQ (EXIT (|markOrigName| |y|)))) + (COND + ((IDENTP |op|) (SPADLET |s| (PNAME |op|)) + (SPADLET |k| (|charPosition| (|char| '|;|) |s| 0)) + (COND + ((> |k| (MAXINDEX |s|)) NIL) + ('T + (SPADLET |origName| + (INTERN (SUBSTRING |s| (PLUS |k| 1) + NIL))) + (MAKEPROP |op| 'ORIGNAME |origName|) + (REMPROP |op| 'PNAME)))) + ('T (|markOrigName| |op|)))))) + ('T 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]) + +(DEFUN |markEncodeLoop| (|i| |r| |s|) + (PROG (|LETTMP#1| |b1| |itl1| |a| |op1| |ISTMP#1| |ISTMP#2| |b2| + |itl2|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (REVERSE (CDR |i|))) + (SPADLET |b1| (CAR |LETTMP#1|)) + (SPADLET |itl1| (NREVERSE (CDR |LETTMP#1|))) + (COND + ((AND (PAIRP |r|) (EQ (QCAR |r|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |r| |a|))) + (COND + ((AND (PAIRP |r|) + (PROGN + (SPADLET |op1| (QCAR |r|)) + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b2| (QCAR |ISTMP#2|)) + (SPADLET |itl2| (QCDR |ISTMP#2|)) + 'T) + (PROGN + (SPADLET |itl2| (NREVERSE |itl2|)) + 'T))) + (MEMQ |op1| '(REPEAT COLLECT))) + (DO ((G167324 |itl1| (CDR G167324)) (|it1| NIL) + (G167325 |itl2| (CDR G167325)) (|it2| NIL)) + ((OR (ATOM G167324) + (PROGN (SETQ |it1| (CAR G167324)) NIL) + (ATOM G167325) + (PROGN (SETQ |it2| (CAR G167325)) NIL)) + NIL) + (SEQ (EXIT (|markEncodeChanges| |it2| + (CONS |it1| |s|))))) + (|markEncodeChanges| |b2| (CONS |b1| |s|))) + ('T (|markEncodeChanges| |r| (CONS |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 + +(DEFUN |getSourceWI| (|x|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) + (RETURN + (COND + ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'WI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |x|) (EQ (QCAR |x|) 'MI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))))) + (COND + ((OR (AND (PAIRP |a|) (EQ (QCAR |a|) 'WI)) + (AND (PAIRP |a|) (EQ (QCAR |a|) 'MI))) + (|getSourceWI| |a|)) + ('T (|markRemove| |a|)))) + ('T (|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] + +(DEFUN |markRemove| (|x|) + (PROG (|fn| |b| |c| |ISTMP#1| |a| |ISTMP#2| |ISTMP#3| |ISTMP#4| |m| + |ISTMP#5| |t|) + (declare (special |$markChoices|)) + (RETURN + (SEQ (COND + ((ATOM |x|) |x|) + ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'WI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |x|) (EQ (QCAR |x|) 'MI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))))) + (|markRemove| |a|)) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |fn| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#3|)) + 'T))))))) + (MEMQ |fn| |$markChoices|)) + (|markRemove| |c|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|TAGGEDreturn|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |m| (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |t| + (QCAR |ISTMP#5|)) + 'T)))))))))))) + (CONS '|TAGGEDreturn| + (CONS |a| + (CONS (CONS (|markRemove| |x|) + (CONS |m| (CONS |t| NIL))) + NIL)))) + ('T + (PROG (G167551) + (SPADLET G167551 NIL) + (RETURN + (DO ((G167556 |x| (CDR G167556)) (|y| NIL)) + ((OR (ATOM G167556) + (PROGN (SETQ |y| (CAR G167556)) NIL)) + (NREVERSE0 G167551)) + (SEQ (EXIT (SETQ G167551 + (CONS (|markRemove| |y|) + G167551))))))))))))) + +;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 + +(DEFUN |getTargetWI| (|x|) + (PROG (|b| |ISTMP#1| |ISTMP#2| |a|) + (RETURN + (COND + ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'WI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |x|) (EQ (QCAR |x|) 'MI) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))))) + (|getTargetWI| |b|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PART) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#2|)) 'T)))))) + (|getTargetWI| |a|)) + ('T |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] + +(DEFUN |markRecord| (|source| |target| |u|) + (PROG (|$source| |$target| |item| |a| |op| |ISTMP#1| |ISTMP#2| |t| + |path| |ipath| |entry|) + (DECLARE (SPECIAL |$source| |$target| |$coerceList| |$from| |$e| |$Zero| + |$monitorCoerce| |$shout2| |$target| |$source| |$One|)) + (RETURN + (SEQ (PROGN + (COND + ((AND (BOOT-EQUAL |source| '$) + (BOOT-EQUAL |target| '|Rep|)) + (SPADLET |target| '|rep|))) + (COND + ((AND (BOOT-EQUAL |source| '|Rep|) + (BOOT-EQUAL |target| '$)) + (SPADLET |target| '|per|))) + (SPADLET |item| (CAR |u|)) + (COND + ((OR (FIXP |item|) (BOOT-EQUAL |item| |$One|) + (BOOT-EQUAL |item| |$Zero|)) + NIL) + ((AND (PAIRP |item|) (EQ (QCAR |item|) '-) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T))) + (OR (FIXP |a|) (BOOT-EQUAL |a| |$One|) + (BOOT-EQUAL |a| |$Zero|))) + NIL) + ((STRINGP |item|) NIL) + ((AND (PAIRP |item|) + (PROGN + (SPADLET |op| (QCAR |item|)) + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |t| (QCAR |ISTMP#2|)) + 'T))))) + (MEMQ |op| '(|::| @ |pretend|)) + (BOOT-EQUAL (|macroExpand| |t| |$e|) |target|)) + NIL) + ('T (SPADLET |$source| |source|) + (SPADLET |$target| |target|) + (SPADLET |path| (OR (|markPath| |u|) (RETURN NIL))) + (SPADLET |path| + (COND ((EQL |path| 0) NIL) ('T |path|))) + (COND + ((AND (BOUNDP '|$shout2|) |$shout2|) + (|pp| (MAKESTRING "=========")) (|pp| |path|) + (SPADLET |ipath| (REVERSE |path|)) + (DO ((G167681 |u| (CDR G167681)) (|x| NIL)) + ((OR (ATOM G167681) + (PROGN (SETQ |x| (CAR G167681)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|pp| |x|) + (COND + (|ipath| + (PROGN + (|pp| (CAR |ipath|)) + (SPADLET |ipath| (CDR |ipath|))))))))))) + (SPADLET |entry| + (CONS |source| (CONS |target| |path|))) + (COND + (|$monitorCoerce| + (|sayBrightlyNT| + (CONS (MAKESTRING "From ") + (CONS |$from| + (CONS (MAKESTRING ": ") NIL)))) + (|pp| |entry|))) + (SPADLET |$coerceList| + (CONS (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 + +(DEFUN |markPath| (|u|) + (PROG (|whole| |part| |v|) + (declare (special |$pathStack| |$path|)) + (RETURN + (PROGN + (SPADLET |whole| (|last| |u|)) + (SPADLET |part| (CAR |u|)) + (SPADLET |$path| |u|) + (COND + ((AND (PAIRP |u|) (EQ (QCDR |u|) NIL)) 0) + ('T (SPADLET |v| (REVERSE (|markPath1| |u|))) + (COND + ((NULL |v|) NIL) + ('T + (SPADLET |$pathStack| (CONS (CONS |v| |u|) |$pathStack|)) + |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 + +(DEFUN |markPath1| (|u|) + (PROG (|a| |ISTMP#1| |b| |r| |path|) + (declare (special |$shout1|)) + (RETURN + (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |a| (QCAR |u|)) + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#1|)) + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T)))) + (COND + ((BOOT-EQUAL |a| |b|) (|markPath1| (CDR |u|))) + ('T + (SPADLET |path| (OR (|markGetPath| |a| |b|) (RETURN NIL))) + (COND + ((AND (BOUNDP '|$shout1|) |$shout1|) + (|pp| (MAKESTRING "=========")) (|pp| |path|) (|pp| |a|) + (|pp| |b|))) + (APPEND (CAR |path|) (|markPath1| (CDR |u|)))))) + ('T 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] + +(DEFUN |markGetPath| (|x| |y|) + (PROG (|$x| |$y| |u| |w| |key|) + (DECLARE (SPECIAL |$x| |$y| |$path| |$pathErrorStack| |$amb|)) + (RETURN + (SEQ (PROGN + (SPADLET |u| (|markGetPaths| |x| |y|)) + (COND + ((AND (PAIRP |u|) (EQ (QCDR |u|) NIL) + (PROGN (SPADLET |w| (QCAR |u|)) 'T)) + |u|) + ('T + (SPADLET |$amb| (CONS |u| (CONS |x| (CONS |y| NIL)))) + (SPADLET |key| + (COND + ((NULL |u|) (MAKESTRING "no match")) + ('T (MAKESTRING "ambiguous")))) + (|sayBrightly| + (CONS (MAKESTRING "-----") + (CONS |key| + (CONS (MAKESTRING "--------") NIL)))) + (COND + ((NULL (BOUNDP '|$pathErrorStack|)) + (SETQ |$pathErrorStack| NIL))) + (SETQ |$pathErrorStack| + (CONS |$path| |$pathErrorStack|)) + (|pp| '|CAUTION: this can cause RPLAC errors|) + (|pp| '|Paths are: |) (|pp| |u|) + (DO ((G167751 |$path| (CDR G167751)) (|p| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G167751) + (PROGN (SETQ |p| (CAR G167751)) NIL) + (QSGREATERP |i| 3)) + NIL) + (SEQ (EXIT (|pp| |p|)))) + (SPADLET |$x| |x|) (SPADLET |$y| |y|) + (|pp| (MAKESTRING "---------------------")) (|pp| |x|) + (|pp| |y|) (|foobar| |key|) + (COND + ((NULL |u|) (CONS 1729 NIL)) + ('T (CONS (CAR |u|) NIL)))))))))) + +;markTryPaths() == markGetPaths($x,$y) + +(DEFUN |markTryPaths| () + (declare (special |$x| |$y|)) + (|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..] + +(DEFUN |markPaths| (|x| |y| |s|) + (PROG (|op| |u| |v| |a| |b| |ISTMP#3| |c| |p| |r| |fn| |ISTMP#1| |m| + |ISTMP#2| |y1|) + (declare (special |$shout|)) + (RETURN + (SEQ (PROGN + (COND + ((AND (BOUNDP '|$shout|) |$shout|) + (|pp| (MAKESTRING "-----")) (|pp| |x|) (|pp| |y|) + (|pp| |s|))) + (COND + ((BOOT-EQUAL |x| |y|) |s|) + ((|markPathsEqual| |x| |y|) |s|) + ((AND (PAIRP |y|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |y|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|elt|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |op| (QCAR |ISTMP#3|)) + 'T))))))) + (PROGN (SPADLET |r| (QCDR |y|)) 'T) + (SPADLET |u| + (|markPaths| |x| (CONS |op| |r|) |s|))) + |u|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) + (PROGN (SPADLET |r| (QCDR |x|)) 'T) + (SPADLET |u| (|markPaths| |r| |y| |s|))) + |u|) + ((AND (PAIRP |y|) (EQ (QCAR |y|) '|elt|) + (PROGN (SPADLET |r| (QCDR |y|)) 'T) + (SPADLET |u| (|markPaths| |x| |r| |s|))) + |u|) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |u| (QCDR |x|)) + 'T) + (MEMQ |op| '(LIST VECTOR)) (PAIRP |y|) + (EQ (QCAR |y|) '|construct|) + (PROGN (SPADLET |v| (QCDR |y|)) 'T) + (SPADLET |p| + (|markPaths| (CONS '|construct| |u|) |y| + |s|))) + |p|) + ((ATOM |y|) NIL) + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))) + (IDENTP |a|)) + (|markPaths| |x| |b| (|markCons| 2 |s|))) + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))) + (GENSYMP |a|)) + (|markPaths| |x| |b| |s|)) + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))) + (GENSYMP |a|)) + (|markPaths| |x| |b| |s|)) + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#3|)) + 'T))))))) + (SPADLET |p| + (COND + ((|markPathsEqual| |x| |b|) 2) + ((|markPathsEqual| |x| |c|) 3) + ('T NIL)))) + (|markCons| |p| |s|)) + ((AND (PAIRP |y|) (EQ (QCAR |y|) '|call|) + (PROGN (SPADLET |r| (QCDR |y|)) 'T)) + (|markPaths| |x| |r| |s|)) + ((AND (PAIRP |y|) + (PROGN + (SPADLET |fn| (QCAR |y|)) + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |m| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y1| (QCAR |ISTMP#2|)) + 'T))))) + (MEMQ |fn| '(PART CATCH THROW))) + (OR (|markPaths| |x| |y1| |s|) + (PROG (G167904) + (SPADLET G167904 NIL) + (RETURN + (DO ((G167910 |y1| (CDR G167910)) (|u| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G167910) + (PROGN + (SETQ |u| (CAR G167910)) + NIL)) + G167904) + (SEQ (EXIT (SETQ G167904 + (APPEND G167904 + (|markPaths| |x| |u| + (|markCons| |i| |s|))))))))))) + ('T + (PROG (G167916) + (SPADLET G167916 NIL) + (RETURN + (DO ((G167922 |y| (CDR G167922)) (|u| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G167922) + (PROGN (SETQ |u| (CAR G167922)) NIL)) + G167916) + (SEQ (EXIT (SETQ G167916 + (APPEND G167916 + (|markPaths| |x| |u| + (|markCons| |i| |s|)))))))))))))))) + +;mymy x == x + +(DEFUN |mymy| (|x|) |x|) + +;markCons(i,s) == [[i,:x] for x in s] + +(DEFUN |markCons| (|i| |s|) + (PROG () + (RETURN + (SEQ (PROG (G167979) + (SPADLET G167979 NIL) + (RETURN + (DO ((G167984 |s| (CDR G167984)) (|x| NIL)) + ((OR (ATOM G167984) + (PROGN (SETQ |x| (CAR G167984)) NIL)) + (NREVERSE0 G167979)) + (SEQ (EXIT (SETQ G167979 + (CONS (CONS |i| |x|) G167979))))))))))) + +;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 = GET(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] + +(DEFUN |markPathsEqual| (|x| |y|) + (PROG (|fn| |a| |b| |r| |ISTMP#3| |c| |u| |ISTMP#1| |ISTMP#2| + |repeet| |v| |z|) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |x| |y|) 'T) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|::|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + 'T))))) + (PAIRP |y|) (EQ (QCAR |y|) '|::|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))) + (BOOT-EQUAL |a| '(|Integer|)) + (BOOT-EQUAL |b| '(|NonNegativeInteger|))) + 'T) + ((AND (PAIRP |y|) + (PROGN + (SPADLET |fn| (QCAR |y|)) + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |z| (QCAR |ISTMP#2|)) + 'T))))) + (MEMQ |fn| '(PART CATCH THROW)) + (|markPathsEqual| |x| |z|)) + 'T) + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))) + (GENSYMP |a|) (|markPathsEqual| |x| |b|)) + 'T) + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))) + (GENSYMP |a|)) + (|markPathsEqual| |x| |b|)) + ((AND (PAIRP |y|) (EQ (QCAR |y|) '|call|) + (PROGN (SPADLET |r| (QCDR |y|)) 'T)) + (|markPathsEqual| (IFCDR |x|) |r|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'REDUCE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |c| (QCAR |ISTMP#3|)) + 'T))))))) + (PAIRP |c|) (EQ (QCAR |c|) 'COLLECT) + (PROGN (SPADLET |u| (QCDR |c|)) 'T) (PAIRP |y|) + (EQ (QCAR |y|) 'PROGN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |repeet| (QCAR |ISTMP#2|)) + 'T))))) + (PAIRP |repeet|) (EQ (QCAR |repeet|) 'REPEAT) + (PROGN (SPADLET |v| (QCDR |repeet|)) 'T)) + (|markPathsEqual| |u| |v|)) + ((OR (ATOM |y|) (ATOM |x|)) + (COND + ((AND (IDENTP |y|) (IDENTP |x|) + (BOOT-EQUAL |y| (GETL |x| 'ORIGNAME))) + 'T) + ((AND (IDENTP |y|) + (SPADLET |z| (|markPathsMacro| |y|))) + (|markPathsEqual| |x| |z|)) + ('T NIL))) + ('T + (PROG (G168093) + (SPADLET G168093 'T) + (RETURN + (DO ((G168100 NIL (NULL G168093)) + (G168101 |x| (CDR G168101)) (|u| NIL) + (G168102 |y| (CDR G168102)) (|v| NIL)) + ((OR G168100 (ATOM G168101) + (PROGN (SETQ |u| (CAR G168101)) NIL) + (ATOM G168102) + (PROGN (SETQ |v| (CAR G168102)) NIL)) + G168093) + (SEQ (EXIT (SETQ G168093 + (AND G168093 + (|markPathsEqual| |u| |v|)))))))))))))) + +;markPathsMacro y == +; LASSOC(y,$localMacroStack) or LASSOC(y,$globalMacroStack) + +(DEFUN |markPathsMacro| (|y|) + (declare (special |$localMacroStack| |$globalMacroStack|)) + (OR (LASSOC |y| |$localMacroStack|) (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 + +(DEFUN |markSpliceInChanges| (|body|) + (PROG (|$data| |code| |target| |loc|) + (declare (special |$data|)) + (DECLARE (SPECIAL |$data| |$hohum| |$coerceList| |$cl|)) + (RETURN + (SEQ (PROGN + (SPADLET |$coerceList| + (REVERSE (SORTBY 'CDDR |$coerceList|))) + (SPADLET |$cl| |$coerceList|) + (SPADLET |body| + (COND + ((AND (PAIRP |body|) (EQ (QCAR |body|) 'WI)) + (|markKillAll| |body|)) + ('T (|markKillAll| |body|)))) + (DO ((G168164 |$coerceList| (CDR G168164)) + (G168151 NIL)) + ((OR (ATOM G168164) + (PROGN (SETQ G168151 (CAR G168164)) NIL) + (PROGN + (PROGN + (SPADLET |code| (CAR G168151)) + (SPADLET |target| (CADR G168151)) + (SPADLET |loc| (CDDR G168151)) + G168151) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |$data| + (CONS |code| + (CONS |target| (CONS |loc| NIL)))) + (COND + ((AND (BOUNDP '|$hohum|) |$hohum|) + (|pp| (MAKESTRING "---------->>>>>")) + (|pp| |$data|) (|pp| |body|) + (|pp| (MAKESTRING + "-------------------------->")))) + (SPADLET |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) + +(DEFUN |markInsertNextChange| (|body|) + (PROG (|code| |target| |loc|) + (declare (special |$data|)) + (RETURN + (PROGN + (SPADLET |code| (CAR |$data|)) + (SPADLET |target| (CADR |$data|)) + (SPADLET |loc| (CADDR |$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) + +(DEFUN |markInsertChanges| (|code| |form| |t| |loc|) + (PROG (|i| |r| |ISTMP#3| |ISTMP#4| |ISTMP#5| |z| |y| |b| |a| |op| + |ISTMP#1| |x| |ISTMP#2| |t1|) + (declare (special |$markPrimitiveNumbers| |$EmptyMode| $CHANGE |$hohum| + |$data|)) + (RETURN + (SEQ (COND + ((AND (PAIRP |loc|) + (PROGN + (SPADLET |i| (QCAR |loc|)) + (SPADLET |r| (QCDR |loc|)) + 'T)) + (SPADLET |x| |form|) + (DO ((G168320 (SPADDIFFERENCE |i| 1)) + (|j| 0 (QSADD1 |j|))) + ((QSGREATERP |j| G168320) NIL) + (SEQ (EXIT (COND + ((NULL (ATOM |x|)) + (SPADLET |x| (CDR |x|))) + ('T NIL))))) + (COND + ((ATOM |x|) + (|pp| (MAKESTRING "Translator RPLACA error")) + (|pp| |$data|) (|foobum| |form|) |form|) + ('T + (COND + ((AND (BOUNDP '|$hohum|) |$hohum|) + (|pp| (CONS |i| + (CONS (MAKESTRING " >>> ") + (CONS |x| NIL)))))) + (SETQ $CHANGE (COPY |x|)) + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) + (PROGN (SPADLET |y| (QCDR |x|)) 'T) |r|) + (SPADLET |x| |y|))) + (RPLACA |x| + (|markInsertChanges| |code| (CAR |x|) |t| + (CDR |loc|))) + (|chk| |x| 100) |form|))) + ((AND (PAIRP |t|) (EQ (QCAR |t|) 'REPLACE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |r| (QCAR |ISTMP#1|)) 'T)))) + (MSUBST |form| '|##1| |r|)) + ((AND (PAIRP |form|) (EQ (QCAR |form|) 'SEQ) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) '|exit|) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQUAL (QCAR |ISTMP#4|) 1) + (PROGN + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |z| (QCAR |ISTMP#5|)) + 'T))))))) + (PROGN (SPADLET |y| (QCDR |ISTMP#2|)) 'T) + (PROGN (SPADLET |y| (NREVERSE |y|)) 'T)))) + (CONS 'SEQ + (APPEND (PROG (G168328) + (SPADLET G168328 NIL) + (RETURN + (DO ((G168333 |y| (CDR G168333)) + (|x| NIL)) + ((OR (ATOM G168333) + (PROGN + (SETQ |x| (CAR G168333)) + NIL)) + (NREVERSE0 G168328)) + (SEQ (EXIT + (SETQ G168328 + (CONS + (|markInsertSeq| |code| |x| + |t|) + G168328))))))) + (CONS (CONS '|exit| + (CONS 1 + (CONS + (|markInsertChanges| |code| + |z| |t| NIL) + NIL))) + NIL)))) + ((OR (BOOT-EQUAL |code| '|pretend|) + (BOOT-EQUAL |code| '|:|)) + (COND + ((AND (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL))))) + (MEMQ |op| '(@ |:| |::| |pretend|))) + (CONS '|pretend| (CONS |a| (CONS |t| NIL)))) + ('T (CONS |code| (CONS |form| (CONS |t| NIL)))))) + ((MEMQ |code| '(@ |::| |pretend|)) + (COND + ((AND (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))) + (MEMQ |op| '(@ |:| |::| |pretend|))) + (COND + ((MEMQ |op| '(|:| |pretend|)) |form|) + ((AND (BOOT-EQUAL |op| |code|) (BOOT-EQUAL |b| |t|)) + |form|) + ('T (|markNumCheck| |code| |form| |t|)))) + ((AND (FIXP |form|) + (MEMQ (|opOf| |t|) |$markPrimitiveNumbers|)) + (CONS '@ (CONS |form| (CONS |t| NIL)))) + ('T (CONS |code| (CONS |form| (CONS |t| NIL)))))) + ((AND (MEMQ |code| '(@ |::| |:|)) (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T))) + (OR (AND (BOOT-EQUAL |op| '|rep|) + (BOOT-EQUAL |t| '|Rep|)) + (AND (BOOT-EQUAL |op| '|per|) + (BOOT-EQUAL |t| '$)))) + |form|) + ((BOOT-EQUAL |code| '|Lisp|) + (COND + ((BOOT-EQUAL |t| |$EmptyMode|) |form|) + ('T (CONS '|pretend| (CONS |form| (CONS |t| NIL)))))) + ((MEMQ |t| '(|rep| |per|)) + (COND + ((AND (BOOT-EQUAL |t| '|rep|) (EQCAR |form| '|per|)) + (CADR |form|)) + ((AND (BOOT-EQUAL |t| '|per|) (EQCAR |form| '|rep|)) + (CADR |form|)) + ('T (CONS |t| (CONS |form| NIL))))) + ((AND (PAIRP |code|) + (PROGN + (SPADLET |op| (QCAR |code|)) + (SPADLET |ISTMP#1| (QCDR |code|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |t1| (QCAR |ISTMP#2|)) + 'T))))) + (MEMQ |op| '(@ |:| |::| |pretend|)) + (BOOT-EQUAL |t1| |t|)) + |form|) + ((AND (FIXP |form|) + (MEMQ (|opOf| |t|) |$markPrimitiveNumbers|)) + (CONS '@ (CONS |form| (CONS |t| NIL)))) + ('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] + +(DEFUN |markNumCheck| (|op| |form| |t|) + (PROG (|s| |ISTMP#1| |n|) + (declare (special |$One| |$Zero|)) + (RETURN + (COND + ((AND (BOOT-EQUAL |op| '|::|) (MEMQ (|opOf| |t|) '(|Integer|))) + (COND + ((SPADLET |s| + (OR (AND (BOOT-EQUAL |form| |$One|) 1) + (AND (BOOT-EQUAL |form| |$Zero|) 0))) + (CONS 'DOLLAR (CONS |s| (CONS |t| NIL)))) + ((FIXP |form|) (CONS '@ (CONS |form| (CONS |t| NIL)))) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '-) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (EQUAL (QCAR |ISTMP#1|) |$One|)))) + (CONS 'DOLLAR (CONS (SPADDIFFERENCE 1) (CONS |t| NIL)))) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '-) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |n| (QCAR |ISTMP#1|)) 'T))) + (FIXP |n|)) + (CONS '@ (CONS (MINUS |n|) (CONS |t| NIL)))) + ('T (CONS |op| (CONS |form| (CONS |t| NIL)))))) + ('T (CONS |op| (CONS |form| (CONS |t| NIL)))))))) + +;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] + +(DEFUN |markInsertSeq| (|code| |x| |t|) + (PROG (|ISTMP#1| |y|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|exit|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T)))) + (CONS '|exit| + (CONS (|markInsertChanges| |code| |y| |t| NIL) NIL))) + ((ATOM |x|) |x|) + ('T + (PROG (G168400) + (SPADLET G168400 NIL) + (RETURN + (DO ((G168405 |x| (CDR G168405)) (|y| NIL)) + ((OR (ATOM G168405) + (PROGN (SETQ |y| (CAR G168405)) NIL)) + (NREVERSE0 G168400)) + (SEQ (EXIT (SETQ G168400 + (CONS + (|markInsertSeq| |code| |y| |t|) + G168400))))))))))))) + +;--====================================================================== +;-- 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 + +(DEFUN |markFinish| (|body| T$) + (declare (special |$cs| |$capsuleStack| |$ps| |$predicateStack| |$ss| + |$signatureStack| |$os| |$originalTarget| |$gis| |$globalImportStack| + |$gds| |$globalDeclareStack| |$gms| |$globalMacroStack| |$as| + |$abbreviationStack| |$lms| |$localMacroStack| |$map| + |$macrosAlreadyPrinted| |$gs| |$importStack| |$fs| |$freeStack| |$b| + |body| |$t| |$e| |$EmptyEnvironment|)) + (PROGN + (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| (CADDR T$)) + (COND + ((ATOM (CDDR T$)) (|systemError|)) + ('T (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() + +(DEFUN |reFinish| () + (declare (special |$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|)) + (PROGN + (SPADLET |$importStack| |$gs|) + (SPADLET |$freeStack| |$fs|) + (SPADLET |$capsuleStack| |$cs|) + (SPADLET |$predicateStack| |$ps|) + (SPADLET |$signatureStack| |$ss|) + (SPADLET |$originalTarget| |$os|) + (SPADLET |$globalMacroStack| |$gms|) + (SPADLET |$abbreviationStack| |$as|) + (SPADLET |$globalImportStack| |$gis|) + (SPADLET |$globalDeclareStack| |$gds|) + (SPADLET |$localMacroStack| |$lms|) + (SPADLET |$macrosAlreadyPrinted| |$map|) + (SPADLET |$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() + +(DEFUN |markFinish1| () + (PROG (|$predGensymAlist| |$commonImports| |$finalImports| T$ |form| + |LETTMP#1| |sig| |globalImports| |ISTMP#1| |a| |ISTMP#2| + |b| |op| |addDomain| |initbody| |importCode| + |leadingMacros| |body| |initcapsule| |capsule| |nsig|) + (DECLARE (SPECIAL |$predGensymAlist| |$commonImports| |$def| |$b| + |$finalImports| |$insideFunctorIfTrue| + |$insideCategoryIfTrue| |$macrosAlreadyPrinted| + |$globalMacroStack| |$abbreviationsAlreadyPrinted| + |$abbreviationStack| |$categoryPart| |$finalImports| + |$extraDefinitions| |$capsuleStack| |$importStack| + |$freeStack| |$globalDeclareStack| |$globalImportStack| + |$commonImports| |$categoryNameForDollar| |$t|)) + (RETURN + (SEQ (PROGN + (SPADLET |body| |$b|) + (SPADLET T$ |$t|) + (SPADLET |$predGensymAlist| NIL) + (SPADLET |form| (CAR T$)) + (SPADLET |LETTMP#1| (CADR T$)) + (SPADLET |sig| (CDR |LETTMP#1|)) + (COND + ((AND |$insideCategoryIfTrue| |$insideFunctorIfTrue|) + (SPADLET |$importStack| + (PROG (G168473) + (SPADLET G168473 NIL) + (RETURN + (DO ((G168478 |$importStack| + (CDR G168478)) + (|x| NIL)) + ((OR (ATOM G168478) + (PROGN + (SETQ |x| (CAR G168478)) + NIL)) + (NREVERSE0 G168473)) + (SEQ (EXIT + (SETQ G168473 + (CONS + (|delete| + |$categoryNameForDollar| |x|) + G168473)))))))) + (SPADLET |$globalImportStack| + (|delete| |$categoryNameForDollar| + |$globalImportStack|)))) + (SPADLET |$commonImports| (|getCommonImports|)) + (SPADLET |globalImports| + (REVERSE (|orderByContainment| + (REMDUP + (APPEND |$commonImports| + |$globalImportStack|))))) + (SPADLET |$finalImports| + (SETDIFFERENCE |globalImports| + |$globalDeclareStack|)) + (SPADLET |$capsuleStack| + (PROG (G168490) + (SPADLET G168490 NIL) + (RETURN + (DO ((G168497 |$freeStack| (CDR G168497)) + (|freepart| NIL) + (G168498 |$importStack| + (CDR G168498)) + (|imports| NIL) + (G168499 |$capsuleStack| + (CDR G168499)) + (|x| NIL)) + ((OR (ATOM G168497) + (PROGN + (SETQ |freepart| (CAR G168497)) + NIL) + (ATOM G168498) + (PROGN + (SETQ |imports| (CAR G168498)) + NIL) + (ATOM G168499) + (PROGN + (SETQ |x| (CAR G168499)) + NIL)) + (NREVERSE0 G168490)) + (SEQ (EXIT (SETQ G168490 + (CONS + (|mkNewCapsuleItem| |freepart| + |imports| |x|) + G168490)))))))) + (SPADLET |$extraDefinitions| (|combineDefinitions|)) + (SPADLET |addDomain| NIL) + (SPADLET |initbody| + (COND + ((AND (PAIRP |$b|) (EQ (QCAR |$b|) '|add|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |$b|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |addDomain| |a|) |b|) + ((AND (PAIRP |$b|) + (PROGN (SPADLET |op| (QCAR |$b|)) 'T) + (|constructor?| |op|)) + (SPADLET |addDomain| |$b|) NIL) + ('T |$b|))) + (SPADLET |body| (|markFinishBody| |initbody|)) + (SPADLET |importCode| + (PROG (G168515) + (SPADLET G168515 NIL) + (RETURN + (DO ((G168520 |$finalImports| + (CDR G168520)) + (|x| NIL)) + ((OR (ATOM G168520) + (PROGN + (SETQ |x| (CAR G168520)) + NIL)) + (NREVERSE0 G168515)) + (SEQ (EXIT (SETQ G168515 + (CONS + (CONS '|import| + (CONS |x| NIL)) + G168515)))))))) + (SPADLET |leadingMacros| + (|markExtractLeadingMacros| |globalImports| + |body|)) + (SPADLET |body| + (|markRemImportsAndLeadingMacros| |leadingMacros| + |body|)) + (SPADLET |initcapsule| + (COND + (|body| (CONS 'CAPSULE + (APPEND |leadingMacros| + (APPEND |importCode| |body|)))) + ('T NIL))) + (SPADLET |capsule| + (COND + (|addDomain| + (CONS '|add| + (CONS |addDomain| + (CONS |initcapsule| NIL)))) + ('T |initcapsule|))) + (SPADLET |nsig| + (COND + (|$categoryPart| |sig|) + ('T (CONS '|Type| (CDR |sig|))))) + (DO ((G168532 (REVERSE |$abbreviationStack|) + (CDR G168532)) + (|x| NIL)) + ((OR (ATOM G168532) + (PROGN (SETQ |x| (CAR G168532)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (|member| |x| + |$abbreviationsAlreadyPrinted|)) + (PROGN + (|markPrintAbbreviation| |x|) + (SPADLET |$abbreviationsAlreadyPrinted| + (|insert| |x| + |$abbreviationsAlreadyPrinted|)))))))) + (DO ((G168545 (REVERSE |$globalMacroStack|) + (CDR G168545)) + (|x| NIL)) + ((OR (ATOM G168545) + (PROGN (SETQ |x| (CAR G168545)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (|member| |x| + |$macrosAlreadyPrinted|)) + (PROGN + (SPADLET |$def| + (CONS 'MDEF + (CONS (CAR |x|) + (CONS '(NIL) + (CONS '(NIL) + (CONS (CDR |x|) NIL)))))) + (|markPrint| 'T) + (SPADLET |$macrosAlreadyPrinted| + (|insert| |x| + |$macrosAlreadyPrinted|)))))))) + (COND + ((AND |$insideCategoryIfTrue| + (NULL |$insideFunctorIfTrue|)) + (|markPrintAttributes| |$b|))) + (SPADLET |$def| + (CONS 'DEF + (CONS |form| + (CONS |nsig| + (CONS + (PROG (G168555) + (SPADLET G168555 NIL) + (RETURN + (DO + ((G168560 |form| + (CDR G168560)) + (|x| NIL)) + ((OR (ATOM G168560) + (PROGN + (SETQ |x| + (CAR G168560)) + NIL)) + (NREVERSE0 G168555)) + (SEQ + (EXIT + (SETQ G168555 + (CONS NIL G168555))))))) + (CONS |capsule| NIL)))))) + (|markPrint|)))))) + +;stop x == x + +(DEFUN |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)]) + +(DEFUN |getNumberTypesInScope| () + (PROG (|y|) + (declare (special |$markNumberTypes| |$globalImportStack| + |$localImportStack|)) + (RETURN + (SEQ (|union| (PROG (G168620) + (SPADLET G168620 NIL) + (RETURN + (DO ((G168626 |$localImportStack| + (CDR G168626)) + (|x| NIL)) + ((OR (ATOM G168626) + (PROGN + (SETQ |x| (CAR G168626)) + NIL)) + (NREVERSE0 G168620)) + (SEQ (EXIT (COND + ((MEMQ + (SPADLET |y| (|opOf| |x|)) + |$markNumberTypes|) + (SETQ G168620 + (CONS |y| G168620))))))))) + (PROG (G168637) + (SPADLET G168637 NIL) + (RETURN + (DO ((G168643 |$globalImportStack| + (CDR G168643)) + (|x| NIL)) + ((OR (ATOM G168643) + (PROGN + (SETQ |x| (CAR G168643)) + NIL)) + (NREVERSE0 G168637)) + (SEQ (EXIT (COND + ((MEMQ + (SPADLET |y| (|opOf| |x|)) + |$markNumberTypes|) + (SETQ G168637 + (CONS |y| G168637)))))))))))))) + +;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] + +(DEFUN |getCommonImports| () + (PROG (|importList| |hash| |threshold|) + (declare (special |$capsuleStack| |$importStack|)) + (RETURN + (SEQ (PROGN + (SPADLET |importList| + (PROG (G168663) + (SPADLET G168663 NIL) + (RETURN + (DO ((G168670 |$importStack| + (CDR G168670)) + (|x| NIL) + (G168671 |$capsuleStack| + (CDR G168671)) + (|y| NIL)) + ((OR (ATOM G168670) + (PROGN + (SETQ |x| (CAR G168670)) + NIL) + (ATOM G168671) + (PROGN + (SETQ |y| (CAR G168671)) + NIL)) + (NREVERSE0 G168663)) + (SEQ (EXIT (COND + ((BOOT-EQUAL (KAR (KAR |y|)) + 'DEF) + (SETQ G168663 + (CONS |x| G168663)))))))))) + (SPADLET |hash| (MAKE-HASHTABLE 'EQUAL)) + (DO ((G168683 |importList| (CDR G168683)) (|x| NIL)) + ((OR (ATOM G168683) + (PROGN (SETQ |x| (CAR G168683)) NIL)) + NIL) + (SEQ (EXIT (DO ((G168692 |x| (CDR G168692)) + (|y| NIL)) + ((OR (ATOM G168692) + (PROGN + (SETQ |y| (CAR G168692)) + NIL)) + NIL) + (SEQ (EXIT (HPUT |hash| |y| + (PLUS 1 + (OR (HGET |hash| |y|) 0))))))))) + (SPADLET |threshold| + (FLOOR (TIMES 0.5 (|#| |importList|)))) + (PROG (G168703) + (SPADLET G168703 NIL) + (RETURN + (DO ((G168709 (HKEYS |hash|) (CDR G168709)) + (|x| NIL)) + ((OR (ATOM G168709) + (PROGN (SETQ |x| (CAR G168709)) NIL)) + (NREVERSE0 G168703)) + (SEQ (EXIT (COND + ((>= (HGET |hash| |x|) |threshold|) + (SETQ G168703 (CONS |x| G168703)))))))))))))) + +;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() + +(DEFUN |markPrintAttributes| (|addForm|) + (PROG (|a| |r| |capsule| |lst| |ISTMP#1| |att|) + (RETURN + (SEQ (PROGN + (SPADLET |capsule| + (COND + ((AND (PAIRP |addForm|) + (EQ (QCAR |addForm|) '|add|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |addForm|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + 'T)))) + (COND + ((AND (PAIRP |a|) (EQ (QCAR |a|) 'CATEGORY)) + |a|) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|Join|)) + (CAR (LASTNODE |a|))) + ('T (CAR (LASTNODE |addForm|))))) + ('T |addForm|))) + (COND + ((AND (PAIRP |capsule|) (EQ (QCAR |capsule|) 'CAPSULE) + (PROGN (SPADLET |r| (QCDR |capsule|)) 'T)) + (SPADLET |capsule| (CAR (LASTNODE |r|))))) + (COND + ((NULL (AND (PAIRP |capsule|) + (EQ (QCAR |capsule|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |capsule|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |lst| (QCDR |ISTMP#1|)) + 'T))))) + NIL) + ('T + (DO ((G168747 |lst| (CDR G168747)) (|x| NIL)) + ((OR (ATOM G168747) + (PROGN (SETQ |x| (CAR G168747)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |att| + (QCAR |ISTMP#1|)) + 'T)))) + (PROGN + (|markSay| (|form2String| |att|)) + (|markSay| + (MAKESTRING ": Category == with")) + (|markTerpri|) + (|markTerpri|)))))))))))))) + +;getCommons u == +; common := KAR u +; while common and u is [x,:u] repeat common := INTERSECTION(x,common) +; common + +(DEFUN |getCommons| (|u|) + (PROG (|x| |common|) + (RETURN + (SEQ (PROGN + (SPADLET |common| (KAR |u|)) + (DO () + ((NULL (AND |common| (PAIRP |u|) + (PROGN + (SPADLET |x| (QCAR |u|)) + (SPADLET |u| (QCDR |u|)) + 'T))) + NIL) + (SEQ (EXIT (SPADLET |common| + (|intersection| |x| |common|))))) + |common|))))) + +;markExtractLeadingMacros(globalImports,body) == +; [x for x in body | x is ['MDEF,[a],:.] and MEMBER(a,globalImports)] + +(DEFUN |markExtractLeadingMacros| (|globalImports| |body|) + (PROG (|ISTMP#1| |ISTMP#2| |a|) + (RETURN + (SEQ (PROG (G168797) + (SPADLET G168797 NIL) + (RETURN + (DO ((G168803 |body| (CDR G168803)) (|x| NIL)) + ((OR (ATOM G168803) + (PROGN (SETQ |x| (CAR G168803)) NIL)) + (NREVERSE0 G168797)) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'MDEF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#2|)) + 'T))))) + (|member| |a| |globalImports|)) + (SETQ G168797 (CONS |x| G168797))))))))))))) + +;markRemImportsAndLeadingMacros(leadingMacros,body) == +; [x for x in body | x isnt ['import,:.] and not MEMBER(x,leadingMacros)] + +(DEFUN |markRemImportsAndLeadingMacros| (|leadingMacros| |body|) + (PROG () + (RETURN + (SEQ (PROG (G168821) + (SPADLET G168821 NIL) + (RETURN + (DO ((G168827 |body| (CDR G168827)) (|x| NIL)) + ((OR (ATOM G168827) + (PROGN (SETQ |x| (CAR G168827)) NIL)) + (NREVERSE0 G168821)) + (SEQ (EXIT (COND + ((AND (NULL + (AND (PAIRP |x|) + (EQ (QCAR |x|) '|import|))) + (NULL + (|member| |x| |leadingMacros|))) + (SETQ G168821 (CONS |x| G168821))))))))))))) + +;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 + +(DEFUN |mkNewCapsuleItem| (|frees| |i| |x|) + (PROG (|originalDef| |ndef| |imports| |importPart| |nbody| |newPart| + |y| |newerBody| |ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |c| + |ISTMP#4| |newerDef| |entry|) + (declare (special |$finalImports|)) + (RETURN + (SEQ (PROGN + (SPADLET |originalDef| (CAR |x|)) + (SPADLET |ndef| (CDR |x|)) + (SPADLET |imports| + (REVERSE (|orderByContainment| + (REMDUP + (SETDIFFERENCE |i| |$finalImports|))))) + (SPADLET |importPart| + (PROG (G168961) + (SPADLET G168961 NIL) + (RETURN + (DO ((G168966 |imports| (CDR G168966)) + (|d| NIL)) + ((OR (ATOM G168966) + (PROGN + (SETQ |d| (CAR G168966)) + NIL)) + (NREVERSE0 G168961)) + (SEQ (EXIT (SETQ G168961 + (CONS + (CONS '|import| + (CONS |d| NIL)) + G168961)))))))) + (SPADLET |nbody| + (COND + ((AND (PAIRP |ndef|) (EQ (QCAR |ndef|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |ndef|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |x| + (QCAR |ISTMP#2|)) + 'T)))))) + |x|) + ((AND (PAIRP |ndef|) (EQ (QCAR |ndef|) 'DEF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |ndef|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |x| + (QCAR |ISTMP#4|)) + 'T)))))))))) + |x|) + ('T |ndef|))) + (SPADLET |newerBody| + (COND + ((SPADLET |newPart| + (APPEND |frees| |importPart|)) + (COND + ((AND (PAIRP |nbody|) + (EQ (QCAR |nbody|) 'SEQ) + (PROGN + (SPADLET |y| (QCDR |nbody|)) + 'T)) + (CONS 'SEQ (APPEND |newPart| |y|))) + ('T + (CONS 'SEQ + (APPEND |newPart| + (CONS + (CONS '|exit| + (CONS 1 (CONS |nbody| NIL))) + NIL)))))) + ('T |nbody|))) + (SPADLET |newerDef| + (COND + ((AND (PAIRP |ndef|) (EQ (QCAR |ndef|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |ndef|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |x| + (QCAR |ISTMP#2|)) + 'T)))))) + (CONS 'LET (CONS |a| (CONS |newerBody| NIL)))) + ((AND (PAIRP |ndef|) (EQ (QCAR |ndef|) 'DEF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |ndef|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |c| + (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |x| + (QCAR |ISTMP#4|)) + 'T)))))))))) + (CONS 'DEF + (CONS |a| + (CONS |b| + (CONS |c| (CONS |newerBody| NIL)))))) + ('T |newerBody|))) + (SPADLET |entry| (CONS |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 + +(DEFUN |markFinishBody| (|capsuleBody|) + (PROG (|itemlist|) + (declare (special |$extraDefinitions| |$insideFunctorIfTrue| + |$insideCategoryIfTrue|)) + (RETURN + (SEQ (COND + ((AND (PAIRP |capsuleBody|) + (EQ (QCAR |capsuleBody|) 'CAPSULE) + (PROGN + (SPADLET |itemlist| (QCDR |capsuleBody|)) + 'T)) + (COND + ((AND |$insideCategoryIfTrue| |$insideFunctorIfTrue|) + (SPADLET |itemlist| (|markCatsub| |itemlist|)))) + (APPEND (PROG (G169012) + (SPADLET G169012 NIL) + (RETURN + (DO ((G169017 |itemlist| (CDR G169017)) + (|x| NIL)) + ((OR (ATOM G169017) + (PROGN + (SETQ |x| (CAR G169017)) + NIL)) + (NREVERSE0 G169012)) + (SEQ (EXIT (SETQ G169012 + (CONS (|markFinishItem| |x|) + G169012))))))) + |$extraDefinitions|)) + ('T NIL)))))) + +;markCatsub x == SUBST("$",$categoryNameForDollar,x) + +(DEFUN |markCatsub| (|x|) + (declare (special |$categoryNameForDollar|)) + (MSUBST '$ |$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 + +(DEFUN |markFinishItem| (|x|) + (PROG (|$macroAlist| |form| |body| |oform| |obody| |newform| |lhs| + |rhs| |olhs| |orhs| |p| |b| |ISTMP#1| |ISTMP#2| |ISTMP#3| + |ISTMP#4| |n| |ISTMP#5| |a| |l| |old| |new|) + (DECLARE (SPECIAL |$macroAlist| |$capsuleStack| |$ob| |$b| |$f| + |$categoryNameForDollar| |$insideFunctorIfTrue| + |$insideCategoryIfTrue| |$globalMacroStack| + |$localMacroStack|)) + (RETURN + (SEQ (PROGN + (SPADLET |$macroAlist| + (APPEND |$localMacroStack| |$globalMacroStack|)) + (COND + ((AND |$insideCategoryIfTrue| |$insideFunctorIfTrue|) + (SPADLET |$macroAlist| + (CONS (CONS '$ |$categoryNameForDollar|) + |$macroAlist|)))) + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |form| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |body| + (QCAR |ISTMP#4|)) + 'T)))))))))) + (OR (PROG (G169273) + (SPADLET G169273 NIL) + (RETURN + (DO ((G169281 NIL G169273) + (G169282 |$capsuleStack| + (CDR G169282)) + (G169108 NIL)) + ((OR G169281 (ATOM G169282) + (PROGN + (SETQ G169108 (CAR G169282)) + NIL) + (PROGN + (PROGN + (SPADLET |old| (CAR G169108)) + (SPADLET |new| (CDR G169108)) + G169108) + NIL)) + G169273) + (SEQ (EXIT (COND + ((AND (PAIRP |old|) + (EQ (QCAR |old|) 'DEF) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |old|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |oform| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND + (PAIRP |ISTMP#4|) + (EQ + (QCDR |ISTMP#4|) + NIL) + (PROGN + (SPADLET |obody| + (QCAR + |ISTMP#4|)) + 'T))))))))) + (|markCompare| |form| |oform|) + (|markCompare| |body| |obody|)) + (SETQ G169273 + (OR G169273 |new|))))))))) + (PROGN + (|pp| (MAKESTRING + "------------MISSING----------------")) + (SPADLET |$f| |form|) + (SPADLET |$b| |body|) + (SPADLET |newform| + (PROG (G169290) + (SPADLET G169290 NIL) + (RETURN + (DO + ((G169298 NIL G169290) + (G169299 |$capsuleStack| + (CDR G169299)) + (G169150 NIL)) + ((OR G169298 (ATOM G169299) + (PROGN + (SETQ G169150 + (CAR G169299)) + NIL) + (PROGN + (PROGN + (SPADLET |old| + (CAR G169150)) + (SPADLET |new| + (CDR G169150)) + G169150) + NIL)) + G169290) + (SEQ + (EXIT + (COND + ((AND (PAIRP |old|) + (EQ (QCAR |old|) 'DEF) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |old|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |oform| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (PROGN + (SPADLET + |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND + (PAIRP + |ISTMP#4|) + (EQ + (QCDR + |ISTMP#4|) + NIL) + (PROGN + (SPADLET + |obody| + (QCAR + |ISTMP#4|)) + 'T))))))))) + (BOOT-EQUAL |oform| |$f|)) + (SETQ G169290 + (OR G169290 |x|)))))))))) + (SPADLET |$ob| + (COND (|newform| |obody|) ('T NIL))) + (|pp| |$f|) + (|pp| |$b|) + (|pp| |$ob|) + (|foobum| |x|) + (|pp| |x|) + |x|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |lhs| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |rhs| (QCAR |ISTMP#2|)) + 'T)))))) + (OR (PROG (G169307) + (SPADLET G169307 NIL) + (RETURN + (DO ((G169315 NIL G169307) + (G169316 |$capsuleStack| + (CDR G169316)) + (G169188 NIL)) + ((OR G169315 (ATOM G169316) + (PROGN + (SETQ G169188 (CAR G169316)) + NIL) + (PROGN + (PROGN + (SPADLET |old| (CAR G169188)) + (SPADLET |new| (CDR G169188)) + G169188) + NIL)) + G169307) + (SEQ (EXIT (COND + ((AND (PAIRP |old|) + (EQ (QCAR |old|) 'LET) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |old|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |olhs| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |orhs| + (QCAR |ISTMP#2|)) + 'T))))) + (|markCompare| |lhs| |olhs|) + (|markCompare| |rhs| |orhs|)) + (SETQ G169307 + (OR G169307 |new|))))))))) + |x|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#3|)) + 'T)))))))) + (CONS 'IF + (CONS |p| + (CONS (|markFinishItem| |a|) + (CONS (|markFinishItem| |b|) NIL))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'SEQ) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) '|exit|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |n| (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#5|)) + 'T))))))) + (PROGN (SPADLET |l| (QCDR |ISTMP#2|)) 'T) + (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))) + (CONS 'SEQ + (APPEND (PROG (G169328) + (SPADLET G169328 NIL) + (RETURN + (DO ((G169333 |l| (CDR G169333)) + (|y| NIL)) + ((OR (ATOM G169333) + (PROGN + (SETQ |y| (CAR G169333)) + NIL)) + (NREVERSE0 G169328)) + (SEQ + (EXIT + (SETQ G169328 + (CONS (|markFinishItem| |y|) + G169328))))))) + (CONS (CONS '|exit| + (CONS |n| + (CONS (|markFinishItem| |a|) NIL))) + NIL)))) + ((PROG (G169339) + (SPADLET G169339 NIL) + (RETURN + (DO ((G169347 NIL G169339) + (G169348 |$capsuleStack| (CDR G169348)) + (G169268 NIL)) + ((OR G169347 (ATOM G169348) + (PROGN + (SETQ G169268 (CAR G169348)) + NIL) + (PROGN + (PROGN + (SPADLET |old| (CAR G169268)) + (SPADLET |new| (CDR G169268)) + G169268) + NIL)) + G169339) + (SEQ (EXIT (COND + ((|markCompare| |x| |old|) + (SETQ G169339 + (OR G169339 |new|))))))))) + |new|) + ('T |x|))))))) + +;markCompare(x,y) == +; markKillAll(SUBLIS($macroAlist,x)) = markKillAll(SUBLIS($macroAlist,y)) + +(DEFUN |markCompare| (|x| |y|) + (declare (special |$macroAlist|)) + (BOOT-EQUAL (|markKillAll| (SUBLIS |$macroAlist| |x|)) + (|markKillAll| (SUBLIS |$macroAlist| |y|)))) + +;diffCompare(x,y) == diff(SUBLIS($macroAlist,x),markKillAll(SUBLIS($macroAlist,y))) + +(DEFUN |diffCompare| (|x| |y|) + (declare (special |$macroAlist|)) + (|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 + +(DEFUN |markPrint| (&REST G169522 &AUX |options|) + (DSETQ |options| G169522) + (PROG (|$DEFdepth| |noTrailingSemicolonIfTrue| |op| |sclist| |body| + T$ |form| |sig| |r| |xtraLines| |ISTMP#1| |a| |ISTMP#2| |b| + |c| |LETTMP#1| |x| |l| |nbody| |signature| |bootLines|) + (DECLARE (SPECIAL |$DEFdepth| |$bootLines| |$bootForm| + |$insideCategoryIfTrue| |$originalTarget| |$def| + |$insideFunctorIfTrue| |$originalBody| |$catAddForm| + |$TriangleVariableList| |$categoryTranForm|)) + (RETURN + (SEQ (PROGN + (SPADLET |noTrailingSemicolonIfTrue| (IFCAR |options|)) + (SPADLET |$DEFdepth| 0) + (SPADLET |LETTMP#1| (|markKillAll| |$def|)) + (SPADLET |op| (CAR |LETTMP#1|)) + (SPADLET |form| (CADR |LETTMP#1|)) + (SPADLET |sig| (CADDR |LETTMP#1|)) + (SPADLET |sclist| (CADDDR |LETTMP#1|)) + (SPADLET |body| (CAR (CDDDDR |LETTMP#1|))) + (COND + (|$insideCategoryIfTrue| + (COND + ((AND (BOOT-EQUAL |op| 'DEF) + |$insideFunctorIfTrue|) + (SPADLET T$ (ELT |$categoryTranForm| 1)) + (SPADLET |form| (CAR T$)) + (SPADLET |sig| (CDR (CADR T$))))) + (SPADLET |form| + (SUBLISLIS + (CDR (|markConstructorForm| + (|opOf| |form|))) + |$TriangleVariableList| |form|)) + (SPADLET |sig| + (SUBLISLIS + (CDR (|markConstructorForm| + (|opOf| |form|))) + |$TriangleVariableList| |sig|)))) + (SPADLET |nbody| |body|) + (COND + (|$insideCategoryIfTrue| + (COND + (|$insideFunctorIfTrue| + (SPADLET |nbody| + (|replaceCapsulePart| |body|)) + (SPADLET |nbody| + (COND + (|$catAddForm| + (CONS '|withDefault| + (CONS |$catAddForm| + (CONS |nbody| NIL)))) + ('T |nbody|)))) + ('T (SPADLET |a| (CADR |$originalBody|)) + (SPADLET |r| (CDDR |$originalBody|)) + (SPADLET |xtraLines| + (PROG (G169473) + (SPADLET G169473 NIL) + (RETURN + (DO + ((G169478 + (|markCheckForAttributes| |a|) + (CDR G169478)) + (|name| NIL)) + ((OR (ATOM G169478) + (PROGN + (SETQ |name| (CAR G169478)) + NIL)) + G169473) + (SEQ + (EXIT + (SETQ G169473 + (APPEND G169473 + (CONS + (STRCONC |name| + (MAKESTRING + ": Category == with")) + (CONS (MAKESTRING "") NIL)))))))))) + (SPADLET |nbody| + (COND + ((AND (PAIRP |$originalBody|) + (EQ (QCAR |$originalBody|) + '|add|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |$originalBody|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((NULL + (AND (PAIRP |b|) + (EQ (QCAR |b|) 'CAPSULE) + (PROGN + (SPADLET |c| (QCDR |b|)) + 'T))) + (|error| NIL)) + ('T + (SPADLET |LETTMP#1| (REVERSE |c|)) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |l| + (NREVERSE (CDR |LETTMP#1|))) + (APPEND (|markTranCategory| |a|) + (CONS + (CONS '|default| + (CONS + (CONS 'SEQ + (APPEND |l| + (CONS + (CONS '|exit| + (CONS 1 (CONS |x| NIL))) + NIL))) + NIL)) + NIL))))) + ('T + (|markTranCategory| |$originalBody|)))))))) + (SPADLET |signature| + (COND + (|$insideFunctorIfTrue| + (CONS (|markTranJoin| |$originalTarget|) + (CDR |sig|))) + (|$insideCategoryIfTrue| + (CONS '|Category| (CDR |sig|))) + ('T '(NIL)))) + (SPADLET |$bootForm| + (COND + ((BOOT-EQUAL |op| 'MDEF) + (CONS |op| + (CONS |form| + (CONS |signature| + (CONS |sclist| (CONS |body| NIL)))))) + ('T + (CONS |op| + (CONS |form| + (CONS |signature| + (CONS |sclist| + (CONS |nbody| NIL)))))))) + (SPADLET |bootLines| (|lisp2Boot| |$bootForm|)) + (SPADLET |$bootLines| (APPEND |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]]]] + +(DEFUN |replaceCapsulePart| (|body|) + (PROG (|c| |ISTMP#1| |ISTMP#2| |exports| |ISTMP#3| |ISTMP#4| + |LETTMP#1| |x| |l|) + (declare (special |$categoryTranForm|)) + (RETURN + (COND + ((NULL (AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) 'CAPSULE) + (PROGN + (SPADLET |c| (QCDR |ISTMP#2|)) + 'T))))))) + |body|) + ((NULL (PROGN + (SPADLET |ISTMP#1| (ELT |$categoryTranForm| 0)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|add|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |exports| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |ISTMP#4| + (QCAR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCAR |ISTMP#4|) 'CAPSULE)))))))))) + (|error| NIL)) + ('T (SPADLET |LETTMP#1| (REVERSE |c|)) + (SPADLET |x| (CAR |LETTMP#1|)) + (SPADLET |l| (NREVERSE (CDR |LETTMP#1|))) + (APPEND (|markTranCategory| |exports|) + (CONS (CONS '|default| + (CONS (CONS 'SEQ + (APPEND |l| + (CONS + (CONS '|exit| + (CONS 1 (CONS |x| NIL))) + NIL))) + NIL)) + NIL))))))) + +;foo(:x) == +; arg := IFCAR x or $bootForm +; markSay lisp2Boot arg + +(DEFUN |foo| (&REST G169584 &AUX |x|) + (DSETQ |x| G169584) + (PROG (|arg|) + (declare (special |$bootForm|)) + (RETURN + (PROGN + (SPADLET |arg| (OR (IFCAR |x|) |$bootForm|)) + (|markSay| (|lisp2Boot| |arg|)))))) + +;markPrintAbbreviation [kind,a,:b] == +; markSay '"--)abbrev " +; markSay kind +; markSay '" " +; markSay a +; markSay '" " +; markSay b +; markTerpri() + +(DEFUN |markPrintAbbreviation| (G169586) + (PROG (|kind| |a| |b|) + (RETURN + (PROGN + (SPADLET |kind| (CAR G169586)) + (SPADLET |a| (CADR G169586)) + (SPADLET |b| (CDDR G169586)) + (|markSay| (MAKESTRING "--)abbrev ")) + (|markSay| |kind|) + (|markSay| (MAKESTRING " ")) + (|markSay| |a|) + (|markSay| (MAKESTRING " ")) + (|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) + +(DEFUN |markSay| (|s|) + (declare (special |$outStream|)) + (SEQ (COND + ((NULL (ATOM |s|)) + (DO ((G169610 |s| (CDR G169610)) (|x| NIL)) + ((OR (ATOM G169610) + (PROGN (SETQ |x| (CAR G169610)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|markSay| (|lispStringList2String| |x|)) + (|markTerpri|)))))) + ('T (PRINTEXP |s|) + (COND (|$outStream| (PRINTEXP |s| |$outStream|)) ('T NIL)))))) + +;markTerpri() == +; TERPRI() +; if $outStream then TERPRI($outStream) + +(DEFUN |markTerpri| () + (declare (special |$outStream|)) + (PROGN + (TERPRI) + (COND (|$outStream| (TERPRI |$outStream|)) ('T NIL)))) + +;markTranJoin u == --subfunction of markPrint +; u is ['Join,:.] => markTranCategory u +; u + +(DEFUN |markTranJoin| (|u|) + (COND + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Join|)) + (|markTranCategory| |u|)) + ('T |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] + +(DEFUN |markTranCategory| (|cat|) + (PROG (|r| |b| |s| |ISTMP#1| |k| |t|) + (RETURN + (COND + ((AND (PAIRP |cat|) (EQ (QCAR |cat|) 'CATEGORY)) |cat|) + ((AND (PAIRP |cat|) (EQ (QCAR |cat|) '|Join|) + (PROGN (SPADLET |r| (QCDR |cat|)) 'T)) + (COND + ((AND (PAIRP |r|) + (PROGN (SPADLET |ISTMP#1| (REVERSE |r|)) 'T) + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#1|)) + (SPADLET |s| (QCDR |ISTMP#1|)) + 'T) + (PROGN (SPADLET |s| (NREVERSE |s|)) 'T) (PAIRP |b|) + (EQ (QCAR |b|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |k| (QCAR |ISTMP#1|)) + (SPADLET |t| (QCDR |ISTMP#1|)) + 'T)))) + (CONS 'CATEGORY + (CONS |k| (APPEND |s| (|markSigTran| |t|))))) + ('T (CONS 'CATEGORY (CONS '|domain| (|markSigTran| |r|)))))) + ('T (CONS 'CATEGORY (CONS '|domain| (CONS |cat| NIL)))))))) + +;markSigTran t == [markElt2Apply x for x in t] + +(DEFUN |markSigTran| (|t|) + (PROG () + (RETURN + (SEQ (PROG (G169655) + (SPADLET G169655 NIL) + (RETURN + (DO ((G169660 |t| (CDR G169660)) (|x| NIL)) + ((OR (ATOM G169660) + (PROGN (SETQ |x| (CAR G169660)) NIL)) + (NREVERSE0 G169655)) + (SEQ (EXIT (SETQ G169655 + (CONS (|markElt2Apply| |x|) + G169655))))))))))) + +;markElt2Apply x == +; x is ["SIGNATURE", "elt", :r] => ['SIGNATURE, 'apply, :r] +; x + +(DEFUN |markElt2Apply| (|x|) + (PROG (|ISTMP#1| |r|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'SIGNATURE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|elt|) + (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) 'T)))) + (CONS 'SIGNATURE (CONS '|apply| |r|))) + ('T |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 + +(DEFUN |markCheckForAttributes,fn| (|x|) + (PROG (|ISTMP#1| |form| |name|) + (declare (special |$knownAttributes|)) + (RETURN + (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |form| (QCAR |ISTMP#1|)) + 'T)))) + (EXIT (SEQ (SPADLET |name| (|opOf| |form|)) + (IF (MEMQ |name| |$knownAttributes|) + (EXIT NIL)) + (SPADLET |$knownAttributes| + (CONS |name| |$knownAttributes|)) + (EXIT |name|)))) + (EXIT NIL))))) + +(DEFUN |markCheckForAttributes| (|cat|) + (PROG (|ISTMP#1| |r| |u|) + (RETURN + (SEQ (COND + ((AND (PAIRP |cat|) (EQ (QCAR |cat|) '|Join|) + (PROGN (SPADLET |r| (QCDR |cat|)) 'T)) + (|markCheckForAttributes| (|last| |r|))) + ((AND (PAIRP |cat|) (EQ (QCAR |cat|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cat|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) 'T)))) + (PROG (G169704) + (SPADLET G169704 NIL) + (RETURN + (DO ((G169710 |r| (CDR G169710)) (|x| NIL)) + ((OR (ATOM G169710) + (PROGN (SETQ |x| (CAR G169710)) NIL)) + (NREVERSE0 G169704)) + (SEQ (EXIT (COND + ((SPADLET |u| + (|markCheckForAttributes,fn| + |x|)) + (SETQ G169704 (CONS |u| G169704)))))))))) + ('T NIL)))))) + +;--====================================================================== +;-- Put in PARTs in code +;--====================================================================== +;$partChoices := '(construct IF) + +(SPADLET |$partChoices| '(|construct| IF)) + +;$partSkips := '(CAPSULE with add) + +(SPADLET |$partSkips| '(CAPSULE |with| |add|)) + +;unpart x == +; x is ['PART,.,y] => y +; x + +(DEFUN |unpart| (|x|) + (PROG (|ISTMP#1| |ISTMP#2| |y|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PART) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) 'T)))))) + |y|) + ('T |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] + +(DEFUN |markInsertParts| (|df|) + (PROG (|form| |a| |b| |body|) + (declare (special |$partNumber|)) + (RETURN + (PROGN + (SPADLET |$partNumber| 0) + (COND ((EQ (CAR |df|) 'DEF) (CAR |df|))) + (SPADLET |form| (CADR |df|)) + (SPADLET |a| (CADDR |df|)) + (SPADLET |b| (CADDDR |df|)) + (SPADLET |body| (CAR (CDDDDR |df|))) + (CONS 'DEF + (CONS |form| + (CONS |a| + (CONS |b| + (CONS (|markInsertBodyParts| |body|) + NIL))))))))) + +;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] + +(DEFUN |markInsertBodyParts| (|u|) + (PROG (|f| |body| |ISTMP#4| |n| |ISTMP#5| |l| |s| |ISTMP#3| |ISTMP#2| + |b| |ISTMP#1| |a| |x| |op|) + (RETURN + (SEQ (COND + ((OR (AND (PAIRP |u|) (EQ (QCAR |u|) '|Join|)) + (AND (PAIRP |u|) (EQ (QCAR |u|) 'CATEGORY))) + |u|) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'DEF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |f| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |body| + (QCAR |ISTMP#4|)) + 'T)))))))))) + (CONS 'DEF + (CONS |f| + (CONS |a| + (CONS |b| + (CONS + (|markInsertBodyParts| |body|) + NIL)))))) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'SEQ) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) '|exit|) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |n| (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |x| (QCAR |ISTMP#5|)) + 'T))))))) + (PROGN (SPADLET |l| (QCDR |ISTMP#2|)) 'T) + (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))) + (CONS 'SEQ + (APPEND (PROG (G169963) + (SPADLET G169963 NIL) + (RETURN + (DO ((G169968 |l| (CDR G169968)) + (|y| NIL)) + ((OR (ATOM G169968) + (PROGN + (SETQ |y| (CAR G169968)) + NIL)) + (NREVERSE0 G169963)) + (SEQ (EXIT + (SETQ G169963 + (CONS + (|markInsertBodyParts| |y|) + G169963))))))) + (CONS (CONS '|exit| + (CONS |n| + (CONS + (|markInsertBodyParts| |x|) + NIL))) + NIL)))) + ((AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |l| (QCDR |u|)) + 'T) + (MEMQ |op| '(REPEAT COLLECT))) + (|markInsertRepeat| |u|)) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|Tuple|) + (PROGN + (SPADLET |s| (QCDR |ISTMP#2|)) + 'T))) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#3|)) + 'T)))))) + (CONS 'LET + (CONS (CONS '|Tuple| + (PROG (G169978) + (SPADLET G169978 NIL) + (RETURN + (DO + ((G169983 |s| (CDR G169983)) + (|x| NIL)) + ((OR (ATOM G169983) + (PROGN + (SETQ |x| (CAR G169983)) + NIL)) + (NREVERSE0 G169978)) + (SEQ + (EXIT + (SETQ G169978 + (CONS (|markWrapPart| |x|) + G169978)))))))) + (CONS (|markInsertBodyParts| |b|) NIL)))) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))) + (PAIRP |a|) (PROGN (SPADLET |op| (QCAR |a|)) 'T)) + (CONS 'LET + (CONS (PROG (G169993) + (SPADLET G169993 NIL) + (RETURN + (DO ((G169998 |a| (CDR G169998)) + (|x| NIL)) + ((OR (ATOM G169998) + (PROGN + (SETQ |x| (CAR G169998)) + NIL)) + (NREVERSE0 G169993)) + (SEQ (EXIT + (SETQ G169993 + (CONS (|markWrapPart| |x|) + G169993))))))) + (CONS (|markInsertBodyParts| |b|) NIL)))) + ((AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))) + (MEMQ |op| '(|add| |with| IN LET))) + (CONS |op| + (CONS (|markInsertBodyParts| |a|) + (CONS (|markInsertBodyParts| |b|) NIL)))) + ((AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))) + (MEMQ |op| '(|:| |::| |pretend| @))) + (CONS |op| + (CONS (|markInsertBodyParts| |a|) (CONS |b| NIL)))) + ((AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |x| (QCDR |ISTMP#1|)) + 'T))) + (MEMQ |op| '(STEP |return| |leave| |exit| |reduce|))) + (CONS |op| + (CONS |a| + (PROG (G170008) + (SPADLET G170008 NIL) + (RETURN + (DO ((G170013 |x| (CDR G170013)) + (|y| NIL)) + ((OR (ATOM G170013) + (PROGN + (SETQ |y| (CAR G170013)) + NIL)) + (NREVERSE0 G170008)) + (SEQ (EXIT + (SETQ G170008 + (CONS + (|markInsertBodyParts| |y|) + G170008)))))))))) + ((AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |x| (QCDR |u|)) + 'T) + (|markPartOp?| |op|)) + (CONS |op| + (PROG (G170023) + (SPADLET G170023 NIL) + (RETURN + (DO ((G170028 |x| (CDR G170028)) (|y| NIL)) + ((OR (ATOM G170028) + (PROGN + (SETQ |y| (CAR G170028)) + NIL)) + (NREVERSE0 G170023)) + (SEQ (EXIT (SETQ G170023 + (CONS (|markWrapPart| |y|) + G170023))))))))) + ((AND (PAIRP |u|) (PROGN (SPADLET |op| (QCAR |u|)) 'T) + (|constructor?| |op|)) + |u|) + ((ATOM |u|) (|markWrapPart| |u|)) + ('T + (PROG (G170038) + (SPADLET G170038 NIL) + (RETURN + (DO ((G170043 |u| (CDR G170043)) (|x| NIL)) + ((OR (ATOM G170043) + (PROGN (SETQ |x| (CAR G170043)) NIL)) + (NREVERSE0 G170038)) + (SEQ (EXIT (SETQ G170038 + (CONS (|markInsertBodyParts| |x|) + G170038))))))))))))) + +;markPartOp? op == +; MEMQ(op,$partChoices) => true +; MEMQ(op,$partSkips) => false +; if op is ['elt,.,o] then op := o +; GET(op,'special) => false +; true + +(DEFUN |markPartOp?| (|op|) + (PROG (|ISTMP#1| |ISTMP#2| |o|) + (declare (special |$partSkips| |$partChoices|)) + (RETURN + (COND + ((MEMQ |op| |$partChoices|) 'T) + ((MEMQ |op| |$partSkips|) NIL) + ('T + (COND + ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |o| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |op| |o|))) + (COND ((GETL |op| '|special|) NIL) ('T 'T))))))) + +;markWrapPart y == +;----------------new definition----------94/10/11 +; atom y => +; y = 'noBranch => y +; GET(y, 'SPECIAL) => y +; $partNumber := $partNumber + 1 +; ['PART,$partNumber, y] +; ['PART,$partNumber := $partNumber + 1,markInsertBodyParts y] + +(DEFUN |markWrapPart| (|y|) + (declare (special |$partNumber|)) + (COND + ((ATOM |y|) + (COND + ((BOOT-EQUAL |y| '|noBranch|) |y|) + ((GETL |y| 'SPECIAL) |y|) + ('T (SPADLET |$partNumber| (PLUS |$partNumber| 1)) + (CONS 'PART (CONS |$partNumber| (CONS |y| NIL)))))) + ('T + (CONS 'PART + (CONS (SPADLET |$partNumber| (PLUS |$partNumber| 1)) + (CONS (|markInsertBodyParts| |y|) NIL)))))) + +;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] + +(DEFUN |markInsertRepeat| (G170130) + (PROG (|op| |LETTMP#1| |body| |itl| |nitl| |nbody|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR G170130)) + (SPADLET |LETTMP#1| (REVERSE (CDR G170130))) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itl| (NREVERSE (CDR |LETTMP#1|))) + (SPADLET |nitl| + (PROG (G170147) + (SPADLET G170147 NIL) + (RETURN + (DO ((G170152 |itl| (CDR G170152)) + (|x| NIL)) + ((OR (ATOM G170152) + (PROGN + (SETQ |x| (CAR G170152)) + NIL)) + (NREVERSE0 G170147)) + (SEQ (EXIT (SETQ G170147 + (CONS + (|markInsertIterator| |x|) + G170147)))))))) + (SPADLET |nbody| (|markInsertBodyParts| |body|)) + (CONS |op| (APPEND |nitl| (CONS |nbody| NIL)))))))) + +;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() + +(DEFUN |markInsertIterator| (|x|) + (PROG (|k| |r| |ISTMP#2| |q| |ISTMP#1| |p|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'STEP) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |k| (QCAR |ISTMP#1|)) + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T)))) + (CONS 'STEP + (CONS (|markWrapPart| |k|) + (PROG (G170209) + (SPADLET G170209 NIL) + (RETURN + (DO ((G170214 |r| (CDR G170214)) + (|x| NIL)) + ((OR (ATOM G170214) + (PROGN + (SETQ |x| (CAR G170214)) + NIL)) + (NREVERSE0 G170209)) + (SEQ (EXIT + (SETQ G170209 + (CONS (|markWrapPart| |x|) + G170209)))))))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IN) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |q| (QCAR |ISTMP#2|)) + 'T)))))) + (CONS 'IN + (CONS (|markWrapPart| |p|) + (CONS (|markWrapPart| |q|) NIL)))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|\||) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) + (CONS '|\|| (CONS (|markWrapPart| |p|) NIL))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'WHILE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) + (CONS 'WHILE (CONS (|markWrapPart| |p|) NIL))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'UNTIL) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) + (CONS 'UNTIL (CONS (|markWrapPart| |p|) NIL))) + ('T (|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 + +(DEFUN |markKillExpr| (|m|) + (PROG (|op| |ISTMP#1| |a| |ISTMP#2| |ISTMP#3| |x| |ISTMP#4| |ISTMP#5| + |e|) + (RETURN + (SEQ (COND + ((AND (PAIRP |m|) (PROGN (SPADLET |op| (QCAR |m|)) 'T)) + (COND + ((MEMQ |op| '(MI WI)) (|markKillExpr| (CADDR |m|))) + ((MEMQ |op| '(AUTOHARD AUTOSUBSET AUTOREP)) + (|markKillExpr| (CADDDR |m|))) + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|TAGGEDreturn|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |m| + (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |e| + (QCAR |ISTMP#5|)) + 'T)))))))))))) + (CONS '|TAGGEDreturn| + (CONS |a| + (CONS (CONS (|markKillExpr| |x|) + (CONS |m| (CONS |e| NIL))) + NIL)))) + ('T + (PROG (G170317) + (SPADLET G170317 NIL) + (RETURN + (DO ((G170322 |m| (CDR G170322)) (|x| NIL)) + ((OR (ATOM G170322) + (PROGN (SETQ |x| (CAR G170322)) NIL)) + (NREVERSE0 G170317)) + (SEQ (EXIT (SETQ G170317 + (CONS (|markKillExpr| |x|) + G170317)))))))))) + ('T |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 + +(DEFUN |markKillButIfs| (|m|) + (PROG (|op| |ISTMP#1| |a| |ISTMP#2| |ISTMP#3| |x| |ISTMP#4| |ISTMP#5| + |e|) + (RETURN + (SEQ (COND + ((AND (PAIRP |m|) (PROGN (SPADLET |op| (QCAR |m|)) 'T)) + (COND + ((BOOT-EQUAL |op| 'IF) |m|) + ((BOOT-EQUAL |op| 'PART) + (|markKillButIfs| (CADDR |m|))) + ((MEMQ |op| '(MI WI)) (|markKillButIfs| (CADDR |m|))) + ((MEMQ |op| '(AUTOHARD AUTOSUBSET AUTOREP)) + (|markKillButIfs| (CADDDR |m|))) + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|TAGGEDreturn|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |m| + (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |e| + (QCAR |ISTMP#5|)) + 'T)))))))))))) + (CONS '|TAGGEDreturn| + (CONS |a| + (CONS (CONS (|markKillButIfs| |x|) + (CONS |m| (CONS |e| NIL))) + NIL)))) + ('T + (PROG (G170422) + (SPADLET G170422 NIL) + (RETURN + (DO ((G170427 |m| (CDR G170427)) (|x| NIL)) + ((OR (ATOM G170427) + (PROGN (SETQ |x| (CAR G170427)) NIL)) + (NREVERSE0 G170422)) + (SEQ (EXIT (SETQ G170422 + (CONS (|markKillButIfs| |x|) + G170422)))))))))) + ('T |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 + +(DEFUN |markKillAll| (|m|) + (PROG (|op| |ISTMP#1| |a| |ISTMP#2| |ISTMP#3| |x| |ISTMP#4| |ISTMP#5| + |e|) + (RETURN + (SEQ (COND + ((AND (PAIRP |m|) (PROGN (SPADLET |op| (QCAR |m|)) 'T)) + (COND + ((BOOT-EQUAL |op| 'PART) (|markKillAll| (CADDR |m|))) + ((MEMQ |op| '(MI WI)) (|markKillAll| (CADDR |m|))) + ((MEMQ |op| '(AUTOHARD AUTOSUBSET AUTOREP)) + (|markKillAll| (CADDDR |m|))) + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|TAGGEDreturn|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |m| + (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| + (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |e| + (QCAR |ISTMP#5|)) + 'T)))))))))))) + (CONS '|TAGGEDreturn| + (CONS |a| + (CONS (CONS (|markKillAll| |x|) + (CONS |m| (CONS |e| NIL))) + NIL)))) + ('T + (PROG (G170527) + (SPADLET G170527 NIL) + (RETURN + (DO ((G170532 |m| (CDR G170532)) (|x| NIL)) + ((OR (ATOM G170532) + (PROGN (SETQ |x| (CAR G170532)) NIL)) + (NREVERSE0 G170527)) + (SEQ (EXIT (SETQ G170527 + (CONS (|markKillAll| |x|) + G170527)))))))))) + ('T |m|)))))) + +;--====================================================================== +;-- Moving lines up/down +;--====================================================================== +;moveAroundLines() == +; changeToEqualEqual $bootLines +; $bootLines := moveImportsAfterDefinitions $bootLines + +(DEFUN |moveAroundLines| () + (declare (special |$bootLines|)) + (PROGN + (|changeToEqualEqual| |$bootLines|) + (SPADLET |$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 + +(DEFUN |changeToEqualEqual| (|lines|) + (PROG (|origLines| |x| N |n| |m| |word| |expandedWord|) + (declare (special |$e| |$blank|)) + (RETURN + (SEQ (PROGN + (SPADLET |origLines| |lines|) + (DO () + ((NULL (AND (PAIRP |lines|) + (PROGN + (SPADLET |x| (QCAR |lines|)) + (SPADLET |lines| (QCDR |lines|)) + 'T))) + NIL) + (SEQ (EXIT (PROGN + (SPADLET N (MAXINDEX |x|)) + (COND + ((> (SPADLET |n| + (|charPosition| |$blank| |x| + 8)) + N) + NIL) + ((EQL |n| 0) NIL) + ((NULL (ALPHA-CHAR-P + (ELT |x| (SPADDIFFERENCE |n| 1)))) + NIL) + ((NULL (|substring?| (MAKESTRING ":= ") + |x| (PLUS |n| 1))) + NIL) + ('T (SPADLET |m| (PLUS |n| 3)) + (DO () + ((NULL + (AND + (<= (SPADLET |m| (PLUS |m| 1)) N) + (ALPHA-CHAR-P (ELT |x| |m|)))) + NIL) + (SEQ (EXIT NIL))) + (COND + ((BOOT-EQUAL |m| (PLUS |n| 2)) NIL) + ((NULL (UPPER-CASE-P + (ELT |x| (PLUS |n| 4)))) + NIL) + ('T + (SPADLET |word| + (INTERN + (SUBSTRING |x| (PLUS |n| 4) + (SPADDIFFERENCE + (SPADDIFFERENCE |m| |n|) + 4)))) + (SPADLET |expandedWord| + (|macroExpand| |word| |$e|)) + (COND + ((NULL + (OR + (MEMQ |word| + '(|Record| |Union| |Mapping|)) + (GETDATABASE + (|opOf| |expandedWord|) + 'CONSTRUCTORFORM))) + NIL) + ('T + (|sayMessage| + (MAKESTRING + "Converting input line:")) + (|sayMessage| + (CONS (MAKESTRING "WAS: ") + (CONS |x| NIL))) + (SETELT |x| (PLUS |n| 1) + (|char| '=)) + (|sayMessage| + (CONS (MAKESTRING "IS: ") + (CONS |x| NIL))) + (TERPRI))))))))))) + |origLines|))))) + +;sayMessage x == +; u := +; ATOM x => ['">> ", x] +; ['">> ",: x] +; sayBrightly u + +(DEFUN |sayMessage| (|x|) + (PROG (|u|) + (RETURN + (PROGN + (SPADLET |u| + (COND + ((ATOM |x|) + (CONS (MAKESTRING ">> ") (CONS |x| NIL))) + ('T (CONS (MAKESTRING ">> ") |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) + +(DEFUN |moveImportsAfterDefinitions| (|lines|) + (PROG (|al| N |m| |n| |defineAlist| |k| |importAlist| |name| |i| + |imp| |j| |moveAlist|) + (declare (special |$blank|)) + (RETURN + (SEQ (PROGN + (SPADLET |al| NIL) + (DO ((G170617 |lines| (CDR G170617)) (|x| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G170617) + (PROGN (SETQ |x| (CAR G170617)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET N (MAXINDEX |x|)) + (SPADLET |m| (|firstNonBlankPosition| |x|)) + (COND + ((MINUSP |m|) NIL) + ((AND (> N + (SPADLET |n| + (|charPosition| |$blank| |x| + (PLUS 1 |m|)))) + (|substring?| (MAKESTRING "== ") + |x| (PLUS |n| 1))) + (SPADLET |name| + (SUBSTRING |x| |m| + (SPADDIFFERENCE |n| |m|))) + (SPADLET |defineAlist| + (CONS (CONS |name| |i|) + |defineAlist|))) + ((SPADLET |k| + (|leadingSubstring?| + (MAKESTRING "import from ") + |x| 0)) + (SPADLET |importAlist| + (CONS + (CONS + (SUBSTRING |x| (PLUS |k| 12) + NIL) + |i|) + |importAlist|)))))))) + (DO ((G170630 |defineAlist| (CDR G170630)) + (G170605 NIL)) + ((OR (ATOM G170630) + (PROGN (SETQ G170605 (CAR G170630)) NIL) + (PROGN + (PROGN + (SPADLET |name| (CAR G170605)) + (SPADLET |i| (CDR G170605)) + G170605) + NIL)) + NIL) + (SEQ (EXIT (PROG (G170637) + (SPADLET G170637 NIL) + (RETURN + (DO ((G170644 NIL G170637) + (G170645 |importAlist| + (CDR G170645)) + (G170597 NIL)) + ((OR G170644 (ATOM G170645) + (PROGN + (SETQ G170597 (CAR G170645)) + NIL) + (PROGN + (PROGN + (SPADLET |imp| (CAR G170597)) + (SPADLET |j| (CDR G170597)) + G170597) + NIL)) + G170637) + (SEQ (EXIT + (SETQ G170637 + (OR G170637 + (COND + ((|substring?| |name| |imp| + 0) + (SPADLET |moveAlist| + (CONS (CONS |i| |j|) + |moveAlist|))) + ('T NIL)))))))))))) + (COND + ((NULL |moveAlist|) |lines|) + ('T (|moveLinesAfter| (|mySort| |moveAlist|) |lines|)))))))) + +;leadingSubstring?(part, whole, :options) == +; after := IFCAR options or 0 +; substring?(part, whole, k := firstNonBlankPosition(whole, after)) => k +; false + +(DEFUN |leadingSubstring?| + (&REST G170676 &AUX |options| |whole| |part|) + (DSETQ (|part| |whole| . |options|) G170676) + (PROG (|after| |k|) + (RETURN + (PROGN + (SPADLET |after| (OR (IFCAR |options|) 0)) + (COND + ((|substring?| |part| |whole| + (SPADLET |k| (|firstNonBlankPosition| |whole| |after|))) + |k|) + ('T NIL)))))) + +;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) + +(DEFUN |stringIsWordOf?| (|s| |t| |startpos|) + (PROG (|maxindex| |n|) + (RETURN + (PROGN + (SPADLET |maxindex| (MAXINDEX |t|)) + (COND + ((> (SPADLET |n| (|stringPosition| |s| |t| |startpos|)) + |maxindex|) + NIL) + ('T (|wordDelimiter?| (ELT |t| (SPADDIFFERENCE |n| 1))) + (OR (BOOT-EQUAL |n| |maxindex|) + (|wordDelimiter?| (ELT |t| (PLUS |n| (|#| |s|))))))))))) + +;wordDelimiter? c == or/[CHAR_=(c,('"() ,;").i) for i in 0..4] + +(DEFUN |wordDelimiter?| (|c|) + (PROG () + (RETURN + (SEQ (PROG (G170683) + (SPADLET G170683 NIL) + (RETURN + (DO ((G170689 NIL G170683) (|i| 0 (QSADD1 |i|))) + ((OR G170689 (QSGREATERP |i| 4)) G170683) + (SEQ (EXIT (SETQ G170683 + (OR G170683 + (CHAR= |c| + (ELT (MAKESTRING "() ,;") |i|))))))))))))) + +;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 + +(DEFUN |moveLinesAfter| (|alist| |lines|) + (PROG (|n| |p| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |n| (|#| |lines|)) + (SPADLET |acc| NIL) + (DO ((G170704 (SPADDIFFERENCE |n| 1)) + (|i| 0 (QSADD1 |i|)) + (G170705 |lines| (CDR G170705)) (|x| NIL)) + ((OR (QSGREATERP |i| G170704) (ATOM G170705) + (PROGN (SETQ |x| (CAR G170705)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (SPADLET |p| (|assoc| |i| |alist|)) + (STRINGP (CDR |p|))) + (SPADLET |acc| + (CONS (CDR |p|) (CONS |x| |acc|)))) + ((AND (SPADLET |p| + (|lookupRight| |i| |alist|)) + (> (CAR |p|) |i|)) + (RPLACD |p| |x|)) + ('T (SPADLET |acc| (CONS |x| |acc|))))))) + (REVERSE |acc|)))))) + +;lookupRight(x, al) == +; al is [p, :al] => +; x = CDR p => p +; lookupRight(x, al) +; nil + +(DEFUN |lookupRight| (|x| |al|) + (PROG (|p|) + (RETURN + (COND + ((AND (PAIRP |al|) + (PROGN + (SPADLET |p| (QCAR |al|)) + (SPADLET |al| (QCDR |al|)) + 'T)) + (COND + ((BOOT-EQUAL |x| (CDR |p|)) |p|) + ('T (|lookupRight| |x| |al|)))) + ('T NIL))))) + +;--====================================================================== +;-- Utility Functions +;--====================================================================== +; +;ppEnv [ce,:.] == +; for env in ce repeat +; for contour in env repeat +; pp contour + +(DEFUN |ppEnv| (G170731) + (PROG (|ce|) + (RETURN + (SEQ (PROGN + (SPADLET |ce| (CAR G170731)) + (DO ((G170741 |ce| (CDR G170741)) (|env| NIL)) + ((OR (ATOM G170741) + (PROGN (SETQ |env| (CAR G170741)) NIL)) + NIL) + (SEQ (EXIT (DO ((G170750 |env| (CDR G170750)) + (|contour| NIL)) + ((OR (ATOM G170750) + (PROGN + (SETQ |contour| (CAR G170750)) + NIL)) + NIL) + (SEQ (EXIT (|pp| |contour|)))))))))))) + +;diff(x,y) == +; for [p,q] in (r := diff1(x,y)) repeat +; pp '"------------" +; pp p +; pp q +; #r + +(DEFUN |diff| (|x| |y|) + (PROG (|r| |p| |q|) + (RETURN + (SEQ (PROGN + (DO ((G170773 (SPADLET |r| (|diff1| |x| |y|)) + (CDR G170773)) + (G170761 NIL)) + ((OR (ATOM G170773) + (PROGN (SETQ G170761 (CAR G170773)) NIL) + (PROGN + (PROGN + (SPADLET |p| (CAR G170761)) + (SPADLET |q| (CADR G170761)) + G170761) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|pp| (MAKESTRING "------------")) + (|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] + +(DEFUN |diff1| (|x| |y|) + (PROG () + (RETURN + (SEQ (COND + ((BOOT-EQUAL |x| |y|) NIL) + ((OR (ATOM |x|) (ATOM |y|)) + (CONS (CONS |x| (CONS |y| NIL)) NIL)) + ((NEQUAL (|#| |x|) (|#| |y|)) (CONS |x| (CONS |y| NIL))) + ('T + (PROG (G170787) + (SPADLET G170787 NIL) + (RETURN + (DO ((G170793 |x| (CDR G170793)) (|u| NIL) + (G170794 |y| (CDR G170794)) (|v| NIL)) + ((OR (ATOM G170793) + (PROGN (SETQ |u| (CAR G170793)) NIL) + (ATOM G170794) + (PROGN (SETQ |v| (CAR G170794)) NIL)) + G170787) + (SEQ (EXIT (SETQ G170787 + (APPEND G170787 + (|diff1| |u| |v|)))))))))))))) + +;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) + +(DEFUN |markConstructorForm| (|name|) + (COND + ((BOOT-EQUAL |name| '|Union|) '(|Union| (|:| |a| A) (|:| |b| B))) + ((BOOT-EQUAL |name| '|UntaggedUnion|) '(|Union| A B)) + ((BOOT-EQUAL |name| '|Record|) '(|Record| (|:| |a| A) (|:| |b| B))) + ((BOOT-EQUAL |name| '|Mapping|) '(|Mapping| T S)) + ('T (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]) + +(DEFUN |markGetPaths| (|x| |y|) + (PROG (|res|) + (declare (special |$newPaths|)) + (RETURN + (COND + ((AND (BOUNDP '|$newPaths|) |$newPaths|) + (SPADLET |res| (|mkGetPaths| |x| |y|))) + ('T (|markPaths| |x| |y| (CONS NIL 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 + +(DEFUN |mkCheck| () + (PROG (|x| |y| |res| |oldRes|) + (declare (special |$badStack|)) + (RETURN + (SEQ (DO ((G170834 (REMDUP |$badStack|) (CDR G170834)) + (G170817 NIL)) + ((OR (ATOM G170834) + (PROGN (SETQ G170817 (CAR G170834)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G170817)) + (SPADLET |y| (CDR G170817)) + G170817) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|pp| (MAKESTRING + "!!-------------------------------!!")) + (SPADLET |res| (|mkGetPaths| |x| |y|)) + (SPADLET |oldRes| + (|markPaths| |x| |y| (CONS NIL NIL))) + (|pp| |x|) + (|pp| |y|) + (|sayBrightlyNT| (MAKESTRING "new: ")) + (|pp| |res|) + (|sayBrightlyNT| (MAKESTRING "old: ")) + (|pp| |oldRes|))))))))) + +;reverseDown u == [REVERSE x for x in u] + +(DEFUN |reverseDown| (|u|) + (PROG () + (RETURN + (SEQ (PROG (G170852) + (SPADLET G170852 NIL) + (RETURN + (DO ((G170857 |u| (CDR G170857)) (|x| NIL)) + ((OR (ATOM G170857) + (PROGN (SETQ |x| (CAR G170857)) NIL)) + (NREVERSE0 G170852)) + (SEQ (EXIT (SETQ G170852 + (CONS (REVERSE |x|) G170852))))))))))) + +;mkCheckRun() == +; for [x, :y] in REMDUP $badStack repeat +; pp mkGetPaths(x,y) + +(DEFUN |mkCheckRun| () + (PROG (|x| |y|) + (declare (special |$badStack|)) + (RETURN + (SEQ (DO ((G170875 (REMDUP |$badStack|) (CDR G170875)) + (G170867 NIL)) + ((OR (ATOM G170875) + (PROGN (SETQ G170867 (CAR G170875)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G170867)) + (SPADLET |y| (CDR G170867)) + G170867) + NIL)) + NIL) + (SEQ (EXIT (|pp| (|mkGetPaths| |x| |y|))))))))) + +;mkGetPaths(x,y) == +; u := REMDUP mkPaths(x,y) => getLocationsOf(u,y,nil) +; nil + +(DEFUN |mkGetPaths| (|x| |y|) + (PROG (|u|) + (RETURN + (COND + ((SPADLET |u| (REMDUP (|mkPaths| |x| |y|))) + (|getLocationsOf| |u| |y| NIL)) + ('T 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)] + +(DEFUN |mkPaths| (|x| |y|) + (PROG (|v| |a| |b| |fn| |y1| |ISTMP#1| |ISTMP#2| |ISTMP#3| |op| |r| + |u|) + (RETURN + (SEQ (COND + ((|markPathsEqual| |x| |y|) (CONS |y| NIL)) + ((ATOM |y|) NIL) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |u| (QCDR |x|)) + 'T) + (MEMQ |op| '(LIST VECTOR)) (PAIRP |y|) + (EQ (QCAR |y|) '|construct|) + (PROGN (SPADLET |v| (QCDR |y|)) 'T) + (|markPathsEqual| (CONS '|construct| |u|) |y|)) + (CONS |y| NIL)) + ((AND (OR (AND (PAIRP |y|) (EQ (QCAR |y|) 'LET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (AND (PAIRP |y|) (EQ (QCAR |y|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))))) + (GENSYMP |a|) (|markPathsEqual| |x| |b|)) + (CONS |y| NIL)) + ((AND (PAIRP |y|) (EQ (QCAR |y|) '|call|) + (PROGN (SPADLET |r| (QCDR |y|)) 'T)) + (COND ((|mkPaths| |x| |r|) (EXIT (CONS |y| NIL))))) + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'PART) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y1| (QCAR |ISTMP#2|)) + 'T)))))) + (|mkPaths| |x| |y1|)) + ((AND (PAIRP |y|) + (PROGN + (SPADLET |fn| (QCAR |y|)) + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y1| (QCAR |ISTMP#2|)) + 'T))))) + (MEMQ |fn| '(CATCH THROW))) + (COND ((|mkPaths| |x| |y1|) (EXIT (CONS |y| NIL))))) + ((AND (PAIRP |y|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |y|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|elt|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |op| (QCAR |ISTMP#3|)) + 'T))))))) + (PROGN (SPADLET |r| (QCDR |y|)) 'T) + (SPADLET |u| (|mkPaths| |x| (CONS |op| |r|)))) + |u|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) + (PROGN (SPADLET |r| (QCDR |x|)) 'T) + (SPADLET |u| (|mkPaths| |r| |y|))) + |u|) + ((AND (PAIRP |y|) (EQ (QCAR |y|) '|elt|) + (PROGN (SPADLET |r| (QCDR |y|)) 'T) + (SPADLET |u| (|mkPaths| |x| |r|))) + |u|) + ('T + (PROG (G170973) + (SPADLET G170973 NIL) + (RETURN + (DO ((G170979 |y| (CDR G170979)) (|z| NIL)) + ((OR (ATOM G170979) + (PROGN (SETQ |z| (CAR G170979)) NIL)) + G170973) + (SEQ (EXIT (COND + ((SPADLET |u| (|mkPaths| |x| |z|)) + (SETQ G170973 + (APPEND G170973 |u|))))))))))))))) + +;getLocationsOf(u,y,s) == [getLocOf(x,y,s) for x in u] + +(DEFUN |getLocationsOf| (|u| |y| |s|) + (PROG () + (RETURN + (SEQ (PROG (G171023) + (SPADLET G171023 NIL) + (RETURN + (DO ((G171028 |u| (CDR G171028)) (|x| NIL)) + ((OR (ATOM G171028) + (PROGN (SETQ |x| (CAR G171028)) NIL)) + (NREVERSE0 G171023)) + (SEQ (EXIT (SETQ G171023 + (CONS (|getLocOf| |x| |y| |s|) + G171023))))))))))) + +;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] + +(DEFUN |getLocOf| (|x| |y| |s|) + (PROG (|ISTMP#1| |ISTMP#2| |y1| |r|) + (RETURN + (SEQ (COND + ((OR (BOOT-EQUAL |x| |y|) + (AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) + (PROGN (SPADLET |r| (QCDR |x|)) 'T) + (BOOT-EQUAL |r| |y|))) + |s|) + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'PART) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y1| (QCAR |ISTMP#2|)) + 'T)))))) + (|getLocOf| |x| |y1| |s|)) + ('T + (COND + ((AND (PAIRP |y|) (EQ (QCAR |y|) '|elt|) + (PROGN (SPADLET |r| (QCDR |y|)) 'T)) + (SPADLET |y| |r|))) + (COND + ((ATOM |y|) NIL) + ('T + (PROG (G171049) + (SPADLET G171049 NIL) + (RETURN + (DO ((G171056 NIL G171049) + (|i| 0 (QSADD1 |i|)) + (G171057 |y| (CDR G171057)) (|z| NIL)) + ((OR G171056 (ATOM G171057) + (PROGN (SETQ |z| (CAR G171057)) NIL)) + G171049) + (SEQ (EXIT (SETQ G171049 + (OR G171049 + (|getLocOf| |x| |z| + (CONS |i| |s|))))))))))))))))) + +;--====================================================================== +;-- 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 + +(DEFUN |combineDefinitions| () + (PROG (|$acc| |item| |op| |oldAlist| |pair| |sig| |items| |k| |predl| + |def| |form| |ops| |opName| |Xdeflist|) + (DECLARE (SPECIAL |$acc| |$hash| |$predicateStack| |$signatureStack| + |$capsuleStack|)) + (RETURN + (SEQ (PROGN + (SPADLET |$hash| (MAKE-HASH-TABLE)) + (DO ((G171103 |$capsuleStack| (CDR G171103)) + (|defs| NIL) + (G171104 |$signatureStack| (CDR G171104)) + (|sig| NIL) + (G171105 |$predicateStack| (CDR G171105)) + (|predl| NIL)) + ((OR (ATOM G171103) + (PROGN (SETQ |defs| (CAR G171103)) NIL) + (ATOM G171104) + (PROGN (SETQ |sig| (CAR G171104)) NIL) + (ATOM G171105) + (PROGN (SETQ |predl| (CAR G171105)) NIL)) + NIL) + (SEQ (EXIT (COND + (|sig| (PROGN + (COND + ((EQ (CAAR |defs|) 'DEF) + (CAAR |defs|))) + (SPADLET |form| (CADAR |defs|)) + (SPADLET |item| + (CONS |predl| |defs|)) + (SPADLET |op| (|opOf| |form|)) + (SPADLET |oldAlist| + (HGET |$hash| (|opOf| |form|))) + (COND + ((SPADLET |pair| + (|assoc| |sig| |oldAlist|)) + (RPLACD |pair| + (CONS |item| (CDR |pair|)))) + ('T + (HPUT |$hash| |op| + (CONS + (CONS |sig| + (CONS |item| NIL)) + |oldAlist|)))))))))) + (SPADLET |Xdeflist| NIL) + (DO ((G171134 (HKEYS |$hash|) (CDR G171134)) + (|op| NIL)) + ((OR (ATOM G171134) + (PROGN (SETQ |op| (CAR G171134)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |$acc| NIL) + (DO ((G171154 (HGET |$hash| |op|) + (CDR G171154)) + (G171085 NIL)) + ((OR (ATOM G171154) + (PROGN + (SETQ G171085 (CAR G171154)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| + (CAR G171085)) + (SPADLET |items| + (CDR G171085)) + G171085) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((> (SPADLET |k| (|#| |items|)) + 1) + (PROGN + (DO + ((|i| 1 (QSADD1 |i|)) + (G171172 |items| + (CDR G171172)) + (|item| NIL)) + ((OR (ATOM G171172) + (PROGN + (SETQ |item| + (CAR G171172)) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |predl| + (CAR |item|)) + (SPADLET |def| + (CDDR |item|)) + (SPADLET |form| + (CADR |def|)) + (SPADLET |ops| + (PNAME |op|)) + (SPADLET |opName| + (INTERN + (STRCONC |ops| + (MAKESTRING "X") + (STRINGIMAGE |i|)))) + (RPLACA |form| |opName|) + (SPADLET |$acc| + (CONS + (CONS |form| |predl|) + |$acc|)))))) + (SPADLET |Xdeflist| + (CONS + (|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 + +(DEFUN |rplacaSubst,fn| (|x| |y| |u|) + (PROG (|p| |q|) + (RETURN + (SEQ (IF (ATOM |u|) (EXIT NIL)) + (EXIT (DO () + ((NULL (AND (PAIRP |u|) + (PROGN + (SPADLET |p| (QCAR |u|)) + (SPADLET |q| (QCDR |u|)) + 'T))) + NIL) + (SEQ (IF (EQ |p| |x|) (RPLACA |u| |y|) NIL) + (IF (NULL (ATOM |p|)) + (|rplacaSubst,fn| |x| |y| |p|) NIL) + (EXIT (SPADLET |u| |q|))))))))) + + +(DEFUN |rplacaSubst| (|x| |y| |u|) + (PROGN (|rplacaSubst,fn| |x| |y| |u|) |u|)) + +;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 + +(DEFUN |buildNewDefinition| (|op| |theSig| |formPredAlist|) + (declare (ignore |op|)) + (PROG (|predl| |newAlist| |outerPred| |theForm| |alist| |theArgl| + |pred| |form| |theAlist| |theNils| |thePred| |def| + |value|) + (RETURN + (SEQ (PROGN + (SPADLET |newAlist| + (PROG (G171247) + (SPADLET G171247 NIL) + (RETURN + (DO ((G171256 |formPredAlist| + (CDR G171256)) + (|item| NIL)) + ((OR (ATOM G171256) + (PROGN + (SETQ |item| (CAR G171256)) + NIL)) + (NREVERSE0 G171247)) + (SEQ (EXIT (SETQ G171247 + (CONS + (PROGN + (SPADLET |form| + (CAR |item|)) + (SPADLET |predl| + (CDR |item|)) + (SPADLET |pred| + (COND + ((NULL |predl|) 'T) + ('T + (|boolBin| + (|simpHasPred| + (|markKillAll| + (MKPF |predl| '|and|))))))) + (CONS |pred| |form|)) + G171247)))))))) + (SPADLET |outerPred| + (|boolBin| + (|simpHasPred| + (MKPF (ASSOCLEFT |newAlist|) '|or|)))) + (SPADLET |theForm| (CDAR |newAlist|)) + (SPADLET |alist| (|moveTruePred2End| |newAlist|)) + (SPADLET |theArgl| (CDR |theForm|)) + (SPADLET |theAlist| + (PROG (G171267) + (SPADLET G171267 NIL) + (RETURN + (DO ((G171273 |alist| (CDR G171273)) + (G171232 NIL)) + ((OR (ATOM G171273) + (PROGN + (SETQ G171232 (CAR G171273)) + NIL) + (PROGN + (PROGN + (SPADLET |pred| (CAR G171232)) + (SPADLET |form| (CDR G171232)) + G171232) + NIL)) + (NREVERSE0 G171267)) + (SEQ (EXIT (SETQ G171267 + (CONS + (CONS |pred| + (CONS (CAR |form|) |theArgl|)) + G171267)))))))) + (SPADLET |theNils| + (PROG (G171284) + (SPADLET G171284 NIL) + (RETURN + (DO ((G171289 |theForm| (CDR G171289)) + (|x| NIL)) + ((OR (ATOM G171289) + (PROGN + (SETQ |x| (CAR G171289)) + NIL)) + (NREVERSE0 G171284)) + (SEQ (EXIT (SETQ G171284 + (CONS NIL G171284)))))))) + (SPADLET |thePred| + (COND + ((|member| |outerPred| '(T 'T)) NIL) + ('T |outerPred|))) + (SPADLET |def| + (CONS 'DEF + (CONS |theForm| + (CONS |theSig| + (CONS |theNils| + (CONS (|ifize| |theAlist|) + NIL)))))) + (SPADLET |value| + (COND + (|thePred| + (CONS 'IF + (CONS |thePred| + (CONS |def| + (CONS '|noBranch| NIL))))) + ('T |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 + +(DEFUN |boolBin| (|x|) + (PROG (|op| |argl| |a| |ISTMP#1| |b| |c|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + 'T)) + (COND + ((AND (MEMQ |op| '(AND OR)) (PAIRP |argl|) + (PROGN + (SPADLET |a| (QCAR |argl|)) + (SPADLET |ISTMP#1| (QCDR |argl|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#1|)) + (SPADLET |c| (QCDR |ISTMP#1|)) + 'T))) + |c|) + (|boolBin| + (CONS |op| + (CONS (|boolBin| + (CONS |op| + (CONS |a| (CONS |b| NIL)))) + |c|)))) + ('T + (PROG (G171339) + (SPADLET G171339 NIL) + (RETURN + (DO ((G171344 |x| (CDR G171344)) (|y| NIL)) + ((OR (ATOM G171344) + (PROGN (SETQ |y| (CAR G171344)) NIL)) + (NREVERSE0 G171339)) + (SEQ (EXIT (SETQ G171339 + (CONS (|boolBin| |y|) + G171339)))))))))) + ('T |x|)))))) + +;ifize [[pred,:value],:r] == +; null r => value +; ['IF, pred, value, ifize r] + +(DEFUN |ifize| (G171361) + (PROG (|pred| |value| |r|) + (RETURN + (PROGN + (SPADLET |pred| (CAAR G171361)) + (SPADLET |value| (CDAR G171361)) + (SPADLET |r| (CDR G171361)) + (COND + ((NULL |r|) |value|) + ('T + (CONS 'IF + (CONS |pred| (CONS |value| (CONS (|ifize| |r|) NIL)))))))))) + +;moveTruePred2End alist == +; truthPair := or/[pair for pair in alist | pair is ["T",:.]] => +; [:DELETE(truthPair, alist), truthPair] +; [:a, [lastPair, lastValue]] := alist +; [:a, ["T", lastValue]] + +(DEFUN |moveTruePred2End| (|alist|) + (PROG (|truthPair| |LETTMP#1| |lastPair| |lastValue| |a|) + (RETURN + (SEQ (COND + ((SPADLET |truthPair| + (PROG (G171384) + (SPADLET G171384 NIL) + (RETURN + (DO ((G171391 NIL G171384) + (G171392 |alist| (CDR G171392)) + (|pair| NIL)) + ((OR G171391 (ATOM G171392) + (PROGN + (SETQ |pair| (CAR G171392)) + NIL)) + G171384) + (SEQ (EXIT (COND + ((AND (PAIRP |pair|) + (EQ (QCAR |pair|) 'T)) + (SETQ G171384 + (OR G171384 |pair|)))))))))) + (APPEND (|delete| |truthPair| |alist|) + (CONS |truthPair| NIL))) + ('T (SPADLET |LETTMP#1| (REVERSE |alist|)) + (SPADLET |lastPair| (CAAR |LETTMP#1|)) + (SPADLET |lastValue| (CADAR |LETTMP#1|)) + (SPADLET |a| (NREVERSE (CDR |LETTMP#1|))) + (APPEND |a| (CONS (CONS 'T (CONS |lastValue| NIL)) NIL)))))))) + +;PE e == +; for x in CAAR e for i in 1.. repeat +; ppf [i, :x] + +(DEFUN PE (|e|) + (SEQ (DO ((G171412 (CAAR |e|) (CDR G171412)) (|x| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G171412) + (PROGN (SETQ |x| (CAR G171412)) NIL)) + NIL) + (SEQ (EXIT (|ppf| (CONS |i| |x|))))))) + +;ppf x == +; _*PRETTYPRINT_* : local := true +; PRINT_-FULL x + +(DEFUN |ppf| (|x|) + (PROG (*PRETTYPRINT*) + (declare (special *prettyprint*)) + (RETURN (PROGN (SPADLET *PRETTYPRINT* 'T) (PRINT-FULL |x|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nruncomp.boot.pamphlet b/src/interp/nruncomp.boot.pamphlet deleted file mode 100644 index b672584..0000000 --- a/src/interp/nruncomp.boot.pamphlet +++ /dev/null @@ -1,770 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp nruncomp.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- 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. - -@ -<<*>>= -<> - ------------------------------NEW buildFunctor CODE----------------------------- -NRTaddDeltaCode() == ---NOTES: This function is called from NRTbuildFunctor to initially --- fill slots in $template. The $template so created is stored in the --- nrlib. On load, makeDomainTemplate is called on this $template to --- create a template which becomes slot 0 of the infovec for the constructor. ---The template has 6 kinds of entries: --- (1) formal arguments and local variables, represented by (QUOTE ) --- this conflicts by (5) but is ok since each is explicitly set by --- instantiator code; --- (2) domains, represented by lazy forms, e.g. (Foo 12 17 6) --- (3) latch slots, represented SPADCALLable forms which goGet an operation --- from a domain then cache the operation in the same slot --- (4) functions, represented by identifiers which are names of functions --- (5) identifiers/strings, parts of signatures (now parts of signatures --- now must all have slot numbers, represented by (QUOTE ) --- (6) constants, like 0 and 1, represented by (CONS .. ) form - kvec := first $catvecList - for i in $NRTbase.. for item in REVERSE $NRTdeltaList - for compItem in REVERSE $NRTdeltaListComp - |null (s:=kvec.i) repeat - $template.i:= deltaTran(item,compItem) - $template.5 := - $NRTaddForm => - $NRTaddForm is ['Tuple,:y] => NREVERSE y - NRTencode($NRTaddForm,$addForm) - nil - -deltaTran(item,compItem) == - item is ['domain,lhs,:.] => NRTencode(lhs,compItem) - --NOTE: all items but signatures are wrapped with domain forms - [op,:modemap] := item - [dcSig,[.,[kind,:.]]] := modemap - [dc,:sig] := dcSig - sig := substitute('$,dc,substitute("$$",'$,sig)) - dcCode := - dc = '$ => - --$NRTaddForm => -5 - 0 - NRTassocIndexAdd dc or keyedSystemError("S2NR0004",[dc]) - formalSig:= SUBLISLIS($FormalMapVariableList,$formalArgList,sig) - kindFlag:= (kind = 'CONST => 'CONST; nil) - newSig := [NRTassocIndex x or x for x in formalSig] - [newSig,dcCode,op,:kindFlag] - ---NRTencodeSig x == [NRTencode y for y in x] - -NRTreplaceAllLocalReferences(form) == - $devaluateList :local := [] - NRTputInLocalReferences form - -NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) == - --converts a domain form to a lazy domain form; everything other than - --the operation name should be assigned a slot - null firstTime and (k:= NRTassocIndex x) => k - VECP x => systemErrorHere '"NRTencode" - PAIRP x => - QCAR x='Record or x is ['Union,['_:,a,b],:.] => - [QCAR x,:[['_:,a,encode(b,c,false)] - for [.,a,b] in QCDR x for [.,=a,c] in CDR compForm]] - constructor? QCAR x or MEMQ(QCAR x,'(Union Mapping)) => - [QCAR x,:[encode(y,z,false) for y in QCDR x for z in CDR compForm]] - ['NRTEVAL,NRTreplaceAllLocalReferences COPY_-TREE lispize compForm] - MEMQ(x,$formalArgList) => - v := $FormalMapVariableList.(POSN1(x,$formalArgList)) - firstTime => ['local,v] - v - x = '$ => x - x = "$$" => x - ['QUOTE,x] - ---------------FUNCTIONS CALLED DURING CAPSULE FUNCTION COMPILATION------------- -listOfBoundVars form == --- Only called from the function genDeltaEntry below - form = '$ => [] - IDENTP form and (u:=get(form,'value,$e)) => - u:=u.expr - MEMQ(KAR u,'(Union Record)) => listOfBoundVars u - [form] - atom form => [] - CAR form = 'QUOTE => [] - EQ(CAR form,":") => listOfBoundVars CADDR form - -- We don't want to pick up the tag, only the domain - "UNION"/[listOfBoundVars x for x in CDR form] - -optDeltaEntry(op,sig,dc,eltOrConst) == - $killOptimizeIfTrue = true => nil - ndc := - dc = '$ => $functorForm - atom dc and (dcval := get(dc,'value,$e)) => dcval.expr - dc ---if (atom dc) and (dcval := get(dc,'value,$e)) --- then ndc := dcval.expr --- else ndc := dc - sig := SUBST(ndc,dc,sig) - not MEMQ(KAR ndc,$optimizableConstructorNames) => nil - dcval := optCallEval ndc - -- MSUBST guarantees to use EQUAL testing - sig := MSUBST(devaluate dcval, ndc, sig) - if rest ndc then - for new in rest devaluate dcval for old in rest ndc repeat - sig := MSUBST(new,old,sig) - -- optCallEval sends (List X) to (LIst (Integer)) etc, - -- so we should make the same transformation - fn := compiledLookup(op,sig,dcval) - if null fn then - -- following code is to handle selectors like first, rest - nsig := [quoteSelector tt for tt in sig] where - quoteSelector(x) == - not(IDENTP x) => x - get(x,'value,$e) => x - x='$ => x - MKQ x - fn := compiledLookup(op,nsig,dcval) - if null fn then return nil - eltOrConst="CONST" => ['XLAM,'ignore,MKQ SPADCALL fn] - GET(compileTimeBindingOf first fn,'SPADreplace) - -genDeltaEntry opMmPair == ---called from compApplyModemap ---$NRTdeltaLength=0.. always equals length of $NRTdeltaList - [.,[odc,:.],.] := opMmPair - --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) - [op,[dc,:sig],[.,cform:=[eltOrConst,.,nsig]]] := opMmPair - if $profileCompiler = true then profileRecord(dc,op,sig) - eltOrConst = 'XLAM => cform - if eltOrConst = 'Subsumed then eltOrConst := 'ELT - if atom dc then - dc = "$" => nsig := sig - if NUMBERP nsig then nsig := substitute('$,dc,substitute("$$","$",sig)) - -- following hack needed to invert Rep to $ substitution --- if odc = 'Rep and cform is [.,.,osig] then sig:=osig - newimp := optDeltaEntry(op,nsig,dc,eltOrConst) => newimp - setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => - ['applyFun,['compiledLookupCheck,MKQ op, - mkList consSig(nsig,dc),consDomainForm(dc,nil)]] - odc := dc - if null atom dc then dc := substitute("$$",'$,dc) - -- sig := substitute('$,dc,sig) - -- cform := substitute('$,dc,cform) - opModemapPair := - [op,[dc,:[genDeltaSig x for x in nsig]],['T,cform]] -- force pred to T - if null NRTassocIndex dc and dc ^= $NRTaddForm and - (MEMBER(dc,$functorLocalParameters) or null atom dc) then - --create "domain" entry to $NRTdeltaList - $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] - saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= compOrCroak(odc,$EmptyMode,$e).expr --- dc - RPLACA(saveNRTdeltaListComp,compEntry) - u := - [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index == - (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 - --n + 1 since $NRTdeltaLength is 1 too large - $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] - $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - 0 - u - -genDeltaSig x == - NRTgetLocalIndex x - -genDeltaSpecialSig x == - x is [":",y,z] => [":",y,genDeltaSig z] - genDeltaSig x - -NRTassocIndexAdd x == - x = $NRTaddForm => 5 - NRTassocIndex x - -NRTassocIndex x == --returns index of "domain" entry x in al - NULL x => x - x = $NRTaddForm => 5 - k := or/[i for i in 1.. for y in $NRTdeltaList - | y.0 = 'domain and y.1 = x and ($found := y)] => - $NRTbase + $NRTdeltaLength - k - nil - -NRTgetLocalIndexClear item == NRTgetLocalIndex1(item,true) - -NRTgetLocalIndex item == NRTgetLocalIndex1(item,false) - -NRTgetLocalIndex1(item,killBindingIfTrue) == - k := NRTassocIndex item => k - item = $NRTaddForm => 5 - item = '$ => 0 - item = '_$_$ => 2 - value:= - MEMQ(item,$formalArgList) => item - nil - atom item and null MEMQ(item,'($ _$_$)) - and null value => --give slots to atoms - $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] - $NRTdeltaListComp:=[item,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - $NRTbase + $NRTdeltaLength - 1 - $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] - saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - saveIndex := $NRTbase + $NRTdeltaLength - $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= compOrCroak(item,$EmptyMode,$e).expr --- item - RPLACA(saveNRTdeltaListComp,compEntry) - saveIndex - -NRTgetAddForm domain == - u := HGET($Slot1DataBase,first domain) => - EQSUBSTLIST(rest domain,$FormalMapVariableList,first u) - systemErrorHere '"NRTgetAddForm" - -NRTassignCapsuleFunctionSlot(op,sig) == ---called from compDefineCapsuleFunction - opSig := [op,sig] - [.,.,implementation] := NRTisExported? opSig or return nil - --if opSig is not exported, it is local and need not be assigned - if $insideCategoryPackageIfTrue then - sig := substitute('$,CADR($functorForm),sig) - sig := [genDeltaSig x for x in sig] - opModemapPair := [op,['_$,:sig],['T,implementation]] - POSN1(opModemapPair,$NRTdeltaList) => nil --already there - $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] - $NRTdeltaListComp := [nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - -NRTisExported? opSig == - or/[u for u in $domainShell.1 | u.0 = opSig] - -consOpSig(op,sig,dc) == - if null atom op then - keyedSystemError("S2GE0016",['"consOpSig",'"bad operator in table"]) - mkList [MKQ op,mkList consSig(sig,dc)] - -consSig(sig,dc) == [consDomainName(sigpart,dc) for sigpart in sig] - -consDomainName(x,dc) == - x = dc => ''$ - x = '$ => ''$ - x = "$$" => ['devaluate,'$] - x is [op,:argl] => - (op = 'Record) or (op = 'Union and argl is [[":",:.],:.]) => - mkList [MKQ op, - :[['LIST,MKQ '_:,MKQ tag,consDomainName(dom,dc)] - for [.,tag,dom] in argl]] - isFunctor op or op = 'Mapping or constructor? op => - -- call to constructor? needed if op was compiled in $bootStrapMode - mkList [MKQ op,:[consDomainName(y,dc) for y in argl]] - substitute('$,"$$",x) - x = [] => x - (y := LASSOC(x,$devaluateList)) => y - k:=NRTassocIndex x => - ['devaluate,['ELT,'$,k]] - get(x,'value,$e) => - isDomainForm(x,$e) => ['devaluate,x] - x - MKQ x - -consDomainForm(x,dc) == - x = '$ => '$ - x is [op,:argl] => - op = ":" and argl is [tag, value] => [op, tag, consDomainForm(value,dc)] - [op,:[consDomainForm(y,dc) for y in argl]] - x = [] => x - (y := LASSOC(x,$devaluateList)) => y - k:=NRTassocIndex x => ['ELT,'$,k] - get(x,'value,$e) or get(x,'mode,$e) => x - MKQ x - -buildFunctor($definition is [name,:args],sig,code,$locals,$e) == ---PARAMETERS --- $definition: constructor form, e.g. (SquareMatrix 10 (RationalNumber)) --- sig: signature of constructor form --- code: result of "doIt", converting body of capsule to CodeDefine forms, e.g. --- (PROGN (LET Rep ...) --- (: (ListOf x y) $) --- (CodeDefine ( )) --- (COND ((HasCategory $ ...) (PROGN ...))) ..) --- $locals: list of variables to go into slot 5, e.g. (R Rep R,1 R,2 R,3 R,4) --- same as $functorLocalParameters --- this list is not augmented by this function --- $e: environment ---GLOBAL VARIABLES REFERENCED: --- $domainShell: passed in from compDefineFunctor1 --- $QuickCode: compilation flag - - if code is ['add,.,newstuff] then code := newstuff - - changeDirectoryInSlot1() --this extends $NRTslot1PredicateList - - --pp '"==================" - --for item in $NRTdeltaList repeat pp item - ---LOCAL BOUND FLUID VARIABLES: - $GENNO: local:= 0 --bound in compDefineFunctor1, then as parameter here ---$frontier: local --index of first local slot=#(cat part of princ view) - $catvecList: local --list of vectors v1..vn for each view - $hasCategoryAlist: local --list of GENSYMs bound to (HasCategory ..) items - $catNames: local --list of names n1..nn for each view - $maximalViews: local --list of maximal categories for domain (???) - $catsig: local --target category (used in ProcessCond) - $SetFunctions: local --copy of p view with preds telling when fnct defined - $MissingFunctionInfo: local --now useless - --vector marking which functions are assigned - $ConstantAssignments: local --code for creation of constants - $epilogue: local := nil --code to set slot 5, things to be done last - $HackSlot4: local --Invention of JHD 13/July/86-set in InvestigateConditions - $extraParms:local --Set in DomainSubstitutionFunction, used in setVector12 - $devaluateList: local --Bound to ((#1 . dv$1)..) where &1 := devaluate #1 later - $devaluateList:= [[arg,:b] for arg in args for b in $ModeVariableList] - $supplementaries: local := nil - --set in InvestigateConditions to represent any additional - --category membership tests that may be needed(see buildFunctor for details) ------------------------- - $maximalViews: local := nil - oldtime:= TEMPUS_-FUGIT() - [$catsig,:argsig]:= sig - catvecListMaker:=REMDUP - [(comp($catsig,$EmptyMode,$e)).expr, - :[compCategories first u for u in CADR $domainShell.4]] - condCats:= InvestigateConditions [$catsig,:rest catvecListMaker] - -- a list, one %for each element of catvecListMaker - -- indicating under what conditions this - -- category should be present. true => always - makeCatvecCode:= first catvecListMaker - emptyVector := VECTOR() ---if $NRTaddForm and null NRTassocIndex $NRTaddForm then --- --create "domain" entry to $NRTdeltaList --- $NRTdeltaList:= --- [['domain,NRTaddInner $NRTaddForm,:$NRTaddForm],:$NRTdeltaList] --- $NRTdeltaLength := $NRTdeltaLength+1 ---NRTgetLocalIndex $NRTaddForm - domainShell := GETREFV (6 + $NRTdeltaLength) - for i in 0..4 repeat domainShell.i := $domainShell.i - --we will clobber elements; copy since $domainShell may be a cached vector - $template := - $NRTvec = true => GETREFV (6 + $NRTdeltaLength) - nil - $catvecList:= [domainShell,:[emptyVector for u in CADR domainShell.4]] - $catNames := ['$] -- for DescendCode -- to be changed below for slot 4 - $maximalViews:= nil - $SetFunctions:= GETREFV SIZE domainShell - $MissingFunctionInfo:= GETREFV SIZE domainShell - $catNames:= ['$,:[GENVAR() for u in rest catvecListMaker]] - domname:='dv_$ - ---> Do this now to create predicate vector; then DescendCode can refer ---> to predicate vector if it can - [$uncondAlist,:$condAlist] := --bound in compDefineFunctor1 - NRTsetVector4Part1($catNames,catvecListMaker,condCats) - [$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] := - makePredicateBitVector [:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList] - - storeOperationCode:= DescendCode(code,true,nil,first $catNames) - outsideFunctionCode:= NRTaddDeltaCode() - storeOperationCode:= NRTputInLocalReferences storeOperationCode - if $NRTvec = true then - NRTdescendCodeTran(storeOperationCode,nil) --side effects storeOperationCode - codePart2:= - $NRTvec = true => - argStuffCode := - [[$setelt,'$,i,v] for i in 6.. for v in $FormalMapVariableList - for arg in rest $definition] - if MEMQ($NRTaddForm,$locals) then - addargname := $FormalMapVariableList.(POSN1($NRTaddForm,$locals)) - argStuffCode := [[$setelt,'$,5,addargname],:argStuffCode] - [['stuffDomainSlots,'$],:argStuffCode, - :predBitVectorCode2,storeOperationCode] - [:outsideFunctionCode,storeOperationCode] - - $CheckVectorList := NRTcheckVector domainShell ---CODE: part 1 - codePart1:= [:devaluateCode,:domainFormCode,createDomainCode, - createViewCode,setVector0Code, slot3Code,:slamCode] where - devaluateCode:= [['LET,b,['devaluate,a]] for [a,:b] in $devaluateList] - domainFormCode := [['LET,a,b] for [a,:b] in NREVERSE $NRTdomainFormList] - --$NRTdomainFormList is unused now - createDomainCode:= - ['LET,domname,['LIST,MKQ CAR $definition,:ASSOCRIGHT $devaluateList]] - createViewCode:= ['LET,'$,['GETREFV, 6+$NRTdeltaLength]] - setVector0Code:=[$setelt,'$,0,'dv_$] - slot3Code := ['QSETREFV,'$,3,['LET,'pv_$,predBitVectorCode1]] - slamCode:= - isCategoryPackageName opOf $definition => nil - [NRTaddToSlam($definition,'$)] - ---CODE: part 3 - $ConstantAssignments := - [NRTputInLocalReferences code for code in $ConstantAssignments] - codePart3:= [:constantCode1, - :constantCode2,:epilogue] where - constantCode1:= - name='Integer => $ConstantAssignments - nil - -- The above line is needed to get the recursion - -- Integer => FontTable => NonNegativeInteger => Integer - -- right. Otherwise NNI has 'unset' for 0 and 1 --- setVector4c:= setVector4part3($catNames,$catvecList) - -- In particular, setVector4part3 and setVector5, - -- which generate calls to local domain-instantiators, - -- must come after operations are set in the vector. - -- The symptoms of getting this wrong are that - -- operations are not set which should be - constantCode2:= --matches previous test on Integer - name='Integer => nil - $ConstantAssignments - epilogue:= $epilogue - ans := - ['PROGN,:optFunctorPROGN [:codePart1,:codePart2,:codePart3], '$] - $getDomainCode:= nil - --if we didn't kill this, DEFINE would insert it in the wrong place - ans:= minimalise ans - SAY ['"time taken in buildFunctor: ",TEMPUS_-FUGIT()-oldtime] - --sayBrightly '"------------------functor code: -------------------" - --pp ans - ans - -NRTcheckVector domainShell == ---RETURNS: an alist (((op,sig),:pred) ...) of missing functions - alist := nil - for i in 6..MAXINDEX domainShell repeat ---Vector elements can be one of --- (a) T -- item was marked --- (b) NIL -- item is a domain; will be filled in by setVector4part3 --- (c) categoryForm-- it was a domain view; now irrelevant --- (d) op-signature-- store missing function info in $CheckVectorList - v:= domainShell.i - v=true => nil --item is marked; ignore - null v => nil --a domain, which setVector4part3 will fill in - atom first v => nil --category form; ignore - atom v => systemErrorHere '"CheckVector" - ASSOC(first v,alist) => nil - alist:= - [[first v,:$SetFunctions.i],:alist] - alist - --- Obsolete once we have moved to JHD's world -NRTvectorCopy(cacheName,domName,deltaLength) == GETREFV (6 + deltaLength) - -mkDomainCatName id == INTERN STRCONC(id,";CAT") - -NRTsetVector4(siglist,formlist,condlist) == - $uncondList: local := nil - $condList: local := nil - $count: local := 0 - for sig in reverse siglist for form in reverse formlist - for cond in reverse condlist repeat - NRTsetVector4a(sig,form,cond) - --NRTsetVector4a(first siglist,first formlist,first condlist) - - $lisplibCategoriesExtended:= [$uncondList,:$condList] - code := ['mapConsDB,MKQ REVERSE REMDUP $uncondList] - if $condList then - localVariable := GENSYM() - code := [['LET,localVariable,code]] - for [pred,list] in $condList repeat - code := - [['COND,[pred,['LET,localVariable, - ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]], - :code] - code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]] - g := GENSYM() - [$setelt,'$,4,['PROG2,['LET,g,code], - ['VECTOR,['catList2catPackageList,g],g]]] - -NRTsetVector4Part1(siglist,formlist,condlist) == - $uncondList: local := nil - $condList: local := nil - $count: local := 0 - for sig in reverse siglist for form in reverse formlist - for cond in reverse condlist repeat - NRTsetVector4a(sig,form,cond) - reducedUncondlist := REMDUP $uncondList - reducedConlist := - [[x,:y] for [x,z] in $condList| y := SETDIFFERENCE(z,reducedUncondlist)] - revCondlist := reverseCondlist reducedConlist - orCondlist := [[x,:MKPF(y,'OR)] for [x,:y] in revCondlist] - [reducedUncondlist,:orCondlist] - --NRTsetVector4a(first siglist,first formlist,first condlist) - -reverseCondlist cl == - alist := nil - for [x,:y] in cl repeat - for z in y repeat - u := ASSOC(z,alist) - null u => alist := [[z,x],:alist] - MEMBER(x,CDR u) => nil - RPLACD(u,[x,:CDR u]) - alist - -NRTsetVector4Part2(uncondList,condList) == - $lisplibCategoriesExtended:= [uncondList,:condList] - code := ['mapConsDB,MKQ REVERSE REMDUP uncondList] - if condList then - localVariable := GENSYM() - code := [['LET,localVariable,code]] - for [pred,list] in condList repeat - code := - [['COND,[predicateBitRef SUBLIS($pairlis,pred),['LET,localVariable, - ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]], - :code] - code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]] - g := GENSYM() - [$setelt,'$,4,['PROG2,['LET,g,code], - ['VECTOR,['catList2catPackageList,g],g]]] - -mergeAppend(l1,l2) == - ATOM l1 => l2 - member(QCAR l1,l2) => mergeAppend(QCDR l1, l2) - CONS(QCAR l1, mergeAppend(QCDR l1, l2)) - ---genLoadTimeValue u == --- name := --- INTERN STRCONC(PNAME first $definition,'";",STRINGIZE($count:=$count+1)) --- $NRTloadTimeAlist := [[name,:['addConsDB,MKQ u]],:$NRTloadTimeAlist] --- --see compDefineFunctor1 --- name - -catList2catPackageList u == ---converts ((Set) (Module R) ...) to ((Set& $) (Module& $ R)...) - [fn x for x in u] where - fn [op,:argl] == - newOp := INTERN(STRCONC(PNAME op,"&")) - addConsDB [newOp,"$",:argl] - -NRTsetVector4a(sig,form,cond) == - sig = '$ => - domainList := - [optimize COPY KAR comp(d,$EmptyMode,$e) or d for d in $domainShell.4.0] - $uncondList := APPEND(domainList,$uncondList) - if isCategoryForm(form,$e) then $uncondList := [form,:$uncondList] - $uncondList - evalform := eval mkEvalableCategoryForm form - cond = true => $uncondList := [form,:APPEND(evalform.4.0,$uncondList)] - $condList := [[cond,[form,:evalform.4.0]],:$condList] - -NRTmakeSlot1 domainShell == - opDirectName := INTERN STRCONC(PNAME first $definition,'";opDirect") - fun := - $NRTmakeCompactDirect => '(function lookupInCompactTable) - '(function lookupInTable) - [($QuickCode=>'QSETREFV;'SETELT), '$,1, ['LIST,fun,'$,opDirectName]] - -NRTmakeSlot1Info() == --- 4 cases: --- a:T == b add c --- slot1 directory has #s for entries defined in c --- a:T == b --- slot1 has all slot #s = NIL (see compFunctorBody) --- a == b add c --- not allowed (line 7 of getTargetFromRhs) --- a == b --- $NRTderivedTargetIfTrue = true; set directory to NIL - pairlis := - $insideCategoryPackageIfTrue = true => - [:argl,dollarName] := rest $form - [[dollarName,:'_$],:mkSlot1sublis argl] - mkSlot1sublis rest $form - $lisplibOpAlist := transformOperationAlist SUBLIS(pairlis,$domainShell.1) - opList := - $NRTderivedTargetIfTrue => 'derived - $insideCategoryPackageIfTrue = true => slot1Filter $lisplibOpAlist - $lisplibOpAlist - addList := SUBLIS(pairlis,$NRTaddForm) - [first $form,[addList,:opList]] - -mkSlot1sublis argl == - [[a,:b] for a in argl for b in $FormalMapVariableList] - -slot1Filter opList == ---include only those ops which are defined within the capsule - [u for x in opList | u := fn x] where - fn [op,:l] == - u := [entry for entry in l | INTEGERP CADR entry] => [op,:u] - nil - -NRToptimizeHas u == ---u is a list ((pred cond)...) -- see optFunctorBody ---produces an alist: (((HasCategory a b) . GENSYM)...) - u is [a,:b] => - a='HasCategory => LASSOC(u,$hasCategoryAlist) or - $hasCategoryAlist := [[u,:(y:=GENSYM())],:$hasCategoryAlist] - y - a='has => NRToptimizeHas ['HasCategory,first b,MKQ first rest b] - a = 'QUOTE => u - [NRToptimizeHas a,:NRToptimizeHas b] - u - -NRTaddToSlam([name,:argnames],shell) == - $mutableDomain => return nil - null argnames => addToConstructorCache(name,nil,shell) - args:= ['LIST,:ASSOCRIGHT $devaluateList] - addToConstructorCache(name,args,shell) - -changeDirectoryInSlot1() == --called by NRTbuildFunctor - --3 cases: - -- if called inside NRTbuildFunctor, $NRTdeltaLength gives different locs - -- otherwise called from compFunctorBody (all lookups are forwarded): - -- $NRTdeltaList = nil ===> all slot numbers become nil - $lisplibOperationAlist := [sigloc entry for entry in $domainShell.1] where - sigloc [opsig,pred,fnsel] == - if pred ^= 'T then - pred := simpBool pred - $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) - fnsel is [op,a,:.] and (op = 'ELT or op = 'CONST) => - if $insideCategoryPackageIfTrue then - opsig := substitute('$,CADR($functorForm),opsig) - [opsig,pred,[op,a,vectorLocation(first opsig,CADR opsig)]] - [opsig,pred,fnsel] - sortedOplist := listSort(function GLESSEQP, - COPY_-LIST $lisplibOperationAlist,function CADR) - $lastPred :local := nil - $newEnv :local := $e - $domainShell.1 := [fn entry for entry in sortedOplist] where - fn [[op,sig],pred,fnsel] == - if $lastPred ^= pred then - $newEnv := deepChaseInferences(pred,$e) - $lastPred := pred - newfnsel := - fnsel is ['Subsumed,op1,sig1] => - ['Subsumed,op1,genSlotSig(sig1,'T,$newEnv)] - fnsel - [[op, genSlotSig(sig,pred,$newEnv)] ,pred,newfnsel] - -genSlotSig(sig,pred,$e) == - [genDeltaSig t for t in sig] - -deepChaseInferences(pred,$e) == - pred is ['AND,:preds] or pred is ['and,:preds] => - for p in preds repeat $e := deepChaseInferences(p,$e) - $e - pred is ['OR,pred1,:.] or pred is ['or,pred1,:.] => - deepChaseInferences(pred1,$e) - pred is 'T or pred is ['NOT,:.] or pred is ['not,:.] => $e - chaseInferences(pred,$e) - -vectorLocation(op,sig) == - u := or/[i for i in 1.. for u in $NRTdeltaList - | u is [=op,[='$,: xsig],:.] and sig=NRTsubstDelta(xsig) ] - u => $NRTdeltaLength - u + 6 - nil -- this signals that calls should be forwarded - -NRTsubstDelta(initSig) == - sig := [replaceSlotTypes s for s in initSig] where - replaceSlotTypes(t) == - atom t => - not INTEGERP t => t - t = 0 => '$ - t = 2 => '_$_$ - t = 5 => $NRTaddForm - u:= $NRTdeltaList.($NRTdeltaLength+5-t) - CAR u = 'domain => CADR u - error "bad $NRTdeltaList entry" - MEMQ(CAR t,'(Mapping Union Record _:)) => - [CAR t,:[replaceSlotTypes(x) for x in rest t]] - t ------------------------------SLOT1 DATABASE------------------------------------ - -updateSlot1DataBase [name,info] == HPUT($Slot1DataBase,name,info) - -NRTputInLocalReferences bod == - $elt: local := ($QuickCode => 'QREFELT; 'ELT) - NRTputInHead bod - -NRTputInHead bod == - atom bod => bod --- LASSOC(bod,$devaluateList) => nil --- k:= NRTassocIndex bod => [$elt,'_$,k] --- systemError '"unexpected position of domain reference" --- bod ---bod is ['LET,var,val,:extra] and IDENTP var => --- NRTputInTail extra --- k:= NRTassocIndex var => RPLAC(CADDR bod,[$elt,'$,k]) --- NRTputInHead val --- bod - bod is ['SPADCALL,:args,fn] => - NRTputInTail rest bod --NOTE: args = COPY of rest bod - -- The following test allows function-returning expressions - fn is [elt,dom,ind] and not (dom='$) and MEMQ(elt,'(ELT QREFELT CONST)) => - k:= NRTassocIndex dom => RPLACA(LASTNODE bod,[$elt,'_$,k]) --- sayBrightlyNT '"unexpected SPADCALL:" --- pp fn --- nil --- keyedSystemError("S2GE0016",['"NRTputInHead", --- '"unexpected SPADCALL form"]) - nil - NRTputInHead fn - bod - bod is ["COND",:clauses] => - for cc in clauses repeat NRTputInTail cc - bod - bod is ["QUOTE",:.] => bod - bod is ["CLOSEDFN",:.] => bod - bod is ["SPADCONST",dom,ind] => - RPLACA(bod,$elt) - dom = '_$ => nil - k:= NRTassocIndex dom => - RPLACA(LASTNODE bod,[$elt,'_$,k]) - bod - keyedSystemError("S2GE0016",['"NRTputInHead", - '"unexpected SPADCONST form"]) - NRTputInHead first bod - NRTputInTail rest bod - bod - -NRTputInTail x == - for y in tails x repeat - atom (u := first y) => - EQ(u,'$) or LASSOC(u,$devaluateList) => nil - k:= NRTassocIndex u => - atom u => RPLACA(y,[$elt,'_$,k]) - -- u atomic means that the slot will always contain a vector - RPLACA(y,['SPADCHECKELT,'_$,k]) - --this reference must check that slot is a vector - nil - NRTputInHead u - x - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/nruncomp.lisp.pamphlet b/src/interp/nruncomp.lisp.pamphlet new file mode 100644 index 0000000..0fa470e --- /dev/null +++ b/src/interp/nruncomp.lisp.pamphlet @@ -0,0 +1,2869 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nruncomp.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= +(IN-PACKAGE "BOOT" ) + +;-----------------------------NEW buildFunctor CODE----------------------------- +;NRTaddDeltaCode() == +;--NOTES: This function is called from NRTbuildFunctor to initially +;-- fill slots in $template. The $template so created is stored in the +;-- nrlib. On load, makeDomainTemplate is called on this $template to +;-- create a template which becomes slot 0 of the infovec for the constructor. +;--The template has 6 kinds of entries: +;-- (1) formal arguments and local variables, represented by (QUOTE ) +;-- this conflicts by (5) but is ok since each is explicitly set by +;-- instantiator code; +;-- (2) domains, represented by lazy forms, e.g. (Foo 12 17 6) +;-- (3) latch slots, represented SPADCALLable forms which goGet an operation +;-- from a domain then cache the operation in the same slot +;-- (4) functions, represented by identifiers which are names of functions +;-- (5) identifiers/strings, parts of signatures (now parts of signatures +;-- now must all have slot numbers, represented by (QUOTE ) +;-- (6) constants, like 0 and 1, represented by (CONS .. ) form +; kvec := first $catvecList +; for i in $NRTbase.. for item in REVERSE $NRTdeltaList +; for compItem in REVERSE $NRTdeltaListComp +; |null (s:=kvec.i) repeat +; $template.i:= deltaTran(item,compItem) +; $template.5 := +; $NRTaddForm => +; $NRTaddForm is ['Tuple,:y] => NREVERSE y +; NRTencode($NRTaddForm,$addForm) +; nil + +(DEFUN |NRTaddDeltaCode| () + (PROG (|kvec| |s| |y|) + (declare (special |$addForm| |$NRTaddForm| |$template| |$NRTdeltaListComp| + |$NRTdeltaList| |$NRTbase| |$catvecList|)) + (RETURN + (SEQ (PROGN + (SPADLET |kvec| (CAR |$catvecList|)) + (DO ((|i| |$NRTbase| (+ |i| 1)) + (G166066 (REVERSE |$NRTdeltaList|) (CDR G166066)) + (|item| NIL) + (G166067 (REVERSE |$NRTdeltaListComp|) + (CDR G166067)) + (|compItem| NIL)) + ((OR (ATOM G166066) + (PROGN (SETQ |item| (CAR G166066)) NIL) + (ATOM G166067) + (PROGN (SETQ |compItem| (CAR G166067)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (SPADLET |s| (ELT |kvec| |i|))) + (SETELT |$template| |i| + (|deltaTran| |item| |compItem|))))))) + (SETELT |$template| 5 + (COND + (|$NRTaddForm| + (COND + ((AND (PAIRP |$NRTaddForm|) + (EQ (QCAR |$NRTaddForm|) '|Tuple|) + (PROGN + (SPADLET |y| (QCDR |$NRTaddForm|)) + 'T)) + (NREVERSE |y|)) + ('T + (|NRTencode| |$NRTaddForm| |$addForm|)))) + ('T NIL)))))))) + +;deltaTran(item,compItem) == +; item is ['domain,lhs,:.] => NRTencode(lhs,compItem) +; --NOTE: all items but signatures are wrapped with domain forms +; [op,:modemap] := item +; [dcSig,[.,[kind,:.]]] := modemap +; [dc,:sig] := dcSig +; sig := substitute('$,dc,substitute("$$",'$,sig)) +; dcCode := +; dc = '$ => +; --$NRTaddForm => -5 +; 0 +; NRTassocIndexAdd dc or keyedSystemError("S2NR0004",[dc]) +; formalSig:= SUBLISLIS($FormalMapVariableList,$formalArgList,sig) +; kindFlag:= (kind = 'CONST => 'CONST; nil) +; newSig := [NRTassocIndex x or x for x in formalSig] +; [newSig,dcCode,op,:kindFlag] + +(DEFUN |deltaTran| (|item| |compItem|) + (PROG (|ISTMP#1| |lhs| |op| |modemap| |dcSig| |kind| |dc| |sig| + |dcCode| |formalSig| |kindFlag| |newSig|) + (declare (special |$formalArgList| |$FormalMapVariableList|)) + (RETURN + (SEQ (COND + ((AND (PAIRP |item|) (EQ (QCAR |item|) '|domain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |lhs| (QCAR |ISTMP#1|)) 'T)))) + (|NRTencode| |lhs| |compItem|)) + ('T (SPADLET |op| (CAR |item|)) + (SPADLET |modemap| (CDR |item|)) + (SPADLET |dcSig| (CAR |modemap|)) + (SPADLET |kind| (CAR (CADADR |modemap|))) + (SPADLET |dc| (CAR |dcSig|)) + (SPADLET |sig| (CDR |dcSig|)) + (SPADLET |sig| (MSUBST '$ |dc| (MSUBST '$$ '$ |sig|))) + (SPADLET |dcCode| + (COND + ((BOOT-EQUAL |dc| '$) 0) + ('T + (OR (|NRTassocIndexAdd| |dc|) + (|keyedSystemError| 'S2NR0004 + (CONS |dc| NIL)))))) + (SPADLET |formalSig| + (SUBLISLIS |$FormalMapVariableList| + |$formalArgList| |sig|)) + (SPADLET |kindFlag| + (COND + ((BOOT-EQUAL |kind| 'CONST) 'CONST) + ('T NIL))) + (SPADLET |newSig| + (PROG (G166102) + (SPADLET G166102 NIL) + (RETURN + (DO ((G166107 |formalSig| (CDR G166107)) + (|x| NIL)) + ((OR (ATOM G166107) + (PROGN + (SETQ |x| (CAR G166107)) + NIL)) + (NREVERSE0 G166102)) + (SEQ (EXIT (SETQ G166102 + (CONS + (OR (|NRTassocIndex| |x|) + |x|) + G166102)))))))) + (CONS |newSig| (CONS |dcCode| (CONS |op| |kindFlag|))))))))) + +;--NRTencodeSig x == [NRTencode y for y in x] +;NRTreplaceAllLocalReferences(form) == +; $devaluateList :local := [] +; NRTputInLocalReferences form + +(DEFUN |NRTreplaceAllLocalReferences| (|form|) + (PROG (|$devaluateList|) + (DECLARE (SPECIAL |$devaluateList|)) + (RETURN + (PROGN + (SPADLET |$devaluateList| NIL) + (|NRTputInLocalReferences| |form|))))) + +;NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) == +; --converts a domain form to a lazy domain form; everything other than +; --the operation name should be assigned a slot +; null firstTime and (k:= NRTassocIndex x) => k +; VECP x => systemErrorHere '"NRTencode" +; PAIRP x => +; QCAR x='Record or x is ['Union,['_:,a,b],:.] => +; [QCAR x,:[['_:,a,encode(b,c,false)] +; for [.,a,b] in QCDR x for [.,=a,c] in CDR compForm]] +; constructor? QCAR x or MEMQ(QCAR x,'(Union Mapping)) => +; [QCAR x,:[encode(y,z,false) for y in QCDR x for z in CDR compForm]] +; ['NRTEVAL,NRTreplaceAllLocalReferences COPY_-TREE lispize compForm] +; MEMQ(x,$formalArgList) => +; v := $FormalMapVariableList.(POSN1(x,$formalArgList)) +; firstTime => ['local,v] +; v +; x = '$ => x +; x = "$$" => x +; ['QUOTE,x] + +(DEFUN |NRTencode,encode| (|x| |compForm| |firstTime|) + (PROG (|k| |ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| |a| |b| |c| |v|) + (declare (special |$formalArgList| |$FormalMapVariableList|)) + (RETURN + (SEQ (IF (AND (NULL |firstTime|) + (SPADLET |k| (|NRTassocIndex| |x|))) + (EXIT |k|)) + (IF (VECP |x|) + (EXIT (|systemErrorHere| (MAKESTRING "NRTencode")))) + (IF (PAIRP |x|) + (EXIT (SEQ (IF (OR (BOOT-EQUAL (QCAR |x|) '|Record|) + (AND (PAIRP |x|) + (EQ (QCAR |x|) '|Union|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|:|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND + (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) + NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#4|)) + 'T))))))))))) + (EXIT (CONS (QCAR |x|) + (PROG (G166191) + (SPADLET G166191 NIL) + (RETURN + (DO + ((G166199 (QCDR |x|) + (CDR G166199)) + (G166173 NIL) + (G166200 (CDR |compForm|) + (CDR G166200)) + (G166177 NIL)) + ((OR (ATOM G166199) + (PROGN + (SETQ G166173 + (CAR G166199)) + NIL) + (PROGN + (PROGN + (SPADLET |a| + (CADR G166173)) + (SPADLET |b| + (CADDR G166173)) + G166173) + NIL) + (ATOM G166200) + (PROGN + (SETQ G166177 + (CAR G166200)) + NIL) + (PROGN + (PROGN + (COND + ((EQUAL |a| + (CADR G166177)) + |a|)) + (SPADLET |c| + (CADDR G166177)) + G166177) + NIL)) + (NREVERSE0 G166191)) + (SEQ + (EXIT + (SETQ G166191 + (CONS + (CONS '|:| + (CONS |a| + (CONS + (|NRTencode,encode| + |b| |c| NIL) + NIL))) + G166191)))))))))) + (IF (OR (|constructor?| (QCAR |x|)) + (MEMQ (QCAR |x|) + '(|Union| |Mapping|))) + (EXIT (CONS (QCAR |x|) + (PROG (G166216) + (SPADLET G166216 NIL) + (RETURN + (DO + ((G166222 (QCDR |x|) + (CDR G166222)) + (|y| NIL) + (G166223 (CDR |compForm|) + (CDR G166223)) + (|z| NIL)) + ((OR (ATOM G166222) + (PROGN + (SETQ |y| + (CAR G166222)) + NIL) + (ATOM G166223) + (PROGN + (SETQ |z| + (CAR G166223)) + NIL)) + (NREVERSE0 G166216)) + (SEQ + (EXIT + (SETQ G166216 + (CONS + (|NRTencode,encode| |y| + |z| NIL) + G166216)))))))))) + (EXIT (CONS 'NRTEVAL + (CONS + (|NRTreplaceAllLocalReferences| + (COPY-TREE + (|lispize| |compForm|))) + NIL)))))) + (IF (MEMQ |x| |$formalArgList|) + (EXIT (SEQ (SPADLET |v| + (ELT |$FormalMapVariableList| + (POSN1 |x| |$formalArgList|))) + (IF |firstTime| + (EXIT (CONS '|local| (CONS |v| NIL)))) + (EXIT |v|)))) + (IF (BOOT-EQUAL |x| '$) (EXIT |x|)) + (IF (BOOT-EQUAL |x| '$$) (EXIT |x|)) + (EXIT (CONS 'QUOTE (CONS |x| NIL))))))) + + +(DEFUN |NRTencode| (|x| |y|) (|NRTencode,encode| |x| |y| 'T)) + +;--------------FUNCTIONS CALLED DURING CAPSULE FUNCTION COMPILATION------------- +;listOfBoundVars form == +;-- Only called from the function genDeltaEntry below +; form = '$ => [] +; IDENTP form and (u:=get(form,'value,$e)) => +; u:=u.expr +; MEMQ(KAR u,'(Union Record)) => listOfBoundVars u +; [form] +; atom form => [] +; CAR form = 'QUOTE => [] +; EQ(CAR form,":") => listOfBoundVars CADDR form +; -- We don't want to pick up the tag, only the domain +; "UNION"/[listOfBoundVars x for x in CDR form] + +(DEFUN |listOfBoundVars| (|form|) + (PROG (|u|) + (declare (special |$e|)) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |form| '$) NIL) + ((AND (IDENTP |form|) + (SPADLET |u| (|get| |form| '|value| |$e|))) + (SPADLET |u| (CAR |u|)) + (COND + ((MEMQ (KAR |u|) '(|Union| |Record|)) + (|listOfBoundVars| |u|)) + ('T (CONS |form| NIL)))) + ((ATOM |form|) NIL) + ((BOOT-EQUAL (CAR |form|) 'QUOTE) NIL) + ((EQ (CAR |form|) '|:|) + (|listOfBoundVars| (CADDR |form|))) + ('T + (PROG (G166254) + (SPADLET G166254 NIL) + (RETURN + (DO ((G166259 (CDR |form|) (CDR G166259)) + (|x| NIL)) + ((OR (ATOM G166259) + (PROGN (SETQ |x| (CAR G166259)) NIL)) + G166254) + (SEQ (EXIT (SETQ G166254 + (|union| G166254 + (|listOfBoundVars| |x|)))))))))))))) + +;optDeltaEntry(op,sig,dc,eltOrConst) == +; $killOptimizeIfTrue = true => nil +; ndc := +; dc = '$ => $functorForm +; atom dc and (dcval := get(dc,'value,$e)) => dcval.expr +; dc +;--if (atom dc) and (dcval := get(dc,'value,$e)) +;-- then ndc := dcval.expr +;-- else ndc := dc +; sig := SUBST(ndc,dc,sig) +; not MEMQ(KAR ndc,$optimizableConstructorNames) => nil +; dcval := optCallEval ndc +; -- MSUBST guarantees to use EQUAL testing +; sig := MSUBST(devaluate dcval, ndc, sig) +; if rest ndc then +; for new in rest devaluate dcval for old in rest ndc repeat +; sig := MSUBST(new,old,sig) +; -- optCallEval sends (List X) to (LIst (Integer)) etc, +; -- so we should make the same transformation +; fn := compiledLookup(op,sig,dcval) +; if null fn then +; -- following code is to handle selectors like first, rest +; nsig := [quoteSelector tt for tt in sig] where +; quoteSelector(x) == +; not(IDENTP x) => x +; get(x,'value,$e) => x +; x='$ => x +; MKQ x +; fn := compiledLookup(op,nsig,dcval) +; if null fn then return nil +; eltOrConst="CONST" => ['XLAM,'ignore,MKQ SPADCALL fn] +; GET(compileTimeBindingOf first fn,'SPADreplace) + +(DEFUN |optDeltaEntry,quoteSelector| (|x|) + (declare (special |$e|)) + (SEQ (IF (NULL (IDENTP |x|)) (EXIT |x|)) + (IF (|get| |x| '|value| |$e|) (EXIT |x|)) + (IF (BOOT-EQUAL |x| '$) (EXIT |x|)) (EXIT (MKQ |x|)))) + +(DEFUN |optDeltaEntry| (|op| |sig| |dc| |eltOrConst|) + (PROG (|ndc| |dcval| |nsig| |fn|) + (declare (special |$optimizableConstructorNames| |$e| |$functorForm| + |$killOptimizeIfTrue|)) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |$killOptimizeIfTrue| 'T) NIL) + ('T + (SPADLET |ndc| + (COND + ((BOOT-EQUAL |dc| '$) |$functorForm|) + ((AND (ATOM |dc|) + (SPADLET |dcval| + (|get| |dc| '|value| |$e|))) + (CAR |dcval|)) + ('T |dc|))) + (SPADLET |sig| (MSUBST |ndc| |dc| |sig|)) + (COND + ((NULL (MEMQ (KAR |ndc|) + |$optimizableConstructorNames|)) + NIL) + ('T (SPADLET |dcval| (|optCallEval| |ndc|)) + (SPADLET |sig| + (MSUBST (|devaluate| |dcval|) |ndc| |sig|)) + (COND + ((CDR |ndc|) + (DO ((G166283 (CDR (|devaluate| |dcval|)) + (CDR G166283)) + (|new| NIL) + (G166284 (CDR |ndc|) (CDR G166284)) + (|old| NIL)) + ((OR (ATOM G166283) + (PROGN (SETQ |new| (CAR G166283)) NIL) + (ATOM G166284) + (PROGN (SETQ |old| (CAR G166284)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |sig| + (MSUBST |new| |old| |sig|))))))) + (SPADLET |fn| (|compiledLookup| |op| |sig| |dcval|)) + (COND + ((NULL |fn|) + (SPADLET |nsig| + (PROG (G166297) + (SPADLET G166297 NIL) + (RETURN + (DO ((G166302 |sig| (CDR G166302)) + (|tt| NIL)) + ((OR (ATOM G166302) + (PROGN + (SETQ |tt| (CAR G166302)) + NIL)) + (NREVERSE0 G166297)) + (SEQ + (EXIT + (SETQ G166297 + (CONS + (|optDeltaEntry,quoteSelector| + |tt|) + G166297)))))))) + (SPADLET |fn| + (|compiledLookup| |op| |nsig| |dcval|)) + (COND ((NULL |fn|) (RETURN NIL)) ('T NIL)))) + (COND + ((BOOT-EQUAL |eltOrConst| 'CONST) + (CONS 'XLAM + (CONS '|ignore| + (CONS (MKQ (SPADCALL |fn|)) NIL)))) + ('T + (GETL (|compileTimeBindingOf| (CAR |fn|)) + '|SPADreplace|))))))))))) + +;genDeltaEntry opMmPair == +;--called from compApplyModemap +;--$NRTdeltaLength=0.. always equals length of $NRTdeltaList +; [.,[odc,:.],.] := opMmPair +; --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) +; [op,[dc,:sig],[.,cform:=[eltOrConst,.,nsig]]] := opMmPair +; if $profileCompiler = true then profileRecord(dc,op,sig) +; eltOrConst = 'XLAM => cform +; if eltOrConst = 'Subsumed then eltOrConst := 'ELT +; if atom dc then +; dc = "$" => nsig := sig +; if NUMBERP nsig then nsig := substitute('$,dc,substitute("$$","$",sig)) +; -- following hack needed to invert Rep to $ substitution +;-- if odc = 'Rep and cform is [.,.,osig] then sig:=osig +; newimp := optDeltaEntry(op,nsig,dc,eltOrConst) => newimp +; setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => +; ['applyFun,['compiledLookupCheck,MKQ op, +; mkList consSig(nsig,dc),consDomainForm(dc,nil)]] +; odc := dc +; if null atom dc then dc := substitute("$$",'$,dc) +; -- sig := substitute('$,dc,sig) +; -- cform := substitute('$,dc,cform) +; opModemapPair := +; [op,[dc,:[genDeltaSig x for x in nsig]],['T,cform]] -- force pred to T +; if null NRTassocIndex dc and dc ^= $NRTaddForm and +; (MEMBER(dc,$functorLocalParameters) or null atom dc) then +; --create "domain" entry to $NRTdeltaList +; $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] +; saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] +; $NRTdeltaLength := $NRTdeltaLength+1 +; compEntry:= compOrCroak(odc,$EmptyMode,$e).expr +;-- dc +; RPLACA(saveNRTdeltaListComp,compEntry) +; u := +; [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index == +; (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 +; --n + 1 since $NRTdeltaLength is 1 too large +; $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] +; $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] +; $NRTdeltaLength := $NRTdeltaLength+1 +; 0 +; u + +(DEFUN |genDeltaEntry| (|opMmPair|) + (PROG (|op| |sig| |cform| |eltOrConst| |nsig| |newimp| |odc| |dc| + |opModemapPair| |saveNRTdeltaListComp| |compEntry| |n| |u|) + (declare (special |$NRTdeltaLength| |$NRTdeltaListComp| |$NRTdeltaList| + |$NRTbase| |$e| |$EmptyMode| |$functorLocalParameters| + |$NRTaddForm| |$profileCompiler|)) + (RETURN + (SEQ (PROGN + (SPADLET |odc| (CAADR |opMmPair|)) + (SPADLET |op| (CAR |opMmPair|)) + (SPADLET |dc| (CAADR |opMmPair|)) + (SPADLET |sig| (CDADR |opMmPair|)) + (SPADLET |cform| (CAR (CDADDR |opMmPair|))) + (SPADLET |eltOrConst| (CAAR (CDADDR |opMmPair|))) + (SPADLET |nsig| (CADDAR (CDADDR |opMmPair|))) + (COND + ((BOOT-EQUAL |$profileCompiler| 'T) + (|profileRecord| |dc| |op| |sig|))) + (COND + ((BOOT-EQUAL |eltOrConst| 'XLAM) |cform|) + ('T + (COND + ((BOOT-EQUAL |eltOrConst| '|Subsumed|) + (SPADLET |eltOrConst| 'ELT))) + (COND + ((ATOM |dc|) + (COND + ((BOOT-EQUAL |dc| '$) (SPADLET |nsig| |sig|)) + ((NUMBERP |nsig|) + (SPADLET |nsig| + (MSUBST '$ |dc| (MSUBST '$$ '$ |sig|)))) + ('T NIL)))) + (COND + ((SPADLET |newimp| + (|optDeltaEntry| |op| |nsig| |dc| + |eltOrConst|)) + |newimp|) + ((NEQUAL (SETDIFFERENCE (|listOfBoundVars| |dc|) + |$functorLocalParameters|) + NIL) + (CONS '|applyFun| + (CONS (CONS '|compiledLookupCheck| + (CONS (MKQ |op|) + (CONS + (|mkList| + (|consSig| |nsig| |dc|)) + (CONS + (|consDomainForm| |dc| NIL) + NIL)))) + NIL))) + ('T (SPADLET |odc| |dc|) + (COND + ((NULL (ATOM |dc|)) + (SPADLET |dc| (MSUBST '$$ '$ |dc|)))) + (SPADLET |opModemapPair| + (CONS |op| + (CONS (CONS |dc| + (PROG (G166339) + (SPADLET G166339 NIL) + (RETURN + (DO + ((G166344 |nsig| + (CDR G166344)) + (|x| NIL)) + ((OR (ATOM G166344) + (PROGN + (SETQ |x| + (CAR G166344)) + NIL)) + (NREVERSE0 G166339)) + (SEQ + (EXIT + (SETQ G166339 + (CONS + (|genDeltaSig| |x|) + G166339)))))))) + (CONS + (CONS 'T (CONS |cform| NIL)) + NIL)))) + (COND + ((AND (NULL (|NRTassocIndex| |dc|)) + (NEQUAL |dc| |$NRTaddForm|) + (OR (|member| |dc| |$functorLocalParameters|) + (NULL (ATOM |dc|)))) + (SPADLET |$NRTdeltaList| + (CONS (CONS '|domain| + (CONS (|NRTaddInner| |dc|) |dc|)) + |$NRTdeltaList|)) + (SPADLET |saveNRTdeltaListComp| + (SPADLET |$NRTdeltaListComp| + (CONS NIL |$NRTdeltaListComp|))) + (SPADLET |$NRTdeltaLength| + (PLUS |$NRTdeltaLength| 1)) + (SPADLET |compEntry| + (CAR (|compOrCroak| |odc| |$EmptyMode| + |$e|))) + (RPLACA |saveNRTdeltaListComp| |compEntry|))) + (SPADLET |u| + (CONS |eltOrConst| + (CONS '$ + (CONS + (SPADDIFFERENCE + (PLUS |$NRTbase| + |$NRTdeltaLength|) + (COND + ((SPADLET |n| + (POSN1 |opModemapPair| + |$NRTdeltaList|)) + (PLUS |n| 1)) + ('T + (SPADLET |$NRTdeltaList| + (CONS |opModemapPair| + |$NRTdeltaList|)) + (SPADLET + |$NRTdeltaListComp| + (CONS NIL + |$NRTdeltaListComp|)) + (SPADLET |$NRTdeltaLength| + (PLUS |$NRTdeltaLength| + 1)) + 0))) + NIL)))) + |u|))))))))) + +;genDeltaSig x == +; NRTgetLocalIndex x + +(DEFUN |genDeltaSig| (|x|) (|NRTgetLocalIndex| |x|)) + +;genDeltaSpecialSig x == +; x is [":",y,z] => [":",y,genDeltaSig z] +; genDeltaSig x + +(DEFUN |genDeltaSpecialSig| (|x|) + (PROG (|ISTMP#1| |y| |ISTMP#2| |z|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |z| (QCAR |ISTMP#2|)) 'T)))))) + (CONS '|:| (CONS |y| (CONS (|genDeltaSig| |z|) NIL)))) + ('T (|genDeltaSig| |x|)))))) + +;NRTassocIndexAdd x == +; x = $NRTaddForm => 5 +; NRTassocIndex x + +(DEFUN |NRTassocIndexAdd| (|x|) + (declare (special |$NRTaddForm|)) + (COND ((BOOT-EQUAL |x| |$NRTaddForm|) 5) ('T (|NRTassocIndex| |x|)))) + +;NRTassocIndex x == --returns index of "domain" entry x in al +; NULL x => x +; x = $NRTaddForm => 5 +; k := or/[i for i in 1.. for y in $NRTdeltaList +; | y.0 = 'domain and y.1 = x and ($found := y)] => +; $NRTbase + $NRTdeltaLength - k +; nil + +(DEFUN |NRTassocIndex| (|x|) + (PROG (|k|) + (declare (special |$NRTdeltaLength| |$NRTbase| |$found| |$NRTdeltaList| + |$NRTaddForm|)) + (RETURN + (SEQ (COND + ((NULL |x|) |x|) + ((BOOT-EQUAL |x| |$NRTaddForm|) 5) + ((SPADLET |k| + (PROG (G166410) + (SPADLET G166410 NIL) + (RETURN + (DO ((G166418 NIL G166410) + (|i| 1 (QSADD1 |i|)) + (G166419 |$NRTdeltaList| + (CDR G166419)) + (|y| NIL)) + ((OR G166418 (ATOM G166419) + (PROGN + (SETQ |y| (CAR G166419)) + NIL)) + G166410) + (SEQ (EXIT (COND + ((AND + (BOOT-EQUAL (ELT |y| 0) + '|domain|) + (BOOT-EQUAL (ELT |y| 1) + |x|) + (SPADLET |$found| |y|)) + (SETQ G166410 + (OR G166410 |i|)))))))))) + (SPADDIFFERENCE (PLUS |$NRTbase| |$NRTdeltaLength|) |k|)) + ('T NIL)))))) + +;NRTgetLocalIndexClear item == NRTgetLocalIndex1(item,true) + +(DEFUN |NRTgetLocalIndexClear| (|item|) + (|NRTgetLocalIndex1| |item| 'T)) + +;NRTgetLocalIndex item == NRTgetLocalIndex1(item,false) + +(DEFUN |NRTgetLocalIndex| (|item|) (|NRTgetLocalIndex1| |item| NIL)) + +;NRTgetLocalIndex1(item,killBindingIfTrue) == +; k := NRTassocIndex item => k +; item = $NRTaddForm => 5 +; item = '$ => 0 +; item = '_$_$ => 2 +; value:= +; MEMQ(item,$formalArgList) => item +; nil +; atom item and null MEMQ(item,'($ _$_$)) +; and null value => --give slots to atoms +; $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] +; $NRTdeltaListComp:=[item,:$NRTdeltaListComp] +; $NRTdeltaLength := $NRTdeltaLength+1 +; $NRTbase + $NRTdeltaLength - 1 +; $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] +; saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] +; saveIndex := $NRTbase + $NRTdeltaLength +; $NRTdeltaLength := $NRTdeltaLength+1 +; compEntry:= compOrCroak(item,$EmptyMode,$e).expr +;-- item +; RPLACA(saveNRTdeltaListComp,compEntry) +; saveIndex + +(DEFUN |NRTgetLocalIndex1| (|item| |killBindingIfTrue|) + (declare (ignore |killBindingIfTrue|)) + (PROG (|k| |value| |saveNRTdeltaListComp| |saveIndex| |compEntry|) + (declare (special |$e| |$EmptyMode| |$NRTdeltaLength| |$NRTbase| + |$NRTdeltaListComp| |$NRTdeltaList| |$formalArgList| + |$NRTaddForm|)) + (RETURN + (COND + ((SPADLET |k| (|NRTassocIndex| |item|)) |k|) + ((BOOT-EQUAL |item| |$NRTaddForm|) 5) + ((BOOT-EQUAL |item| '$) 0) + ((BOOT-EQUAL |item| '$$) 2) + ('T + (SPADLET |value| + (COND + ((MEMQ |item| |$formalArgList|) |item|) + ('T NIL))) + (COND + ((AND (ATOM |item|) (NULL (MEMQ |item| '($ $$))) + (NULL |value|)) + (SPADLET |$NRTdeltaList| + (CONS (CONS '|domain| + (CONS (|NRTaddInner| |item|) |value|)) + |$NRTdeltaList|)) + (SPADLET |$NRTdeltaListComp| + (CONS |item| |$NRTdeltaListComp|)) + (SPADLET |$NRTdeltaLength| (PLUS |$NRTdeltaLength| 1)) + (SPADDIFFERENCE (PLUS |$NRTbase| |$NRTdeltaLength|) 1)) + ('T + (SPADLET |$NRTdeltaList| + (CONS (CONS '|domain| + (CONS (|NRTaddInner| |item|) |value|)) + |$NRTdeltaList|)) + (SPADLET |saveNRTdeltaListComp| + (SPADLET |$NRTdeltaListComp| + (CONS NIL |$NRTdeltaListComp|))) + (SPADLET |saveIndex| (PLUS |$NRTbase| |$NRTdeltaLength|)) + (SPADLET |$NRTdeltaLength| (PLUS |$NRTdeltaLength| 1)) + (SPADLET |compEntry| + (CAR (|compOrCroak| |item| |$EmptyMode| |$e|))) + (RPLACA |saveNRTdeltaListComp| |compEntry|) |saveIndex|))))))) + +;NRTgetAddForm domain == +; u := HGET($Slot1DataBase,first domain) => +; EQSUBSTLIST(rest domain,$FormalMapVariableList,first u) +; systemErrorHere '"NRTgetAddForm" + +(DEFUN |NRTgetAddForm| (|domain|) + (PROG (|u|) + (declare (special |$FormalMapVariableList| |$Slot1DataBase|)) + (RETURN + (COND + ((SPADLET |u| (HGET |$Slot1DataBase| (CAR |domain|))) + (EQSUBSTLIST (CDR |domain|) |$FormalMapVariableList| + (CAR |u|))) + ('T (|systemErrorHere| (MAKESTRING "NRTgetAddForm"))))))) + +;NRTassignCapsuleFunctionSlot(op,sig) == +;--called from compDefineCapsuleFunction +; opSig := [op,sig] +; [.,.,implementation] := NRTisExported? opSig or return nil +; --if opSig is not exported, it is local and need not be assigned +; if $insideCategoryPackageIfTrue then +; sig := substitute('$,CADR($functorForm),sig) +; sig := [genDeltaSig x for x in sig] +; opModemapPair := [op,['_$,:sig],['T,implementation]] +; POSN1(opModemapPair,$NRTdeltaList) => nil --already there +; $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] +; $NRTdeltaListComp := [nil,:$NRTdeltaListComp] +; $NRTdeltaLength := $NRTdeltaLength+1 + +(DEFUN |NRTassignCapsuleFunctionSlot| (|op| |sig|) + (PROG (|opSig| |LETTMP#1| |implementation| |opModemapPair|) + (declare (special |$NRTdeltaLength| |$NRTdeltaListComp| |$NRTdeltaList| + |$functorForm| |$insideCategoryPackageIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |opSig| (CONS |op| (CONS |sig| NIL))) + (SPADLET |LETTMP#1| + (OR (|NRTisExported?| |opSig|) (RETURN NIL))) + (SPADLET |implementation| (CADDR |LETTMP#1|)) + (COND + (|$insideCategoryPackageIfTrue| + (SPADLET |sig| + (MSUBST '$ (CADR |$functorForm|) |sig|)))) + (SPADLET |sig| + (PROG (G166470) + (SPADLET G166470 NIL) + (RETURN + (DO ((G166475 |sig| (CDR G166475)) + (|x| NIL)) + ((OR (ATOM G166475) + (PROGN + (SETQ |x| (CAR G166475)) + NIL)) + (NREVERSE0 G166470)) + (SEQ (EXIT (SETQ G166470 + (CONS (|genDeltaSig| |x|) + G166470)))))))) + (SPADLET |opModemapPair| + (CONS |op| + (CONS (CONS '$ |sig|) + (CONS (CONS 'T + (CONS |implementation| NIL)) + NIL)))) + (COND + ((POSN1 |opModemapPair| |$NRTdeltaList|) NIL) + ('T + (SPADLET |$NRTdeltaList| + (CONS |opModemapPair| |$NRTdeltaList|)) + (SPADLET |$NRTdeltaListComp| + (CONS NIL |$NRTdeltaListComp|)) + (SPADLET |$NRTdeltaLength| (PLUS |$NRTdeltaLength| 1))))))))) + +;NRTisExported? opSig == +; or/[u for u in $domainShell.1 | u.0 = opSig] + +(DEFUN |NRTisExported?| (|opSig|) + (PROG () + (declare (special |$domainShell|)) + (RETURN + (SEQ (PROG (G166494) + (SPADLET G166494 NIL) + (RETURN + (DO ((G166501 NIL G166494) + (G166502 (ELT |$domainShell| 1) (CDR G166502)) + (|u| NIL)) + ((OR G166501 (ATOM G166502) + (PROGN (SETQ |u| (CAR G166502)) NIL)) + G166494) + (SEQ (EXIT (COND + ((BOOT-EQUAL (ELT |u| 0) |opSig|) + (SETQ G166494 (OR G166494 |u|))))))))))))) + +;consOpSig(op,sig,dc) == +; if null atom op then +; keyedSystemError("S2GE0016",['"consOpSig",'"bad operator in table"]) +; mkList [MKQ op,mkList consSig(sig,dc)] + +(DEFUN |consOpSig| (|op| |sig| |dc|) + (PROGN + (COND + ((NULL (ATOM |op|)) + (|keyedSystemError| 'S2GE0016 + (CONS (MAKESTRING "consOpSig") + (CONS (MAKESTRING "bad operator in table") NIL))))) + (|mkList| + (CONS (MKQ |op|) (CONS (|mkList| (|consSig| |sig| |dc|)) NIL))))) + +;consSig(sig,dc) == [consDomainName(sigpart,dc) for sigpart in sig] + +(DEFUN |consSig| (|sig| |dc|) + (PROG () + (RETURN + (SEQ (PROG (G166521) + (SPADLET G166521 NIL) + (RETURN + (DO ((G166526 |sig| (CDR G166526)) (|sigpart| NIL)) + ((OR (ATOM G166526) + (PROGN (SETQ |sigpart| (CAR G166526)) NIL)) + (NREVERSE0 G166521)) + (SEQ (EXIT (SETQ G166521 + (CONS (|consDomainName| |sigpart| + |dc|) + G166521))))))))))) + +;consDomainName(x,dc) == +; x = dc => ''$ +; x = '$ => ''$ +; x = "$$" => ['devaluate,'$] +; x is [op,:argl] => +; (op = 'Record) or (op = 'Union and argl is [[":",:.],:.]) => +; mkList [MKQ op, +; :[['LIST,MKQ '_:,MKQ tag,consDomainName(dom,dc)] +; for [.,tag,dom] in argl]] +; isFunctor op or op = 'Mapping or constructor? op => +; -- call to constructor? needed if op was compiled in $bootStrapMode +; mkList [MKQ op,:[consDomainName(y,dc) for y in argl]] +; substitute('$,"$$",x) +; x = [] => x +; (y := LASSOC(x,$devaluateList)) => y +; k:=NRTassocIndex x => +; ['devaluate,['ELT,'$,k]] +; get(x,'value,$e) => +; isDomainForm(x,$e) => ['devaluate,x] +; x +; MKQ x + +(DEFUN |consDomainName| (|x| |dc|) + (PROG (|op| |argl| |ISTMP#1| |tag| |dom| |y| |k|) + (declare (special |$e| |$devaluateList|)) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |x| |dc|) ''$) + ((BOOT-EQUAL |x| '$) ''$) + ((BOOT-EQUAL |x| '$$) (CONS '|devaluate| (CONS '$ NIL))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + 'T)) + (COND + ((OR (BOOT-EQUAL |op| '|Record|) + (AND (BOOT-EQUAL |op| '|Union|) (PAIRP |argl|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |argl|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|:|))))) + (|mkList| + (CONS (MKQ |op|) + (PROG (G166553) + (SPADLET G166553 NIL) + (RETURN + (DO ((G166559 |argl| (CDR G166559)) + (G166541 NIL)) + ((OR (ATOM G166559) + (PROGN + (SETQ G166541 (CAR G166559)) + NIL) + (PROGN + (PROGN + (SPADLET |tag| + (CADR G166541)) + (SPADLET |dom| + (CADDR G166541)) + G166541) + NIL)) + (NREVERSE0 G166553)) + (SEQ (EXIT + (SETQ G166553 + (CONS + (CONS 'LIST + (CONS (MKQ '|:|) + (CONS (MKQ |tag|) + (CONS + (|consDomainName| |dom| + |dc|) + NIL)))) + G166553)))))))))) + ((OR (|isFunctor| |op|) (BOOT-EQUAL |op| '|Mapping|) + (|constructor?| |op|)) + (|mkList| + (CONS (MKQ |op|) + (PROG (G166570) + (SPADLET G166570 NIL) + (RETURN + (DO ((G166575 |argl| (CDR G166575)) + (|y| NIL)) + ((OR (ATOM G166575) + (PROGN + (SETQ |y| (CAR G166575)) + NIL)) + (NREVERSE0 G166570)) + (SEQ (EXIT + (SETQ G166570 + (CONS + (|consDomainName| |y| |dc|) + G166570)))))))))) + ('T (MSUBST '$ '$$ |x|)))) + ((NULL |x|) |x|) + ((SPADLET |y| (LASSOC |x| |$devaluateList|)) |y|) + ((SPADLET |k| (|NRTassocIndex| |x|)) + (CONS '|devaluate| + (CONS (CONS 'ELT (CONS '$ (CONS |k| NIL))) NIL))) + ((|get| |x| '|value| |$e|) + (COND + ((|isDomainForm| |x| |$e|) + (CONS '|devaluate| (CONS |x| NIL))) + ('T |x|))) + ('T (MKQ |x|))))))) + +;consDomainForm(x,dc) == +; x = '$ => '$ +; x is [op,:argl] => +; op = ":" and argl is [tag, value] => [op, tag, consDomainForm(value,dc)] +; [op,:[consDomainForm(y,dc) for y in argl]] +; x = [] => x +; (y := LASSOC(x,$devaluateList)) => y +; k:=NRTassocIndex x => ['ELT,'$,k] +; get(x,'value,$e) or get(x,'mode,$e) => x +; MKQ x + +(DEFUN |consDomainForm| (|x| |dc|) + (PROG (|op| |argl| |tag| |ISTMP#1| |value| |y| |k|) + (declare (special |$e| |$devaluateList|)) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |x| '$) '$) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + 'T)) + (COND + ((AND (BOOT-EQUAL |op| '|:|) (PAIRP |argl|) + (PROGN + (SPADLET |tag| (QCAR |argl|)) + (SPADLET |ISTMP#1| (QCDR |argl|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |value| (QCAR |ISTMP#1|)) + 'T)))) + (CONS |op| + (CONS |tag| + (CONS (|consDomainForm| |value| |dc|) NIL)))) + ('T + (CONS |op| + (PROG (G166611) + (SPADLET G166611 NIL) + (RETURN + (DO ((G166616 |argl| (CDR G166616)) + (|y| NIL)) + ((OR (ATOM G166616) + (PROGN + (SETQ |y| (CAR G166616)) + NIL)) + (NREVERSE0 G166611)) + (SEQ (EXIT (SETQ G166611 + (CONS + (|consDomainForm| |y| |dc|) + G166611))))))))))) + ((NULL |x|) |x|) + ((SPADLET |y| (LASSOC |x| |$devaluateList|)) |y|) + ((SPADLET |k| (|NRTassocIndex| |x|)) + (CONS 'ELT (CONS '$ (CONS |k| NIL)))) + ((OR (|get| |x| '|value| |$e|) (|get| |x| '|mode| |$e|)) + |x|) + ('T (MKQ |x|))))))) + +;buildFunctor($definition is [name,:args],sig,code,$locals,$e) == +;--PARAMETERS +;-- $definition: constructor form, e.g. (SquareMatrix 10 (RationalNumber)) +;-- sig: signature of constructor form +;-- code: result of "doIt", converting body of capsule to CodeDefine forms, e.g. +;-- (PROGN (LET Rep ...) +;-- (: (ListOf x y) $) +;-- (CodeDefine ( )) +;-- (COND ((HasCategory $ ...) (PROGN ...))) ..) +;-- $locals: list of variables to go into slot 5, e.g. (R Rep R,1 R,2 R,3 R,4) +;-- same as $functorLocalParameters +;-- this list is not augmented by this function +;-- $e: environment +;--GLOBAL VARIABLES REFERENCED: +;-- $domainShell: passed in from compDefineFunctor1 +;-- $QuickCode: compilation flag +; if code is ['add,.,newstuff] then code := newstuff +; changeDirectoryInSlot1() --this extends $NRTslot1PredicateList +; --pp '"==================" +; --for item in $NRTdeltaList repeat pp item +;--LOCAL BOUND FLUID VARIABLES: +; $GENNO: local:= 0 --bound in compDefineFunctor1, then as parameter here +;--$frontier: local --index of first local slot=#(cat part of princ view) +; $catvecList: local --list of vectors v1..vn for each view +; $hasCategoryAlist: local --list of GENSYMs bound to (HasCategory ..) items +; $catNames: local --list of names n1..nn for each view +; $maximalViews: local --list of maximal categories for domain (???) +; $catsig: local --target category (used in ProcessCond) +; $SetFunctions: local --copy of p view with preds telling when fnct defined +; $MissingFunctionInfo: local --now useless +; --vector marking which functions are assigned +; $ConstantAssignments: local --code for creation of constants +; $epilogue: local := nil --code to set slot 5, things to be done last +; $HackSlot4: local --Invention of JHD 13/July/86-set in InvestigateConditions +; $extraParms:local --Set in DomainSubstitutionFunction, used in setVector12 +; $devaluateList: local --Bound to ((#1 . dv$1)..) where &1 := devaluate #1 later +; $devaluateList:= [[arg,:b] for arg in args for b in $ModeVariableList] +; $supplementaries: local := nil +; --set in InvestigateConditions to represent any additional +; --category membership tests that may be needed(see buildFunctor for details) +;------------------------ +; $maximalViews: local := nil +; oldtime:= TEMPUS_-FUGIT() +; [$catsig,:argsig]:= sig +; catvecListMaker:=REMDUP +; [(comp($catsig,$EmptyMode,$e)).expr, +; :[compCategories first u for u in CADR $domainShell.4]] +; condCats:= InvestigateConditions [$catsig,:rest catvecListMaker] +; -- a list, one %for each element of catvecListMaker +; -- indicating under what conditions this +; -- category should be present. true => always +; makeCatvecCode:= first catvecListMaker +; emptyVector := VECTOR() +;--if $NRTaddForm and null NRTassocIndex $NRTaddForm then +;-- --create "domain" entry to $NRTdeltaList +;-- $NRTdeltaList:= +;-- [['domain,NRTaddInner $NRTaddForm,:$NRTaddForm],:$NRTdeltaList] +;-- $NRTdeltaLength := $NRTdeltaLength+1 +;--NRTgetLocalIndex $NRTaddForm +; domainShell := GETREFV (6 + $NRTdeltaLength) +; for i in 0..4 repeat domainShell.i := $domainShell.i +; --we will clobber elements; copy since $domainShell may be a cached vector +; $template := +; $NRTvec = true => GETREFV (6 + $NRTdeltaLength) +; nil +; $catvecList:= [domainShell,:[emptyVector for u in CADR domainShell.4]] +; $catNames := ['$] -- for DescendCode -- to be changed below for slot 4 +; $maximalViews:= nil +; $SetFunctions:= GETREFV SIZE domainShell +; $MissingFunctionInfo:= GETREFV SIZE domainShell +; $catNames:= ['$,:[GENVAR() for u in rest catvecListMaker]] +; domname:='dv_$ +;--> Do this now to create predicate vector; then DescendCode can refer +;--> to predicate vector if it can +; [$uncondAlist,:$condAlist] := --bound in compDefineFunctor1 +; NRTsetVector4Part1($catNames,catvecListMaker,condCats) +; [$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] := +; makePredicateBitVector [:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList] +; storeOperationCode:= DescendCode(code,true,nil,first $catNames) +; outsideFunctionCode:= NRTaddDeltaCode() +; storeOperationCode:= NRTputInLocalReferences storeOperationCode +; if $NRTvec = true then +; NRTdescendCodeTran(storeOperationCode,nil) --side effects storeOperationCode +; codePart2:= +; $NRTvec = true => +; argStuffCode := +; [[$setelt,'$,i,v] for i in 6.. for v in $FormalMapVariableList +; for arg in rest $definition] +; if MEMQ($NRTaddForm,$locals) then +; addargname := $FormalMapVariableList.(POSN1($NRTaddForm,$locals)) +; argStuffCode := [[$setelt,'$,5,addargname],:argStuffCode] +; [['stuffDomainSlots,'$],:argStuffCode, +; :predBitVectorCode2,storeOperationCode] +; [:outsideFunctionCode,storeOperationCode] +; $CheckVectorList := NRTcheckVector domainShell +;--CODE: part 1 +; codePart1:= [:devaluateCode,:domainFormCode,createDomainCode, +; createViewCode,setVector0Code, slot3Code,:slamCode] where +; devaluateCode:= [['LET,b,['devaluate,a]] for [a,:b] in $devaluateList] +; domainFormCode := [['LET,a,b] for [a,:b] in NREVERSE $NRTdomainFormList] +; --$NRTdomainFormList is unused now +; createDomainCode:= +; ['LET,domname,['LIST,MKQ CAR $definition,:ASSOCRIGHT $devaluateList]] +; createViewCode:= ['LET,'$,['GETREFV, 6+$NRTdeltaLength]] +; setVector0Code:=[$setelt,'$,0,'dv_$] +; slot3Code := ['QSETREFV,'$,3,['LET,'pv_$,predBitVectorCode1]] +; slamCode:= +; isCategoryPackageName opOf $definition => nil +; [NRTaddToSlam($definition,'$)] +;--CODE: part 3 +; $ConstantAssignments := +; [NRTputInLocalReferences code for code in $ConstantAssignments] +; codePart3:= [:constantCode1, +; :constantCode2,:epilogue] where +; constantCode1:= +; name='Integer => $ConstantAssignments +; nil +; -- The above line is needed to get the recursion +; -- Integer => FontTable => NonNegativeInteger => Integer +; -- right. Otherwise NNI has 'unset' for 0 and 1 +;-- setVector4c:= setVector4part3($catNames,$catvecList) +; -- In particular, setVector4part3 and setVector5, +; -- which generate calls to local domain-instantiators, +; -- must come after operations are set in the vector. +; -- The symptoms of getting this wrong are that +; -- operations are not set which should be +; constantCode2:= --matches previous test on Integer +; name='Integer => nil +; $ConstantAssignments +; epilogue:= $epilogue +; ans := +; ['PROGN,:optFunctorPROGN [:codePart1,:codePart2,:codePart3], '$] +; $getDomainCode:= nil +; --if we didn't kill this, DEFINE would insert it in the wrong place +; ans:= minimalise ans +; SAY ['"time taken in buildFunctor: ",TEMPUS_-FUGIT()-oldtime] +; --sayBrightly '"------------------functor code: -------------------" +; --pp ans +; ans + +(DEFUN |buildFunctor| (|$definition| |sig| |code| |$locals| |$e|) + (DECLARE (SPECIAL |$definition| |$locals| |$e|)) + (PROG ($GENNO |$catvecList| |$hasCategoryAlist| |$catNames| |$catsig| + |$SetFunctions| |$MissingFunctionInfo| + |$ConstantAssignments| |$epilogue| |$HackSlot4| + |$extraParms| |$devaluateList| |$supplementaries| + |$maximalViews| |name| |args| |ISTMP#1| |ISTMP#2| + |newstuff| |oldtime| |argsig| |catvecListMaker| + |condCats| |makeCatvecCode| |emptyVector| |domainShell| + |domname| |LETTMP#1| |predBitVectorCode1| + |predBitVectorCode2| |outsideFunctionCode| + |storeOperationCode| |addargname| |argStuffCode| + |codePart2| |devaluateCode| |a| |b| |domainFormCode| + |createDomainCode| |createViewCode| |setVector0Code| + |slot3Code| |slamCode| |codePart1| |constantCode1| + |constantCode2| |epilogue| |codePart3| |ans|) + (DECLARE (SPECIAL $GENNO |$catvecList| |$hasCategoryAlist| |$EmptyMode| + |$catNames| |$catsig| |$SetFunctions| |$ModeVariableList| + |$MissingFunctionInfo| |$ConstantAssignments| |$setelt| + |$epilogue| |$HackSlot4| |$extraParms| |$NRTdeltaLength| + |$devaluateList| |$supplementaries| |$NRTdomainFormList| + |$maximalViews| |$getDomainCode| |$CheckVectorList| + |$NRTaddForm| |$FormalMapVariableList| |$NRTvec| + |$catNames| |$NRTslot1PredicateList| |$condAlist| + |$uncondAlist| |$template| |$domainShell| + |$SetFunctions|)) + (RETURN + (SEQ (PROGN + (SPADLET |name| (CAR |$definition|)) + (SPADLET |args| (CDR |$definition|)) + (COND + ((AND (PAIRP |code|) (EQ (QCAR |code|) '|add|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |code|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |newstuff| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |code| |newstuff|))) + (|changeDirectoryInSlot1|) + (SPADLET $GENNO 0) + (SPADLET |$catvecList| NIL) + (SPADLET |$hasCategoryAlist| NIL) + (SPADLET |$catNames| NIL) + (SPADLET |$maximalViews| NIL) + (SPADLET |$catsig| NIL) + (SPADLET |$SetFunctions| NIL) + (SPADLET |$MissingFunctionInfo| NIL) + (SPADLET |$ConstantAssignments| NIL) + (SPADLET |$epilogue| NIL) + (SPADLET |$HackSlot4| NIL) + (SPADLET |$extraParms| NIL) + (SPADLET |$devaluateList| NIL) + (SPADLET |$devaluateList| + (PROG (G166745) + (SPADLET G166745 NIL) + (RETURN + (DO ((G166751 |args| (CDR G166751)) + (|arg| NIL) + (G166752 |$ModeVariableList| + (CDR G166752)) + (|b| NIL)) + ((OR (ATOM G166751) + (PROGN + (SETQ |arg| (CAR G166751)) + NIL) + (ATOM G166752) + (PROGN + (SETQ |b| (CAR G166752)) + NIL)) + (NREVERSE0 G166745)) + (SEQ (EXIT (SETQ G166745 + (CONS (CONS |arg| |b|) + G166745)))))))) + (SPADLET |$supplementaries| NIL) + (SPADLET |$maximalViews| NIL) + (SPADLET |oldtime| (TEMPUS-FUGIT)) + (SPADLET |$catsig| (CAR |sig|)) + (SPADLET |argsig| (CDR |sig|)) + (SPADLET |catvecListMaker| + (REMDUP (CONS (CAR + (|comp| |$catsig| |$EmptyMode| + |$e|)) + (PROG (G166765) + (SPADLET G166765 NIL) + (RETURN + (DO + ((G166770 + (CADR + (ELT |$domainShell| 4)) + (CDR G166770)) + (|u| NIL)) + ((OR (ATOM G166770) + (PROGN + (SETQ |u| (CAR G166770)) + NIL)) + (NREVERSE0 G166765)) + (SEQ + (EXIT + (SETQ G166765 + (CONS + (|compCategories| + (CAR |u|)) + G166765)))))))))) + (SPADLET |condCats| + (|InvestigateConditions| + (CONS |$catsig| (CDR |catvecListMaker|)))) + (SPADLET |makeCatvecCode| (CAR |catvecListMaker|)) + (SPADLET |emptyVector| (VECTOR)) + (SPADLET |domainShell| + (GETREFV (PLUS 6 |$NRTdeltaLength|))) + (DO ((|i| 0 (QSADD1 |i|))) ((QSGREATERP |i| 4) NIL) + (SEQ (EXIT (SETELT |domainShell| |i| + (ELT |$domainShell| |i|))))) + (SPADLET |$template| + (COND + ((BOOT-EQUAL |$NRTvec| 'T) + (GETREFV (PLUS 6 |$NRTdeltaLength|))) + ('T NIL))) + (SPADLET |$catvecList| + (CONS |domainShell| + (PROG (G166786) + (SPADLET G166786 NIL) + (RETURN + (DO ((G166791 + (CADR (ELT |domainShell| 4)) + (CDR G166791)) + (|u| NIL)) + ((OR (ATOM G166791) + (PROGN + (SETQ |u| (CAR G166791)) + NIL)) + (NREVERSE0 G166786)) + (SEQ (EXIT + (SETQ G166786 + (CONS |emptyVector| G166786))))))))) + (SPADLET |$catNames| (CONS '$ NIL)) + (SPADLET |$maximalViews| NIL) + (SPADLET |$SetFunctions| (GETREFV (SIZE |domainShell|))) + (SPADLET |$MissingFunctionInfo| + (GETREFV (SIZE |domainShell|))) + (SPADLET |$catNames| + (CONS '$ + (PROG (G166801) + (SPADLET G166801 NIL) + (RETURN + (DO ((G166806 (CDR |catvecListMaker|) + (CDR G166806)) + (|u| NIL)) + ((OR (ATOM G166806) + (PROGN + (SETQ |u| (CAR G166806)) + NIL)) + (NREVERSE0 G166801)) + (SEQ (EXIT + (SETQ G166801 + (CONS (GENVAR) G166801))))))))) + (SPADLET |domname| '|dv$|) + (SPADLET |LETTMP#1| + (|NRTsetVector4Part1| |$catNames| + |catvecListMaker| |condCats|)) + (SPADLET |$uncondAlist| (CAR |LETTMP#1|)) + (SPADLET |$condAlist| (CDR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (|makePredicateBitVector| + (APPEND (ASSOCRIGHT |$condAlist|) + |$NRTslot1PredicateList|))) + (SPADLET |$NRTslot1PredicateList| (CAR |LETTMP#1|)) + (SPADLET |predBitVectorCode1| (CADR |LETTMP#1|)) + (SPADLET |predBitVectorCode2| (CDDR |LETTMP#1|)) + (SPADLET |storeOperationCode| + (|DescendCode| |code| 'T NIL (CAR |$catNames|))) + (SPADLET |outsideFunctionCode| (|NRTaddDeltaCode|)) + (SPADLET |storeOperationCode| + (|NRTputInLocalReferences| |storeOperationCode|)) + (COND + ((BOOT-EQUAL |$NRTvec| 'T) + (|NRTdescendCodeTran| |storeOperationCode| NIL))) + (SPADLET |codePart2| + (COND + ((BOOT-EQUAL |$NRTvec| 'T) + (SPADLET |argStuffCode| + (PROG (G166818) + (SPADLET G166818 NIL) + (RETURN + (DO + ((|i| 6 (+ |i| 1)) + (G166825 + |$FormalMapVariableList| + (CDR G166825)) + (|v| NIL) + (G166826 (CDR |$definition|) + (CDR G166826)) + (|arg| NIL)) + ((OR (ATOM G166825) + (PROGN + (SETQ |v| (CAR G166825)) + NIL) + (ATOM G166826) + (PROGN + (SETQ |arg| (CAR G166826)) + NIL)) + (NREVERSE0 G166818)) + (SEQ + (EXIT + (SETQ G166818 + (CONS + (CONS |$setelt| + (CONS '$ + (CONS |i| (CONS |v| NIL)))) + G166818)))))))) + (COND + ((MEMQ |$NRTaddForm| |$locals|) + (SPADLET |addargname| + (ELT |$FormalMapVariableList| + (POSN1 |$NRTaddForm| |$locals|))) + (SPADLET |argStuffCode| + (CONS + (CONS |$setelt| + (CONS '$ + (CONS 5 + (CONS |addargname| NIL)))) + |argStuffCode|)))) + (CONS (CONS '|stuffDomainSlots| (CONS '$ NIL)) + (APPEND |argStuffCode| + (APPEND |predBitVectorCode2| + (CONS |storeOperationCode| NIL))))) + ('T + (APPEND |outsideFunctionCode| + (CONS |storeOperationCode| NIL))))) + (SPADLET |$CheckVectorList| + (|NRTcheckVector| |domainShell|)) + (SPADLET |devaluateCode| + (PROG (G166840) + (SPADLET G166840 NIL) + (RETURN + (DO ((G166846 |$devaluateList| + (CDR G166846)) + (G166666 NIL)) + ((OR (ATOM G166846) + (PROGN + (SETQ G166666 (CAR G166846)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G166666)) + (SPADLET |b| (CDR G166666)) + G166666) + NIL)) + (NREVERSE0 G166840)) + (SEQ (EXIT (SETQ G166840 + (CONS + (CONS 'LET + (CONS |b| + (CONS + (CONS '|devaluate| + (CONS |a| NIL)) + NIL))) + G166840)))))))) + (SPADLET |domainFormCode| + (PROG (G166858) + (SPADLET G166858 NIL) + (RETURN + (DO ((G166864 + (NREVERSE |$NRTdomainFormList|) + (CDR G166864)) + (G166670 NIL)) + ((OR (ATOM G166864) + (PROGN + (SETQ G166670 (CAR G166864)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G166670)) + (SPADLET |b| (CDR G166670)) + G166670) + NIL)) + (NREVERSE0 G166858)) + (SEQ (EXIT (SETQ G166858 + (CONS + (CONS 'LET + (CONS |a| (CONS |b| NIL))) + G166858)))))))) + (SPADLET |createDomainCode| + (CONS 'LET + (CONS |domname| + (CONS (CONS 'LIST + (CONS + (MKQ (CAR |$definition|)) + (ASSOCRIGHT |$devaluateList|))) + NIL)))) + (SPADLET |createViewCode| + (CONS 'LET + (CONS '$ + (CONS (CONS 'GETREFV + (CONS + (PLUS 6 |$NRTdeltaLength|) + NIL)) + NIL)))) + (SPADLET |setVector0Code| + (CONS |$setelt| + (CONS '$ (CONS 0 (CONS '|dv$| NIL))))) + (SPADLET |slot3Code| + (CONS 'QSETREFV + (CONS '$ + (CONS 3 + (CONS + (CONS 'LET + (CONS '|pv$| + (CONS |predBitVectorCode1| + NIL))) + NIL))))) + (SPADLET |slamCode| + (COND + ((|isCategoryPackageName| + (|opOf| |$definition|)) + NIL) + ('T + (CONS (|NRTaddToSlam| |$definition| '$) NIL)))) + (SPADLET |codePart1| + (APPEND |devaluateCode| + (APPEND |domainFormCode| + (CONS |createDomainCode| + (CONS |createViewCode| + (CONS |setVector0Code| + (CONS |slot3Code| |slamCode|))))))) + (SPADLET |$ConstantAssignments| + (PROG (G166875) + (SPADLET G166875 NIL) + (RETURN + (DO ((G166880 |$ConstantAssignments| + (CDR G166880)) + (|code| NIL)) + ((OR (ATOM G166880) + (PROGN + (SETQ |code| (CAR G166880)) + NIL)) + (NREVERSE0 G166875)) + (SEQ (EXIT (SETQ G166875 + (CONS + (|NRTputInLocalReferences| + |code|) + G166875)))))))) + (SPADLET |constantCode1| + (COND + ((BOOT-EQUAL |name| '|Integer|) + |$ConstantAssignments|) + ('T NIL))) + (SPADLET |constantCode2| + (COND + ((BOOT-EQUAL |name| '|Integer|) NIL) + ('T |$ConstantAssignments|))) + (SPADLET |epilogue| |$epilogue|) + (SPADLET |codePart3| + (APPEND |constantCode1| + (APPEND |constantCode2| |epilogue|))) + (SPADLET |ans| + (CONS 'PROGN + (APPEND (|optFunctorPROGN| + (APPEND |codePart1| + (APPEND |codePart2| |codePart3|))) + (CONS '$ NIL)))) + (SPADLET |$getDomainCode| NIL) + (SPADLET |ans| (|minimalise| |ans|)) + (SAY (CONS (MAKESTRING "time taken in buildFunctor: ") + (CONS (SPADDIFFERENCE (TEMPUS-FUGIT) |oldtime|) + NIL))) + |ans|))))) + +;NRTcheckVector domainShell == +;--RETURNS: an alist (((op,sig),:pred) ...) of missing functions +; alist := nil +; for i in 6..MAXINDEX domainShell repeat +;--Vector elements can be one of +;-- (a) T -- item was marked +;-- (b) NIL -- item is a domain; will be filled in by setVector4part3 +;-- (c) categoryForm-- it was a domain view; now irrelevant +;-- (d) op-signature-- store missing function info in $CheckVectorList +; v:= domainShell.i +; v=true => nil --item is marked; ignore +; null v => nil --a domain, which setVector4part3 will fill in +; atom first v => nil --category form; ignore +; atom v => systemErrorHere '"CheckVector" +; ASSOC(first v,alist) => nil +; alist:= +; [[first v,:$SetFunctions.i],:alist] +; alist + +(DEFUN |NRTcheckVector| (|domainShell|) + (PROG (|v| |alist|) + (declare (special |$SetFunctions|)) + (RETURN + (SEQ (PROGN + (SPADLET |alist| NIL) + (DO ((G167008 (MAXINDEX |domainShell|)) + (|i| 6 (+ |i| 1))) + ((> |i| G167008) NIL) + (SEQ (EXIT (PROGN + (SPADLET |v| (ELT |domainShell| |i|)) + (COND + ((BOOT-EQUAL |v| 'T) NIL) + ((NULL |v|) NIL) + ((ATOM (CAR |v|)) NIL) + ((ATOM |v|) + (|systemErrorHere| + (MAKESTRING "CheckVector"))) + ((|assoc| (CAR |v|) |alist|) NIL) + ('T + (SPADLET |alist| + (CONS + (CONS (CAR |v|) + (ELT |$SetFunctions| |i|)) + |alist|)))))))) + |alist|))))) + +;-- Obsolete once we have moved to JHD's world +;NRTvectorCopy(cacheName,domName,deltaLength) == GETREFV (6 + deltaLength) + +(DEFUN |NRTvectorCopy| (|cacheName| |domName| |deltaLength|) + (declare (ignore |cacheName| |domName| )) + (GETREFV (PLUS 6 |deltaLength|))) + +;mkDomainCatName id == INTERN STRCONC(id,";CAT") + +(DEFUN |mkDomainCatName| (|id|) (INTERN (STRCONC |id| '|;CAT|))) + +;NRTsetVector4(siglist,formlist,condlist) == +; $uncondList: local := nil +; $condList: local := nil +; $count: local := 0 +; for sig in reverse siglist for form in reverse formlist +; for cond in reverse condlist repeat +; NRTsetVector4a(sig,form,cond) +; --NRTsetVector4a(first siglist,first formlist,first condlist) +; $lisplibCategoriesExtended:= [$uncondList,:$condList] +; code := ['mapConsDB,MKQ REVERSE REMDUP $uncondList] +; if $condList then +; localVariable := GENSYM() +; code := [['LET,localVariable,code]] +; for [pred,list] in $condList repeat +; code := +; [['COND,[pred,['LET,localVariable, +; ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]], +; :code] +; code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]] +; g := GENSYM() +; [$setelt,'$,4,['PROG2,['LET,g,code], +; ['VECTOR,['catList2catPackageList,g],g]]] + +(DEFUN |NRTsetVector4| (|siglist| |formlist| |condlist|) + (PROG (|$uncondList| |$condList| |$count| |localVariable| |pred| LIST + |code| |g|) + (DECLARE (SPECIAL |$uncondList| |$condList| |$count| |$setelt| + |$lisplibCategoriesExtended|)) + (RETURN + (SEQ (PROGN + (SPADLET |$uncondList| NIL) + (SPADLET |$condList| NIL) + (SPADLET |$count| 0) + (DO ((G167035 (REVERSE |siglist|) (CDR G167035)) + (|sig| NIL) + (G167036 (REVERSE |formlist|) (CDR G167036)) + (|form| NIL) + (G167037 (REVERSE |condlist|) (CDR G167037)) + (|cond| NIL)) + ((OR (ATOM G167035) + (PROGN (SETQ |sig| (CAR G167035)) NIL) + (ATOM G167036) + (PROGN (SETQ |form| (CAR G167036)) NIL) + (ATOM G167037) + (PROGN (SETQ |cond| (CAR G167037)) NIL)) + NIL) + (SEQ (EXIT (|NRTsetVector4a| |sig| |form| |cond|)))) + (SPADLET |$lisplibCategoriesExtended| + (CONS |$uncondList| |$condList|)) + (SPADLET |code| + (CONS '|mapConsDB| + (CONS (MKQ (REVERSE (REMDUP |$uncondList|))) + NIL))) + (COND + (|$condList| (SPADLET |localVariable| (GENSYM)) + (SPADLET |code| + (CONS (CONS 'LET + (CONS |localVariable| + (CONS |code| NIL))) + NIL)) + (DO ((G167053 |$condList| (CDR G167053)) + (G167024 NIL)) + ((OR (ATOM G167053) + (PROGN + (SETQ G167024 (CAR G167053)) + NIL) + (PROGN + (PROGN + (SPADLET |pred| (CAR G167024)) + (SPADLET LIST (CADR G167024)) + G167024) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |code| + (CONS + (CONS 'COND + (CONS + (CONS |pred| + (CONS + (CONS 'LET + (CONS |localVariable| + (CONS + (CONS '|mergeAppend| + (CONS + (CONS '|mapConsDB| + (CONS (MKQ LIST) + NIL)) + (CONS + |localVariable| + NIL))) + NIL))) + NIL)) + NIL)) + |code|))))) + (SPADLET |code| + (CONS 'PROGN + (NREVERSE + (CONS + (CONS 'NREVERSE + (CONS |localVariable| NIL)) + |code|)))))) + (SPADLET |g| (GENSYM)) + (CONS |$setelt| + (CONS '$ + (CONS 4 + (CONS (CONS 'PROG2 + (CONS + (CONS 'LET + (CONS |g| (CONS |code| NIL))) + (CONS + (CONS 'VECTOR + (CONS + (CONS + '|catList2catPackageList| + (CONS |g| NIL)) + (CONS |g| NIL))) + NIL))) + NIL))))))))) + +;NRTsetVector4Part1(siglist,formlist,condlist) == +; $uncondList: local := nil +; $condList: local := nil +; $count: local := 0 +; for sig in reverse siglist for form in reverse formlist +; for cond in reverse condlist repeat +; NRTsetVector4a(sig,form,cond) +; reducedUncondlist := REMDUP $uncondList +; reducedConlist := +; [[x,:y] for [x,z] in $condList| y := SETDIFFERENCE(z,reducedUncondlist)] +; revCondlist := reverseCondlist reducedConlist +; orCondlist := [[x,:MKPF(y,'OR)] for [x,:y] in revCondlist] +; [reducedUncondlist,:orCondlist] + +(DEFUN |NRTsetVector4Part1| (|siglist| |formlist| |condlist|) + (PROG (|$uncondList| |$condList| |$count| |reducedUncondlist| |z| + |reducedConlist| |revCondlist| |x| |y| |orCondlist|) + (DECLARE (SPECIAL |$uncondList| |$condList| |$count|)) + (RETURN + (SEQ (PROGN + (SPADLET |$uncondList| NIL) + (SPADLET |$condList| NIL) + (SPADLET |$count| 0) + (DO ((G167095 (REVERSE |siglist|) (CDR G167095)) + (|sig| NIL) + (G167096 (REVERSE |formlist|) (CDR G167096)) + (|form| NIL) + (G167097 (REVERSE |condlist|) (CDR G167097)) + (|cond| NIL)) + ((OR (ATOM G167095) + (PROGN (SETQ |sig| (CAR G167095)) NIL) + (ATOM G167096) + (PROGN (SETQ |form| (CAR G167096)) NIL) + (ATOM G167097) + (PROGN (SETQ |cond| (CAR G167097)) NIL)) + NIL) + (SEQ (EXIT (|NRTsetVector4a| |sig| |form| |cond|)))) + (SPADLET |reducedUncondlist| (REMDUP |$uncondList|)) + (SPADLET |reducedConlist| + (PROG (G167115) + (SPADLET G167115 NIL) + (RETURN + (DO ((G167122 |$condList| (CDR G167122)) + (G167081 NIL)) + ((OR (ATOM G167122) + (PROGN + (SETQ G167081 (CAR G167122)) + NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G167081)) + (SPADLET |z| (CADR G167081)) + G167081) + NIL)) + (NREVERSE0 G167115)) + (SEQ (EXIT (COND + ((SPADLET |y| + (SETDIFFERENCE |z| + |reducedUncondlist|)) + (SETQ G167115 + (CONS (CONS |x| |y|) + G167115)))))))))) + (SPADLET |revCondlist| + (|reverseCondlist| |reducedConlist|)) + (SPADLET |orCondlist| + (PROG (G167134) + (SPADLET G167134 NIL) + (RETURN + (DO ((G167140 |revCondlist| + (CDR G167140)) + (G167085 NIL)) + ((OR (ATOM G167140) + (PROGN + (SETQ G167085 (CAR G167140)) + NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G167085)) + (SPADLET |y| (CDR G167085)) + G167085) + NIL)) + (NREVERSE0 G167134)) + (SEQ (EXIT (SETQ G167134 + (CONS (CONS |x| (MKPF |y| 'OR)) + G167134)))))))) + (CONS |reducedUncondlist| |orCondlist|)))))) + +; --NRTsetVector4a(first siglist,first formlist,first condlist) +;reverseCondlist cl == +; alist := nil +; for [x,:y] in cl repeat +; for z in y repeat +; u := ASSOC(z,alist) +; null u => alist := [[z,x],:alist] +; MEMBER(x,CDR u) => nil +; RPLACD(u,[x,:CDR u]) +; alist + +(DEFUN |reverseCondlist| (|cl|) + (PROG (|x| |y| |u| |alist|) + (RETURN + (SEQ (PROGN + (SPADLET |alist| NIL) + (DO ((G167182 |cl| (CDR G167182)) (G167171 NIL)) + ((OR (ATOM G167182) + (PROGN (SETQ G167171 (CAR G167182)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G167171)) + (SPADLET |y| (CDR G167171)) + G167171) + NIL)) + NIL) + (SEQ (EXIT (DO ((G167194 |y| (CDR G167194)) + (|z| NIL)) + ((OR (ATOM G167194) + (PROGN + (SETQ |z| (CAR G167194)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |u| + (|assoc| |z| |alist|)) + (COND + ((NULL |u|) + (SPADLET |alist| + (CONS + (CONS |z| (CONS |x| NIL)) + |alist|))) + ((|member| |x| (CDR |u|)) + NIL) + ('T + (RPLACD |u| + (CONS |x| (CDR |u|)))))))))))) + |alist|))))) + +;NRTsetVector4Part2(uncondList,condList) == +; $lisplibCategoriesExtended:= [uncondList,:condList] +; code := ['mapConsDB,MKQ REVERSE REMDUP uncondList] +; if condList then +; localVariable := GENSYM() +; code := [['LET,localVariable,code]] +; for [pred,list] in condList repeat +; code := +; [['COND,[predicateBitRef SUBLIS($pairlis,pred),['LET,localVariable, +; ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]], +; :code] +; code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]] +; g := GENSYM() +; [$setelt,'$,4,['PROG2,['LET,g,code], +; ['VECTOR,['catList2catPackageList,g],g]]] + +(DEFUN |NRTsetVector4Part2| (|uncondList| |condList|) + (PROG (|localVariable| |pred| LIST |code| |g|) + (declare (special |$setelt| |$pairlis| |$lisplibCategoriesExtended|)) + (RETURN + (SEQ (PROGN + (SPADLET |$lisplibCategoriesExtended| + (CONS |uncondList| |condList|)) + (SPADLET |code| + (CONS '|mapConsDB| + (CONS (MKQ (REVERSE (REMDUP |uncondList|))) + NIL))) + (COND + (|condList| (SPADLET |localVariable| (GENSYM)) + (SPADLET |code| + (CONS (CONS 'LET + (CONS |localVariable| + (CONS |code| NIL))) + NIL)) + (DO ((G167218 |condList| (CDR G167218)) + (G167208 NIL)) + ((OR (ATOM G167218) + (PROGN + (SETQ G167208 (CAR G167218)) + NIL) + (PROGN + (PROGN + (SPADLET |pred| (CAR G167208)) + (SPADLET LIST (CADR G167208)) + G167208) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |code| + (CONS + (CONS 'COND + (CONS + (CONS + (|predicateBitRef| + (SUBLIS |$pairlis| + |pred|)) + (CONS + (CONS 'LET + (CONS |localVariable| + (CONS + (CONS '|mergeAppend| + (CONS + (CONS '|mapConsDB| + (CONS (MKQ LIST) + NIL)) + (CONS + |localVariable| + NIL))) + NIL))) + NIL)) + NIL)) + |code|))))) + (SPADLET |code| + (CONS 'PROGN + (NREVERSE + (CONS + (CONS 'NREVERSE + (CONS |localVariable| NIL)) + |code|)))))) + (SPADLET |g| (GENSYM)) + (CONS |$setelt| + (CONS '$ + (CONS 4 + (CONS (CONS 'PROG2 + (CONS + (CONS 'LET + (CONS |g| (CONS |code| NIL))) + (CONS + (CONS 'VECTOR + (CONS + (CONS + '|catList2catPackageList| + (CONS |g| NIL)) + (CONS |g| NIL))) + NIL))) + NIL))))))))) + +;mergeAppend(l1,l2) == +; ATOM l1 => l2 +; member(QCAR l1,l2) => mergeAppend(QCDR l1, l2) +; CONS(QCAR l1, mergeAppend(QCDR l1, l2)) + +(DEFUN |mergeAppend| (|l1| |l2|) + (COND + ((ATOM |l1|) |l2|) + ((|member| (QCAR |l1|) |l2|) (|mergeAppend| (QCDR |l1|) |l2|)) + ('T (CONS (QCAR |l1|) (|mergeAppend| (QCDR |l1|) |l2|))))) + +;--genLoadTimeValue u == +;-- name := +;-- INTERN STRCONC(PNAME first $definition,'";",STRINGIZE($count:=$count+1)) +;-- $NRTloadTimeAlist := [[name,:['addConsDB,MKQ u]],:$NRTloadTimeAlist] +;-- --see compDefineFunctor1 +;-- name +;catList2catPackageList u == +;--converts ((Set) (Module R) ...) to ((Set& $) (Module& $ R)...) +; [fn x for x in u] where +; fn [op,:argl] == +; newOp := INTERN(STRCONC(PNAME op,"&")) +; addConsDB [newOp,"$",:argl] + +(DEFUN |catList2catPackageList,fn| (G167242) + (PROG (|op| |argl| |newOp|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR G167242)) + (SPADLET |argl| (CDR G167242)) + G167242 + (SEQ (SPADLET |newOp| (INTERN (STRCONC (PNAME |op|) '&))) + (EXIT (|addConsDB| (CONS |newOp| (CONS '$ |argl|)))))))))) + +(DEFUN |catList2catPackageList| (|u|) + (PROG () + (RETURN + (SEQ (PROG (G167262) + (SPADLET G167262 NIL) + (RETURN + (DO ((G167267 |u| (CDR G167267)) (|x| NIL)) + ((OR (ATOM G167267) + (PROGN (SETQ |x| (CAR G167267)) NIL)) + (NREVERSE0 G167262)) + (SEQ (EXIT (SETQ G167262 + (CONS (|catList2catPackageList,fn| + |x|) + G167262))))))))))) + +;NRTsetVector4a(sig,form,cond) == +; sig = '$ => +; domainList := +; [optimize COPY KAR comp(d,$EmptyMode,$e) or d for d in $domainShell.4.0] +; $uncondList := APPEND(domainList,$uncondList) +; if isCategoryForm(form,$e) then $uncondList := [form,:$uncondList] +; $uncondList +; evalform := eval mkEvalableCategoryForm form +; cond = true => $uncondList := [form,:APPEND(evalform.4.0,$uncondList)] +; $condList := [[cond,[form,:evalform.4.0]],:$condList] + +(DEFUN |NRTsetVector4a| (|sig| |form| |cond|) + (PROG (|domainList| |evalform|) + (declare (special |$condList| |$uncondList| |$e| |$EmptyMode| + |$domainShell|)) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |sig| '$) + (SPADLET |domainList| + (PROG (G167283) + (SPADLET G167283 NIL) + (RETURN + (DO ((G167288 + (ELT (ELT |$domainShell| 4) 0) + (CDR G167288)) + (|d| NIL)) + ((OR (ATOM G167288) + (PROGN + (SETQ |d| (CAR G167288)) + NIL)) + (NREVERSE0 G167283)) + (SEQ (EXIT (SETQ G167283 + (CONS + (OR + (|optimize| + (COPY + (KAR + (|comp| |d| |$EmptyMode| + |$e|)))) + |d|) + G167283)))))))) + (SPADLET |$uncondList| + (APPEND |domainList| |$uncondList|)) + (COND + ((|isCategoryForm| |form| |$e|) + (SPADLET |$uncondList| (CONS |form| |$uncondList|)))) + |$uncondList|) + ('T + (SPADLET |evalform| + (|eval| (|mkEvalableCategoryForm| |form|))) + (COND + ((BOOT-EQUAL |cond| 'T) + (SPADLET |$uncondList| + (CONS |form| + (APPEND (ELT (ELT |evalform| 4) 0) + |$uncondList|)))) + ('T + (SPADLET |$condList| + (CONS (CONS |cond| + (CONS + (CONS |form| + (ELT (ELT |evalform| 4) 0)) + NIL)) + |$condList|)))))))))) + +;NRTmakeSlot1 domainShell == +; opDirectName := INTERN STRCONC(PNAME first $definition,'";opDirect") +; fun := +; $NRTmakeCompactDirect => '(function lookupInCompactTable) +; '(function lookupInTable) +; [($QuickCode=>'QSETREFV;'SETELT), '$,1, ['LIST,fun,'$,opDirectName]] + +(DEFUN |NRTmakeSlot1| (|domainShell|) + (declare (ignore |domainShell|)) + (PROG (|opDirectName| |fun|) + (declare (special |$QuickCode| |$NRTmakeCompactDirect| |$definition|)) + (RETURN + (PROGN + (SPADLET |opDirectName| + (INTERN (STRCONC (PNAME (CAR |$definition|)) + (MAKESTRING ";opDirect")))) + (SPADLET |fun| + (COND + (|$NRTmakeCompactDirect| + '(|function| |lookupInCompactTable|)) + ('T '(|function| |lookupInTable|)))) + (CONS (COND (|$QuickCode| 'QSETREFV) ('T 'SETELT)) + (CONS '$ + (CONS 1 + (CONS (CONS 'LIST + (CONS |fun| + (CONS '$ + (CONS |opDirectName| NIL)))) + NIL)))))))) + +;NRTmakeSlot1Info() == +;-- 4 cases: +;-- a:T == b add c --- slot1 directory has #s for entries defined in c +;-- a:T == b --- slot1 has all slot #s = NIL (see compFunctorBody) +;-- a == b add c --- not allowed (line 7 of getTargetFromRhs) +;-- a == b --- $NRTderivedTargetIfTrue = true; set directory to NIL +; pairlis := +; $insideCategoryPackageIfTrue = true => +; [:argl,dollarName] := rest $form +; [[dollarName,:'_$],:mkSlot1sublis argl] +; mkSlot1sublis rest $form +; $lisplibOpAlist := transformOperationAlist SUBLIS(pairlis,$domainShell.1) +; opList := +; $NRTderivedTargetIfTrue => 'derived +; $insideCategoryPackageIfTrue = true => slot1Filter $lisplibOpAlist +; $lisplibOpAlist +; addList := SUBLIS(pairlis,$NRTaddForm) +; [first $form,[addList,:opList]] + +(DEFUN |NRTmakeSlot1Info| () + (PROG (|LETTMP#1| |LETTMP#2| |dollarName| |argl| |pairlis| |opList| + |addList|) + (declare (special |$form| |$NRTaddForm| |$lisplibOpAlist| |$domainShell| + |$insideCategoryPackageIfTrue| |$NRTderivedTargetIfTrue|)) + (RETURN + (PROGN + (SPADLET |pairlis| + (COND + ((BOOT-EQUAL |$insideCategoryPackageIfTrue| 'T) + (SPADLET |LETTMP#1| (CDR |$form|)) + (SPADLET |LETTMP#2| (REVERSE |LETTMP#1|)) + (SPADLET |dollarName| (CAR |LETTMP#2|)) + (SPADLET |argl| (NREVERSE (CDR |LETTMP#2|))) + (CONS (CONS |dollarName| '$) + (|mkSlot1sublis| |argl|))) + ('T (|mkSlot1sublis| (CDR |$form|))))) + (SPADLET |$lisplibOpAlist| + (|transformOperationAlist| + (SUBLIS |pairlis| (ELT |$domainShell| 1)))) + (SPADLET |opList| + (COND + (|$NRTderivedTargetIfTrue| '|derived|) + ((BOOT-EQUAL |$insideCategoryPackageIfTrue| 'T) + (|slot1Filter| |$lisplibOpAlist|)) + ('T |$lisplibOpAlist|))) + (SPADLET |addList| (SUBLIS |pairlis| |$NRTaddForm|)) + (CONS (CAR |$form|) (CONS (CONS |addList| |opList|) NIL)))))) + +;mkSlot1sublis argl == +; [[a,:b] for a in argl for b in $FormalMapVariableList] + +(DEFUN |mkSlot1sublis| (|argl|) + (PROG () + (declare (special |$FormalMapVariableList|)) + (RETURN + (SEQ (PROG (G167341) + (SPADLET G167341 NIL) + (RETURN + (DO ((G167347 |argl| (CDR G167347)) (|a| NIL) + (G167348 |$FormalMapVariableList| + (CDR G167348)) + (|b| NIL)) + ((OR (ATOM G167347) + (PROGN (SETQ |a| (CAR G167347)) NIL) + (ATOM G167348) + (PROGN (SETQ |b| (CAR G167348)) NIL)) + (NREVERSE0 G167341)) + (SEQ (EXIT (SETQ G167341 + (CONS (CONS |a| |b|) G167341))))))))))) + +;slot1Filter opList == +;--include only those ops which are defined within the capsule +; [u for x in opList | u := fn x] where +; fn [op,:l] == +; u := [entry for entry in l | INTEGERP CADR entry] => [op,:u] +; nil + +(DEFUN |slot1Filter,fn| (G167362) + (PROG (|op| |l| |u|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR G167362)) + (SPADLET |l| (CDR G167362)) + G167362 + (SEQ (IF (SPADLET |u| + (PROG (G167376) + (SPADLET G167376 NIL) + (RETURN + (DO + ((G167382 |l| (CDR G167382)) + (|entry| NIL)) + ((OR (ATOM G167382) + (PROGN + (SETQ |entry| (CAR G167382)) + NIL)) + (NREVERSE0 G167376)) + (SEQ + (EXIT + (COND + ((INTEGERP (CADR |entry|)) + (SETQ G167376 + (CONS |entry| G167376)))))))))) + (EXIT (CONS |op| |u|))) + (EXIT NIL))))))) + +(DEFUN |slot1Filter| (|opList|) + (PROG (|u|) + (RETURN + (SEQ (PROG (G167401) + (SPADLET G167401 NIL) + (RETURN + (DO ((G167407 |opList| (CDR G167407)) (|x| NIL)) + ((OR (ATOM G167407) + (PROGN (SETQ |x| (CAR G167407)) NIL)) + (NREVERSE0 G167401)) + (SEQ (EXIT (COND + ((SPADLET |u| (|slot1Filter,fn| |x|)) + (SETQ G167401 (CONS |u| G167401))))))))))))) + +;NRToptimizeHas u == +;--u is a list ((pred cond)...) -- see optFunctorBody +;--produces an alist: (((HasCategory a b) . GENSYM)...) +; u is [a,:b] => +; a='HasCategory => LASSOC(u,$hasCategoryAlist) or +; $hasCategoryAlist := [[u,:(y:=GENSYM())],:$hasCategoryAlist] +; y +; a='has => NRToptimizeHas ['HasCategory,first b,MKQ first rest b] +; a = 'QUOTE => u +; [NRToptimizeHas a,:NRToptimizeHas b] +; u + +(DEFUN |NRToptimizeHas| (|u|) + (PROG (|a| |b| |y|) + (declare (special |$hasCategoryAlist|)) + (RETURN + (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |a| (QCAR |u|)) + (SPADLET |b| (QCDR |u|)) + 'T)) + (COND + ((BOOT-EQUAL |a| '|HasCategory|) + (OR (LASSOC |u| |$hasCategoryAlist|) + (PROGN + (SPADLET |$hasCategoryAlist| + (CONS (CONS |u| (SPADLET |y| (GENSYM))) + |$hasCategoryAlist|)) + |y|))) + ((BOOT-EQUAL |a| '|has|) + (|NRToptimizeHas| + (CONS '|HasCategory| + (CONS (CAR |b|) (CONS (MKQ (CAR (CDR |b|))) NIL))))) + ((BOOT-EQUAL |a| 'QUOTE) |u|) + ('T (CONS (|NRToptimizeHas| |a|) (|NRToptimizeHas| |b|))))) + ('T |u|))))) + +;NRTaddToSlam([name,:argnames],shell) == +; $mutableDomain => return nil +; null argnames => addToConstructorCache(name,nil,shell) +; args:= ['LIST,:ASSOCRIGHT $devaluateList] +; addToConstructorCache(name,args,shell) + +(DEFUN |NRTaddToSlam| (G167432 |shell|) + (PROG (|name| |argnames| |args|) + (declare (special |$devaluateList| |$mutableDomain|)) + (RETURN + (PROGN + (SPADLET |name| (CAR G167432)) + (SPADLET |argnames| (CDR G167432)) + (COND + (|$mutableDomain| (RETURN NIL)) + ((NULL |argnames|) + (|addToConstructorCache| |name| NIL |shell|)) + ('T + (SPADLET |args| (CONS 'LIST (ASSOCRIGHT |$devaluateList|))) + (|addToConstructorCache| |name| |args| |shell|))))))) + +;changeDirectoryInSlot1() == --called by NRTbuildFunctor +; --3 cases: +; -- if called inside NRTbuildFunctor, $NRTdeltaLength gives different locs +; -- otherwise called from compFunctorBody (all lookups are forwarded): +; -- $NRTdeltaList = nil ===> all slot numbers become nil +; $lisplibOperationAlist := [sigloc entry for entry in $domainShell.1] where +; sigloc [opsig,pred,fnsel] == +; if pred ^= 'T then +; pred := simpBool pred +; $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) +; fnsel is [op,a,:.] and (op = 'ELT or op = 'CONST) => +; if $insideCategoryPackageIfTrue then +; opsig := substitute('$,CADR($functorForm),opsig) +; [opsig,pred,[op,a,vectorLocation(first opsig,CADR opsig)]] +; [opsig,pred,fnsel] +; sortedOplist := listSort(function GLESSEQP, +; COPY_-LIST $lisplibOperationAlist,function CADR) +; $lastPred :local := nil +; $newEnv :local := $e +; $domainShell.1 := [fn entry for entry in sortedOplist] where +; fn [[op,sig],pred,fnsel] == +; if $lastPred ^= pred then +; $newEnv := deepChaseInferences(pred,$e) +; $lastPred := pred +; newfnsel := +; fnsel is ['Subsumed,op1,sig1] => +; ['Subsumed,op1,genSlotSig(sig1,'T,$newEnv)] +; fnsel +; [[op, genSlotSig(sig,pred,$newEnv)] ,pred,newfnsel] + +(DEFUN |changeDirectoryInSlot1,sigloc| (G167459) + (PROG (|fnsel| |pred| |op| |ISTMP#1| |a| |opsig|) + (declare (special |$functorForm| |$insideCategoryPackageIfTrue| + |$NRTslot1PredicateList|)) + (RETURN + (SEQ (PROGN + (SPADLET |opsig| (CAR G167459)) + (SPADLET |pred| (CADR G167459)) + (SPADLET |fnsel| (CADDR G167459)) + G167459 + (SEQ (IF (NEQUAL |pred| 'T) + (SEQ (SPADLET |pred| (|simpBool| |pred|)) + (EXIT (SPADLET |$NRTslot1PredicateList| + (|insert| |pred| + |$NRTslot1PredicateList|)))) + NIL) + (IF (AND (AND (PAIRP |fnsel|) + (PROGN + (SPADLET |op| (QCAR |fnsel|)) + (SPADLET |ISTMP#1| (QCDR |fnsel|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + 'T)))) + (OR (BOOT-EQUAL |op| 'ELT) + (BOOT-EQUAL |op| 'CONST))) + (EXIT (SEQ (IF |$insideCategoryPackageIfTrue| + (SPADLET |opsig| + (MSUBST '$ (CADR |$functorForm|) + |opsig|)) + NIL) + (EXIT (CONS |opsig| + (CONS |pred| + (CONS + (CONS |op| + (CONS |a| + (CONS + (|vectorLocation| + (CAR |opsig|) + (CADR |opsig|)) + NIL))) + NIL))))))) + (EXIT (CONS |opsig| (CONS |pred| (CONS |fnsel| NIL)))))))))) + +(DEFUN |changeDirectoryInSlot1,fn| (G167507) + (PROG (|op| |sig| |pred| |fnsel| |ISTMP#1| |op1| |ISTMP#2| |sig1| + |newfnsel|) + (declare (special |$newEnv| |$lastPred| |$e|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAAR G167507)) + (SPADLET |sig| (CADAR G167507)) + (SPADLET |pred| (CADR G167507)) + (SPADLET |fnsel| (CADDR G167507)) + G167507 + (SEQ (IF (NEQUAL |$lastPred| |pred|) + (SEQ (SPADLET |$newEnv| + (|deepChaseInferences| |pred| |$e|)) + (EXIT (SPADLET |$lastPred| |pred|))) + NIL) + (SPADLET |newfnsel| + (SEQ (IF (AND (PAIRP |fnsel|) + (EQ (QCAR |fnsel|) '|Subsumed|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |fnsel|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op1| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |sig1| + (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT + (CONS '|Subsumed| + (CONS |op1| + (CONS + (|genSlotSig| |sig1| 'T + |$newEnv|) + NIL))))) + (EXIT |fnsel|))) + (EXIT (CONS (CONS |op| + (CONS + (|genSlotSig| |sig| |pred| + |$newEnv|) + NIL)) + (CONS |pred| (CONS |newfnsel| NIL)))))))))) + +(DEFUN |changeDirectoryInSlot1| () + (PROG (|$lastPred| |$newEnv| |sortedOplist|) + (DECLARE (SPECIAL |$lastPred| |$newEnv| |$domainShell| + |$lisplibOperationAlist|)) + (RETURN + (SEQ (PROGN + (SPADLET |$lisplibOperationAlist| + (PROG (G167547) + (SPADLET G167547 NIL) + (RETURN + (DO ((G167552 (ELT |$domainShell| 1) + (CDR G167552)) + (|entry| NIL)) + ((OR (ATOM G167552) + (PROGN + (SETQ |entry| (CAR G167552)) + NIL)) + (NREVERSE0 G167547)) + (SEQ (EXIT (SETQ G167547 + (CONS + (|changeDirectoryInSlot1,sigloc| + |entry|) + G167547)))))))) + (SPADLET |sortedOplist| + (|listSort| (|function| GLESSEQP) + (COPY-LIST |$lisplibOperationAlist|) + (|function| CADR))) + (SPADLET |$lastPred| NIL) + (SPADLET |$newEnv| |$e|) + (SETELT |$domainShell| 1 + (PROG (G167562) + (SPADLET G167562 NIL) + (RETURN + (DO ((G167567 |sortedOplist| + (CDR G167567)) + (|entry| NIL)) + ((OR (ATOM G167567) + (PROGN + (SETQ |entry| (CAR G167567)) + NIL)) + (NREVERSE0 G167562)) + (SEQ (EXIT (SETQ G167562 + (CONS + (|changeDirectoryInSlot1,fn| + |entry|) + G167562))))))))))))) + +;genSlotSig(sig,pred,$e) == +; [genDeltaSig t for t in sig] + +(DEFUN |genSlotSig| (|sig| |pred| |$e|) + (DECLARE (SPECIAL |$e|) (ignore |pred|)) + (PROG () + (RETURN + (SEQ (PROG (G167590) + (SPADLET G167590 NIL) + (RETURN + (DO ((G167595 |sig| (CDR G167595)) (|t| NIL)) + ((OR (ATOM G167595) + (PROGN (SETQ |t| (CAR G167595)) NIL)) + (NREVERSE0 G167590)) + (SEQ (EXIT (SETQ G167590 + (CONS (|genDeltaSig| |t|) G167590))))))))))) + +;deepChaseInferences(pred,$e) == +; pred is ['AND,:preds] or pred is ['and,:preds] => +; for p in preds repeat $e := deepChaseInferences(p,$e) +; $e +; pred is ['OR,pred1,:.] or pred is ['or,pred1,:.] => +; deepChaseInferences(pred1,$e) +; pred is 'T or pred is ['NOT,:.] or pred is ['not,:.] => $e +; chaseInferences(pred,$e) + +(DEFUN |deepChaseInferences| (|pred| |$e|) + (DECLARE (SPECIAL |$e|)) + (PROG (|preds| |ISTMP#1| |pred1|) + (RETURN + (SEQ (COND + ((OR (AND (PAIRP |pred|) (EQ (QCAR |pred|) 'AND) + (PROGN (SPADLET |preds| (QCDR |pred|)) 'T)) + (AND (PAIRP |pred|) (EQ (QCAR |pred|) '|and|) + (PROGN (SPADLET |preds| (QCDR |pred|)) 'T))) + (DO ((G167619 |preds| (CDR G167619)) (|p| NIL)) + ((OR (ATOM G167619) + (PROGN (SETQ |p| (CAR G167619)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |$e| + (|deepChaseInferences| |p| |$e|))))) + |$e|) + ((OR (AND (PAIRP |pred|) (EQ (QCAR |pred|) 'OR) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pred1| (QCAR |ISTMP#1|)) + 'T)))) + (AND (PAIRP |pred|) (EQ (QCAR |pred|) '|or|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pred1| (QCAR |ISTMP#1|)) + 'T))))) + (|deepChaseInferences| |pred1| |$e|)) + ((OR (EQ |pred| 'T) + (AND (PAIRP |pred|) (EQ (QCAR |pred|) 'NOT)) + (AND (PAIRP |pred|) (EQ (QCAR |pred|) '|not|))) + |$e|) + ('T (|chaseInferences| |pred| |$e|))))))) + +;vectorLocation(op,sig) == +; u := or/[i for i in 1.. for u in $NRTdeltaList +; | u is [=op,[='$,: xsig],:.] and sig=NRTsubstDelta(xsig) ] +; u => $NRTdeltaLength - u + 6 +; nil -- this signals that calls should be forwarded + +(DEFUN |vectorLocation| (|op| |sig|) + (PROG (|ISTMP#1| |ISTMP#2| |xsig| |u|) + (declare (special |$NRTdeltaLength| |$NRTdeltaList|)) + (RETURN + (SEQ (PROGN + (SPADLET |u| + (PROG (G167647) + (SPADLET G167647 NIL) + (RETURN + (DO ((G167655 NIL G167647) + (|i| 1 (QSADD1 |i|)) + (G167656 |$NRTdeltaList| + (CDR G167656)) + (|u| NIL)) + ((OR G167655 (ATOM G167656) + (PROGN + (SETQ |u| (CAR G167656)) + NIL)) + G167647) + (SEQ (EXIT (COND + ((AND (PAIRP |u|) + (EQUAL (QCAR |u|) |op|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQUAL + (QCAR |ISTMP#2|) '$) + (PROGN + (SPADLET |xsig| + (QCDR |ISTMP#2|)) + 'T))))) + (BOOT-EQUAL |sig| + (|NRTsubstDelta| |xsig|))) + (SETQ G167647 + (OR G167647 |i|)))))))))) + (COND + (|u| (PLUS (SPADDIFFERENCE |$NRTdeltaLength| |u|) 6)) + ('T NIL))))))) + +;NRTsubstDelta(initSig) == +; sig := [replaceSlotTypes s for s in initSig] where +; replaceSlotTypes(t) == +; atom t => +; not INTEGERP t => t +; t = 0 => '$ +; t = 2 => '_$_$ +; t = 5 => $NRTaddForm +; u:= $NRTdeltaList.($NRTdeltaLength+5-t) +; CAR u = 'domain => CADR u +; error "bad $NRTdeltaList entry" +; MEMQ(CAR t,'(Mapping Union Record _:)) => +; [CAR t,:[replaceSlotTypes(x) for x in rest t]] +; t + +(DEFUN |NRTsubstDelta,replaceSlotTypes| (|t|) + (PROG (|u|) + (declare (special |$NRTdeltaLength| |$NRTdeltaList| |$NRTaddForm|)) + (RETURN + (SEQ (IF (ATOM |t|) + (EXIT (SEQ (IF (NULL (INTEGERP |t|)) (EXIT |t|)) + (IF (EQL |t| 0) (EXIT '$)) + (IF (EQL |t| 2) (EXIT '$$)) + (IF (EQL |t| 5) (EXIT |$NRTaddForm|)) + (SPADLET |u| + (ELT |$NRTdeltaList| + (SPADDIFFERENCE + (PLUS |$NRTdeltaLength| 5) |t|))) + (IF (BOOT-EQUAL (CAR |u|) '|domain|) + (EXIT (CADR |u|))) + (EXIT (|error| '|bad $NRTdeltaList entry|))))) + (IF (MEMQ (CAR |t|) '(|Mapping| |Union| |Record| |:|)) + (EXIT (CONS (CAR |t|) + (PROG (G167677) + (SPADLET G167677 NIL) + (RETURN + (DO ((G167682 (CDR |t|) + (CDR G167682)) + (|x| NIL)) + ((OR (ATOM G167682) + (PROGN + (SETQ |x| (CAR G167682)) + NIL)) + (NREVERSE0 G167677)) + (SEQ (EXIT + (SETQ G167677 + (CONS + (|NRTsubstDelta,replaceSlotTypes| + |x|) + G167677)))))))))) + (EXIT |t|))))) + +(DEFUN |NRTsubstDelta| (|initSig|) + (PROG (|sig|) + (RETURN + (SEQ (SPADLET |sig| + (PROG (G167698) + (SPADLET G167698 NIL) + (RETURN + (DO ((G167703 |initSig| (CDR G167703)) + (|s| NIL)) + ((OR (ATOM G167703) + (PROGN + (SETQ |s| (CAR G167703)) + NIL)) + (NREVERSE0 G167698)) + (SEQ (EXIT (SETQ G167698 + (CONS + (|NRTsubstDelta,replaceSlotTypes| + |s|) + G167698)))))))))))) + +;-----------------------------SLOT1 DATABASE------------------------------------ +;updateSlot1DataBase [name,info] == HPUT($Slot1DataBase,name,info) + +(DEFUN |updateSlot1DataBase| (G167714) + (PROG (|name| |info|) + (declare (special |$Slot1DataBase|)) + (RETURN + (PROGN + (SPADLET |name| (CAR G167714)) + (SPADLET |info| (CADR G167714)) + (HPUT |$Slot1DataBase| |name| |info|))))) + +;NRTputInLocalReferences bod == +; $elt: local := ($QuickCode => 'QREFELT; 'ELT) +; NRTputInHead bod + +(DEFUN |NRTputInLocalReferences| (|bod|) + (PROG (|$elt|) + (DECLARE (SPECIAL |$elt| |$QuickCode|)) + (RETURN + (PROGN + (SPADLET |$elt| (COND (|$QuickCode| 'QREFELT) ('T 'ELT))) + (|NRTputInHead| |bod|))))) + +;NRTputInHead bod == +; atom bod => bod +;-- LASSOC(bod,$devaluateList) => nil +;-- k:= NRTassocIndex bod => [$elt,'_$,k] +;-- systemError '"unexpected position of domain reference" +;-- bod +;--bod is ['LET,var,val,:extra] and IDENTP var => +;-- NRTputInTail extra +;-- k:= NRTassocIndex var => RPLAC(CADDR bod,[$elt,'$,k]) +;-- NRTputInHead val +;-- bod +; bod is ['SPADCALL,:args,fn] => +; NRTputInTail rest bod --NOTE: args = COPY of rest bod +; -- The following test allows function-returning expressions +; fn is [elt,dom,ind] and not (dom='$) and MEMQ(elt,'(ELT QREFELT CONST)) => +; k:= NRTassocIndex dom => RPLACA(LASTNODE bod,[$elt,'_$,k]) +;-- sayBrightlyNT '"unexpected SPADCALL:" +;-- pp fn +;-- nil +;-- keyedSystemError("S2GE0016",['"NRTputInHead", +;-- '"unexpected SPADCALL form"]) +; nil +; NRTputInHead fn +; bod +; bod is ["COND",:clauses] => +; for cc in clauses repeat NRTputInTail cc +; bod +; bod is ["QUOTE",:.] => bod +; bod is ["CLOSEDFN",:.] => bod +; bod is ["SPADCONST",dom,ind] => +; RPLACA(bod,$elt) +; dom = '_$ => nil +; k:= NRTassocIndex dom => +; RPLACA(LASTNODE bod,[$elt,'_$,k]) +; bod +; keyedSystemError("S2GE0016",['"NRTputInHead", +; '"unexpected SPADCONST form"]) +; NRTputInHead first bod +; NRTputInTail rest bod +; bod + +(DEFUN |NRTputInHead| (|bod|) + (PROG (|fn| |args| |elt| |clauses| |ISTMP#1| |dom| |ISTMP#2| |ind| |k|) + (declare (special |$elt|)) + (RETURN + (SEQ (COND + ((ATOM |bod|) |bod|) + ((AND (PAIRP |bod|) (EQ (QCAR |bod|) 'SPADCALL) + (PROGN + (SPADLET |ISTMP#1| (QCDR |bod|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |fn| (QCAR |ISTMP#2|)) + (SPADLET |args| (QCDR |ISTMP#2|)) + 'T) + (PROGN + (SPADLET |args| (NREVERSE |args|)) + 'T)))) + (|NRTputInTail| (CDR |bod|)) + (COND + ((AND (PAIRP |fn|) + (PROGN + (SPADLET |elt| (QCAR |fn|)) + (SPADLET |ISTMP#1| (QCDR |fn|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |dom| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ind| (QCAR |ISTMP#2|)) + 'T))))) + (NULL (BOOT-EQUAL |dom| '$)) + (MEMQ |elt| '(ELT QREFELT CONST))) + (COND + ((SPADLET |k| (|NRTassocIndex| |dom|)) + (RPLACA (LASTNODE |bod|) + (CONS |$elt| (CONS '$ (CONS |k| NIL))))) + ('T NIL))) + ('T (|NRTputInHead| |fn|) |bod|))) + ((AND (PAIRP |bod|) (EQ (QCAR |bod|) 'COND) + (PROGN (SPADLET |clauses| (QCDR |bod|)) 'T)) + (DO ((G167797 |clauses| (CDR G167797)) (|cc| NIL)) + ((OR (ATOM G167797) + (PROGN (SETQ |cc| (CAR G167797)) NIL)) + NIL) + (SEQ (EXIT (|NRTputInTail| |cc|)))) + |bod|) + ((AND (PAIRP |bod|) (EQ (QCAR |bod|) 'QUOTE)) |bod|) + ((AND (PAIRP |bod|) (EQ (QCAR |bod|) 'CLOSEDFN)) |bod|) + ((AND (PAIRP |bod|) (EQ (QCAR |bod|) 'SPADCONST) + (PROGN + (SPADLET |ISTMP#1| (QCDR |bod|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |dom| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ind| (QCAR |ISTMP#2|)) + 'T)))))) + (RPLACA |bod| |$elt|) + (COND + ((BOOT-EQUAL |dom| '$) NIL) + ((SPADLET |k| (|NRTassocIndex| |dom|)) + (RPLACA (LASTNODE |bod|) + (CONS |$elt| (CONS '$ (CONS |k| NIL)))) + |bod|) + ('T + (|keyedSystemError| 'S2GE0016 + (CONS (MAKESTRING "NRTputInHead") + (CONS (MAKESTRING + "unexpected SPADCONST form") + NIL)))))) + ('T (|NRTputInHead| (CAR |bod|)) + (|NRTputInTail| (CDR |bod|)) |bod|)))))) + +;NRTputInTail x == +; for y in tails x repeat +; atom (u := first y) => +; EQ(u,'$) or LASSOC(u,$devaluateList) => nil +; k:= NRTassocIndex u => +; atom u => RPLACA(y,[$elt,'_$,k]) +; -- u atomic means that the slot will always contain a vector +; RPLACA(y,['SPADCHECKELT,'_$,k]) +; --this reference must check that slot is a vector +; nil +; NRTputInHead u +; x + +(DEFUN |NRTputInTail| (|x|) + (PROG (|u| |k|) + (declare (special |$elt| |$devaluateList|)) + (RETURN + (SEQ (PROGN + (DO ((|y| |x| (CDR |y|))) ((ATOM |y|) NIL) + (SEQ (EXIT (COND + ((ATOM (SPADLET |u| (CAR |y|))) + (COND + ((OR (EQ |u| '$) + (LASSOC |u| |$devaluateList|)) + NIL) + ((SPADLET |k| (|NRTassocIndex| |u|)) + (COND + ((ATOM |u|) + (RPLACA |y| + (CONS |$elt| + (CONS '$ (CONS |k| NIL))))) + ('T + (RPLACA |y| + (CONS 'SPADCHECKELT + (CONS '$ (CONS |k| NIL))))))) + ('T NIL))) + ('T (|NRTputInHead| |u|)))))) + |x|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}