diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 7fee5fe..7eef84a 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -10325,6 +10325,56 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{compHasFormat}{compHasFormat} +\calls{compHasFormat}{take} +\calls{compHasFormat}{length} +\calls{compHasFormat}{sublislis} +\calls{compHasFormat}{comp} +\calls{compHasFormat}{pairp} +\calls{compHasFormat}{qcar} +\calls{compHasFormat}{qcdr} +\calls{compHasFormat}{mkList} +\calls{compHasFormat}{mkDomainConstructor} +\calls{compHasFormat}{isDomainForm} +\refsdollar{compHasFormat}{FormalMapVariableList} +\refsdollar{compHasFormat}{EmptyMode} +\refsdollar{compHasFormat}{e} +\refsdollar{compHasFormat}{form} +\refsdollar{compHasFormat}{EmptyEnvironment} +\begin{chunk}{defun compHasFormat} +(defun |compHasFormat| (pred) + (let (olda b argl formals tmp1 a) + (declare (special |$EmptyEnvironment| |$e| |$EmptyMode| + |$FormalMapVariableList| |$form|)) + (when (eq (car pred) '|has|) (car pred)) + (setq olda (second pred)) + (setq b (third pred)) + (setq argl (rest |$form|)) + (setq formals (take (|#| argl) |$FormalMapVariableList|)) + (setq a (sublislis argl formals olda)) + (setq tmp1 (|comp| a |$EmptyMode| |$e|)) + (when tmp1 + (setq a (car tmp1)) + (setq a (sublislis formals argl a)) + (cond + ((and (pairp b) (eq (qcar b) 'attribute) (pairp (qcdr b)) + (eq (qcdr (qcdr b)) nil)) + (list '|HasAttribute| a (list 'quote (qcar (qcdr b))))) + ((and (pairp b) (eq (qcar b) 'signature) (pairp (qcdr b)) + (pairp (qcdr (qcdr b))) (EQ (QCDR (qcdr (qcdr b))) NIL)) + (list '|HasSignature| a + (|mkList| + (list (MKQ (qcar (qcdr b))) + (|mkList| + (loop for type in (qcar (qcdr (qcdr b))) + collect (|mkDomainConstructor| type))))))) + ((|isDomainForm| b |$EmptyEnvironment|) + (list 'equal a b)) + (t + (list '|HasCategory| a (|mkDomainConstructor| b))))))) + +\end{chunk} + \defplist{if}{compIf plist} \begin{chunk}{postvars} (eval-when (eval load) @@ -10375,6 +10425,109 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{canReturn}{canReturn} +\calls{canReturn}{say} +\calls{canReturn}{pairp} +\calls{canReturn}{qcar} +\calls{canReturn}{qcdr} +\calls{canReturn}{canReturn} +\calls{canReturn}{systemErrorHere} +\begin{chunk}{defun canReturn} +(defun |canReturn| (expr level exitCount ValueFlag) + (labels ( + (findThrow (gs expr level exitCount ValueFlag) + (cond + ((atom expr) nil) + ((and (pairp expr) (eq (qcar expr) 'throw) (pairp (qcdr expr)) + (equal (qcar (qcdr expr)) gs) (pairp (qcdr (qcdr expr))) + (eq (qcdr (qcdr (qcdr expr))) nil)) + t) + ((and (pairp expr) (eq (qcar expr) 'seq)) + (let (result) + (loop for u in (qcdr expr) + do (setq result + (or result + (findThrow gs u (1+ level) exitCount ValueFlag)))) + result)) + (t + (let (result) + (loop for u in (rest expr) + do (setq result + (or result + (findThrow gs u level exitCount ValueFlag)))) + result))))) + (let (op count gs) + (cond + ((atom expr) (and ValueFlag (equal level exitCount))) + ((eq (setq op (car expr)) 'quote) (and ValueFlag (equal level exitCount))) + ((eq op '|TAGGEDexit|) + (cond + ((and (pairp expr) (pairp (qcdr expr)) (pairp (qcdr (qcdr expr))) + (eq (qcdr (qcdr (qcdr expr))) nil)) + (|canReturn| (car (third expr)) level (second expr) + (equal (second expr) level))))) + ((and (equal level exitCount) (null ValueFlag)) + nil) + ((eq op 'seq) + (let (result) + (loop for u in (rest expr) + do (setq result (or result (|canReturn| u (1+ level) exitCount nil)))) + result)) + ((eq op '|TAGGEDreturn|) nil) + ((eq op 'catch) + (cond + ((findThrow (second expr) (third expr) level + exitCount ValueFlag) + t) + (t + (|canReturn| (third expr) level exitCount ValueFlag)))) + ((eq op 'cond) + (cond + ((equal level exitCount) + (let (result) + (loop for u in (rest expr) + do (setq result (or result + (|canReturn| (|last| u) level exitCount ValueFlag)))) + result)) + (t + (let (outer) + (loop for v in (rest expr) + do (setq outer (or outer + (let (inner) + (loop for u in v + do (setq inner + (or inner + (findThrow gs u level exitCount ValueFlag)))) + inner)))) + outer)))) + ((eq op 'if) + (and (pairp expr) (pairp (qcdr expr)) (pairp (qcdr (qcdr expr))) + (pairp (qcdr (qcdr (qcdr expr)))) + (eq (qcdr (qcdr (qcdr (qcdr expr)))) nil)) + (cond + ((null (|canReturn| (second expr) 0 0 t)) + (say "IF statement can not cause consequents to be executed") + (|pp| expr))) + (or (|canReturn| (second expr) level exitCount nil) + (|canReturn| (third expr) level exitCount ValueFlag) + (|canReturn| (fourth expr) level exitCount ValueFlag))) + ((atom op) + (let ((result t)) + (loop for u in expr + do (setq result + (and result (|canReturn| u level exitCount ValueFlag)))) + result)) + ((and (pairp op) (eq (qcar op) 'xlam) (pairp (qcdr op)) + (pairp (qcdr (qcdr op))) (eq (qcdr (qcdr (qcdr op))) nil)) + (let ((result t)) + (loop for u in expr + do (setq result + (and result (|canReturn| u level exitCount ValueFlag)))) + result)) + (t (|systemErrorHere| "canReturn")))))) + +\end{chunk} + \defun{compBoolean}{compBoolean} \calls{compBoolean}{comp} \calls{compBoolean}{getSuccessEnvironment} @@ -10391,6 +10544,158 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{getSuccessEnvironment}{getSuccessEnvironment} +\calls{getSuccessEnvironment}{pairp} +\calls{getSuccessEnvironment}{qcar} +\calls{getSuccessEnvironment}{qcdr} +\calls{getSuccessEnvironment}{isDomainForm} +\calls{getSuccessEnvironment}{put} +\calls{getSuccessEnvironment}{identp} +\calls{getSuccessEnvironment}{getProplist} +\calls{getSuccessEnvironment}{comp} +\calls{getSuccessEnvironment}{consProplistOf} +\calls{getSuccessEnvironment}{removeEnv} +\calls{getSuccessEnvironment}{addBinding} +\calls{getSuccessEnvironment}{get} +\refsdollar{getSuccessEnvironment}{EmptyEnvironment} +\refsdollar{getSuccessEnvironment}{EmptyMode} +\begin{chunk}{defun getSuccessEnvironment} +(defun |getSuccessEnvironment| (a env) + (let (id currentProplist tt newProplist x m) + (declare (special |$EmptyMode| |$EmptyEnvironment|)) + (cond + ((and (pairp a) (eq (qcar a) '|has|) (PAIRP (qcdr a)) + (pairp (qcdr (qcdr a))) (eq (qcdr (qcdr (qcdr a))) nil)) + (if + (and (identp (second a)) (|isDomainForm| (third a) |$EmptyEnvironment|)) + (|put| (second a) '|specialCase| (third a) env) + env)) + ((and (pairp a) (eq (qcar a) '|is|) (pairp (qcdr a)) + (pairp (qcdr (qcdr a))) (eq (qcdr (qcdr (qcdr a))) nil)) + (setq id (qcar (qcdr a))) + (setq m (qcar (qcdr (qcdr a)))) + (cond + ((and (identp id) (|isDomainForm| m |$EmptyEnvironment|)) + (setq env (|put| id '|specialCase| m env)) + (setq currentProplist (|getProplist| id env)) + (setq tt (|comp| m |$EmptyMode| env)) + (when tt + (setq env (caddr tt)) + (setq newProplist + (|consProplistOf| id currentProplist '|value| + (cons m (cdr (|removeEnv| tt))))) + (|addBinding| id newProplist env))) + (t env))) + ((and (pairp a) (eq (qcar a) '|case|) (pairp (qcdr a)) + (pairp (qcdr (qcdr a))) (eq (qcdr (qcdr (qcdr a))) nil) + (identp (qcar (qcdr a)))) + (setq x (qcar (qcdr a))) + (setq m (qcar (qcdr (qcdr a)))) + (|put| x '|condition| (cons a (|get| x '|condition| env)) env)) + (t env)))) + +\end{chunk} + +\defun{getInverseEnvironment}{getInverseEnvironment} +\calls{getInverseEnvironment}{pairp} +\calls{getInverseEnvironment}{qcar} +\calls{getInverseEnvironment}{qcdr} +\calls{getInverseEnvironment}{identp} +\calls{getInverseEnvironment}{isDomainForm} +\calls{getInverseEnvironment}{put} +\calls{getInverseEnvironment}{get} +\calls{getInverseEnvironment}{member} +\calls{getInverseEnvironment}{mkpf} +\calls{getInverseEnvironment}{delete} +\calls{getInverseEnvironment}{getUnionMode} +\refsdollar{getInverseEnvironment}{EmptyEnvironment} +\begin{chunk}{defun getInverseEnvironment} +(defun |getInverseEnvironment| (a env) + (let (op argl x m tmp2 oldpred z tmp1 zz newpred) + (declare (special |$EmptyEnvironment|)) + (cond + ((atom a) env) + (t + (setq op (car a)) + (setq argl (cdr a)) + (cond + ((eq op '|has|) + (setq x (car argl)) + (setq m (cadr argl)) + (cond + ((and (identp x) (|isDomainForm| m |$EmptyEnvironment|)) + (|put| x '|specialCase| m env)) + (t env))) + ((and (pairp a) (eq (qcar a) '|case|) + (PROGN + (setq tmp1 (QCDR a)) + (and (pairp tmp1) + (PROGN + (setq x (QCAR tmp1)) + (setq tmp2 (QCDR tmp1)) + (AND (PAIRP tmp2) + (EQ (QCDR tmp2) nil) + (PROGN (setq m (QCAR tmp2)) t))))) + (IDENTP x)) + (COND + ((AND (PROGN + (setq tmp1 (|get| x '|condition| env)) + (AND (PAIRP tmp1) (EQ (QCDR tmp1) nil) + (PROGN + (setq tmp2 (QCAR tmp1)) + (AND (PAIRP tmp2) + (EQ (QCAR tmp2) 'OR) + (PROGN (setq oldpred (QCDR tmp2)) t))))) + (|member| a oldpred)) + (|put| x '|condition| + (LIST (MKPF (|delete| a oldpred) 'OR)) + env)) + (t + (setq tmp1 (|getUnionMode| x env)) + (AND (PAIRP tmp1) + (EQ (QCAR tmp1) '|Union|) + (PROGN + (setq z (QCDR tmp1)) t)) + (setq zz (|delete| m z)) + (DO ((G169713 zz (CDR G169713)) (u nil)) + ((OR (ATOM G169713) + (PROGN (SETQ u (CAR G169713)) nil)) + nil) + (COND + ((AND (PAIRP u) + (EQ (QCAR u) '|:|) + (PROGN + (setq tmp1 (QCDR u)) + (AND (PAIRP tmp1) + (EQUAL (QCAR tmp1) m)))) + (setq zz (|delete| u zz))) + (t nil))) + (setq newpred + (MKPF (PROG (G169723) + (RETURN + (DO + ((G169728 zz + (CDR G169728)) + (mp nil)) + ((OR (ATOM G169728) + (PROGN + (SETQ mp (CAR G169728)) + nil)) + (NREVERSE0 G169723)) + (SETQ G169723 + (CONS + (CONS '|case| + (CONS x + (CONS mp nil))) + G169723))))) + 'OR)) + (|put| x '|condition| + (CONS newpred (|get| x '|condition| env)) + env)))) + (t env)))))) + +\end{chunk} + \defplist{import}{compImport plist} \begin{chunk}{postvars} (eval-when (eval load) @@ -10998,6 +11303,48 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{replaceExitEtc}{replaceExitEtc} +\calls{replaceExitEtc}{pairp} +\calls{replaceExitEtc}{qcar} +\calls{replaceExitEtc}{qcdr} +\calls{replaceExitEtc}{rplac} +\calls{replaceExitEtc}{replaceExitEtc} +\calls{replaceExitEtc}{intersectionEnvironment} +\calls{replaceExitEtc}{convertOrCroak} +\defsdollar{replaceExitEtc}{finalEnv} +\refsdollar{replaceExitEtc}{finalEnv} +\begin{chunk}{defun replaceExitEtc} +(defun |replaceExitEtc| (x tag opFlag opMode) + (declare (special |$finalEnv|)) + (cond + ((atom x) nil) + ((and (pairp x) (eq (qcar x) 'quote)) nil) + ((and (pairp x) (equal (qcar x) opFlag) (pairp (qcdr x)) + (pairp (qcdr (qcdr x))) (eq (qcdr (qcdr (qcdr x))) nil)) + (|rplac| (caaddr x) (|replaceExitEtc| (caaddr x) tag opFlag opMode)) + (cond + ((eql (second x) 0) + (setq |$finalEnv| + (if |$finalEnv| + (|intersectionEnvironment| |$finalEnv| (third (third x))) + (third (third x)))) + (|rplac| (car x) 'throw) + (|rplac| (cadr x) tag) + (|rplac| (caddr x) (car (|convertOrCroak| (caddr x) opMode)))) + (t + (|rplac| (cadr x) (1- (cadr x)))))) + ((and (pairp x) (pairp (qcdr x)) (pairp (qcdr (qcdr x))) + (eq (qcdr (qcdr (qcdr x))) nil) + (member (qcar x) '(|TAGGEDreturn| |TAGGEDexit|))) + (|rplac| (car (caddr x)) + (|replaceExitEtc| (car (caddr x)) tag opFlag opMode))) + (t + (|replaceExitEtc| (car x) tag opFlag opMode) + (|replaceExitEtc| (cdr x) tag opFlag opMode))) + x) + +\end{chunk} + \defun{compSeqItem}{compSeqItem} \calls{compSeqItem}{comp} \calls{compSeqItem}{macroExpand} @@ -11158,6 +11505,59 @@ An angry JHD - August 15th., 1984 \end{chunk} +\defun{setqMultipleExplicit}{setqMultipleExplicit} +\calls{setqMultipleExplicit}{nequal} +\calls{setqMultipleExplicit}{stackMessage} +\calls{setqMultipleExplicit}{genVariable} +\calls{setqMultipleExplicit}{compSetq1} +\calls{setqMultipleExplicit}{last} +\refsdollar{setqMultipleExplicit}{EmptyMode} +\refsdollar{setqMultipleExplicit}{NoValueMode} +\begin{chunk}{defun setqMultipleExplicit} +(defun |setqMultipleExplicit| (nameList valList m env) + (declare (ignore m)) + (let (gensymList assignList tmp1 reAssignList) + (declare (special |$NoValueMode| |$EmptyMode|)) + (cond + ((nequal (|#| nameList) (|#| valList)) + (|stackMessage| + (list '|Multiple assignment error; # of items in: | nameList + '|must = # in: | valList))) + (t + (setq gensymList + (loop for name in nameList + collect (|genVariable|))) + (setq assignList + (loop for g in gensymList + for val in valList + collect (progn + (setq tmp1 + (or (|compSetq1| g val |$EmptyMode| env) + (return '|failed|))) + (setq env (third tmp1)) + tmp1))) + (unless (eq assignList '|failed|) + (setq reAssignList + (loop for g in gensymList + for name in nameList + collect (progn + (setq tmp1 + (or (|compSetq1| name g |$EmptyMode| env) + (return '|failed|))) + (setq env (third tmp1)) + tmp1))) + (unless (eq reAssignList '|failed|) + (list + (cons 'progn + (append + (loop for tt in assignList + collect (car tt)) + (loop for tt in reAssignList + collect (car tt)))) + |$NoValueMode| (third (|last| reAssignList))))))))) + +\end{chunk} + \defun{setqSetelt}{setqSetelt} \calls{setqSetelt}{comp} \begin{chunk}{defun setqSetelt} @@ -18969,6 +19369,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun blankp} \getchunk{defun bumperrorcount} +\getchunk{defun canReturn} \getchunk{defun char-eq} \getchunk{defun char-ne} \getchunk{defun checkWarning} @@ -19017,6 +19418,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun compFormPartiallyBottomUp} \getchunk{defun compFunctorBody} \getchunk{defun compHas} +\getchunk{defun compHasFormat} \getchunk{defun compIf} \getchunk{defun compileFileQuietly} \getchunk{defun compile-lib-file} @@ -19104,6 +19506,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun getDomainsInScope} \getchunk{defun getFormModemaps} \getchunk{defun getFunctorOpsAndAtts} +\getchunk{defun getInverseEnvironment} \getchunk{defun getModemap} \getchunk{defun getModemapList} \getchunk{defun getModemapListFromDomain} @@ -19111,6 +19514,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun getScriptName} \getchunk{defun getSlotFromCategoryForm} \getchunk{defun getSlotFromFunctor} +\getchunk{defun getSuccessEnvironment} \getchunk{defun getTargetFromRhs} \getchunk{defun get-token} \getchunk{defun getToken} @@ -19397,6 +19801,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun read-a-line} \getchunk{defun recompile-lib-file-if-necessary} +\getchunk{defun replaceExitEtc} \getchunk{defun /rf-1} \getchunk{defun removeSuperfluousMapping} \getchunk{defun replaceVars} @@ -19407,6 +19812,7 @@ if \verb|$InteractiveMode| then use a null outputstream \getchunk{defun setDefOp} \getchunk{defun seteltModemapFilter} \getchunk{defun setqMultiple} +\getchunk{defun setqMultipleExplicit} \getchunk{defun signatureTran} \getchunk{defun skip-blanks} \getchunk{defun skip-ifblock} diff --git a/changelog b/changelog index e5f86c7..7a65066 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20110812 tpd src/axiom-website/patches.html 20110812.02.tpd.patch +20110812 tpd src/interp/compiler.lisp treeshake compiler +20110812 tpd books/bookvol9 treeshake compiler 20110812 tpd src/axiom-website/patches.html 20110812.01.rhx.patch 20110812 tpd src/input/Makefile document finite field bug 20110812 rhx src/input/ffieldbug.input added diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 450baa5..1c29ddd 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3582,5 +3582,7 @@ books/bookvol9 treeshake compiler
books/bookvol9 treeshake compiler
20110812.01.rhx.patch src/input/ffieldbug.input added
+20110812.02.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/compiler.lisp.pamphlet b/src/interp/compiler.lisp.pamphlet index e54586e..4c54370 100644 --- a/src/interp/compiler.lisp.pamphlet +++ b/src/interp/compiler.lisp.pamphlet @@ -332,790 +332,6 @@ \end{chunk} -\subsection{setqMultipleExplicit} -\begin{chunk}{*} -;setqMultipleExplicit(nameList,valList,m,e) == -; #nameList^=#valList => -; stackMessage ["Multiple assignment error; # of items in: ",nameList, -; "must = # in: ",valList] -; gensymList:= [genVariable() for name in nameList] -; assignList:= -; --should be fixed to declare genVar when possible -; [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" -; for g in gensymList for val in valList] -; assignList="failed" => nil -; reAssignList:= -; [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" -; for g in gensymList for name in nameList] -; reAssignList="failed" => nil -; [["PROGN",:[T.expr for T in assignList],:[T.expr for T in reAssignList]], -; $NoValueMode, (LAST reAssignList).env] - -(DEFUN |setqMultipleExplicit| (|nameList| |valList| |m| |e|) - (declare (special |m|)) - (PROG (|gensymList| |assignList| |LETTMP#1| |reAssignList|) - (declare (special |$NoValueMode| |$EmptyMode|)) - (RETURN - (SEQ (COND - ((NEQUAL (|#| |nameList|) (|#| |valList|)) - (|stackMessage| - (CONS '|Multiple assignment error; # of items in: | - (CONS |nameList| - (CONS '|must = # in: | - (CONS |valList| NIL)))))) - ('T - (SPADLET |gensymList| - (PROG (G168445) - (SPADLET G168445 NIL) - (RETURN - (DO ((G168450 |nameList| (CDR G168450)) - (|name| NIL)) - ((OR (ATOM G168450) - (PROGN - (SETQ |name| (CAR G168450)) - NIL)) - (NREVERSE0 G168445)) - (SEQ (EXIT (SETQ G168445 - (CONS (|genVariable|) - G168445)))))))) - (SPADLET |assignList| - (PROG (G168464) - (SPADLET G168464 NIL) - (RETURN - (DO ((G168473 |gensymList| - (CDR G168473)) - (|g| NIL) - (G168474 |valList| (CDR G168474)) - (|val| NIL)) - ((OR (ATOM G168473) - (PROGN - (SETQ |g| (CAR G168473)) - NIL) - (ATOM G168474) - (PROGN - (SETQ |val| (CAR G168474)) - NIL)) - (NREVERSE0 G168464)) - (SEQ (EXIT (SETQ G168464 - (CONS - (PROGN - (SPADLET |LETTMP#1| - (OR - (|compSetq1| |g| |val| - |$EmptyMode| |e|) - (RETURN '|failed|))) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|) - G168464)))))))) - (COND - ((BOOT-EQUAL |assignList| '|failed|) NIL) - ('T - (SPADLET |reAssignList| - (PROG (G168491) - (SPADLET G168491 NIL) - (RETURN - (DO ((G168500 |gensymList| - (CDR G168500)) - (|g| NIL) - (G168501 |nameList| - (CDR G168501)) - (|name| NIL)) - ((OR (ATOM G168500) - (PROGN - (SETQ |g| (CAR G168500)) - NIL) - (ATOM G168501) - (PROGN - (SETQ |name| (CAR G168501)) - NIL)) - (NREVERSE0 G168491)) - (SEQ (EXIT - (SETQ G168491 - (CONS - (PROGN - (SPADLET |LETTMP#1| - (OR - (|compSetq1| |name| |g| - |$EmptyMode| |e|) - (RETURN '|failed|))) - (SPADLET |e| - (CADDR |LETTMP#1|)) - |LETTMP#1|) - G168491)))))))) - (COND - ((BOOT-EQUAL |reAssignList| '|failed|) NIL) - ('T - (CONS (CONS 'PROGN - (APPEND (PROG (G168514) - (SPADLET G168514 NIL) - (RETURN - (DO - ((G168519 |assignList| - (CDR G168519)) - (T$ NIL)) - ((OR (ATOM G168519) - (PROGN - (SETQ T$ - (CAR G168519)) - NIL)) - (NREVERSE0 G168514)) - (SEQ - (EXIT - (SETQ G168514 - (CONS (CAR T$) - G168514))))))) - (PROG (G168529) - (SPADLET G168529 NIL) - (RETURN - (DO - ((G168534 |reAssignList| - (CDR G168534)) - (T$ NIL)) - ((OR (ATOM G168534) - (PROGN - (SETQ T$ - (CAR G168534)) - NIL)) - (NREVERSE0 G168529)) - (SEQ - (EXIT - (SETQ G168529 - (CONS (CAR T$) - G168529))))))))) - (CONS |$NoValueMode| - (CONS (CADDR (|last| |reAssignList|)) - NIL))))))))))))) - -\end{chunk} -\subsection{replaceExitEtc} -\begin{chunk}{*} -;replaceExitEtc(x,tag,opFlag,opMode) == -; (fn(x,tag,opFlag,opMode); x) where -; fn(x,tag,opFlag,opMode) == -; atom x => nil -; x is ["QUOTE",:.] => nil -; x is [ =opFlag,n,t] => -; rplac(CAADDR x,replaceExitEtc(CAADDR x,tag,opFlag,opMode)) -; n=0 => -; $finalEnv:= -; --bound in compSeq1 and compDefineCapsuleFunction -; $finalEnv => intersectionEnvironment($finalEnv,t.env) -; t.env -; rplac(first x,"THROW") -; rplac(CADR x,tag) -; rplac(CADDR x,(convertOrCroak(t,opMode)).expr) -; true => rplac(CADR x,CADR x-1) -; x is [key,n,t] and MEMQ(key,'(TAGGEDreturn TAGGEDexit)) => -; rplac(first t,replaceExitEtc(first t,tag,opFlag,opMode)) -; replaceExitEtc(first x,tag,opFlag,opMode) -; replaceExitEtc(rest x,tag,opFlag,opMode) - -(DEFUN |replaceExitEtc,fn| (|x| |tag| |opFlag| |opMode|) - (PROG (|key| |ISTMP#1| |n| |ISTMP#2| |t|) - (declare (special |$finalEnv|)) - (RETURN - (SEQ (IF (ATOM |x|) (EXIT NIL)) - (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'QUOTE)) (EXIT NIL)) - (IF (AND (PAIRP |x|) (EQUAL (QCAR |x|) |opFlag|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |n| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |t| (QCAR |ISTMP#2|)) - 'T)))))) - (EXIT (SEQ (|rplac| (CAADDR |x|) - (|replaceExitEtc| (CAADDR |x|) |tag| - |opFlag| |opMode|)) - (IF (EQL |n| 0) - (EXIT (SEQ - (SPADLET |$finalEnv| - (SEQ - (IF |$finalEnv| - (EXIT - (|intersectionEnvironment| - |$finalEnv| (CADDR |t|)))) - (EXIT (CADDR |t|)))) - (|rplac| (CAR |x|) 'THROW) - (|rplac| (CADR |x|) |tag|) - (EXIT - (|rplac| (CADDR |x|) - (CAR - (|convertOrCroak| |t| |opMode|))))))) - (EXIT (IF 'T - (EXIT - (|rplac| (CADR |x|) - (SPADDIFFERENCE (CADR |x|) 1)))))))) - (IF (AND (AND (PAIRP |x|) - (PROGN - (SPADLET |key| (QCAR |x|)) - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |n| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |t| (QCAR |ISTMP#2|)) - 'T)))))) - (member |key| '(|TAGGEDreturn| |TAGGEDexit|))) - (EXIT (|rplac| (CAR |t|) - (|replaceExitEtc| (CAR |t|) |tag| - |opFlag| |opMode|)))) - (|replaceExitEtc| (CAR |x|) |tag| |opFlag| |opMode|) - (EXIT (|replaceExitEtc| (CDR |x|) |tag| |opFlag| |opMode|)))))) - - -(DEFUN |replaceExitEtc| (|x| |tag| |opFlag| |opMode|) - (PROGN (|replaceExitEtc,fn| |x| |tag| |opFlag| |opMode|) |x|)) - -\end{chunk} -\subsection{compHasFormat} -\begin{chunk}{*} -;compHasFormat (pred is ["has",olda,b]) == -; argl := rest $form -; formals := TAKE(#argl,$FormalMapVariableList) -; a := SUBLISLIS(argl,formals,olda) -; [a,:.] := comp(a,$EmptyMode,$e) or return nil -; a := SUBLISLIS(formals,argl,a) -; b is ["ATTRIBUTE",c] => ["HasAttribute",a,["QUOTE",c]] -; b is ["SIGNATURE",op,sig] => -; ["HasSignature",a, -; mkList [MKQ op,mkList [mkDomainConstructor type for type in sig]]] -; isDomainForm(b,$EmptyEnvironment) => ["EQUAL",a,b] -; ["HasCategory",a,mkDomainConstructor b] - -(DEFUN |compHasFormat| (|pred|) - (PROG (|olda| |b| |argl| |formals| |LETTMP#1| |a| |c| |ISTMP#1| |op| - |ISTMP#2| |sig|) - (declare (special |$EmptyEnvironment| |$e| |$EmptyMode| - |$FormalMapVariableList| |$form|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR |pred|) '|has|) (CAR |pred|))) - (SPADLET |olda| (CADR |pred|)) - (SPADLET |b| (CADDR |pred|)) - (SPADLET |argl| (CDR |$form|)) - (SPADLET |formals| - (TAKE (|#| |argl|) |$FormalMapVariableList|)) - (SPADLET |a| (SUBLISLIS |argl| |formals| |olda|)) - (SPADLET |LETTMP#1| - (OR (|comp| |a| |$EmptyMode| |$e|) (RETURN NIL))) - (SPADLET |a| (CAR |LETTMP#1|)) - (SPADLET |a| (SUBLISLIS |formals| |argl| |a|)) - (COND - ((AND (PAIRP |b|) (EQ (QCAR |b|) 'ATTRIBUTE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |b|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |c| (QCAR |ISTMP#1|)) 'T)))) - (CONS '|HasAttribute| - (CONS |a| - (CONS (CONS 'QUOTE (CONS |c| NIL)) NIL)))) - ((AND (PAIRP |b|) (EQ (QCAR |b|) 'SIGNATURE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |b|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |op| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |sig| (QCAR |ISTMP#2|)) - 'T)))))) - (CONS '|HasSignature| - (CONS |a| - (CONS (|mkList| - (CONS (MKQ |op|) - (CONS - (|mkList| - (PROG (G169224) - (SPADLET G169224 NIL) - (RETURN - (DO - ((G169229 |sig| - (CDR G169229)) - (|type| NIL)) - ((OR (ATOM G169229) - (PROGN - (SETQ |type| - (CAR G169229)) - NIL)) - (NREVERSE0 G169224)) - (SEQ - (EXIT - (SETQ G169224 - (CONS - (|mkDomainConstructor| - |type|) - G169224)))))))) - NIL))) - NIL)))) - ((|isDomainForm| |b| |$EmptyEnvironment|) - (CONS 'EQUAL (CONS |a| (CONS |b| NIL)))) - ('T - (CONS '|HasCategory| - (CONS |a| (CONS (|mkDomainConstructor| |b|) NIL)))))))))) - -\end{chunk} -\subsection{canReturn} -\begin{chunk}{*} -;canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends -; atom expr => ValueFlag and level=exitCount -; (op:= first expr)="QUOTE" => ValueFlag and level=exitCount -; op="TAGGEDexit" => -; expr is [.,count,data] => canReturn(data.expr,level,count,count=level) -; level=exitCount and not ValueFlag => nil -; op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] -; op="TAGGEDreturn" => nil -; op="CATCH" => -; [.,gs,data]:= expr -; (findThrow(gs,data,level,exitCount,ValueFlag) => true) where -; findThrow(gs,expr,level,exitCount,ValueFlag) == -; atom expr => nil -; expr is ["THROW", =gs,data] => true -; --this is pessimistic, but I know of no more accurate idea -; expr is ["SEQ",:l] => -; or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] -; or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] -; canReturn(data,level,exitCount,ValueFlag) -; op = "COND" => -; level = exitCount => -; or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] -; or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] -; for v in rest expr] -; op="IF" => -; expr is [.,a,b,c] -; if not canReturn(a,0,0,true) then -; SAY "IF statement can not cause consequents to be executed" -; pp expr -; canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) -; or canReturn(c,level,exitCount,ValueFlag) -; --now we have an ordinary form -; atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] -; op is ["XLAM",args,bods] => -; and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] -; systemErrorHere '"canReturn" --for the time being - -(DEFUN |canReturn,findThrow| - (|gs| |expr| |level| |exitCount| |ValueFlag|) - (PROG (|ISTMP#1| |ISTMP#2| |data| |l|) - (RETURN - (SEQ (IF (ATOM |expr|) (EXIT NIL)) - (IF (AND (PAIRP |expr|) (EQ (QCAR |expr|) 'THROW) - (PROGN - (SPADLET |ISTMP#1| (QCDR |expr|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |gs|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |data| (QCAR |ISTMP#2|)) - 'T)))))) - (EXIT 'T)) - (IF (AND (PAIRP |expr|) (EQ (QCAR |expr|) 'SEQ) - (PROGN (SPADLET |l| (QCDR |expr|)) 'T)) - (EXIT (PROG (G169370) - (SPADLET G169370 NIL) - (RETURN - (DO ((G169376 NIL G169370) - (G169377 |l| (CDR G169377)) - (|u| NIL)) - ((OR G169376 (ATOM G169377) - (PROGN - (SETQ |u| (CAR G169377)) - NIL)) - G169370) - (SEQ (EXIT (SETQ G169370 - (OR G169370 - (|canReturn,findThrow| |gs| |u| - (PLUS |level| 1) |exitCount| - |ValueFlag|)))))))))) - (EXIT (PROG (G169384) - (SPADLET G169384 NIL) - (RETURN - (DO ((G169390 NIL G169384) - (G169391 (CDR |expr|) (CDR G169391)) - (|u| NIL)) - ((OR G169390 (ATOM G169391) - (PROGN (SETQ |u| (CAR G169391)) NIL)) - G169384) - (SEQ (EXIT (SETQ G169384 - (OR G169384 - (|canReturn,findThrow| |gs| - |u| |level| |exitCount| - |ValueFlag|))))))))))))) - -(DEFUN |canReturn| (|expr| |level| |exitCount| |ValueFlag|) - (PROG (|op| |count| |gs| |data| |a| |b| |ISTMP#3| |c| |ISTMP#1| - |args| |ISTMP#2| |bods|) - (RETURN - (SEQ (COND - ((ATOM |expr|) - (AND |ValueFlag| (BOOT-EQUAL |level| |exitCount|))) - ((BOOT-EQUAL (SPADLET |op| (CAR |expr|)) 'QUOTE) - (AND |ValueFlag| (BOOT-EQUAL |level| |exitCount|))) - ((BOOT-EQUAL |op| '|TAGGEDexit|) - (COND - ((AND (PAIRP |expr|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |expr|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |count| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |data| (QCAR |ISTMP#2|)) - 'T)))))) - (EXIT (|canReturn| (CAR |data|) |level| |count| - (BOOT-EQUAL |count| |level|)))))) - ((AND (BOOT-EQUAL |level| |exitCount|) (NULL |ValueFlag|)) - NIL) - ((BOOT-EQUAL |op| 'SEQ) - (PROG (G169463) - (SPADLET G169463 NIL) - (RETURN - (DO ((G169469 NIL G169463) - (G169470 (CDR |expr|) (CDR G169470)) - (|u| NIL)) - ((OR G169469 (ATOM G169470) - (PROGN (SETQ |u| (CAR G169470)) NIL)) - G169463) - (SEQ (EXIT (SETQ G169463 - (OR G169463 - (|canReturn| |u| (PLUS |level| 1) - |exitCount| NIL))))))))) - ((BOOT-EQUAL |op| '|TAGGEDreturn|) NIL) - ((BOOT-EQUAL |op| 'CATCH) - (PROGN - (SPADLET |gs| (CADR |expr|)) - (SPADLET |data| (CADDR |expr|)) - (COND - ((|canReturn,findThrow| |gs| |data| |level| - |exitCount| |ValueFlag|) - 'T) - ('T - (|canReturn| |data| |level| |exitCount| |ValueFlag|))))) - ((BOOT-EQUAL |op| 'COND) - (COND - ((BOOT-EQUAL |level| |exitCount|) - (PROG (G169477) - (SPADLET G169477 NIL) - (RETURN - (DO ((G169483 NIL G169477) - (G169484 (CDR |expr|) (CDR G169484)) - (|u| NIL)) - ((OR G169483 (ATOM G169484) - (PROGN (SETQ |u| (CAR G169484)) NIL)) - G169477) - (SEQ (EXIT (SETQ G169477 - (OR G169477 - (|canReturn| (|last| |u|) - |level| |exitCount| - |ValueFlag|))))))))) - ('T - (PROG (G169491) - (SPADLET G169491 NIL) - (RETURN - (DO ((G169497 NIL G169491) - (G169498 (CDR |expr|) (CDR G169498)) - (|v| NIL)) - ((OR G169497 (ATOM G169498) - (PROGN (SETQ |v| (CAR G169498)) NIL)) - G169491) - (SEQ (EXIT (SETQ G169491 - (OR G169491 - (PROG (G169505) - (SPADLET G169505 NIL) - (RETURN - (DO - ((G169511 NIL - G169505) - (G169512 |v| - (CDR G169512)) - (|u| NIL)) - ((OR G169511 - (ATOM G169512) - (PROGN - (SETQ |u| - (CAR G169512)) - NIL)) - G169505) - (SEQ - (EXIT - (SETQ G169505 - (OR G169505 - (|canReturn| |u| - |level| |exitCount| - |ValueFlag|)))))))))))))))))) - ((BOOT-EQUAL |op| 'IF) - (PROGN - (AND (PAIRP |expr|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |expr|)) - (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)))))))) - (COND - ((NULL (|canReturn| |a| 0 0 'T)) - (SAY "IF statement can not cause consequents to be executed") - (|pp| |expr|))) - (OR (|canReturn| |a| |level| |exitCount| NIL) - (|canReturn| |b| |level| |exitCount| |ValueFlag|) - (|canReturn| |c| |level| |exitCount| |ValueFlag|)))) - ((ATOM |op|) - (PROG (G169519) - (SPADLET G169519 'T) - (RETURN - (DO ((G169525 NIL (NULL G169519)) - (G169526 |expr| (CDR G169526)) (|u| NIL)) - ((OR G169525 (ATOM G169526) - (PROGN (SETQ |u| (CAR G169526)) NIL)) - G169519) - (SEQ (EXIT (SETQ G169519 - (AND G169519 - (|canReturn| |u| |level| - |exitCount| |ValueFlag|))))))))) - ((AND (PAIRP |op|) (EQ (QCAR |op|) 'XLAM) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |args| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |bods| (QCAR |ISTMP#2|)) - 'T)))))) - (PROG (G169533) - (SPADLET G169533 'T) - (RETURN - (DO ((G169539 NIL (NULL G169533)) - (G169540 |expr| (CDR G169540)) (|u| NIL)) - ((OR G169539 (ATOM G169540) - (PROGN (SETQ |u| (CAR G169540)) NIL)) - G169533) - (SEQ (EXIT (SETQ G169533 - (AND G169533 - (|canReturn| |u| |level| - |exitCount| |ValueFlag|))))))))) - ('T (|systemErrorHere| "canReturn"))))))) - -\end{chunk} -\subsection{getSuccessEnvironment} -\begin{chunk}{*} -;getSuccessEnvironment(a,e) == -; -- the next four lines try to ensure that explicit special-case tests -; -- prevent implicit ones from being generated -; a is ["has",x,m] => -; IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) -; e -; a is ["is",id,m] => -; IDENTP id and isDomainForm(m,$EmptyEnvironment) => -; e:=put(id,"specialCase",m,e) -; currentProplist:= getProplist(id,e) -; [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs -; newProplist:= consProplistOf(id,currentProplist,"value",[m,:rest removeEnv T]) -; addBinding(id,newProplist,e) -; e -; a is ["case",x,m] and IDENTP x => -; put(x,"condition",[a,:get(x,"condition",e)],e) -; e - -(DEFUN |getSuccessEnvironment| (|a| |e|) - (PROG (|id| |currentProplist| T$ |newProplist| |ISTMP#1| |x| |ISTMP#2| |m|) - (declare (special |$EmptyMode| |$EmptyEnvironment|)) - (RETURN - (COND - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|has|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (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 |m| (QCAR |ISTMP#2|)) 'T)))))) - (COND - ((AND (IDENTP |x|) (|isDomainForm| |m| |$EmptyEnvironment|)) - (|put| |x| '|specialCase| |m| |e|)) - ('T |e|))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|is|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |id| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |m| (QCAR |ISTMP#2|)) 'T)))))) - (COND - ((AND (IDENTP |id|) - (|isDomainForm| |m| |$EmptyEnvironment|)) - (SPADLET |e| (|put| |id| '|specialCase| |m| |e|)) - (SPADLET |currentProplist| (|getProplist| |id| |e|)) - (SPADLET T$ - (OR (|comp| |m| |$EmptyMode| |e|) (RETURN NIL))) - (SPADLET |e| (CADDR T$)) - (SPADLET |newProplist| - (|consProplistOf| |id| |currentProplist| '|value| - (CONS |m| (CDR (|removeEnv| T$))))) - (|addBinding| |id| |newProplist| |e|)) - ('T |e|))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|case|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (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 |m| (QCAR |ISTMP#2|)) 'T))))) - (IDENTP |x|)) - (|put| |x| '|condition| - (CONS |a| (|get| |x| '|condition| |e|)) |e|)) - ('T |e|))))) - -\end{chunk} -\subsection{getInverseEnvironment} -\begin{chunk}{*} -;getInverseEnvironment(a,E) == -; atom a => E -; [op,:argl]:= a -;-- the next five lines try to ensure that explicit special-case tests -;-- prevent implicit ones from being generated -; op="has" => -; [x,m]:= argl -; IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) -; E -; a is ["case",x,m] and IDENTP x => -; --the next two lines are necessary to get 3-branched Unions to work -; -- old-style unions, that is -; (get(x,"condition",E) is [["OR",:oldpred]]) and MEMBER(a,oldpred) => -; put(x,"condition",LIST MKPF(DELETE(a,oldpred),"OR"),E) -; getUnionMode(x,E) is ["Union",:l] -; l':= DELETE(m,l) -; for u in l' repeat -; if u is ['_:,=m,:.] then l':=DELETE(u,l') -; newpred:= MKPF([["case",x,m'] for m' in l'],"OR") -; put(x,"condition",[newpred,:get(x,"condition",E)],E) -; E - -(DEFUN |getInverseEnvironment| (|a| E) - (PROG (|op| |argl| |x| |m| |ISTMP#2| |oldpred| |l| |ISTMP#1| |l'| |newpred|) - (declare (special |$EmptyEnvironment|)) - (RETURN - (SEQ (COND - ((ATOM |a|) E) - ('T (SPADLET |op| (CAR |a|)) (SPADLET |argl| (CDR |a|)) - (COND - ((BOOT-EQUAL |op| '|has|) (SPADLET |x| (CAR |argl|)) - (SPADLET |m| (CADR |argl|)) - (COND - ((AND (IDENTP |x|) - (|isDomainForm| |m| |$EmptyEnvironment|)) - (|put| |x| '|specialCase| |m| E)) - ('T E))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|case|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (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 |m| (QCAR |ISTMP#2|)) - 'T))))) - (IDENTP |x|)) - (COND - ((AND (PROGN - (SPADLET |ISTMP#1| - (|get| |x| '|condition| E)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) 'OR) - (PROGN - (SPADLET |oldpred| - (QCDR |ISTMP#2|)) - 'T))))) - (|member| |a| |oldpred|)) - (|put| |x| '|condition| - (LIST (MKPF (|delete| |a| |oldpred|) 'OR)) - E)) - ('T (SPADLET |ISTMP#1| (|getUnionMode| |x| E)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|Union|) - (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) 'T)) - (SPADLET |l'| (|delete| |m| |l|)) - (DO ((G169713 |l'| (CDR G169713)) (|u| NIL)) - ((OR (ATOM G169713) - (PROGN (SETQ |u| (CAR G169713)) NIL)) - NIL) - (SEQ (EXIT (COND - ((AND (PAIRP |u|) - (EQ (QCAR |u|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |m|)))) - (SPADLET |l'| (|delete| |u| |l'|))) - ('T NIL))))) - (SPADLET |newpred| - (MKPF (PROG (G169723) - (SPADLET G169723 NIL) - (RETURN - (DO - ((G169728 |l'| - (CDR G169728)) - (|m'| NIL)) - ((OR (ATOM G169728) - (PROGN - (SETQ |m'| (CAR G169728)) - NIL)) - (NREVERSE0 G169723)) - (SEQ - (EXIT - (SETQ G169723 - (CONS - (CONS '|case| - (CONS |x| - (CONS |m'| NIL))) - G169723))))))) - 'OR)) - (|put| |x| '|condition| - (CONS |newpred| (|get| |x| '|condition| E)) - E)))) - ('T E)))))))) - -\end{chunk} \subsection{getUnionMode} \begin{chunk}{*} ;getUnionMode(x,e) ==