diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index edc19a4..45d9a53 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -640,6 +640,7 @@ information is initialized. (if (<= n 0) "" (make-string n :initial-element (character (or (ifcar charPart) " "))))) + \end{chunk} \defunsec{spad}{Starts the interpreter but do not read in profiles} @@ -29648,6 +29649,27 @@ o )what \end{chunk} +\defun{isExposedConstructor}{isExposedConstructor} +\calls{isExposedConstructor}{getalist} +\refsdollar{isExposedConstructor}{localExposureData} +\refsdollar{isExposedConstructor}{globalExposureGroupAlist} +\begin{chunk}{defun isExposedConstructor} +(defun |isExposedConstructor| (name) + (let (x found) + (declare (special |$globalExposureGroupAlist| |$localExposureData|)) + (cond + ((member name '(|Union| |Record| |Mapping|)) t) + ((member name (elt |$localExposureData| 2)) nil) + ((member name (elt |$localExposureData| 1)) t) + (t + (loop for g in (elt |$localExposureData| 0) do + while (not found) + (setq x (getalist |$globalExposureGroupAlist| g)) + (when (and x (getalist x name)) (setq found t))) + found)))) + +\end{chunk} + \defun{displayOperationsFromLisplib}{displayOperationsFromLisplib} \calls{displayOperationsFromLisplib}{getdatabase} \calls{displayOperationsFromLisplib}{centerAndHighlight} @@ -29807,6 +29829,63 @@ o )what \end{chunk} +\defun{getOplistForConstructorForm}{getOplistForConstructorForm} +The new form is an op-Alist which has entries +\begin{verbatim} + ( . signature-Alist) +\end{verbatim} +where signature-Alist has entries +\begin{verbatim} + ( . item) +\end{verbatim} +where item has form ( ) +\begin{verbatim} + ( ) +\end{verbatim} +where = ELT | CONST | Subsumed | (XLAM..) .. +\begin{verbatim} + = ELT | CONST | Subsumed | (XLAM..) .. +\end{verbatim} +\begin{chunk}{defun getOplistForConstructorForm} +(defun |getOplistForConstructorForm| (form) + (let (argl pairlis opAlist op signatureAlist result) + (declare (special |$FormalMapVariableList|)) + (setq op (car form)) + (setq argl (cdr form)) + (setq pairlis + (loop for fv in |$FormalMapVariableList| + for arg in argl + collect (cons fv arg))) + (setq opAlist (|getOperationAlistFromLisplib| op)) + (loop for item in opAlist do + (setq op (car item)) + (setq signatureAlist (cdr item)) + (setq result + (append result + (|getOplistWithUniqueSignatures| op pairlis signatureAlist)))) + result)) + +\end{chunk} + +\defun{getOplistWithUniqueSignatures}{getOplistWithUniqueSignatures} +\begin{chunk}{defun getOplistWithUniqueSignatures} +(defun |getOplistWithUniqueSignatures| (op pairlis signatureAlist) + (let (sig slotNumber pred kind alist) + (loop for item in signatureAlist do + where (nequal (fourth item) '|Subsumed|) + (setq sig (first item)) + (setq slotNumber (second item)) + (setq pred (third item)) + (setq kind (fourth item)) + (setq alist + (|insertAlist| + (sublis pairlis (list op sig)) + (sublis pairlis (list pred (list kind nil slotNumber))) + alist))) + alist)) + +\end{chunk} + \defun{reportOpsFromUnitDirectly1}{reportOpsFromUnitDirectly1} \calls{reportOpsFromUnitDirectly1}{pathname} \calls{reportOpsFromUnitDirectly1}{erase} @@ -32529,6 +32608,19 @@ to convert the data into type "Expression" (|spadReply|))))))))))) \end{chunk} + +\defun{remover}{remover} +\calls{remover}{rplnode} +\calls{remover}{remover} +\begin{chunk}{defun remover} +(defun remover (lst item) + (cond + ((null (pairp lst)) (cond ((equal lst item) nil) (t lst))) + ((equal (car lst) item) (cdr lst)) + (t (rplnode lst (remover (car lst) item) (remover (cdr lst) item))))) + +\end{chunk} + \defun{prTraceNames,fn}{prTraceNames,fn} \calls{prTraceNames,fn}{seq} \calls{prTraceNames,fn}{pairp} @@ -33975,14 +34067,14 @@ in patterns \calls{filterAndFormatConstructors}{function} \usesdollar{filterAndFormatConstructors}{linelength} \begin{chunk}{defun filterAndFormatConstructors} -(defun |filterAndFormatConstructors| (|constrType| label patterns) +(defun |filterAndFormatConstructors| (constrType label patterns) (prog (l) (declare (special $linelength)) (return (progn (|centerAndHighlight| label $linelength (|specialChar| '|hbar|)) (setq l (|filterListOfStringsWithFn| patterns - (|whatConstructors| |constrType|) + (|whatConstructors| constrType) (|function| cdr))) (cond (patterns (cond @@ -34016,7 +34108,7 @@ in patterns \calls{whatConstructors}{msort} \calls{whatConstructors}{exit} \begin{chunk}{defun whatConstructors} -(defun |whatConstructors| (|constrType|) +(defun |whatConstructors| (constrType) (prog nil (return (seq @@ -34029,8 +34121,7 @@ in patterns (seq (exit (cond - ((boot-equal (getdatabase |con| 'constructorkind) - |constrType|) + ((equal (getdatabase |con| 'constructorkind) constrType) (setq t0 (cons (cons @@ -36310,6 +36401,27 @@ The localdatabase function tries to find files in the order of: \end{chunk} +\defun{updateDatabase}{updateDatabase} +For now in NRUNTIME do database update only if forced +\calls{updateDatabase}{constructor?} +\calls{updateDatabase}{clearClams} +\calls{updateDatabase}{clearAllSlams} +\refsdollar{updateDatabase}{forceDatabaseUpdate} +\begin{chunk}{defun updateDatabase} +(defun |updateDatabase| (fname cname systemdirp) + (declare (ignore fname)) + (declare (special |$forceDatabaseUpdate|)) + (when |$forceDatabaseUpdate| + (when (|constructor?| cname) + (|clearClams|) + (|clearAllSlams| nil) + (when (getl cname 'loaded) (|clearConstructorCaches|))) + (when (or |$forceDatabaseUpdate| (null systemdirp)) + (|clearClams|) + (|clearAllSlams| nil)))) + +\end{chunk} + \defun{make-databases}{Make new databases} Making new databases consists of: \begin{enumerate} @@ -40379,6 +40491,8 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun getMsgPos} \getchunk{defun getMsgPos2} \getchunk{defun getMsgToWhere} +\getchunk{defun getOplistForConstructorForm} +\getchunk{defun getOplistWithUniqueSignatures} \getchunk{defun getOption} \getchunk{defun getPosStL} \getchunk{defun getPreviousMapSubNames} @@ -40475,6 +40589,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun ioclear} \getchunk{defun iostat} \getchunk{defun isDomainOrPackage} +\getchunk{defun isExposedConstructor} \getchunk{defun isgenvar} \getchunk{defun isInterpOnlyMap} \getchunk{defun isListOfIdentifiers} @@ -41039,6 +41154,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun redundant} \getchunk{defun remFile} \getchunk{defun removeOption} +\getchunk{defun remover} \getchunk{defun removeTracedMapSigs} \getchunk{defun removeUndoLines} \getchunk{defun replaceFile} @@ -41257,6 +41373,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun untraceMapSubNames} \getchunk{defun unwritable?} \getchunk{defun updateCurrentInterpreterFrame} +\getchunk{defun updateDatabase} \getchunk{defun updateFromCurrentInterpreterFrame} \getchunk{defun updateHist} \getchunk{defun updateInCoreHist} diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index f200df1..7e96512 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -6691,7 +6691,7 @@ $\rightarrow$ \calls{flattenSignatureList}{flattenSignatureList} \begin{chunk}{defun flattenSignatureList} (defun |flattenSignatureList| (x) - (let (tmp1 cond tmp2 b1 tmp3 b2 z zz) + (let (zz) (cond ((atom x) nil) ((and (pairp x) (eq (qcar x) 'signature)) (list x)) @@ -6820,6 +6820,203 @@ identifier in newvars in the expression x \end{chunk} +\defun{orderPredicateItems}{orderPredicateItems} +\calls{orderPredicateItems}{pairp} +\calls{orderPredicateItems}{qcar} +\calls{orderPredicateItems}{qcdr} +\calls{orderPredicateItems}{signatureTran} +\calls{orderPredicateItems}{orderPredTran} +\begin{chunk}{defun orderPredicateItems} +(defun |orderPredicateItems| (pred1 sig skip) + (let (pred) + (setq pred (|signatureTran| pred1)) + (if (and (pairp pred) (eq (qcar pred) 'and)) + (|orderPredTran| (qcdr pred) sig skip) + pred))) + +\end{chunk} + +\defun{signatureTran}{signatureTran} +\calls{signatureTran}{signatureTran} +\calls{signatureTran}{isCategoryForm} +\refsdollar{signatureTran}{e} +\begin{chunk}{defun signatureTran} +(defun |signatureTran| (pred) + (declare (special |$e|)) + (cond + ((atom pred) pred) + ((and (pairp pred) (eq (qcar pred) '|has|) (PAIRP (qcdr pred)) + (pairp (qcdr (qcdr pred))) + (eq (qcdr (qcdr (qcdr pred))) nil) + (|isCategoryForm| (third pred) |$e|)) + (list '|ofCategory| (second pred) (third pred))) + (t + (loop for p in pred + collect (|signatureTran| p))))) + +\end{chunk} + +\defun{orderPredTran}{orderPredTran} +\calls{orderPredTran}{pairp} +\calls{orderPredTran}{qcar} +\calls{orderPredTran}{qcdr} +\calls{orderPredTran}{member} +\calls{orderPredTran}{delete} +\calls{orderPredTran}{unionq} +\calls{orderPredTran}{listOfPatternIds} +\calls{orderPredTran}{intersectionq} +\calls{orderPredTran}{setdifference} +\calls{orderPredTran}{insertWOC} +\calls{orderPredTran}{isDomainSubst} +\begin{chunk}{defun orderPredTran} +(defun |orderPredTran| (oldList sig skip) + (let (lastDependList somethingDone lastPreds indepvl depvl dependList + noldList x ids fullDependList newList answer) +; --(1) make two kinds of predicates appear last: +; ----- (op *target ..) when *target does not appear later in sig +; ----- (isDomain *1 ..) + (SEQ + (loop for pred in oldList + do (cond + ((or (and (pairp pred) (pairp (qcdr pred)) + (pairp (qcdr (qcdr pred))) + (eq (qcdr (qcdr (qcdr pred))) nil) + (member (qcar pred) '(|isDomain| |ofCategory|)) + (equal (qcar (qcdr pred)) (car sig)) + (null (|member| (qcar (qcdr pred)) (cdr sig)))) + (and (null skip) (pairp pred) (eq (qcar pred) '|isDomain|) + (pairp (qcdr pred)) (pairp (qcdr (qcdr pred))) + (eq (qcdr (qcdr (qcdr pred))) nil) + (equal (qcar (qcdr pred)) '*1))) + (setq oldList (|delete| pred oldList)) + (setq lastPreds (cons pred lastPreds))))) +; --(2a) lastDependList=list of all variables that lastPred forms depend upon + (setq lastDependList + (let (result) + (loop for x in lastPreds + do (setq result (unionq result (|listOfPatternIds| x)))) + result)) +; --(2b) dependList=list of all variables that isDom/ofCat forms depend upon + (setq dependList + (let (result) + (loop for x in oldList + do (when + (and (pairp x) + (or (eq (qcar x) '|isDomain|) (eq (qcar x) '|ofCategory|)) + (pairp (qcdr x)) (pairp (qcdr (qcdr x))) + (eq (qcdr (qcdr (qcdr x))) nil)) + (setq result (unionq result (|listOfPatternIds| (third x)))))) + result)) +; --(3a) newList= list of ofCat/isDom entries that don't depend on + (loop for x in oldList + do + (cond + ((and (pairp x) + (or (eq (qcar x) '|ofCategory|) (eq (qcar x) '|isDomain|)) + (pairp (qcdr x)) (pairp (qcdr (qcdr x))) + (eq (qcdr (qcdr (qcdr x))) nil)) + (setq indepvl (|listOfPatternIds| (second x))) + (setq depvl (|listOfPatternIds| (third x)))) + (t + (setq indepvl (|listOfPatternIds| x)) + (setq depvl nil))) + (when + (and (null (intersectionq indepvl dependList)) + (intersectionq indepvl lastDependList)) + (setq somethingDone t) + (setq lastPreds (append lastPreds (list x))) + (setq oldList (|delete| x oldList)))) +; --(3b) newList= list of ofCat/isDom entries that don't depend on + (loop while oldList do + (loop for x in oldList do + (cond + ((and (pairp x) + (or (eq (qcar x) '|ofCategory|) (eq (qcar x) '|isDomain|)) + (pairp (qcdr x)) + (pairp (qcdr (qcdr x))) (eq (qcdr (qcdr (qcdr x))) nil)) + (setq indepvl (|listOfPatternIds| (second x))) + (setq depvl (|listOfPatternIds| (third x)))) + (t + (setq indepvl (|listOfPatternIds| x)) + (setq depvl nil))) + (when (null (intersectionq indepvl dependList)) + (setq dependList (SETDIFFERENCE dependList depvl)) + (setq newList (APPEND newList (list x))))) +; --(4) noldList= what is left over + (cond + ((equal (setq noldList (setdifference oldList newList)) oldList) + (setq newList (APPEND newList oldList)) + (return nil)) + (t + (setq oldList noldList)))) + (loop for pred in newList do + (when + (and (pairp pred) + (or (eq (qcar pred) '|isDomain|) (eq (qcar x) '|ofCategory|)) + (pairp (qcdr pred)) + (pairp (qcdr (qcdr pred))) + (eq (qcdr (qcdr (qcdr pred))) nil)) + (setq ids (|listOfPatternIds| (third pred))) + (when + (let (result) + (loop for id in ids do + (setq result (and result (|member| id fullDependList)))) + result) + (setq fullDependList (|insertWOC| (second pred) fullDependList))) + (setq fullDependList (unionq fullDependList ids)))) + (setq newList (append newList lastPreds)) + (setq newList (|isDomainSubst| newList)) + (setq answer + (cons (cons 'and newList) (intersectionq fullDependList sig)))))) + +\end{chunk} + +\defun{isDomainSubst}{isDomainSubst} +\begin{chunk}{defun isDomainSubst} +(defun |isDomainSubst| (u) + (labels ( + (findSub (x alist) + (cond + ((null alist) nil) + ((and (pairp alist) (pairp (qcar alist)) + (eq (qcar (qcar alist)) '|isDomain|) + (pairp (qcdr (qcar alist))) + (pairp (qcdr (qcdr (qcar alist)))) + (eq (qcdr (qcdr (qcdr (qcar alist)))) nil) + (equal x (cadar alist))) + (caddar alist)) + (t (findSub x (cdr alist))))) + (fn (x alist) + (let (s) + (declare (special |$PatternVariableList|)) + (if (atom x) + (if + (and (identp x) + (member x |$PatternVariableList|) + (setq s (findSub x alist))) + s + x) + (cons (car x) + (loop for y in (cdr x) + collect (fn y alist))))))) + (let (head tail tmp1 x tmp2 y nhead) + (if (pairp u) + (progn + (setq head (qcar u)) + (setq tail (qcdr u)) + (setq nhead + (cond + ((and (pairp head) (eq (qcar head) '|isDomain|) + (pairp (qcdr head)) (pairp (qcdr (qcdr head))) + (eq (qcdr (qcdr (qcdr head))) nil)) + (list '|isDomain| (second head) + (fn (third head) tail))) + (t head))) + (cons nhead (|isDomainSubst| (cdr u)))) + u)))) + +\end{chunk} + \defun{moveORsOutside}{moveORsOutside} \calls{moveORsOutside}{moveORsOutside} \begin{chunk}{defun moveORsOutside} @@ -7912,6 +8109,15 @@ where item has form \end{chunk} +\defun{allLASSOCs}{allLASSOCs} +\begin{chunk}{defun allLASSOCs} +(defun |allLASSOCs| (op alist) + (loop for value in alist + when (equal (car value) op) + collect value)) + +\end{chunk} + \defun{formal2Pattern}{formal2Pattern} \calls{formal2Pattern}{sublis} \calls{formal2Pattern}{pairList} @@ -8929,6 +9135,13 @@ add flag identifiers as literals in the environment \end{chunk} +\defun{insertModemap}{insertModemap} +\begin{chunk}{defun insertModemap} +(defun |insertModemap| (new mmList) + (if (null mmList) (list new) (cons new mmList))) + +\end{chunk} + \defun{mergeModemap}{mergeModemap} \calls{mergeModemap}{isSuperDomain} \calls{mergeModemap}{TruthP} @@ -18299,6 +18512,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun add-parens-and-semis-to-line} \getchunk{defun Advance-Char} \getchunk{defun advance-token} +\getchunk{defun allLASSOCs} \getchunk{defun aplTran} \getchunk{defun aplTran1} \getchunk{defun aplTranList} @@ -18470,10 +18684,12 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun initial-substring} \getchunk{defun initial-substring-p} \getchunk{defun initializeLisplib} +\getchunk{defun insertModemap} \getchunk{defun interactiveModemapForm} \getchunk{defun is-console} \getchunk{defun isDomainConstructorForm} \getchunk{defun isDomainForm} +\getchunk{defun isDomainSubst} \getchunk{defun isFunctor} \getchunk{defun isListConstructor} \getchunk{defun isSuperDomain} @@ -18529,6 +18745,8 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun nonblankloc} \getchunk{defun optional} +\getchunk{defun orderPredicateItems} +\getchunk{defun orderPredTran} \getchunk{defun PARSE-AnyId} \getchunk{defun PARSE-Application} @@ -18735,6 +18953,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun rwriteLispForm} \getchunk{defun setDefOp} +\getchunk{defun signatureTran} \getchunk{defun skip-blanks} \getchunk{defun skip-ifblock} \getchunk{defun skip-to-endif} diff --git a/changelog b/changelog index d1703de..832ed65 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20110801 tpd src/axiom-website/patches.html 20110801.01.tpd.patch +20110801 tpd src/interp/database.lisp treeshake compiler +20110801 tpd books/bookvol5 treeshake interpreter +20110801 tpd books/bookvol9 treeshake compiler 20110731 tpd src/axiom-website/patches.html 20110731.01.tpd.patch 20110731 tpd src/interp/database.lisp treeshake compiler 20110731 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 8994407..64903ae 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3568,5 +3568,7 @@ src/axiom-website/download.html add ubuntu
books/bookvol9 treeshake compiler
20110731.01.tpd.patch books/bookvol9 treeshake compiler
+20110801.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/database.lisp.pamphlet b/src/interp/database.lisp.pamphlet index 05edadc..3a98992 100644 --- a/src/interp/database.lisp.pamphlet +++ b/src/interp/database.lisp.pamphlet @@ -14,107 +14,6 @@ (SETANDFILEQ |$getUnexposedOperations| 'T) -;getDomainFromMm mm == -; -- Returns the Domain (or package or category) of origin from a pattern -; -- modemap -; [., cond] := mm -; if cond is ['partial, :c] then cond := c -; condList := -; cond is ['AND, :cl] => cl -; cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info -; [cond] -; val := -; for condition in condList repeat -; condition is ['isDomain, "*1", dom] => return opOf dom -; condition is ['ofCategory, "*1", cat] => return opOf cat -; null val => -; keyedSystemError("S2GE0016", -; ['"getDomainFromMm",'"Can't find domain in modemap condition"]) -; val - -;(DEFUN |getDomainFromMm| (|mm|) -; (PROG (|c| |cond| |cl| |condList| |dom| |ISTMP#1| |ISTMP#2| |cat| -; |val|) -; (RETURN -; (SEQ (PROGN -; (SPADLET |cond| (CADR |mm|)) -; (COND -; ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|partial|) -; (PROGN (SPADLET |c| (QCDR |cond|)) 'T)) -; (SPADLET |cond| |c|))) -; (SPADLET |condList| -; (COND -; ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'AND) -; (PROGN (SPADLET |cl| (QCDR |cond|)) 'T)) -; |cl|) -; ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'OR) -; (PROGN -; (SPADLET |ISTMP#1| (QCDR |cond|)) -; (AND (PAIRP |ISTMP#1|) -; (PROGN -; (SPADLET |ISTMP#2| -; (QCAR |ISTMP#1|)) -; (AND (PAIRP |ISTMP#2|) -; (EQ (QCAR |ISTMP#2|) 'AND) -; (PROGN -; (SPADLET |cl| -; (QCDR |ISTMP#2|)) -; 'T)))))) -; |cl|) -; ('T (CONS |cond| NIL)))) -; (SPADLET |val| -; (DO ((G167289 |condList| (CDR G167289)) -; (|condition| NIL)) -; ((OR (ATOM G167289) -; (PROGN -; (SETQ |condition| (CAR G167289)) -; NIL)) -; NIL) -; (SEQ (EXIT (COND -; ((AND (PAIRP |condition|) -; (EQ (QCAR |condition|) -; '|isDomain|) -; (PROGN -; (SPADLET |ISTMP#1| -; (QCDR |condition|)) -; (AND (PAIRP |ISTMP#1|) -; (EQ (QCAR |ISTMP#1|) '*1) -; (PROGN -; (SPADLET |ISTMP#2| -; (QCDR |ISTMP#1|)) -; (AND (PAIRP |ISTMP#2|) -; (EQ (QCDR |ISTMP#2|) NIL) -; (PROGN -; (SPADLET |dom| -; (QCAR |ISTMP#2|)) -; 'T)))))) -; (RETURN (|opOf| |dom|))) -; ((AND (PAIRP |condition|) -; (EQ (QCAR |condition|) -; '|ofCategory|) -; (PROGN -; (SPADLET |ISTMP#1| -; (QCDR |condition|)) -; (AND (PAIRP |ISTMP#1|) -; (EQ (QCAR |ISTMP#1|) '*1) -; (PROGN -; (SPADLET |ISTMP#2| -; (QCDR |ISTMP#1|)) -; (AND (PAIRP |ISTMP#2|) -; (EQ (QCDR |ISTMP#2|) NIL) -; (PROGN -; (SPADLET |cat| -; (QCAR |ISTMP#2|)) -; 'T)))))) -; (RETURN (|opOf| |cat|)))))))) -; (COND -; ((NULL |val|) -; (|keyedSystemError| 'S2GE0016 -; (CONS "getDomainFromMm" -; (CONS "Can't find domain in modemap condition" -; NIL)))) -; ('T |val|))))))) - (defun |getDomainFromMm| (mm) (let (c cond condList val) (setq cond (cadr mm)) @@ -375,985 +274,6 @@ |mms|) ('T NIL)))))) -;getInCoreModemaps(modemapList,op,nargs) == -; mml:= LASSOC (op,modemapList) => -; mml:= CAR mml -; [x for (x:= [[dc,:sig],.]) in mml | -; (NUMBERP nargs => nargs=#rest sig; true) and -; (cfn := abbreviate (domName := getDomainFromMm x)) and -; ($getUnexposedOperations or isExposedConstructor(domName))] -; nil - -;(DEFUN |getInCoreModemaps| (|modemapList| |op| |nargs|) -; (PROG (|mml| |dc| |sig| |domName| |cfn|) -; (DECLARE (SPECIAL |$getUnexposedOperations|)) -; (RETURN -; (SEQ (COND -; ((SPADLET |mml| (LASSOC |op| |modemapList|)) -; (SPADLET |mml| (CAR |mml|)) -; (PROG (G167477) -; (SPADLET G167477 NIL) -; (RETURN -; (DO ((G167484 |mml| (CDR G167484)) (|x| NIL)) -; ((OR (ATOM G167484) -; (PROGN (SETQ |x| (CAR G167484)) NIL) -; (PROGN -; (PROGN -; (SPADLET |dc| (CAAR |x|)) -; (SPADLET |sig| (CDAR |x|)) -; |x|) -; NIL)) -; (NREVERSE0 G167477)) -; (SEQ (EXIT (COND -; ((AND (COND -; ((NUMBERP |nargs|) -; (BOOT-EQUAL |nargs| -; (|#| (CDR |sig|)))) -; ('T 'T)) -; (SPADLET |cfn| -; (|abbreviate| -; (SPADLET |domName| -; (|getDomainFromMm| |x|)))) -; (OR |$getUnexposedOperations| -; (|isExposedConstructor| -; |domName|))) -; (SETQ G167477 (CONS |x| G167477)))))))))) -; ('T NIL)))))) - -;updateDatabase(fname,cname,systemdir?) == -; -- for now in NRUNTIME do database update only if forced -; not $forceDatabaseUpdate => nil -; -- these modemaps are never needed in the old scheme -; if oldFname := constructor? cname then -; clearClams() -; clearAllSlams [] -; if GET(cname, 'LOADED) then -; clearConstructorCaches() -; if $forceDatabaseUpdate or not systemdir? then -; clearClams() -; clearAllSlams [] - -(DEFUN |updateDatabase| (|fname| |cname| |systemdir?|) - (declare (ignore |fname|)) - (PROG (|oldFname|) - (DECLARE (SPECIAL |$forceDatabaseUpdate|)) - (RETURN - (COND - ((NULL |$forceDatabaseUpdate|) NIL) - ('T - (COND - ((SPADLET |oldFname| (|constructor?| |cname|)) - (|clearClams|) (|clearAllSlams| NIL) - (COND - ((GETL |cname| 'LOADED) (|clearConstructorCaches|)) - ('T NIL)))) - (COND - ((OR |$forceDatabaseUpdate| (NULL |systemdir?|)) - (|clearClams|) (|clearAllSlams| NIL)) - ('T NIL))))))) - -;removeCoreModemaps(modemapList,c) == -; newUserModemaps:= nil -; c := opOf unabbrev c -; for [op,mmList] in modemapList repeat -; temp:= nil -; for mm in mmList repeat -; cname := getDomainFromMm mm -; if cname ^= c then temp:= [:temp,mm] -; if temp then newUserModemaps:= [:newUserModemaps,[op,temp]] -; newUserModemaps - -(DEFUN |removeCoreModemaps| (|modemapList| |c|) - (PROG (|op| |mmList| |cname| |temp| |newUserModemaps|) - (RETURN - (SEQ (PROGN - (SPADLET |newUserModemaps| NIL) - (SPADLET |c| (|opOf| (|unabbrev| |c|))) - (DO ((G167724 |modemapList| (CDR G167724)) - (G167710 NIL)) - ((OR (ATOM G167724) - (PROGN (SETQ G167710 (CAR G167724)) NIL) - (PROGN - (PROGN - (SPADLET |op| (CAR G167710)) - (SPADLET |mmList| (CADR G167710)) - G167710) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |temp| NIL) - (DO ((G167736 |mmList| (CDR G167736)) - (|mm| NIL)) - ((OR (ATOM G167736) - (PROGN - (SETQ |mm| (CAR G167736)) - NIL)) - NIL) - (SEQ (EXIT - (PROGN - (SPADLET |cname| - (|getDomainFromMm| |mm|)) - (COND - ((NEQUAL |cname| |c|) - (SPADLET |temp| - (APPEND |temp| - (CONS |mm| NIL)))) - ('T NIL)))))) - (COND - (|temp| (SPADLET |newUserModemaps| - (APPEND |newUserModemaps| - (CONS - (CONS |op| (CONS |temp| NIL)) - NIL)))) - ('T NIL)))))) - |newUserModemaps|))))) - -;addCoreModemap(modemapList,op,modemap,cname) == -; entry:= ASSQ(op,modemapList) => -; RPLAC(CADR entry,[modemap,:CADR entry]) -; modemapList -; modeMapList:= [:modemapList,[op,[ modemap]]] - -(DEFUN |addCoreModemap| (|modemapList| |op| |modemap| |cname|) - (declare (ignore |cname|)) - (PROG (|entry| |modeMapList|) - (RETURN - (COND - ((SPADLET |entry| (ASSQ |op| |modemapList|)) - (RPLAC (CADR |entry|) (CONS |modemap| (CADR |entry|))) - |modemapList|) - ('T - (SPADLET |modeMapList| - (APPEND |modemapList| - (CONS (CONS |op| - (CONS (CONS |modemap| NIL) NIL)) - NIL)))))))) - -;REMOVER(lst,item) == -; --destructively removes item from lst -; not PAIRP lst => -; lst=item => nil -; lst -; first lst=item => rest lst -; RPLNODE(lst,REMOVER(first lst,item),REMOVER(rest lst,item)) - -(DEFUN REMOVER (|lst| |item|) - (COND - ((NULL (PAIRP |lst|)) - (COND ((BOOT-EQUAL |lst| |item|) NIL) ('T |lst|))) - ((BOOT-EQUAL (CAR |lst|) |item|) (CDR |lst|)) - ('T - (RPLNODE |lst| (REMOVER (CAR |lst|) |item|) - (REMOVER (CDR |lst|) |item|))))) - -;allLASSOCs(op,alist) == -; [value for [key,:value] in alist | key = op] - -(DEFUN |allLASSOCs| (|op| |alist|) - (PROG (|key| |value|) - (RETURN - (SEQ (PROG (G167775) - (SPADLET G167775 NIL) - (RETURN - (DO ((G167782 |alist| (CDR G167782)) - (G167765 NIL)) - ((OR (ATOM G167782) - (PROGN (SETQ G167765 (CAR G167782)) NIL) - (PROGN - (PROGN - (SPADLET |key| (CAR G167765)) - (SPADLET |value| (CDR G167765)) - G167765) - NIL)) - (NREVERSE0 G167775)) - (SEQ (EXIT (COND - ((BOOT-EQUAL |key| |op|) - (SETQ G167775 - (CONS |value| G167775))))))))))))) - -;loadDependents fn == -; isExistingFile [fn,$spadLibFT,"*"] => -; MEMQ("dependents",RKEYIDS(fn,$spadLibFT)) => -; stream:= readLib1(fn,$spadLibFT,"*") -; l:= rread('dependents,stream,nil) -; RSHUT stream -; for x in l repeat -; x='SubDomain => nil -; loadIfNecessary x - -(DEFUN |loadDependents| (|fn|) - (PROG (|stream| |l|) - (DECLARE (SPECIAL |$spadLibFT|)) - (RETURN - (SEQ (COND - ((|isExistingFile| - (CONS |fn| (CONS |$spadLibFT| (CONS '* NIL)))) - (EXIT (COND - ((member '|dependents| (RKEYIDS |fn| |$spadLibFT|)) - (EXIT (PROGN - (SPADLET |stream| - (|readLibPathFast| (|pathname| (list |fn| |$spadLibFT| '*)))) - (SPADLET |l| - (|rread| '|dependents| |stream| - NIL)) - (RSHUT |stream|) - (DO ((G167800 |l| (CDR G167800)) - (|x| NIL)) - ((OR (ATOM G167800) - (PROGN - (SETQ |x| (CAR G167800)) - NIL)) - NIL) - (SEQ (EXIT - (COND - ((BOOT-EQUAL |x| '|SubDomain|) - NIL) - ('T (|loadIfNecessary| |x|))))))))))))))))) - -;--% Miscellaneous Stuff -;getOplistForConstructorForm (form := [op,:argl]) == -; -- The new form is an op-Alist which has entries ( . signature-Alist) -; -- where signature-Alist has entries ( . item) -; -- where item has form ( ) -; -- where = ELT | CONST | Subsumed | (XLAM..) .. -; pairlis:= [[fv,:arg] for fv in $FormalMapVariableList for arg in argl] -; opAlist := getOperationAlistFromLisplib op -; [:getOplistWithUniqueSignatures(op,pairlis,signatureAlist) -; for [op,:signatureAlist] in opAlist] - -(DEFUN |getOplistForConstructorForm| (|form|) - (PROG (|argl| |pairlis| |opAlist| |op| |signatureAlist|) - (DECLARE (SPECIAL |$FormalMapVariableList|)) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |pairlis| - (PROG (G167832) - (SPADLET G167832 NIL) - (RETURN - (DO ((G167838 |$FormalMapVariableList| - (CDR G167838)) - (|fv| NIL) - (G167839 |argl| (CDR G167839)) - (|arg| NIL)) - ((OR (ATOM G167838) - (PROGN - (SETQ |fv| (CAR G167838)) - NIL) - (ATOM G167839) - (PROGN - (SETQ |arg| (CAR G167839)) - NIL)) - (NREVERSE0 G167832)) - (SEQ (EXIT (SETQ G167832 - (CONS (CONS |fv| |arg|) - G167832)))))))) - (SPADLET |opAlist| (|getOperationAlistFromLisplib| |op|)) - (PROG (G167848) - (SPADLET G167848 NIL) - (RETURN - (DO ((G167854 |opAlist| (CDR G167854)) - (G167811 NIL)) - ((OR (ATOM G167854) - (PROGN (SETQ G167811 (CAR G167854)) NIL) - (PROGN - (PROGN - (SPADLET |op| (CAR G167811)) - (SPADLET |signatureAlist| - (CDR G167811)) - G167811) - NIL)) - G167848) - (SEQ (EXIT (SETQ G167848 - (APPEND G167848 - (|getOplistWithUniqueSignatures| - |op| |pairlis| |signatureAlist|))))))))))))) - -;getOplistWithUniqueSignatures(op,pairlis,signatureAlist) == -; alist:= nil -; for [sig,:[slotNumber,pred,kind]] in signatureAlist | kind ^= 'Subsumed repeat -; alist:= insertAlist(SUBLIS(pairlis,[op,sig]), -; SUBLIS(pairlis,[pred,[kind,nil,slotNumber]]), -; alist) -; alist - -(DEFUN |getOplistWithUniqueSignatures| - (|op| |pairlis| |signatureAlist|) - (PROG (|sig| |slotNumber| |pred| |kind| |alist|) - (RETURN - (SEQ (PROGN - (SPADLET |alist| NIL) - (DO ((G167884 |signatureAlist| (CDR G167884)) - (G167872 NIL)) - ((OR (ATOM G167884) - (PROGN (SETQ G167872 (CAR G167884)) NIL) - (PROGN - (PROGN - (SPADLET |sig| (CAR G167872)) - (SPADLET |slotNumber| (CADR G167872)) - (SPADLET |pred| (CADDR G167872)) - (SPADLET |kind| (CADDDR G167872)) - G167872) - NIL)) - NIL) - (SEQ (EXIT (COND - ((NEQUAL |kind| '|Subsumed|) - (SPADLET |alist| - (|insertAlist| - (SUBLIS |pairlis| - (CONS |op| (CONS |sig| NIL))) - (SUBLIS |pairlis| - (CONS |pred| - (CONS - (CONS |kind| - (CONS NIL - (CONS |slotNumber| NIL))) - NIL))) - |alist|))))))) - |alist|))))) - -;--% Code For Modemap Insertion -;insertModemap(new,mmList) == -; null mmList => [new] -;--isMoreSpecific(new,old:= first mmList) => [new,:mmList] -;--[old,:insertModemap(new,rest mmList)] -; [new,:mmList] - -(DEFUN |insertModemap| (|new| |mmList|) - (COND ((NULL |mmList|) (CONS |new| NIL)) ('T (CONS |new| |mmList|)))) - -;--% Exposure Group Code -;dropPrefix(fn) == -; MEMBER(fn.0,[char "?",char "-",char "+"]) => SUBSTRING(fn,1,nil) -; fn - -(DEFUN |dropPrefix| (|fn|) - (COND - ((|member| (ELT |fn| 0) - (CONS (|char| '?) - (CONS (|char| '-) (CONS (|char| '+) NIL)))) - (SUBSTRING |fn| 1 NIL)) - ('T |fn|))) - -;isExposedConstructor name == -; -- this function checks the local exposure data in the frame to -; -- see if the given constructor is exposed. The format of -; -- $localExposureData is a vector with -; -- slot 0: list of groups exposed in the frame -; -- slot 1: list of constructors explicitly exposed -; -- slot 2: list of constructors explicitly hidden -; -- check if it is explicitly hidden -; MEMQ(name,'(Union Record Mapping)) => true -; MEMQ(name,$localExposureData.2) => false -; -- check if it is explicitly exposed -; MEMQ(name,$localExposureData.1) => true -; -- check if it is in an exposed group -; found := NIL -; for g in $localExposureData.0 while not found repeat -; null (x := GETALIST($globalExposureGroupAlist,g)) => 'iterate -; if GETALIST(x,name) then found := true -; found - -(DEFUN |isExposedConstructor| (|name|) - (PROG (|x| |found|) - (DECLARE (SPECIAL |$globalExposureGroupAlist| |$localExposureData|)) - (RETURN - (SEQ (COND - ((member |name| '(|Union| |Record| |Mapping|)) 'T) - ((member |name| (ELT |$localExposureData| 2)) NIL) - ((member |name| (ELT |$localExposureData| 1)) 'T) - ('T (SPADLET |found| NIL) - (DO ((G167914 (ELT |$localExposureData| 0) - (CDR G167914)) - (|g| NIL)) - ((OR (ATOM G167914) - (PROGN (SETQ |g| (CAR G167914)) NIL) - (NULL (NULL |found|))) - NIL) - (SEQ (EXIT (COND - ((NULL (SPADLET |x| - (GETALIST - |$globalExposureGroupAlist| |g|))) - '|iterate|) - ((GETALIST |x| |name|) - (SPADLET |found| 'T)) - ('T NIL))))) - |found|)))))) - - -;orderPredicateItems(pred1,sig,skip) == -; pred:= signatureTran pred1 -; pred is ["AND",:l] => orderPredTran(l,sig,skip) -; pred - -(DEFUN |orderPredicateItems| (|pred1| |sig| |skip|) - (PROG (|pred| |l|) - (RETURN - (PROGN - (SPADLET |pred| (|signatureTran| |pred1|)) - (COND - ((AND (PAIRP |pred|) (EQ (QCAR |pred|) 'AND) - (PROGN (SPADLET |l| (QCDR |pred|)) 'T)) - (|orderPredTran| |l| |sig| |skip|)) - ('T |pred|)))))) - -;orderPredTran(oldList,sig,skip) == -; lastPreds:=nil -; --(1) make two kinds of predicates appear last: -; ----- (op *target ..) when *target does not appear later in sig -; ----- (isDomain *1 ..) -; for pred in oldList repeat -; ((pred is [op,pvar,.] and MEMQ(op,'(isDomain ofCategory)) -; and pvar=first sig and ^(pvar in rest sig)) or -; (^skip and pred is ['isDomain,pvar,.] and pvar="*1")) => -; oldList:=DELETE(pred,oldList) -; lastPreds:=[pred,:lastPreds] -;--sayBrightlyNT "lastPreds=" -;--pp lastPreds -; --(2a) lastDependList=list of all variables that lastPred forms depend upon -; lastDependList := "UNIONQ"/[listOfPatternIds x for x in lastPreds] -;--sayBrightlyNT "lastDependList=" -;--pp lastDependList -; --(2b) dependList=list of all variables that isDom/ofCat forms depend upon -; dependList := -; "UNIONQ"/[listOfPatternIds y for x in oldList | -; x is ['isDomain,.,y] or x is ['ofCategory,.,y]] -;--sayBrightlyNT "dependList=" -;--pp dependList -; --(3a) newList= list of ofCat/isDom entries that don't depend on -; for x in oldList repeat -; if (x is ['ofCategory,v,body]) or (x is ['isDomain,v,body]) then -; indepvl:=listOfPatternIds v -; depvl:=listOfPatternIds body -; else -; indepvl := listOfPatternIds x -; depvl := nil -; (INTERSECTIONQ(indepvl,dependList) = nil) -; and INTERSECTIONQ(indepvl,lastDependList) => -; somethingDone := true -; lastPreds := [:lastPreds,x] -; oldList := DELETE(x,oldList) -;--if somethingDone then -;-- sayBrightlyNT "Again lastPreds=" -;-- pp lastPreds -;-- sayBrightlyNT "Again oldList=" -;-- pp oldList -; --(3b) newList= list of ofCat/isDom entries that don't depend on -; while oldList repeat -; for x in oldList repeat -; if (x is ['ofCategory,v,body]) or (x is ['isDomain,v,body]) then -; indepvl:=listOfPatternIds v -; depvl:=listOfPatternIds body -; else -; indepvl := listOfPatternIds x -; depvl := nil -; (INTERSECTIONQ(indepvl,dependList) = nil) => -; dependList:= setDifference(dependList,depvl) -; newList:= [:newList,x] -;-- sayBrightlyNT "newList=" -;-- pp newList -; --(4) noldList= what is left over -; (noldList:= setDifference(oldList,newList)) = oldList => -;-- sayMSG '"NOTE: Parameters to domain have circular dependencies" -; newList := [:newList,:oldList] -; return nil -; oldList:=noldList -;-- sayBrightlyNT "noldList=" -;-- pp noldList -; for pred in newList repeat -; if pred is ['isDomain,x,y] or x is ['ofCategory,x,y] then -; ids:= listOfPatternIds y -; if and/[id in fullDependList for id in ids] then -; fullDependList:= insertWOC(x,fullDependList) -; fullDependList:= UNIONQ(fullDependList,ids) -; newList:=[:newList,:lastPreds] -;--substitute (isDomain ..) forms as completely as possible to avoid false paths -; newList := isDomainSubst newList -; answer := [['AND,:newList],:INTERSECTIONQ(fullDependList,sig)] - -(DEFUN |orderPredTran| (|oldList| |sig| |skip|) - (PROG (|op| |pvar| |lastDependList| |somethingDone| |lastPreds| |v| - |body| |indepvl| |depvl| |dependList| |noldList| - |ISTMP#1| |x| |ISTMP#2| |y| |ids| |fullDependList| - |newList| |answer|) - (RETURN - (SEQ (PROGN - (SPADLET |lastPreds| NIL) - (SEQ (DO ((G166547 |oldList| (CDR G166547)) - (|pred| NIL)) - ((OR (ATOM G166547) - (PROGN (SETQ |pred| (CAR G166547)) NIL)) - NIL) - (SEQ (EXIT (COND - ((OR (AND (PAIRP |pred|) - (PROGN - (SPADLET |op| (QCAR |pred|)) - (SPADLET |ISTMP#1| - (QCDR |pred|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |pvar| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL))))) - (member |op| - '(|isDomain| |ofCategory|)) - (BOOT-EQUAL |pvar| (CAR |sig|)) - (NULL - (|member| |pvar| (CDR |sig|)))) - (AND (NULL |skip|) (PAIRP |pred|) - (EQ (QCAR |pred|) '|isDomain|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |pred|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |pvar| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL))))) - (BOOT-EQUAL |pvar| '*1))) - (EXIT (PROGN - (SPADLET |oldList| - (|delete| |pred| |oldList|)) - (SPADLET |lastPreds| - (CONS |pred| |lastPreds|))))))))) - (SPADLET |lastDependList| - (PROG (G166553) - (SPADLET G166553 NIL) - (RETURN - (DO ((G166558 |lastPreds| - (CDR G166558)) - (|x| NIL)) - ((OR (ATOM G166558) - (PROGN - (SETQ |x| (CAR G166558)) - NIL)) - G166553) - (SEQ (EXIT - (SETQ G166553 - (UNIONQ G166553 - (|listOfPatternIds| |x|))))))))) - (SPADLET |dependList| - (PROG (G166564) - (SPADLET G166564 NIL) - (RETURN - (DO ((G166570 |oldList| - (CDR G166570)) - (|x| NIL)) - ((OR (ATOM G166570) - (PROGN - (SETQ |x| (CAR G166570)) - NIL)) - G166564) - (SEQ (EXIT - (COND - ((OR - (AND (PAIRP |x|) - (EQ (QCAR |x|) '|isDomain|) - (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)))))) - (AND (PAIRP |x|) - (EQ (QCAR |x|) - '|ofCategory|) - (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))))))) - (SETQ G166564 - (UNIONQ G166564 - (|listOfPatternIds| |y|))))))))))) - (DO ((G166598 |oldList| (CDR G166598)) (|x| NIL)) - ((OR (ATOM G166598) - (PROGN (SETQ |x| (CAR G166598)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (COND - ((OR - (AND (PAIRP |x|) - (EQ (QCAR |x|) '|ofCategory|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |v| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |body| - (QCAR |ISTMP#2|)) - 'T)))))) - (AND (PAIRP |x|) - (EQ (QCAR |x|) '|isDomain|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |v| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |body| - (QCAR |ISTMP#2|)) - 'T))))))) - (SPADLET |indepvl| - (|listOfPatternIds| |v|)) - (SPADLET |depvl| - (|listOfPatternIds| |body|))) - ('T - (SPADLET |indepvl| - (|listOfPatternIds| |x|)) - (SPADLET |depvl| NIL))) - (COND - ((AND - (NULL - (INTERSECTIONQ |indepvl| - |dependList|)) - (INTERSECTIONQ |indepvl| - |lastDependList|)) - (PROGN - (SPADLET |somethingDone| 'T) - (SPADLET |lastPreds| - (APPEND |lastPreds| - (CONS |x| NIL))) - (SPADLET |oldList| - (|delete| |x| |oldList|))))))))) - (DO () ((NULL |oldList|) NIL) - (SEQ (EXIT (PROGN - (DO ((G166651 |oldList| - (CDR G166651)) - (|x| NIL)) - ((OR (ATOM G166651) - (PROGN - (SETQ |x| (CAR G166651)) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (COND - ((OR - (AND (PAIRP |x|) - (EQ (QCAR |x|) - '|ofCategory|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |v| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET |body| - (QCAR |ISTMP#2|)) - 'T)))))) - (AND (PAIRP |x|) - (EQ (QCAR |x|) '|isDomain|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |v| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET |body| - (QCAR |ISTMP#2|)) - 'T))))))) - (SPADLET |indepvl| - (|listOfPatternIds| |v|)) - (SPADLET |depvl| - (|listOfPatternIds| |body|))) - ('T - (SPADLET |indepvl| - (|listOfPatternIds| |x|)) - (SPADLET |depvl| NIL))) - (COND - ((NULL - (INTERSECTIONQ |indepvl| - |dependList|)) - (PROGN - (SPADLET |dependList| - (SETDIFFERENCE - |dependList| |depvl|)) - (SPADLET |newList| - (APPEND |newList| - (CONS |x| NIL)))))))))) - (COND - ((BOOT-EQUAL - (SPADLET |noldList| - (SETDIFFERENCE |oldList| - |newList|)) - |oldList|) - (SPADLET |newList| - (APPEND |newList| |oldList|)) - (RETURN NIL)) - ('T (SPADLET |oldList| |noldList|))))))) - (DO ((G166674 |newList| (CDR G166674)) - (|pred| NIL)) - ((OR (ATOM G166674) - (PROGN (SETQ |pred| (CAR G166674)) NIL)) - NIL) - (SEQ (EXIT (COND - ((OR (AND (PAIRP |pred|) - (EQ (QCAR |pred|) '|isDomain|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |pred|)) - (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 |y| - (QCAR |ISTMP#2|)) - 'T)))))) - (AND (PAIRP |x|) - (EQ (QCAR |x|) '|ofCategory|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (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 |y| - (QCAR |ISTMP#2|)) - 'T))))))) - (SPADLET |ids| - (|listOfPatternIds| |y|)) - (COND - ((PROG (G166680) - (SPADLET G166680 'T) - (RETURN - (DO - ((G166686 NIL - (NULL G166680)) - (G166687 |ids| - (CDR G166687)) - (|id| NIL)) - ((OR G166686 - (ATOM G166687) - (PROGN - (SETQ |id| - (CAR G166687)) - NIL)) - G166680) - (SEQ - (EXIT - (SETQ G166680 - (AND G166680 - (|member| |id| - |fullDependList|)))))))) - (SPADLET |fullDependList| - (|insertWOC| |x| - |fullDependList|)))) - (SPADLET |fullDependList| - (UNIONQ |fullDependList| - |ids|))) - ('T NIL))))) - (SPADLET |newList| (APPEND |newList| |lastPreds|)) - (SPADLET |newList| (|isDomainSubst| |newList|)) - (SPADLET |answer| - (CONS (CONS 'AND |newList|) - (INTERSECTIONQ |fullDependList| |sig|))))))))) - - -;--sayBrightlyNT '"answer=" -;--pp answer -;isDomainSubst u == main where -; main == -; u is [head,:tail] => -; nhead := -; head is ['isDomain,x,y] => ['isDomain,x,fn(y,tail)] -; head -; [nhead,:isDomainSubst rest u] -; u -; fn(x,alist) == -; atom x => -; IDENTP x and MEMQ(x,$PatternVariableList) and (s := findSub(x,alist)) => s -; x -; [CAR x,:[fn(y,alist) for y in CDR x]] -; findSub(x,alist) == -; null alist => nil -; alist is [['isDomain,y,z],:.] and x = y => z -; findSub(x,rest alist) - -(DEFUN |isDomainSubst,findSub| (|x| |alist|) - (PROG (|ISTMP#1| |ISTMP#2| |y| |ISTMP#3| |z|) - (RETURN - (SEQ (IF (NULL |alist|) (EXIT NIL)) - (IF (AND (AND (PAIRP |alist|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |alist|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|isDomain|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |y| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |z| - (QCAR |ISTMP#3|)) - 'T)))))))) - (BOOT-EQUAL |x| |y|)) - (EXIT |z|)) - (EXIT (|isDomainSubst,findSub| |x| (CDR |alist|))))))) - -(DEFUN |isDomainSubst,fn| (|x| |alist|) - (PROG (|s|) - (DECLARE (SPECIAL |$PatternVariableList|)) - (RETURN - (SEQ (IF (ATOM |x|) - (EXIT (SEQ (IF (AND (AND (IDENTP |x|) - (member |x| |$PatternVariableList|)) - (SPADLET |s| - (|isDomainSubst,findSub| |x| - |alist|))) - (EXIT |s|)) - (EXIT |x|)))) - (EXIT (CONS (CAR |x|) - (PROG (G166826) - (SPADLET G166826 NIL) - (RETURN - (DO ((G166831 (CDR |x|) (CDR G166831)) - (|y| NIL)) - ((OR (ATOM G166831) - (PROGN - (SETQ |y| (CAR G166831)) - NIL)) - (NREVERSE0 G166826)) - (SEQ (EXIT (SETQ G166826 - (CONS - (|isDomainSubst,fn| |y| - |alist|) - G166826))))))))))))) - -(DEFUN |isDomainSubst| (|u|) - (PROG (|head| |tail| |ISTMP#1| |x| |ISTMP#2| |y| |nhead|) - (RETURN - (COND - ((AND (PAIRP |u|) - (PROGN - (SPADLET |head| (QCAR |u|)) - (SPADLET |tail| (QCDR |u|)) - 'T)) - (SPADLET |nhead| - (COND - ((AND (PAIRP |head|) (EQ (QCAR |head|) '|isDomain|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |head|)) - (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 |y| (QCAR |ISTMP#2|)) - 'T)))))) - (CONS '|isDomain| - (CONS |x| - (CONS (|isDomainSubst,fn| |y| |tail|) - NIL)))) - ('T |head|))) - (CONS |nhead| (|isDomainSubst| (CDR |u|)))) - ('T |u|))))) - -;signatureTran pred == -; atom pred => pred -; pred is ['has,D,catForm] and isCategoryForm(catForm,$e) => -; ['ofCategory,D,catForm] -; [signatureTran p for p in pred] - -(DEFUN |signatureTran| (|pred|) - (PROG (|ISTMP#1| D |ISTMP#2| |catForm|) - (DECLARE (SPECIAL |$e|)) - (RETURN - (SEQ (COND - ((ATOM |pred|) |pred|) - ((AND (PAIRP |pred|) (EQ (QCAR |pred|) '|has|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |pred|)) - (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 |catForm| (QCAR |ISTMP#2|)) - 'T))))) - (|isCategoryForm| |catForm| |$e|)) - (CONS '|ofCategory| (CONS D (CONS |catForm| NIL)))) - ('T - (PROG (G166884) - (SPADLET G166884 NIL) - (RETURN - (DO ((G166889 |pred| (CDR G166889)) (|p| NIL)) - ((OR (ATOM G166889) - (PROGN (SETQ |p| (CAR G166889)) NIL)) - (NREVERSE0 G166884)) - (SEQ (EXIT (SETQ G166884 - (CONS (|signatureTran| |p|) - G166884))))))))))))) - \end{chunk} \eject \begin{thebibliography}{99}