diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 73b581a..c9f17b6 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -7348,6 +7348,54 @@ $\rightarrow$ \end{chunk} +\defun{getUniqueModemap}{getUniqueModemap} +\calls{getUniqueModemap}{getModemapList} +\calls{getUniqueModemap}{qslessp} +\calls{getUniqueModemap}{stackWarning} +\begin{chunk}{defun getUniqueModemap} +(defun |getUniqueModemap| (op numOfArgs env) + (let (mml) + (cond + ((eql 1 (|#| (setq mml (|getModemapList| op numOfArgs env)))) + (car mml)) + ((qslessp 1 (|#| mml)) + (|stackWarning| + (list numOfArgs " argument form of: " op " has more than one modemap")) + (car mml)) + (t nil)))) + +\end{chunk} + +\defun{getModemapList}{getModemapList} +\calls{getModemapList}{pairp} +\calls{getModemapList}{qcar} +\calls{getModemapList}{qcdr} +\calls{getModemapList}{getModemapListFromDomain} +\calls{getModemapList}{nreverse0} +\calls{getModemapList}{get} +\begin{chunk}{defun getModemapList} +(defun |getModemapList| (op numOfArgs env) + (let (result) + (cond + ((and (pairp op) (eq (qcar op) '|elt|) (pairp (qcdr op)) + (pairp (qcdr (qcdr op))) (eq (qcdr (qcdr (qcdr op))) nil)) + (|getModemapListFromDomain| (third op) numOfArgs (second op) env)) + (t + (dolist (term (|get| op '|modemap| env) (nreverse0 result)) + (when (eql numOfArgs (|#| (cddar term))) (push term result))))))) + +\end{chunk} + +\defun{getModemapListFromDomain}{getModemapListFromDomain} +\calls{getModemapListFromDomain}{get} +\begin{chunk}{defun getModemapListFromDomain} +(defun |getModemapListFromDomain| (op numOfArgs d env) + (loop for term in (|get| op '|modemap| env) + when (and (equal (caar term) d) (eql (|#| (cddar term)) numOfArgs)) + collect term)) + +\end{chunk} + \defun{domainMember}{domainMember} \calls{domainMember}{modeEqual} \begin{chunk}{defun domainMember} @@ -7382,6 +7430,207 @@ $\rightarrow$ \end{chunk} +\defun{addModemapKnown}{addModemapKnown} +\calls{addModemapKnown}{addModemap0} +\refsdollar{addModemapKnown}{e} +\refsdollar{CapsuleModemapFrame}{insideCapsuleFunctionIfTrue} +\defsdollar{addModemapKnown}{CapsuleModemapFrame} +\begin{chunk}{defun addModemapKnown} +(defun |addModemapKnown| (op mc sig pred fn |$e|) + (declare (special |$e| |$CapsuleModemapFrame| |$insideCapsuleFunctionIfTrue|)) + (if (eq |$insideCapsuleFunctionIfTrue| t) + (progn + (setq |$CapsuleModemapFrame| + (|addModemap0| op mc sig pred fn |$CapsuleModemapFrame|)) + |$e|) + (|addModemap0| op mc sig pred fn |$e|))) + +\end{chunk} + +\defun{addModemap0}{addModemap0} +\calls{addModemap0}{pairp} +\calls{addModemap0}{qcar} +\calls{addModemap0}{addEltModemap} +\calls{addModemap0}{addModemap1} +\refsdollar{addModemap0}{functorForm} +\begin{chunk}{defun addModemap0} +(defun |addModemap0| (op mc sig pred fn env) + (declare (special |$functorForm|)) + (cond + ((and (pairp |$functorForm|) + (eq (qcar |$functorForm|) '|CategoryDefaults|) + (eq mc '$)) + env) + ((or (eq op '|elt|) (eq op '|setelt|)) + (|addEltModemap| op mc sig pred fn env)) + (t (|addModemap1| op mc sig pred fn env)))) + +\end{chunk} + +\defun{addEltModemap}{addEltModemap} +This is a hack to change selectors from strings to identifiers; and to +add flag identifiers as literals in the environment +\calls{addEltModemap}{pairp} +\calls{addEltModemap}{qcar} +\calls{addEltModemap}{qcdr} +\calls{addEltModemap}{makeLiteral} +\calls{addEltModemap}{addModemap1} +\calls{addEltModemap}{systemErrorHere} +\refsdollar{addEltModemap}{insideCapsuleFunctionIfTrue} +\defsdollar{addEltModemap}{e} +\begin{chunk}{defun addEltModemap} +(defun |addEltModemap| (op mc sig pred fn env) + (let (tmp1 v sel lt id) + (declare (special |$e| |$insideCapsuleFunctionIfTrue|)) + (cond + ((and (eq op '|elt|) (pairp sig)) + (setq tmp1 (reverse sig)) + (setq sel (qcar tmp1)) + (setq lt (nreverse (qcdr tmp1))) + (cond + ((stringp sel) + (setq id (intern sel)) + (if |$insideCapsuleFunctionIfTrue| + (setq |$e| (|makeLiteral| id |$e|)) + (setq env (|makeLiteral| id env))) + (|addModemap1| op mc (append lt (list id)) pred fn env)) + (t (|addModemap1| op mc sig pred fn env)))) + ((and (eq op '|setelt|) (pairp sig)) + (setq tmp1 (reverse sig)) + (setq v (qcar tmp1)) + (setq sel (qcar (qcdr tmp1))) + (setq lt (nreverse (qcdr (qcdr tmp1)))) + (cond + ((stringp sel) (setq id (intern sel)) + (if |$insideCapsuleFunctionIfTrue| + (setq |$e| (|makeLiteral| id |$e|)) + (setq env (|makeLiteral| id env))) + (|addModemap1| op mc (append lt (list id v)) pred fn env)) + (t (|addModemap1| op mc sig pred fn env)))) + (t (|systemErrorHere| "addEltModemap"))))) + +\end{chunk} + +\defun{addModemap1}{addModemap1} +\calls{addModemap1}{msubst} +\calls{addModemap1}{getProplist} +\calls{addModemap1}{mkNewModemapList} +\calls{addModemap1}{lassoc} +\calls{addModemap1}{augProplist} +\calls{addModemap1}{unErrorRef} +\calls{addModemap1}{addBinding} +\begin{chunk}{defun addModemap1} +(defun |addModemap1| (op mc sig pred fn env) + (let (currentProplist newModemapList newProplist newProplistp) + (when (eq mc '|Rep|) (setq sig (msubst '$ '|Rep| sig))) + (setq currentProplist (or (|getProplist| op env) nil)) + (setq newModemapList + (|mkNewModemapList| mc sig pred fn + (lassoc '|modemap| currentProplist) env nil)) + (setq newProplist (|augProplist| currentProplist '|modemap| newModemapList)) + (setq newProplistp (|augProplist| newProplist 'fluid t)) + (|unErrorRef| op) + (|addBinding| op newProplistp env))) + +\end{chunk} + +\defun{mkNewModemapList}{mkNewModemapList} +\calls{mkNewModemapList}{member} +\calls{mkNewModemapList}{assoc} +\calls{mkNewModemapList}{pairp} +\calls{mkNewModemapList}{qcar} +\calls{mkNewModemapList}{qcdr} +\calls{mkNewModemapList}{mergeModemap} +\calls{mkNewModemapList}{nequal} +\calls{mkNewModemapList}{nreverse0} +\calls{mkNewModemapList}{insertModemap} +\refsdollar{mkNewModemapList}{InteractiveMode} +\refsdollar{mkNewModemapList}{forceAdd} +\begin{chunk}{defun mkNewModemapList} +(defun |mkNewModemapList| (mc sig pred fn curModemapList env filenameOrNil) + (let (map entry oldMap opred result) + (declare (special |$InteractiveMode| |$forceAdd|)) + (setq entry + (cons (setq map (cons mc sig)) (cons (list pred fn) filenameOrNil))) + (cond + ((|member| entry curModemapList) curModemapList) + ((and (setq oldMap (|assoc| map curModemapList)) + (pairp oldMap) (pairp (qcdr oldMap)) + (pairp (qcar (qcdr oldMap))) + (pairp (qcdr (qcar (qcdr oldMap)))) + (eq (qcdr (qcdr (qcar (qcdr oldMap)))) nil) + (equal (qcar (qcdr (qcar (qcdr oldMap)))) fn)) + (setq opred (qcar (qcar (qcdr oldMap)))) + (cond + (|$forceAdd| (|mergeModemap| entry curModemapList env)) + ((eq opred t) curModemapList) + (t + (when (and (nequal pred t) (nequal pred opred)) + (setq pred (list 'or pred opred))) + (dolist (x curModemapList (nreverse0 result)) + (push + (if (equal x oldMap) + (cons map (cons (list pred fn) filenameOrNil)) + x) + result))))) + (|$InteractiveMode| + (|insertModemap| entry curModemapList)) + (t + (|mergeModemap| entry curModemapList env))))) + +\end{chunk} + +\defun{mergeModemap}{mergeModemap} +\calls{mergeModemap}{isSuperDomain} +\calls{mergeModemap}{TruthP} +\refsdollar{mergeModemap}{forceAdd} +\begin{chunk}{defun mergeModemap} +(defun |mergeModemap| (entry modemapList env) + (let (mc sig pred mcp sigp predp newmm mm) + (declare (special |$forceAdd|)) + ; break out the condition, signature, and predicate fields of the new entry + (setq mc (caar entry)) + (setq sig (cdar entry)) + (setq pred (caadr entry)) + (seq + ; walk across the successive tails of the modemap list + (do ((mmtail modemapList (cdr mmtail))) + ((atom mmtail) nil) + (setq mcp (caaar mmtail)) + (setq sigp (cdaar mmtail)) + (setq predp (caadar mmtail)) + (cond + ((or (equal mc mcp) (|isSuperDomain| mcp mc env)) + ; if this is a duplicate condition + (exit + (progn + (setq newmm nil) + (setq mm modemapList) + ; copy the unique modemap terms + (loop while (not (eq mm mmtail)) do + (setq newmm (cons (car mm) newmm)) + (setq mm (cdr mm))) + ; if the conditions and signatures are equal + (when (and (equal mc mcp) (equal sig sigp)) + ; we only need one of these unless the conditions are hairy + (cond + ((and (null |$forceAdd|) (|TruthP| predp)) + ; the new predicate buys us nothing + (setq entry nil) + (return modemapList)) + ((|TruthP| pred) + ; the thing we matched against is useless, by comparison + (setq mmtail (cdr mmtail))))) + (setq modemapList (nconc (nreverse newmm) (cons entry mmtail))) + (setq entry nil) + (return modemapList)))))) + ; if the entry is still defined, add it to the modemap + (if entry + (append modemapList (list entry)) + modemapList)))) + +\end{chunk} + \defun{evalAndSub}{evalAndSub} \calls{evalAndSub}{isCategory} \calls{evalAndSub}{substNames} @@ -16644,7 +16893,11 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun action} \getchunk{defun addclose} \getchunk{defun addDomain} +\getchunk{defun addEltModemap} \getchunk{defun addEmptyCapsuleIfNecessary} +\getchunk{defun addModemapKnown} +\getchunk{defun addModemap0} +\getchunk{defun addModemap1} \getchunk{defun add-parens-and-semis-to-line} \getchunk{defun Advance-Char} \getchunk{defun advance-token} @@ -16774,11 +17027,14 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun get-a-line} \getchunk{defun getModemap} +\getchunk{defun getModemapList} +\getchunk{defun getModemapListFromDomain} \getchunk{defun getOperationAlist} \getchunk{defun getScriptName} \getchunk{defun getTargetFromRhs} \getchunk{defun get-token} \getchunk{defun getToken} +\getchunk{defun getUniqueModemap} \getchunk{defun getUniqueSignature} \getchunk{defun genDomainOps} \getchunk{defun genDomainViewList0} @@ -16824,9 +17080,11 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun match-next-token} \getchunk{defun match-string} \getchunk{defun match-token} +\getchunk{defun mergeModemap} \getchunk{defun meta-syntax-error} \getchunk{defun mkCategoryPackage} \getchunk{defun mkConstructor} +\getchunk{defun mkNewModemapList} \getchunk{defun mkOpVec} \getchunk{defun modifyModeStack} diff --git a/changelog b/changelog index 38cb550..9f4bc58 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20110710 tpd src/axiom-website/patches.html 20110710.01.tpd.patch +20110710 tpd src/interp/modemap.lisp treeshake compiler +20110710 tpd books/bookvol9 treeshake compiler 20110708 tpd src/axiom-website/patches.html 20110708.02.tpd.patch 20110708 tpd src/interp/modemap.lisp treeshake compiler 20110708 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index efde134..f6093d7 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3534,5 +3534,7 @@ books/bookvol9 treeshake compiler
books/bookvol9 treeshake compiler
20110708.02.tpd.patch books/bookvol9 treeshake compiler
+20110710.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/modemap.lisp.pamphlet b/src/interp/modemap.lisp.pamphlet index c2b2d95..d300b24 100644 --- a/src/interp/modemap.lisp.pamphlet +++ b/src/interp/modemap.lisp.pamphlet @@ -13,400 +13,6 @@ (IN-PACKAGE "BOOT" ) -;getUniqueModemap(op,numOfArgs,e) == -; 1=#(mml:= getModemapList(op,numOfArgs,e)) => first mml -; 1<#mml => -; stackWarning [numOfArgs,'" argument form of: ",op, -; '" has more than one modemap"] -; first mml -; nil - -(DEFUN |getUniqueModemap| (|op| |numOfArgs| |e|) - (PROG (|mml|) - (RETURN - (COND - ((EQL 1 - (|#| (SPADLET |mml| - (|getModemapList| |op| |numOfArgs| |e|)))) - (CAR |mml|)) - ((QSLESSP 1 (|#| |mml|)) - (|stackWarning| - (CONS |numOfArgs| - (CONS " argument form of: " - (CONS |op| - (CONS " has more than one modemap" - NIL))))) - (CAR |mml|)) - ('T NIL))))) - -;getModemapList(op,numOfArgs,e) == -; op is ['elt,D,op'] => getModemapListFromDomain(op',numOfArgs,D,e) -; [mm for -; (mm:= [[.,.,:sigl],:.]) in get(op,'modemap,e) | numOfArgs=#sigl] - -(DEFUN |getModemapList| (|op| |numOfArgs| |e|) - (PROG (|ISTMP#1| D |ISTMP#2| |op'| |sigl|) - (RETURN - (SEQ (COND - ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET D (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |op'| (QCAR |ISTMP#2|)) - 'T)))))) - (|getModemapListFromDomain| |op'| |numOfArgs| D |e|)) - ('T - (PROG (G166165) - (SPADLET G166165 NIL) - (RETURN - (DO ((G166172 (|get| |op| '|modemap| |e|) - (CDR G166172)) - (|mm| NIL)) - ((OR (ATOM G166172) - (PROGN (SETQ |mm| (CAR G166172)) NIL) - (PROGN - (PROGN - (SPADLET |sigl| (CDDAR |mm|)) - |mm|) - NIL)) - (NREVERSE0 G166165)) - (SEQ (EXIT (COND - ((BOOT-EQUAL |numOfArgs| (|#| |sigl|)) - (SETQ G166165 - (CONS |mm| G166165))))))))))))))) - -;getModemapListFromDomain(op,numOfArgs,D,e) == -; [mm -; for (mm:= [[dc,:sig],:.]) in get(op,'modemap,e) | dc=D and #rest sig= -; numOfArgs] - -(DEFUN |getModemapListFromDomain| (|op| |numOfArgs| D |e|) - (PROG (|dc| |sig|) - (RETURN - (SEQ (PROG (G166197) - (SPADLET G166197 NIL) - (RETURN - (DO ((G166204 (|get| |op| '|modemap| |e|) - (CDR G166204)) - (|mm| NIL)) - ((OR (ATOM G166204) - (PROGN (SETQ |mm| (CAR G166204)) NIL) - (PROGN - (PROGN - (SPADLET |dc| (CAAR |mm|)) - (SPADLET |sig| (CDAR |mm|)) - |mm|) - NIL)) - (NREVERSE0 G166197)) - (SEQ (EXIT (COND - ((AND (BOOT-EQUAL |dc| D) - (BOOT-EQUAL (|#| (CDR |sig|)) - |numOfArgs|)) - (SETQ G166197 (CONS |mm| G166197))))))))))))) - -;addModemapKnown(op,mc,sig,pred,fn,$e) == -;-- if knownInfo pred then pred:=true -;-- that line is handled elsewhere -; $insideCapsuleFunctionIfTrue=true => -; $CapsuleModemapFrame := -; addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) -; $e -; addModemap0(op,mc,sig,pred,fn,$e) - -(DEFUN |addModemapKnown| (|op| |mc| |sig| |pred| |fn| |$e|) - (DECLARE (SPECIAL |$e| |$CapsuleModemapFrame| - |$insideCapsuleFunctionIfTrue|)) - (COND - ((BOOT-EQUAL |$insideCapsuleFunctionIfTrue| 'T) - (SPADLET |$CapsuleModemapFrame| - (|addModemap0| |op| |mc| |sig| |pred| |fn| - |$CapsuleModemapFrame|)) - |$e|) - ('T (|addModemap0| |op| |mc| |sig| |pred| |fn| |$e|)))) - -;addModemap0(op,mc,sig,pred,fn,e) == -; --mc is the "mode of computation"; fn the "implementation" -; $functorForm is ['CategoryDefaults,:.] and mc="$" => e -; --don't put CD modemaps into environment -; --fn is ['Subsumed,:.] => e -- don't skip subsumed modemaps -; -- breaks -:($,$)->U($,failed) in DP -; op='elt or op='setelt => addEltModemap(op,mc,sig,pred,fn,e) -; addModemap1(op,mc,sig,pred,fn,e) - -(DEFUN |addModemap0| (|op| |mc| |sig| |pred| |fn| |e|) - (declare (special |$functorForm|)) - (COND - ((AND (PAIRP |$functorForm|) - (EQ (QCAR |$functorForm|) '|CategoryDefaults|) - (BOOT-EQUAL |mc| '$)) - |e|) - ((OR (BOOT-EQUAL |op| '|elt|) (BOOT-EQUAL |op| '|setelt|)) - (|addEltModemap| |op| |mc| |sig| |pred| |fn| |e|)) - ('T (|addModemap1| |op| |mc| |sig| |pred| |fn| |e|)))) - -;addEltModemap(op,mc,sig,pred,fn,e) == -; --hack to change selectors from strings to identifiers; and to -; --add flag identifiers as literals in the envir -; op='elt and sig is [:lt,sel] => -; STRINGP sel => -; id:= INTERN sel -; if $insideCapsuleFunctionIfTrue=true -; then $e:= makeLiteral(id,$e) -; else e:= makeLiteral(id,e) -; addModemap1(op,mc,[:lt,id],pred,fn,e) -; -- atom sel => systemErrorHere '"addEltModemap" -; addModemap1(op,mc,sig,pred,fn,e) -; op='setelt and sig is [:lt,sel,v] => -; STRINGP sel => -; id:= INTERN sel -; if $insideCapsuleFunctionIfTrue=true -; then $e:= makeLiteral(id,$e) -; else e:= makeLiteral(id,e) -; addModemap1(op,mc,[:lt,id,v],pred,fn,e) -; -- atom sel => systemError '"addEltModemap" -; addModemap1(op,mc,sig,pred,fn,e) -; systemErrorHere '"addEltModemap" - -(DEFUN |addEltModemap| (|op| |mc| |sig| |pred| |fn| |e|) - (PROG (|ISTMP#1| |v| |ISTMP#2| |sel| |lt| |id|) - (declare (special |$e| |$insideCapsuleFunctionIfTrue|)) - (RETURN - (COND - ((AND (BOOT-EQUAL |op| '|elt|) (PAIRP |sig|) - (PROGN (SPADLET |ISTMP#1| (REVERSE |sig|)) 'T) - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |sel| (QCAR |ISTMP#1|)) - (SPADLET |lt| (QCDR |ISTMP#1|)) - 'T) - (PROGN (SPADLET |lt| (NREVERSE |lt|)) 'T)) - (COND - ((STRINGP |sel|) (SPADLET |id| (INTERN |sel|)) - (COND - ((BOOT-EQUAL |$insideCapsuleFunctionIfTrue| 'T) - (SPADLET |$e| (|makeLiteral| |id| |$e|))) - ('T (SPADLET |e| (|makeLiteral| |id| |e|)))) - (|addModemap1| |op| |mc| (APPEND |lt| (CONS |id| NIL)) - |pred| |fn| |e|)) - ('T (|addModemap1| |op| |mc| |sig| |pred| |fn| |e|)))) - ((AND (BOOT-EQUAL |op| '|setelt|) (PAIRP |sig|) - (PROGN (SPADLET |ISTMP#1| (REVERSE |sig|)) 'T) - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |v| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |sel| (QCAR |ISTMP#2|)) - (SPADLET |lt| (QCDR |ISTMP#2|)) - 'T))) - (PROGN (SPADLET |lt| (NREVERSE |lt|)) 'T)) - (COND - ((STRINGP |sel|) (SPADLET |id| (INTERN |sel|)) - (COND - ((BOOT-EQUAL |$insideCapsuleFunctionIfTrue| 'T) - (SPADLET |$e| (|makeLiteral| |id| |$e|))) - ('T (SPADLET |e| (|makeLiteral| |id| |e|)))) - (|addModemap1| |op| |mc| - (APPEND |lt| (CONS |id| (CONS |v| NIL))) |pred| |fn| - |e|)) - ('T (|addModemap1| |op| |mc| |sig| |pred| |fn| |e|)))) - ('T (|systemErrorHere| "addEltModemap")))))) - -;addModemap1(op,mc,sig,pred,fn,e) == -; --mc is the "mode of computation"; fn the "implementation" -; if mc='Rep then -;-- if fn is [kind,'Rep,.] and -; -- save old sig for NRUNTIME -;-- (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig] -; sig:= substitute("$",'Rep,sig) -; currentProplist:= getProplist(op,e) or nil -; newModemapList:= -; mkNewModemapList(mc,sig,pred,fn,LASSOC('modemap,currentProplist),e,nil) -; newProplist:= augProplist(currentProplist,'modemap,newModemapList) -; newProplist':= augProplist(newProplist,"FLUID",true) -; unErrorRef op -; --There may have been a warning about op having no value -; addBinding(op,newProplist',e) - -(DEFUN |addModemap1| (|op| |mc| |sig| |pred| |fn| |e|) - (PROG (|currentProplist| |newModemapList| |newProplist| - |newProplist'|) - (RETURN - (PROGN - (COND - ((BOOT-EQUAL |mc| '|Rep|) - (SPADLET |sig| (MSUBST '$ '|Rep| |sig|)))) - (SPADLET |currentProplist| (OR (|getProplist| |op| |e|) NIL)) - (SPADLET |newModemapList| - (|mkNewModemapList| |mc| |sig| |pred| |fn| - (LASSOC '|modemap| |currentProplist|) |e| NIL)) - (SPADLET |newProplist| - (|augProplist| |currentProplist| '|modemap| - |newModemapList|)) - (SPADLET |newProplist'| - (|augProplist| |newProplist| 'FLUID 'T)) - (|unErrorRef| |op|) - (|addBinding| |op| |newProplist'| |e|))))) - -;mkNewModemapList(mc,sig,pred,fn,curModemapList,e,filenameOrNil) == -; entry:= [map:= [mc,:sig],[pred,fn],:filenameOrNil] -; MEMBER(entry,curModemapList) => curModemapList -; (oldMap:= ASSOC(map,curModemapList)) and oldMap is [.,[opred, =fn],:.] => -; $forceAdd => mergeModemap(entry,curModemapList,e) -; opred=true => curModemapList -; if pred^=true and pred^=opred then pred:= ["OR",pred,opred] -; [if x=oldMap then [map,[pred,fn],:filenameOrNil] else x -; -; --if new modemap less general, put at end; otherwise, at front -; for x in curModemapList] -; $InteractiveMode => insertModemap(entry,curModemapList) -; mergeModemap(entry,curModemapList,e) - -(DEFUN |mkNewModemapList| - (|mc| |sig| |pred| |fn| |curModemapList| |e| |filenameOrNil|) - (PROG (|map| |entry| |oldMap| |ISTMP#1| |ISTMP#2| |opred| |ISTMP#3|) - (declare (special |$InteractiveMode| |$forceAdd|)) - (RETURN - (SEQ (PROGN - (SPADLET |entry| - (CONS (SPADLET |map| (CONS |mc| |sig|)) - (CONS (CONS |pred| (CONS |fn| NIL)) - |filenameOrNil|))) - (COND - ((|member| |entry| |curModemapList|) |curModemapList|) - ((AND (SPADLET |oldMap| - (|assoc| |map| |curModemapList|)) - (PAIRP |oldMap|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |oldMap|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |opred| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (EQUAL (QCAR |ISTMP#3|) |fn|)))))))) - (COND - (|$forceAdd| - (|mergeModemap| |entry| |curModemapList| |e|)) - ((BOOT-EQUAL |opred| 'T) |curModemapList|) - ('T - (COND - ((AND (NEQUAL |pred| 'T) (NEQUAL |pred| |opred|)) - (SPADLET |pred| - (CONS 'OR - (CONS |pred| (CONS |opred| NIL)))))) - (PROG (G166301) - (SPADLET G166301 NIL) - (RETURN - (DO ((G166306 |curModemapList| - (CDR G166306)) - (|x| NIL)) - ((OR (ATOM G166306) - (PROGN (SETQ |x| (CAR G166306)) NIL)) - (NREVERSE0 G166301)) - (SEQ (EXIT (SETQ G166301 - (CONS - (COND - ((BOOT-EQUAL |x| |oldMap|) - (CONS |map| - (CONS - (CONS |pred| - (CONS |fn| NIL)) - |filenameOrNil|))) - ('T |x|)) - G166301)))))))))) - (|$InteractiveMode| - (|insertModemap| |entry| |curModemapList|)) - ('T (|mergeModemap| |entry| |curModemapList| |e|)))))))) - -;mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) == -; for (mmtail:= [[[mc',:sig'],[pred',:.],:.],:.]) in tails modemapList repeat -; mc=mc' or isSuperDomain(mc',mc,e) => -; newmm:= nil -; mm:= modemapList -; while (not EQ(mm,mmtail)) repeat (newmm:= [first mm,:newmm]; mm:= rest mm) -; if (mc=mc') and (sig=sig') then -; --We only need one of these, unless the conditions are hairy -; not $forceAdd and TruthP pred' => -; entry:=nil -; --the new predicate buys us nothing -; return modemapList -; TruthP pred => mmtail:=rest mmtail -; --the thing we matched against is useless, by comparison -; modemapList:= NCONC(NREVERSE newmm,[entry,:mmtail]) -; entry:= nil -; return modemapList -; if entry then [:modemapList,entry] else modemapList - -(DEFUN |mergeModemap| (|entry| |modemapList| |e|) - (PROG (|mc| |sig| |pred| |mc'| |sig'| |pred'| |newmm| |mm|) - (declare (special |$forceAdd|)) - (RETURN - (SEQ (PROGN - (SPADLET |mc| (CAAR |entry|)) - (SPADLET |sig| (CDAR |entry|)) - (SPADLET |pred| (CAADR |entry|)) - (SEQ (DO ((|mmtail| |modemapList| (CDR |mmtail|))) - ((OR (ATOM |mmtail|) - (PROGN - (PROGN - (SPADLET |mc'| (CAAAR |mmtail|)) - (SPADLET |sig'| (CDAAR |mmtail|)) - (SPADLET |pred'| (CAADAR |mmtail|)) - |mmtail|) - NIL)) - NIL) - (SEQ (EXIT (COND - ((OR (BOOT-EQUAL |mc| |mc'|) - (|isSuperDomain| |mc'| |mc| |e|)) - (EXIT (PROGN - (SPADLET |newmm| NIL) - (SPADLET |mm| |modemapList|) - (DO () - ((NULL - (NULL (EQ |mm| |mmtail|))) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |newmm| - (CONS (CAR |mm|) - |newmm|)) - (SPADLET |mm| - (CDR |mm|)))))) - (COND - ((AND - (BOOT-EQUAL |mc| |mc'|) - (BOOT-EQUAL |sig| |sig'|)) - (COND - ((AND (NULL |$forceAdd|) - (|TruthP| |pred'|)) - (SPADLET |entry| NIL) - (RETURN |modemapList|)) - ((|TruthP| |pred|) - (SPADLET |mmtail| - (CDR |mmtail|)))))) - (SPADLET |modemapList| - (NCONC (NREVERSE |newmm|) - (CONS |entry| |mmtail|))) - (SPADLET |entry| NIL) - (RETURN |modemapList|)))))))) - (COND - (|entry| (APPEND |modemapList| (CONS |entry| NIL))) - ('T |modemapList|)))))))) - ;-- next definition RPLACs, and hence causes problems. ;-- In ptic., SubResGcd in SparseUnivariatePolynomial is miscompiled ;--mergeModemap(entry:=((mc,:sig),:.),modemapList,e) ==