diff --git a/changelog b/changelog index fddcd41..2c2408f 100644 --- a/changelog +++ b/changelog @@ -1,4 +1,5 @@ -20090914 tpd src/axiom-website/patches.html 20090914.01.tpd.patch +20090915 tpd src/axiom-website/patches.html 20090915.01.tpd.patch +20090915 tpd src/interp/i-funsel.lisp refactored 20090914 tpd src/interp/Makefile add generic rules for lisp compiles 20090907 tpd src/axiom-website/patches.html 20090907.02.tpd.patch 20090907 tpd src/input/unit-i-funsel.input unit test the i-funsel functions diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index c41772b..c1175c3 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2004,5 +2004,7 @@ src/interp/chtheorm.inputadd more checking
src/input/unit-i-funsel.input unit test the i-funsel functions
20090914.01.tpd.patch src/interp/Makefile add generic rules for lisp compiles
+20090915.01.tpd.patch +src/interp/i-funsel.lisp refactored
diff --git a/src/interp/i-funsel.lisp.pamphlet b/src/interp/i-funsel.lisp.pamphlet index d7aa652..fe2d913 100644 --- a/src/interp/i-funsel.lisp.pamphlet +++ b/src/interp/i-funsel.lisp.pamphlet @@ -39,12 +39,12 @@ isPartialMode m == CONTAINED($EmptyMode,m) <<*>>= + (IN-PACKAGE "BOOT" ) ;SETANDFILEQ($constructorExposureList, '(Boolean Integer String)) -(SETANDFILEQ |$constructorExposureList| '(|Boolean| |Integer| |String|)) - +(SETANDFILEQ |$constructorExposureList| (QUOTE (|Boolean| |Integer| |String|))) ;sayFunctionSelection(op,args,target,dc,func) == ; $abbreviateTypes : local := true ; startTimingProcess 'debug @@ -58,34 +58,44 @@ isPartialMode m == ; if dc then sayMSG concat ['" From: ", :bright prefix2String dc] ; stopTimingProcess 'debug +; NO UNIT TEST (DEFUN |sayFunctionSelection| (|op| |args| |target| |dc| |func|) - (PROG (|$abbreviateTypes| |fsig|) - (DECLARE (SPECIAL |$abbreviateTypes|)) - (RETURN - (PROGN - (SPADLET |$abbreviateTypes| (QUOTE T)) - (|startTimingProcess| (QUOTE |debug|)) - (SPADLET |fsig| (|formatSignatureArgs| |args|)) - (COND ((NULL (LISTP |fsig|)) (SPADLET |fsig| (LIST |fsig|)))) - (COND (|func| (SPADLET |func| (|bright| (CONS "by " (CONS |func| NIL)))))) - (|sayMSG| - (|concat| - (CONS (QUOTE |%l|) - (APPEND (|bright| "Function Selection for") - (CONS |op| - (APPEND |func| - (CONS (QUOTE |%l|) (CONS " Arguments:" (|bright| |fsig|))))))))) - (COND - (|target| - (|sayMSG| - (|concat| - (CONS " Target type:" (|bright| (|prefix2String| |target|))))))) - (COND - (|dc| - (|sayMSG| - (|concat| - (CONS " From: " (|bright| (|prefix2String| |dc|))))))) - (|stopTimingProcess| (QUOTE |debug|)))))) + (PROG (|$abbreviateTypes| |fsig|) + (DECLARE (SPECIAL |$abbreviateTypes|)) + (RETURN + (PROGN + (setq |$abbreviateTypes| t) + (|startTimingProcess| '|debug|) + (setq |fsig| (|formatSignatureArgs| |args|)) + (COND ((NULL (LISTP |fsig|)) (setq |fsig| (LIST |fsig|)))) + (COND + (|func| (setq |func| + (|bright| + (CONS "by " + (CONS |func| NIL)))))) + (|sayMSG| + (|concat| + (CONS '|%l| + (APPEND (|bright| + "Function Selection for") + (CONS |op| + (APPEND |func| + (CONS '|%l| + (CONS + " Arguments:" + (|bright| |fsig|))))))))) + (COND + (|target| + (|sayMSG| + (|concat| + (CONS " Target type:" + (|bright| (|prefix2String| |target|))))))) + (COND + (|dc| (|sayMSG| + (|concat| + (CONS " From: " + (|bright| (|prefix2String| |dc|))))))) + (|stopTimingProcess| '|debug|))))) ;sayFunctionSelectionResult(op,args,mmS) == ; $abbreviateTypes : local := true @@ -95,23 +105,26 @@ isPartialMode m == ; '"found for arguments",:bright formatSignatureArgs args] ; stopTimingProcess 'debug +; NO UNIT TEST (DEFUN |sayFunctionSelectionResult| (|op| |args| |mmS|) - (PROG (|$abbreviateTypes|) - (DECLARE (SPECIAL |$abbreviateTypes|)) - (RETURN - (PROGN - (SPADLET |$abbreviateTypes| (QUOTE T)) - (|startTimingProcess| (QUOTE |debug|)) - (COND - (|mmS| (|printMms| |mmS|)) - ((QUOTE T) - (|sayMSG| - (|concat| - (CONS " -> no function" - (APPEND (|bright| |op|) - (CONS "found for arguments" - (|bright| (|formatSignatureArgs| |args|))))))))) - (|stopTimingProcess| (QUOTE |debug|)))))) + (PROG (|$abbreviateTypes|) + (DECLARE (SPECIAL |$abbreviateTypes|)) + (RETURN + (PROGN + (setq |$abbreviateTypes| t) + (|startTimingProcess| '|debug|) + (COND + (|mmS| (|printMms| |mmS|)) + (t + (|sayMSG| + (|concat| + (CONS " -> no function" + (APPEND (|bright| |op|) + (CONS + "found for arguments" + (|bright| + (|formatSignatureArgs| |args|))))))))) + (|stopTimingProcess| '|debug|))))) ;selectMms(op,args,$declaredMode) == ; -- selects applicable modemaps for node op and arguments args @@ -183,176 +196,217 @@ isPartialMode m == ; sayMSG concat ['" Default target type:", ; :bright prefix2String tar] ; selectLocalMms(op,n,types1,tar) or -; (VECTORP op and selectMms1(n,tar,types1,types2,'T)) +; (VECTORP op and selectMms1(n,tar,types1,types2,t)) ; if $reportBottomUpFlag then sayFunctionSelectionResult(n,types1,mmS) ; stopTimingProcess 'modemaps ; mmS (DEFUN |selectMms| (|op| |args| |$declaredMode|) - (DECLARE (SPECIAL |$declaredMode|)) - (PROG (|n| |opMode| |ta| |imp| |ISTMP#1| |f| |numArgs| |tree| |ut| |ua| - |val| |types1| |dc| |identType| |types2| |tar| |mmS|) - (RETURN - (SEQ - (PROGN - (|startTimingProcess| (QUOTE |modemaps|)) - (SPADLET |n| (|getUnname| |op|)) - (SPADLET |val| (|getValue| |op|)) - (SPADLET |opMode| (|objMode| |val|)) - (COND - ((AND - (OR (AND (|isSharpVarWithNum| |n|) |opMode|) (AND |val| |opMode|)) - (PAIRP |opMode|) - (EQ (QCAR |opMode|) (QUOTE |Mapping|)) - (PROGN (SPADLET |ta| (QCDR |opMode|)) (QUOTE T))) - (SPADLET |imp| - (COND (|val| (|wrapped2Quote| (|objVal| |val|))) ((QUOTE T) |n|))) - (CONS - (CONS (CONS (QUOTE |local|) |ta|) (CONS |imp| (CONS NIL NIL))) - NIL)) - ((AND - (OR (AND (|isSharpVarWithNum| |n|) |opMode|) (AND |val| |opMode|)) - (PAIRP |opMode|) - (EQ (QCAR |opMode|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |opMode|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |f| (QCAR |ISTMP#1|)) (QUOTE T))))) - (|emptyAtree| |op|) - (SETELT |op| 0 |f|) - (|selectMms| |op| |args| |$declaredMode|)) - ((AND - (|isSharpVarWithNum| |n|) - (PAIRP |opMode|) - (EQ (QCAR |opMode|) (QUOTE |FunctionCalled|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |opMode|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |f| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SETELT |op| 0 |f|) - (|selectMms| |op| |args| |$declaredMode|)) - ((QUOTE T) - (SPADLET |types1| (|getOpArgTypes| |n| |args|)) - (SPADLET |numArgs| (|#| |args|)) - (COND - ((|member| (QUOTE (|SubDomain| (|Domain|))) |types1|) NIL) - ((|member| (QUOTE (|Domain|)) |types1|) NIL) - ((|member| |$EmptyMode| |types1|) NIL) - ((QUOTE T) - (SPADLET |tar| (|getTarget| |op|)) - (SPADLET |dc| (|getAtree| |op| (QUOTE |dollar|))) - (COND - ((AND (NULL |dc|) - |val| - (BOOT-EQUAL (|objMode| |val|) |$AnonymousFunction|)) - (SPADLET |tree| (|mkAtree| (|objValUnwrap| (|getValue| |op|)))) - (|putTarget| |tree| (CONS (QUOTE |Mapping|) (CONS |tar| |types1|))) - (|bottomUp| |tree|) - (SPADLET |val| (|getValue| |tree|)) - (CONS - (CONS - (CONS (QUOTE |local|) (CDR (|objMode| |val|))) - (CONS (|wrapped2Quote| (|objVal| |val|)) (CONS NIL NIL))) - NIL)) - ((QUOTE T) - (COND - ((AND - (BOOT-EQUAL |n| (QUOTE |map|)) - (BOOT-EQUAL (CAR |types1|) |$AnonymousFunction|)) - (SPADLET |tree| - (|mkAtree| (|objValUnwrap| (|getValue| (CAR |args|))))) - (SPADLET |ut| - (COND (|tar| (|underDomainOf| |tar|)) ((QUOTE T) NIL))) - (SPADLET |ua| - (PROG (#0=#:G166098) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166103 (CDR |types1|) (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (|underDomainOf| |x|) #0#)))))))) - (COND - ((|member| NIL |ua|) NIL) - ((QUOTE T) - (|putTarget| |tree| (CONS (QUOTE |Mapping|) (CONS |ut| |ua|))) - (|bottomUp| |tree|) - (SPADLET |val| (|getValue| |tree|)) - (SPADLET |types1| (CONS (|objMode| |val|) (CDR |types1|))) - (RPLACA |args| |tree|))))) - (COND - ((AND - (EQL |numArgs| 1) - (OR - (BOOT-EQUAL |n| (QUOTE |numer|)) - (BOOT-EQUAL |n| (QUOTE |denom|))) - (|isEqualOrSubDomain| (CAR |types1|) |$Integer|) - (NULL |dc|)) - (SPADLET |dc| (CONS (QUOTE |Fraction|) (CONS |$Integer| NIL))) - (|putAtree| |op| (QUOTE |dollar|) |dc|))) - (COND - (|$reportBottomUpFlag| - (|sayFunctionSelection| |n| |types1| |tar| |dc| NIL))) - (SPADLET |identType| (QUOTE |Variable|)) - (SEQ - (DO ((#2=#:G166113 |types1| (CDR #2#)) (|x| NIL)) - ((OR (ATOM #2#) - (PROGN (SETQ |x| (CAR #2#)) NIL) - (NULL (NULL |$declaredMode|))) - NIL) - (SEQ - (EXIT - (COND - ((NULL (EQCAR |x| |identType|)) - (EXIT (SPADLET |$declaredMode| |x|))))))) - (SPADLET |types2| - (PROG (#3=#:G166125) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G166131 |types1| (CDR #4#)) - (|x| NIL) - (#5=#:G166132 |args| (CDR #5#)) - (|y| NIL)) - ((OR (ATOM #4#) - (PROGN (SETQ |x| (CAR #4#)) NIL) - (ATOM #5#) - (PROGN (SETQ |y| (CAR #5#)) NIL)) - (NREVERSE0 #3#)) - (SEQ - (EXIT - (SETQ #3# - (CONS (|altTypeOf| |x| |y| |$declaredMode|) #3#)))))))) - (SPADLET |mmS| + (DECLARE (SPECIAL |$declaredMode|)) + (PROG (|n| |opMode| |ta| |imp| |ISTMP#1| |f| |numArgs| |tree| |ut| + |ua| |val| |types1| |dc| |identType| |types2| |tar| |mmS|) + (declare (special |$AnonymousFunction| |$reportBottomUpFlag| |$EmptyMode| + |$RationalNumber| |$Integer| |$declaredMode|)) + (RETURN + (SEQ (PROGN + (|startTimingProcess| '|modemaps|) + (setq |n| (|getUnname| |op|)) + (setq |val| (|getValue| |op|)) + (setq |opMode| (|objMode| |val|)) (COND - (|dc| (|selectDollarMms| |dc| |n| |types1| |types2|)) - ((QUOTE T) - (COND - ((AND (BOOT-EQUAL |n| (QUOTE /)) (BOOT-EQUAL |tar| |$Integer|)) - (SPADLET |tar| |$RationalNumber|) - (|putTarget| |op| |tar|))) - (COND - ((NULL |tar|) - (SPADLET |tar| - (|defaultTarget| |op| |n| (|#| |types1|) |types1|)) - (COND - ((AND |tar| |$reportBottomUpFlag|) - (|sayMSG| - (|concat| - (CONS " Default target type:" - (|bright| (|prefix2String| |tar|)))))) - ((QUOTE T) NIL)))) - (OR - (|selectLocalMms| |op| |n| |types1| |tar|) - (AND - (VECTORP |op|) - (|selectMms1| |n| |tar| |types1| |types2| (QUOTE T))))))) - (COND - (|$reportBottomUpFlag| - (|sayFunctionSelectionResult| |n| |types1| |mmS|))) - (|stopTimingProcess| (QUOTE |modemaps|)) - (EXIT |mmS|))))))))))))) + ((AND (OR (AND (|isSharpVarWithNum| |n|) |opMode|) + (AND |val| |opMode|)) + (PAIRP |opMode|) (EQ (QCAR |opMode|) '|Mapping|) + (PROGN (setq |ta| (QCDR |opMode|)) t)) + (setq |imp| + (COND + (|val| (|wrapped2Quote| (|objVal| |val|))) + (t |n|))) + (CONS (CONS (CONS '|local| |ta|) + (CONS |imp| (CONS NIL NIL))) + NIL)) + ((AND (OR (AND (|isSharpVarWithNum| |n|) |opMode|) + (AND |val| |opMode|)) + (PAIRP |opMode|) (EQ (QCAR |opMode|) '|Variable|) + (PROGN + (setq |ISTMP#1| (QCDR |opMode|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |f| (QCAR |ISTMP#1|)) t)))) + (|emptyAtree| |op|) (SETELT |op| 0 |f|) + (|selectMms| |op| |args| |$declaredMode|)) + ((AND (|isSharpVarWithNum| |n|) (PAIRP |opMode|) + (EQ (QCAR |opMode|) '|FunctionCalled|) + (PROGN + (setq |ISTMP#1| (QCDR |opMode|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |f| (QCAR |ISTMP#1|)) t)))) + (SETELT |op| 0 |f|) + (|selectMms| |op| |args| |$declaredMode|)) + (t (setq |types1| (|getOpArgTypes| |n| |args|)) + (setq |numArgs| (|#| |args|)) + (COND + ((|member| '(|SubDomain| (|Domain|)) |types1|) NIL) + ((|member| '(|Domain|) |types1|) NIL) + ((|member| |$EmptyMode| |types1|) NIL) + (t (setq |tar| (|getTarget| |op|)) + (setq |dc| (|getAtree| |op| '|dollar|)) + (COND + ((AND (NULL |dc|) |val| + (BOOT-EQUAL (|objMode| |val|) + |$AnonymousFunction|)) + (setq |tree| + (|mkAtree| + (|objValUnwrap| (|getValue| |op|)))) + (|putTarget| |tree| + (CONS '|Mapping| (CONS |tar| |types1|))) + (|bottomUp| |tree|) + (setq |val| (|getValue| |tree|)) + (CONS (CONS (CONS '|local| + (CDR (|objMode| |val|))) + (CONS (|wrapped2Quote| + (|objVal| |val|)) + (CONS NIL NIL))) + NIL)) + (t + (COND + ((AND (BOOT-EQUAL |n| '|map|) + (BOOT-EQUAL (CAR |types1|) + |$AnonymousFunction|)) + (setq |tree| + (|mkAtree| + (|objValUnwrap| + (|getValue| (CAR |args|))))) + (setq |ut| + (COND + (|tar| (|underDomainOf| |tar|)) + (t NIL))) + (setq |ua| + (PROG (G166098) + (setq G166098 NIL) + (RETURN + (DO + ((G166103 (CDR |types1|) + (CDR G166103)) + (|x| NIL)) + ((OR (ATOM G166103) + (PROGN + (SETQ |x| (CAR G166103)) + NIL)) + (NREVERSE0 G166098)) + (SEQ + (EXIT + (SETQ G166098 + (CONS (|underDomainOf| |x|) + G166098)))))))) + (COND + ((|member| NIL |ua|) NIL) + (t + (|putTarget| |tree| + (CONS '|Mapping| (CONS |ut| |ua|))) + (|bottomUp| |tree|) + (setq |val| (|getValue| |tree|)) + (setq |types1| + (CONS (|objMode| |val|) + (CDR |types1|))) + (RPLACA |args| |tree|))))) + (COND + ((AND (EQL |numArgs| 1) + (OR (BOOT-EQUAL |n| '|numer|) + (BOOT-EQUAL |n| '|denom|)) + (|isEqualOrSubDomain| (CAR |types1|) + |$Integer|) + (NULL |dc|)) + (setq |dc| + (CONS '|Fraction| + (CONS |$Integer| NIL))) + (|putAtree| |op| '|dollar| |dc|))) + (COND + (|$reportBottomUpFlag| + (|sayFunctionSelection| |n| |types1| |tar| + |dc| NIL))) + (setq |identType| '|Variable|) + (SEQ (DO ((G166113 |types1| (CDR G166113)) + (|x| NIL)) + ((OR (ATOM G166113) + (PROGN + (SETQ |x| (CAR G166113)) + NIL) + (NULL (NULL |$declaredMode|))) + NIL) + (SEQ (EXIT (COND + ((NULL + (EQCAR |x| |identType|)) + (EXIT + (setq |$declaredMode| + |x|))))))) + (setq |types2| + (PROG (G166125) + (setq G166125 NIL) + (RETURN + (DO + ((G166131 |types1| + (CDR G166131)) + (|x| NIL) + (G166132 |args| + (CDR G166132)) + (|y| NIL)) + ((OR (ATOM G166131) + (PROGN + (SETQ |x| (CAR G166131)) + NIL) + (ATOM G166132) + (PROGN + (SETQ |y| (CAR G166132)) + NIL)) + (NREVERSE0 G166125)) + (SEQ + (EXIT + (SETQ G166125 + (CONS + (|altTypeOf| |x| |y| + |$declaredMode|) + G166125)))))))) + (setq |mmS| + (COND + (|dc| + (|selectDollarMms| |dc| |n| + |types1| |types2|)) + (t + (COND + ((AND (BOOT-EQUAL |n| '/) + (BOOT-EQUAL |tar| + |$Integer|)) + (setq |tar| + |$RationalNumber|) + (|putTarget| |op| |tar|))) + (COND + ((NULL |tar|) + (setq |tar| + (|defaultTarget| |op| |n| + (|#| |types1|) |types1|)) + (COND + ((AND |tar| + |$reportBottomUpFlag|) + (|sayMSG| + (|concat| + (CONS + " Default target type:" + (|bright| + (|prefix2String| + |tar|)))))) + (t NIL)))) + (OR + (|selectLocalMms| |op| |n| + |types1| |tar|) + (AND (VECTORP |op|) + (|selectMms1| |n| |tar| + |types1| |types2| t)))))) + (COND + (|$reportBottomUpFlag| + (|sayFunctionSelectionResult| |n| + |types1| |mmS|))) + (|stopTimingProcess| '|modemaps|) + (EXIT |mmS|))))))))))))) ;-- selectMms1 is in clammed.boot ;selectMms2(op,tar,args1,args2,$Coerce) == @@ -440,259 +494,349 @@ isPartialMode m == ; mmS and orderMms(op, mmS,args1,args2,tar) (DEFUN |selectMms2| (|op| |tar| |args1| |args2| |$Coerce|) - (DECLARE (SPECIAL |$Coerce|)) - (PROG (|nargs| |ISTMP#2| |fun| |ud| |ut| |funNode| |mapMms| |mapMm| |r| - |xx| |t| |l| |ISTMP#1| |name| |xm| |a'| |x| |a| |mmS|) - (RETURN - (SEQ - (COND - ((PROG (#0=#:G166213) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166219 NIL #0#) - (#2=#:G166220 |args1| (CDR #2#)) - (|arg| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |arg| (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (OR #0# (STRINGP |arg|)))))))) - NIL) - ((QUOTE T) - (COND ((BOOT-EQUAL |tar| |$EmptyMode|) (SPADLET |tar| NIL))) - (SPADLET |nargs| (|#| |args1|)) - (SPADLET |mmS| NIL) - (SPADLET |mmS| - (COND - ((AND - |$Coerce| - (BOOT-EQUAL |op| (QUOTE |map|)) - (EQL 2 |nargs|) - (PROGN - (SPADLET |ISTMP#1| (CAR |args1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |fun| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (COND - ((NULL (SPADLET |ud| (|underDomainOf| (CADR |args1|)))) NIL) - ((QUOTE T) - (COND - (|tar| (SPADLET |ut| (|underDomainOf| |tar|))) - ((QUOTE T) (SPADLET |ut| NIL))) - (COND - ((NULL - (SPADLET |mapMms| - (|selectMms1| |fun| |ut| - (CONS |ud| NIL) - (CONS NIL NIL) - (QUOTE T)))) - NIL) - ((QUOTE T) - (SPADLET |mapMm| (CDAAR |mapMms|)) - (|selectMms1| |op| |tar| - (CONS - (CONS (QUOTE |Mapping|) |mapMm|) - (CONS (CADR |args1|) NIL)) - (CONS NIL (CONS (CADR |args2|) NIL)) |$Coerce|)))))) - ((AND - |$Coerce| - (BOOT-EQUAL |op| (QUOTE |map|)) - (EQL 2 |nargs|) - (PROGN - (SPADLET |ISTMP#1| (CAR |args1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |FunctionCalled|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |fun| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (COND - ((NULL (SPADLET |ud| (|underDomainOf| (CADR |args1|)))) NIL) - ((QUOTE T) - (COND - (|tar| (SPADLET |ut| (|underDomainOf| |tar|))) - ((QUOTE T) (SPADLET |ut| NIL))) - (SPADLET |funNode| (|mkAtreeNode| |fun|)) - (|transferPropsToNode| |fun| |funNode|) - (COND - ((NULL - (SPADLET |mapMms| - (|selectLocalMms| |funNode| |fun| (CONS |ud| NIL) NIL))) + (DECLARE (SPECIAL |$Coerce|)) + (PROG (|nargs| |ISTMP#2| |fun| |ud| |ut| |funNode| |mapMms| |mapMm| + |r| |xx| |t| |l| |ISTMP#1| |name| |xm| |a'| |x| |a| + |mmS|) + (declare (special |$e| |$RationalNumber| |$EmptyMode|)) + (RETURN + (SEQ (COND + ((PROG (G166213) + (setq G166213 NIL) + (RETURN + (DO ((G166219 NIL G166213) + (G166220 |args1| (CDR G166220)) (|arg| NIL)) + ((OR G166219 (ATOM G166220) + (PROGN (SETQ |arg| (CAR G166220)) NIL)) + G166213) + (SEQ (EXIT (SETQ G166213 + (OR G166213 (STRINGP |arg|)))))))) NIL) - ((QUOTE T) - (SPADLET |mapMm| (CDAAR |mapMms|)) - (|selectMms1| |op| |tar| - (CONS - (CONS (QUOTE |Mapping|) |mapMm|) - (CONS (CADR |args1|) NIL)) - (CONS NIL (CONS (CADR |args2|) NIL)) |$Coerce|)))))) - ((QUOTE T) - (SPADLET |a| NIL) - (DO ((#3=#:G166230 |args1| (CDR #3#)) (|x| NIL)) - ((OR (ATOM #3#) (PROGN (SETQ |x| (CAR #3#)) NIL)) NIL) - (SEQ - (EXIT - (COND (|x| (SPADLET |a| (CONS |x| |a|))) ((QUOTE T) NIL))))) - (DO ((#4=#:G166239 |args2| (CDR #4#)) (|x| NIL)) - ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) NIL) - (SEQ - (EXIT - (COND (|x| (SPADLET |a| (CONS |x| |a|))) ((QUOTE T) NIL))))) - (COND - ((AND |tar| (NULL (|isPartialMode| |tar|))) - (SPADLET |a| (CONS |tar| |a|)))) - (COND - ((|member| |op| (QUOTE (= + * -))) - (SPADLET |r| (|resolveTypeList| |a|)) - (COND - ((NEQUAL |r| NIL) (SPADLET |a| (CONS |r| |a|))) - ((QUOTE T) NIL)))) - (COND - ((AND |tar| (NULL (|isPartialMode| |tar|))) - (COND - ((SPADLET |xx| (|underDomainOf| |tar|)) - (SPADLET |a| (CONS |xx| |a|))) - ((QUOTE T) NIL)))) - (SEQ - (DO ((#5=#:G166248 |args1| (CDR #5#)) (|x| NIL)) - ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) NIL) - (SEQ - (EXIT + (t (COND - ((AND (PAIRP |x|) - (|member| (CAR |x|) - (QUOTE (|List| |Vector| |Stream| |FiniteSet| |Array|)))) - (EXIT - (COND - ((SPADLET |xx| (|underDomainOf| |x|)) - (EXIT (SPADLET |a| (CONS |xx| |a|))))))))))) - (SPADLET |a'| NIL) - (SPADLET |a| (NREVERSE (REMDUP |a|))) - (DO ((#6=#:G166271 |a| (CDR #6#)) (|x| NIL)) - ((OR (ATOM #6#) (PROGN (SETQ |x| (CAR #6#)) NIL)) NIL) - (SEQ - (COND - ((NULL |x|) (QUOTE |iterate|)) - ((BOOT-EQUAL |x| (QUOTE (|RationalRadicals|))) - (SPADLET |a'| (CONS |$RationalNumber| |a'|))) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |Union|)) - (PROGN (SPADLET |l| (QCDR |x|)) (QUOTE T))) - (COND - ((AND |l| - (PROGN - (SPADLET |ISTMP#1| (CAR |l|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |:|))))) - (DO ((#7=#:G166281 |l| (CDR #7#)) (#8=#:G166199 NIL)) - ((OR (ATOM #7#) - (PROGN (SETQ #8# (CAR #7#)) NIL) - (PROGN (PROGN (SPADLET |t| (CADDR #8#)) #8#) NIL)) - NIL) - (SEQ (EXIT (SPADLET |a'| (CONS |t| |a'|)))))) - ((QUOTE T) (SPADLET |a'| (APPEND (REVERSE |l|) |a'|))))) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |Mapping|)) - (PROGN (SPADLET |l| (QCDR |x|)) (QUOTE T))) - (SPADLET |a'| (APPEND (REVERSE |l|) |a'|))) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |Record|)) - (PROGN (SPADLET |l| (QCDR |x|)) (QUOTE T))) - (SPADLET |a'| - (APPEND - (REVERSE - (PROG (#9=#:G166292) - (SPADLET #9# NIL) - (RETURN - (DO ((#10=#:G166297 |l| (CDR #10#)) (|s| NIL)) - ((OR (ATOM #10#) (PROGN (SETQ |s| (CAR #10#)) NIL)) - (NREVERSE0 #9#)) - (SEQ (EXIT (SETQ #9# (CONS (CADDR |s|) #9#)))))))) - |a'|))) - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |FunctionCalled|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |name| (QCAR |ISTMP#1|)) (QUOTE T))))) - (COND - ((AND - (SPADLET |xm| (|get| |name| (QUOTE |mode|) |$e|)) - (NULL (|isPartialMode| |xm|))) - (EXIT (SPADLET |a'| (CONS |xm| |a'|))))))))) - (SPADLET |a| (APPEND |a| (REMDUP |a'|))) - (SPADLET |a| - (PROG (#11=#:G166308) - (SPADLET #11# NIL) - (RETURN - (DO ((#12=#:G166314 |a| (CDR #12#)) (|x| NIL)) - ((OR (ATOM #12#) (PROGN (SETQ |x| (CAR #12#)) NIL)) - (NREVERSE0 #11#)) - (SEQ - (EXIT - (COND ((PAIRP |x|) (SETQ #11# (CONS |x| #11#)))))))))) - (SPADLET |a'| |a|) - (DO () - ((NULL |a|) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |x| (CAR |a|)) - (SPADLET |a| (CDR |a|)) - (COND - ((ATOM |x|) (QUOTE |iterate|)) - ((QUOTE T) - (SPADLET |mmS| - (APPEND |mmS| - (|findFunctionInDomain| |op| |x| |tar| |args1| |args2| - NIL NIL))))))))) - (COND - ((AND (NULL |mmS|) |$Coerce|) - (SPADLET |a| |a'|) - (DO () - ((NULL |a|) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |x| (CAR |a|)) - (SPADLET |a| (CDR |a|)) - (COND - ((ATOM |x|) (QUOTE |iterate|)) - ((QUOTE T) - (SPADLET |mmS| - (APPEND |mmS| - (|findFunctionInDomain| |op| |x| |tar| |args1| + ((BOOT-EQUAL |tar| |$EmptyMode|) (setq |tar| NIL))) + (setq |nargs| (|#| |args1|)) (setq |mmS| NIL) + (setq |mmS| + (COND + ((AND |$Coerce| (BOOT-EQUAL |op| '|map|) + (EQL 2 |nargs|) + (PROGN + (setq |ISTMP#1| (CAR |args1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Variable|) + (PROGN + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |fun| + (QCAR |ISTMP#2|)) + t)))))) + (COND + ((NULL (setq |ud| + (|underDomainOf| (CADR |args1|)))) + NIL) + (t + (COND + (|tar| (setq |ut| + (|underDomainOf| |tar|))) + (t (setq |ut| NIL))) + (COND + ((NULL (setq |mapMms| + (|selectMms1| |fun| |ut| + (CONS |ud| NIL) (CONS NIL NIL) + t))) + NIL) + (t (setq |mapMm| (CDAAR |mapMms|)) + (|selectMms1| |op| |tar| + (CONS (CONS '|Mapping| |mapMm|) + (CONS (CADR |args1|) NIL)) + (CONS NIL + (CONS (CADR |args2|) NIL)) + |$Coerce|)))))) + ((AND |$Coerce| (BOOT-EQUAL |op| '|map|) + (EQL 2 |nargs|) + (PROGN + (setq |ISTMP#1| (CAR |args1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|FunctionCalled|) + (PROGN + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |fun| + (QCAR |ISTMP#2|)) + t)))))) + (COND + ((NULL (setq |ud| + (|underDomainOf| (CADR |args1|)))) + NIL) + (t + (COND + (|tar| (setq |ut| + (|underDomainOf| |tar|))) + (t (setq |ut| NIL))) + (setq |funNode| (|mkAtreeNode| |fun|)) + (|transferPropsToNode| |fun| |funNode|) + (COND + ((NULL (setq |mapMms| + (|selectLocalMms| |funNode| + |fun| (CONS |ud| NIL) NIL))) + NIL) + (t (setq |mapMm| (CDAAR |mapMms|)) + (|selectMms1| |op| |tar| + (CONS (CONS '|Mapping| |mapMm|) + (CONS (CADR |args1|) NIL)) + (CONS NIL + (CONS (CADR |args2|) NIL)) + |$Coerce|)))))) + (t (setq |a| NIL) + (DO ((G166230 |args1| (CDR G166230)) + (|x| NIL)) + ((OR (ATOM G166230) + (PROGN + (SETQ |x| (CAR G166230)) + NIL)) + NIL) + (SEQ (EXIT (COND + (|x| + (setq |a| (CONS |x| |a|))) + (t NIL))))) + (DO ((G166239 |args2| (CDR G166239)) + (|x| NIL)) + ((OR (ATOM G166239) + (PROGN + (SETQ |x| (CAR G166239)) + NIL)) + NIL) + (SEQ (EXIT (COND + (|x| + (setq |a| (CONS |x| |a|))) + (t NIL))))) + (COND + ((AND |tar| (NULL (|isPartialMode| |tar|))) + (setq |a| (CONS |tar| |a|)))) + (COND + ((|member| |op| '(= + * -)) + (setq |r| (|resolveTypeList| |a|)) + (COND + ((NEQUAL |r| NIL) + (setq |a| (CONS |r| |a|))) + (t NIL)))) + (COND + ((AND |tar| (NULL (|isPartialMode| |tar|))) + (COND + ((setq |xx| (|underDomainOf| |tar|)) + (setq |a| (CONS |xx| |a|))) + (t NIL)))) + (SEQ (DO ((G166248 |args1| (CDR G166248)) + (|x| NIL)) + ((OR (ATOM G166248) + (PROGN + (SETQ |x| (CAR G166248)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((AND (PAIRP |x|) + (|member| (CAR |x|) + '(|List| |Vector| |Stream| + |FiniteSet| |Array|))) + (EXIT + (COND + ((setq |xx| + (|underDomainOf| |x|)) + (EXIT + (setq |a| + (CONS |xx| |a|))))))))))) + (setq |a'| NIL) + (setq |a| (NREVERSE (REMDUP |a|))) + (DO ((G166271 |a| (CDR G166271)) + (|x| NIL)) + ((OR (ATOM G166271) + (PROGN + (SETQ |x| (CAR G166271)) + NIL)) + NIL) + (SEQ (COND + ((NULL |x|) '|iterate|) + ((BOOT-EQUAL |x| + '(|RationalRadicals|)) + (setq |a'| + (CONS |$RationalNumber| |a'|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '|Union|) + (PROGN + (setq |l| (QCDR |x|)) + t)) + (COND + ((AND |l| + (PROGN + (setq |ISTMP#1| + (CAR |l|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|:|)))) + (DO + ((G166281 |l| + (CDR G166281)) + (G166199 NIL)) + ((OR (ATOM G166281) + (PROGN + (SETQ G166199 + (CAR G166281)) + NIL) + (PROGN + (PROGN + (setq |t| + (CADDR G166199)) + G166199) + NIL)) + NIL) + (SEQ + (EXIT + (setq |a'| + (CONS |t| |a'|)))))) + (t + (setq |a'| + (APPEND (REVERSE |l|) + |a'|))))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '|Mapping|) + (PROGN + (setq |l| (QCDR |x|)) + t)) + (setq |a'| + (APPEND (REVERSE |l|) |a'|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '|Record|) + (PROGN + (setq |l| (QCDR |x|)) + t)) + (setq |a'| + (APPEND + (REVERSE + (PROG (G166292) + (setq G166292 NIL) + (RETURN + (DO + ((G166297 |l| + (CDR G166297)) + (|s| NIL)) + ((OR (ATOM G166297) + (PROGN + (SETQ |s| + (CAR G166297)) + NIL)) + (NREVERSE0 G166292)) + (SEQ + (EXIT + (SETQ G166292 + (CONS (CADDR |s|) + G166292)))))))) + |a'|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) + '|FunctionCalled|) + (PROGN + (setq |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |name| + (QCAR |ISTMP#1|)) + t)))) + (COND + ((AND + (setq |xm| + (|get| |name| '|mode| + |$e|)) + (NULL + (|isPartialMode| |xm|))) + (EXIT + (setq |a'| + (CONS |xm| |a'|))))))))) + (setq |a| (APPEND |a| (REMDUP |a'|))) + (setq |a| + (PROG (G166308) + (setq G166308 NIL) + (RETURN + (DO + ((G166314 |a| + (CDR G166314)) + (|x| NIL)) + ((OR (ATOM G166314) + (PROGN + (SETQ |x| + (CAR G166314)) + NIL)) + (NREVERSE0 G166308)) + (SEQ + (EXIT + (COND + ((PAIRP |x|) + (SETQ G166308 + (CONS |x| + G166308)))))))))) + (setq |a'| |a|) + (DO () ((NULL |a|) NIL) + (SEQ (EXIT + (PROGN + (setq |x| (CAR |a|)) + (setq |a| (CDR |a|)) + (COND + ((ATOM |x|) '|iterate|) + (t + (setq |mmS| + (APPEND |mmS| + (|findFunctionInDomain| + |op| |x| |tar| |args1| + |args2| NIL NIL))))))))) + (COND + ((AND (NULL |mmS|) |$Coerce|) + (setq |a| |a'|) + (DO () ((NULL |a|) NIL) + (SEQ + (EXIT + (PROGN + (setq |x| (CAR |a|)) + (setq |a| (CDR |a|)) + (COND + ((ATOM |x|) '|iterate|) + (t + (setq |mmS| + (APPEND |mmS| + (|findFunctionInDomain| + |op| |x| |tar| |args1| |args2| |$Coerce| NIL))))))))))) - (OR |mmS| (|selectMmsGen| |op| |tar| |args1| |args2|)))))) - (AND |mmS| (|orderMms| |op| |mmS| |args1| |args2| |tar|)))))))) + (OR |mmS| + (|selectMmsGen| |op| |tar| |args1| + |args2|)))))) + (AND |mmS| (|orderMms| |op| |mmS| |args1| |args2| |tar|)))))))) ;isAVariableType t == ; t is ['Variable,.] or t = $Symbol or t is ['OrderedVariableList,.] -(DEFUN |isAVariableType| (|t|) - (PROG (|ISTMP#1|) - (RETURN - (OR - (AND (PAIRP |t|) - (EQ (QCAR |t|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - (BOOT-EQUAL |t| |$Symbol|) - (AND (PAIRP |t|) - (EQ (QCAR |t|) (QUOTE |OrderedVariableList|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))))))) +(defun |isAVariableType| (arg) + (let (tmp1) + (declare (special |$Symbol|)) + (or + (and (pairp arg) + (eq (qcar arg) '|Variable|) + (progn + (setq tmp1 (qcdr arg)) + (and (pairp tmp1) (eq (qcdr tmp1) nil)))) + (boot-equal arg |$Symbol|) + (and (pairp arg) + (eq (qcar arg) '|OrderedVariableList|) + (progn + (setq tmp1 (qcdr arg)) + (and (pairp tmp1) (eq (qcdr tmp1) nil))))))) ;defaultTarget(opNode,op,nargs,args) == ; -- this is for efficiency. Chooses standard targets for operations @@ -869,555 +1013,654 @@ isPartialMode m == ; target (DEFUN |defaultTarget| (|opNode| |op| |nargs| |args|) - (PROG (|a1| |a1f| |a2| |mms| |LETTMP#1| |targ| |sym| |symNode| |b1| |b2| - |t| |ISTMP#2| |ISTMP#3| |a2e| D1 D |a3| |ISTMP#1| |a3e| |target|) - (RETURN - (SEQ - (PROGN - (SPADLET |target| NIL) - (COND - ((EQL |nargs| 0) - (COND - ((BOOT-EQUAL |op| (QUOTE |nil|)) - (|putTarget| |opNode| (SPADLET |target| (QUOTE (|List| (|None|))))) - |target|) - ((OR - (BOOT-EQUAL |op| (QUOTE |true|)) - (BOOT-EQUAL |op| (QUOTE |false|))) - (|putTarget| |opNode| (SPADLET |target| |$Boolean|)) - |target|) - ((BOOT-EQUAL |op| (QUOTE |pi|)) - (|putTarget| |opNode| (SPADLET |target| (CONS (QUOTE |Pi|) NIL))) - |target|) - ((BOOT-EQUAL |op| (QUOTE |infinity|)) - (|putTarget| |opNode| - (SPADLET |target| - (CONS (QUOTE |OnePointCompletion|) (CONS |$Integer| NIL)))) - |target|) - ((|member| |op| (QUOTE (|plusInfinity| |minusInfinity|))) - (|putTarget| |opNode| - (SPADLET |target| - (CONS (QUOTE |OrderedCompletion|) (CONS |$Integer| NIL)))) - |target|) - ((QUOTE T) |target|))) - ((QUOTE T) - (SPADLET |a1| (CAR |args|)) - (COND - ((ATOM |a1|) |target|) - ((QUOTE T) - (SPADLET |a1f| (QCAR |a1|)) - (COND - ((EQL |nargs| 1) - (COND - ((BOOT-EQUAL |op| (QUOTE |kernel|)) - (|putTarget| |opNode| - (SPADLET |target| - (CONS - (QUOTE |Kernel|) - (CONS (CONS (QUOTE |Expression|) (CONS |$Integer| NIL)) NIL)))) - |target|) - ((BOOT-EQUAL |op| (QUOTE |list|)) - (|putTarget| |opNode| - (SPADLET |target| (CONS (QUOTE |List|) (CONS |a1| NIL)))) - |target|) - ((QUOTE T) |target|))) - ((QUOTE T) - (SPADLET |a2| (CADR |args|)) - (COND - ((AND - (>= |nargs| 2) - (BOOT-EQUAL |op| (QUOTE |draw|)) - (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |FunctionCalled|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |sym| (QCAR |ISTMP#1|)) (QUOTE T)))) - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Segment|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - (SPADLET |symNode| (|mkAtreeNode| |sym|)) - (|transferPropsToNode| |sym| |symNode|) - (COND - ((AND (>= |nargs| 3) - (PROGN - (SPADLET |ISTMP#1| (CADDR |args|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Segment|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) - (|selectLocalMms| |symNode| |sym| - (CONS |$DoubleFloat| (CONS |$DoubleFloat| NIL)) NIL) - (|putTarget| |opNode| - (SPADLET |target| (QUOTE (|ThreeDimensionalViewport|)))) - |target|) - ((SPADLET |mms| - (|selectLocalMms| |symNode| |sym| - (CONS |$DoubleFloat| NIL) NIL)) - (SPADLET |LETTMP#1| (CAAR |mms|)) - (SPADLET |targ| (CADR |LETTMP#1|)) - (COND - ((BOOT-EQUAL |targ| |$DoubleFloat|) - (|putTarget| |opNode| - (SPADLET |target| (QUOTE (|TwoDimensionalViewport|)))) - |target|) - ((BOOT-EQUAL |targ| - (CONS (QUOTE |Point|) (CONS |$DoubleFloat| NIL))) - (|putTarget| |opNode| - (SPADLET |target| - (QUOTE (|ThreeDimensionalViewport|)))) |target|) - ((QUOTE T) |target|))) - ((QUOTE T) |target|))) - ((AND (>= |nargs| 2) - (BOOT-EQUAL |op| (QUOTE |makeObject|)) - (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |FunctionCalled|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |sym| (QCAR |ISTMP#1|)) (QUOTE T)))) - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Segment|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - (SPADLET |symNode| (|mkAtreeNode| |sym|)) - (|transferPropsToNode| |sym| |symNode|) + (PROG (|a1| |a1f| |a2| |mms| |LETTMP#1| |targ| |sym| |symNode| |b1| + |b2| |t| |ISTMP#2| |ISTMP#3| |a2e| D1 D |a3| |ISTMP#1| + |a3e| |target|) + (declare (special |$Any| |$Integer| |$RationalNumber| |$QuotientField| + |$NonNegativeInteger| |$PositiveInteger| |$DoubleFloat| + |$Float| |$Boolean|)) + (RETURN + (SEQ (PROGN + (setq |target| NIL) (COND - ((AND (>= |nargs| 3) - (PROGN - (SPADLET |ISTMP#1| (CADDR |args|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Segment|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) - (|selectLocalMms| |symNode| |sym| - (CONS |$DoubleFloat| (CONS |$DoubleFloat| NIL)) NIL) - |target|) - ((QUOTE T) - (|selectLocalMms| |symNode| |sym| - (CONS |$DoubleFloat| NIL) NIL) |target|))) - ((EQL |nargs| 2) - (COND - ((BOOT-EQUAL |op| (QUOTE |elt|)) + ((EQL |nargs| 0) (COND - ((AND - (BOOT-EQUAL |a1| (QUOTE (|BasicOperator|))) - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |List|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) (QUOTE |OrderedVariableList|)) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL)))))))) - (CONS (QUOTE |Expression|) (CONS |$Integer| NIL))) - ((QUOTE T) |target|))) - ((BOOT-EQUAL |op| (QUOTE |eval|)) - (COND - ((AND - (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |Expression|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |b1| (QCAR |ISTMP#1|)) (QUOTE T)))) - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Equation|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) (QUOTE |Polynomial|)) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |b2| (QCAR |ISTMP#3|)) - (QUOTE T))))))))) - (SPADLET |target| - (COND - ((|canCoerce| |b2| |a1|) |a1|) - ((QUOTE T) - (SPADLET |t| (|resolveTT| |b1| |b2|)) - (COND - ((OR (NULL |t|) (BOOT-EQUAL |t| |$Any|)) NIL) - ((QUOTE T) (|resolveTT| |a1| |t|)))))) - (COND (|target| (|putTarget| |opNode| |target|))) |target|) - ((AND - (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |Equation|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Equation|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - (SPADLET |target| (|resolveTT| |a1| |a2|)) - (COND - ((AND |target| (NULL (BOOT-EQUAL |target| |$Any|))) - (|putTarget| |opNode| |target|)) - ((QUOTE T) (SPADLET |target| NIL))) - |target|) - ((AND - (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |Equation|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |List|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a2e| (QCAR |ISTMP#1|)) (QUOTE T)))) - (PAIRP |a2e|) - (EQ (QCAR |a2e|) (QUOTE |Equation|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2e|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - (SPADLET |target| (|resolveTT| |a1| |a2e|)) - (COND - ((AND |target| (NULL (BOOT-EQUAL |target| |$Any|))) - (|putTarget| |opNode| |target|)) - ((QUOTE T) (SPADLET |target| NIL))) - |target|) - ((OR - (AND - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Equation|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a2e| (QCAR |ISTMP#1|)) (QUOTE T))))) - (AND - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |List|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) (QUOTE |Equation|)) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |a2e| (QCAR |ISTMP#3|)) - (QUOTE T)))))))))) - (PROGN - (SPADLET |target| (|resolveTT| |a1| |a2e|)) - (COND - ((AND |target| (NULL (BOOT-EQUAL |target| |$Any|))) - (|putTarget| |opNode| |target|)) - ((QUOTE T) (SPADLET |target| NIL))) - |target|)))) - ((OR (BOOT-EQUAL |op| (QUOTE **)) (BOOT-EQUAL |op| (QUOTE ^))) - (COND - ((BOOT-EQUAL |a2| |$Integer|) - (COND - ((SPADLET |target| (|resolveTCat| |a1| (QUOTE (|Field|)))) - (|putTarget| |opNode| |target|))) - |target|) - ((AND - (BOOT-EQUAL |a1| (QUOTE (|AlgebraicNumber|))) - (OR - (BOOT-EQUAL |a2| |$Float|) - (BOOT-EQUAL |a2| |$DoubleFloat|))) - (SPADLET |target| - (CONS (QUOTE |Expression|) (CONS |a2| NIL))) - (|putTarget| |opNode| |target|) |target|) - ((AND - (BOOT-EQUAL |a1| (QUOTE (|AlgebraicNumber|))) - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Complex|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a3| (QCAR |ISTMP#1|)) (QUOTE T)))) - (OR - (BOOT-EQUAL |a3| |$Float|) - (BOOT-EQUAL |a3| |$DoubleFloat|))) - (SPADLET |target| - (CONS (QUOTE |Expression|) (CONS |a3| NIL))) - (|putTarget| |opNode| |target|) |target|) - ((AND - (BOOT-EQUAL |a2| |$RationalNumber|) - (OR - (|typeIsASmallInteger| |a1|) - (|isEqualOrSubDomain| |a1| |$Integer|))) - (|putTarget| |opNode| - (SPADLET |target| (QUOTE (|AlgebraicNumber|)))) |target|) - ((AND - (BOOT-EQUAL |a2| |$RationalNumber|) - (OR - (|isAVariableType| |a1|) - (AND (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |Polynomial|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - (AND (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |RationalFunction|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))))) - (|putTarget| |opNode| - (SPADLET |target| (|defaultTargetFE| |a1|))) |target|) - ((AND - (|isAVariableType| |a1|) - (OR - (BOOT-EQUAL |a2| |$PositiveInteger|) - (BOOT-EQUAL |a2| |$NonNegativeInteger|))) - (|putTarget| |opNode| - (SPADLET |target| (QUOTE (|Polynomial| (|Integer|))))) - |target|) - ((|isAVariableType| |a2|) - (|putTarget| |opNode| - (SPADLET |target| (|defaultTargetFE| |a1|))) |target|) - ((AND - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Polynomial|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) - (COND - ((OR - (BOOT-EQUAL |a1| |a2|) - (|isAVariableType| |a1|) - (AND - (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |RationalFunction|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D1 (QCAR |ISTMP#1|)) (QUOTE T)))) - (BOOT-EQUAL D1 D)) - (BOOT-EQUAL |a1| D) - (AND - (PAIRP |a1|) - (EQUAL (QCAR |a1|) |$QuotientField|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D1 (QCAR |ISTMP#1|)) (QUOTE T)))) - (BOOT-EQUAL D1 |a1|))) - (|putTarget| |opNode| - (SPADLET |target| (|defaultTargetFE| |a2|))) |target|) - ((QUOTE T) |target|))) - ((AND - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |RationalFunction|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) - (COND - ((OR - (BOOT-EQUAL |a1| |a2|) - (|isAVariableType| |a1|) - (AND (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |RationalFunction|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D1 (QCAR |ISTMP#1|)) (QUOTE T)))) - (BOOT-EQUAL D1 D)) - (BOOT-EQUAL |a1| D) - (AND - (PAIRP |a1|) - (EQUAL (QCAR |a1|) |$QuotientField|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D1 (QCAR |ISTMP#1|)) (QUOTE T)))) - (BOOT-EQUAL D1 |a1|))) - (|putTarget| |opNode| - (SPADLET |target| (|defaultTargetFE| |a2|))) |target|) - ((QUOTE T) |target|))) - ((QUOTE T) |target|))) - ((BOOT-EQUAL |op| (QUOTE /)) - (COND - ((AND - (|isEqualOrSubDomain| |a1| |$Integer|) - (|isEqualOrSubDomain| |a2| |$Integer|)) + ((BOOT-EQUAL |op| '|nil|) (|putTarget| |opNode| - (SPADLET |target| |$RationalNumber|)) |target|) - ((BOOT-EQUAL |a1| |a2|) - (COND - ((SPADLET |target| - (|resolveTCat| (CAR |args|) (QUOTE (|Field|)))) - (|putTarget| |opNode| |target|))) + (setq |target| '(|List| (|None|)))) |target|) - ((AND - (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + ((OR (BOOT-EQUAL |op| '|true|) + (BOOT-EQUAL |op| '|false|)) + (|putTarget| |opNode| (setq |target| |$Boolean|)) + |target|) + ((BOOT-EQUAL |op| '|pi|) (|putTarget| |opNode| - (SPADLET |target| - (|mkRationalFunction| (QUOTE (|Integer|))))) + (setq |target| (CONS '|Pi| NIL))) |target|) - ((AND - (|isEqualOrSubDomain| |a1| |$Integer|) - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + ((BOOT-EQUAL |op| '|infinity|) (|putTarget| |opNode| - (SPADLET |target| - (|mkRationalFunction| (QUOTE (|Integer|))))) + (setq |target| + (CONS '|OnePointCompletion| + (CONS |$Integer| NIL)))) |target|) - ((QUOTE T) - (AND - (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) - (COND - ((AND - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Polynomial|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) - (|putTarget| |opNode| - (SPADLET |target| (|mkRationalFunction| D))) |target|) - ((QUOTE T) |target|))) - (AND - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) - (COND - ((AND - (PAIRP |a1|) - (EQ (QCAR |a1|) (QUOTE |Polynomial|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) - (|putTarget| |opNode| - (SPADLET |target| (|mkRationalFunction| D))) |target|) - ((QUOTE T) |target|))) + ((|member| |op| '(|plusInfinity| |minusInfinity|)) + (|putTarget| |opNode| + (setq |target| + (CONS '|OrderedCompletion| + (CONS |$Integer| NIL)))) + |target|) + (t |target|))) + (t (setq |a1| (CAR |args|)) + (COND + ((ATOM |a1|) |target|) + (t (setq |a1f| (QCAR |a1|)) (COND - ((AND - (PAIRP |a2|) - (EQ (QCAR |a2|) (QUOTE |Polynomial|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T)))) - (BOOT-EQUAL |a1| D)) - (|putTarget| |opNode| - (SPADLET |target| (|mkRationalFunction| D))) |target|) - ((QUOTE T) |target|))))))) - ((QUOTE T) - (SPADLET |a3| (CADDR |args|)) - (SEQ - (COND - ((EQL |nargs| 3) - (COND - ((BOOT-EQUAL |op| (QUOTE |eval|)) - (EXIT - (COND - ((AND - (PAIRP |a3|) - (EQ (QCAR |a3|) (QUOTE |List|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a3|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a3e| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |target| (|resolveTT| |a1| |a3e|)) + ((EQL |nargs| 1) (COND - ((NULL (BOOT-EQUAL |target| |$Any|)) - (|putTarget| |opNode| |target|)) - ((QUOTE T) (SPADLET |target| NIL))) - |target|) - ((QUOTE T) - (SPADLET |target| (|resolveTT| |a1| |a3|)) + ((BOOT-EQUAL |op| '|kernel|) + (|putTarget| |opNode| + (setq |target| + (CONS '|Kernel| + (CONS + (CONS '|Expression| + (CONS |$Integer| NIL)) + NIL)))) + |target|) + ((BOOT-EQUAL |op| '|list|) + (|putTarget| |opNode| + (setq |target| + (CONS '|List| (CONS |a1| NIL)))) + |target|) + (t |target|))) + (t (setq |a2| (CADR |args|)) (COND - ((NULL (BOOT-EQUAL |target| |$Any|)) - (|putTarget| |opNode| |target|)) - ((QUOTE T) (SPADLET |target| NIL))) - |target|)))))) - ((QUOTE T) |target|)))))))))))))))) + ((AND (>= |nargs| 2) (BOOT-EQUAL |op| '|draw|) + (PAIRP |a1|) + (EQ (QCAR |a1|) '|FunctionCalled|) + (PROGN + (setq |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |sym| (QCAR |ISTMP#1|)) + t))) + (PAIRP |a2|) (EQ (QCAR |a2|) '|Segment|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))) + (setq |symNode| (|mkAtreeNode| |sym|)) + (|transferPropsToNode| |sym| |symNode|) + (COND + ((AND (>= |nargs| 3) + (PROGN + (setq |ISTMP#1| (CADDR |args|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Segment|) + (PROGN + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (|selectLocalMms| |symNode| |sym| + (CONS |$DoubleFloat| + (CONS |$DoubleFloat| NIL)) + NIL) + (|putTarget| |opNode| + (setq |target| + '(|ThreeDimensionalViewport|))) + |target|) + ((setq |mms| + (|selectLocalMms| |symNode| |sym| + (CONS |$DoubleFloat| NIL) NIL)) + (setq |LETTMP#1| (CAAR |mms|)) + (setq |targ| (CADR |LETTMP#1|)) + (COND + ((BOOT-EQUAL |targ| |$DoubleFloat|) + (|putTarget| |opNode| + (setq |target| + '(|TwoDimensionalViewport|))) + |target|) + ((BOOT-EQUAL |targ| + (CONS '|Point| + (CONS |$DoubleFloat| NIL))) + (|putTarget| |opNode| + (setq |target| + '(|ThreeDimensionalViewport|))) + |target|) + (t |target|))) + (t |target|))) + ((AND (>= |nargs| 2) + (BOOT-EQUAL |op| '|makeObject|) + (PAIRP |a1|) + (EQ (QCAR |a1|) '|FunctionCalled|) + (PROGN + (setq |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |sym| (QCAR |ISTMP#1|)) + t))) + (PAIRP |a2|) (EQ (QCAR |a2|) '|Segment|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))) + (setq |symNode| (|mkAtreeNode| |sym|)) + (|transferPropsToNode| |sym| |symNode|) + (COND + ((AND (>= |nargs| 3) + (PROGN + (setq |ISTMP#1| (CADDR |args|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Segment|) + (PROGN + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (|selectLocalMms| |symNode| |sym| + (CONS |$DoubleFloat| + (CONS |$DoubleFloat| NIL)) + NIL) + |target|) + (t + (|selectLocalMms| |symNode| |sym| + (CONS |$DoubleFloat| NIL) NIL) + |target|))) + ((EQL |nargs| 2) + (COND + ((BOOT-EQUAL |op| '|elt|) + (COND + ((AND (BOOT-EQUAL |a1| + '(|BasicOperator|)) + (PAIRP |a2|) + (EQ (QCAR |a2|) '|List|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) + '|OrderedVariableList|) + (PROGN + (setq |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL)))))))) + (CONS '|Expression| + (CONS |$Integer| NIL))) + (t |target|))) + ((BOOT-EQUAL |op| '|eval|) + (COND + ((AND (PAIRP |a1|) + (EQ (QCAR |a1|) '|Expression|) + (PROGN + (setq |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |b1| + (QCAR |ISTMP#1|)) + t))) + (PAIRP |a2|) + (EQ (QCAR |a2|) '|Equation|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) + '|Polynomial|) + (PROGN + (setq |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (setq |b2| + (QCAR |ISTMP#3|)) + t)))))))) + (setq |target| + (COND + ((|canCoerce| |b2| |a1|) + |a1|) + (t + (setq |t| + (|resolveTT| |b1| |b2|)) + (COND + ((OR (NULL |t|) + (BOOT-EQUAL |t| |$Any|)) + NIL) + (t + (|resolveTT| |a1| |t|)))))) + (COND + (|target| + (|putTarget| |opNode| |target|))) + |target|) + ((AND (PAIRP |a1|) + (EQ (QCAR |a1|) '|Equation|) + (PROGN + (setq |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL))) + (PAIRP |a2|) + (EQ (QCAR |a2|) '|Equation|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))) + (setq |target| + (|resolveTT| |a1| |a2|)) + (COND + ((AND |target| + (NULL + (BOOT-EQUAL |target| |$Any|))) + (|putTarget| |opNode| |target|)) + (t (setq |target| NIL))) + |target|) + ((AND (PAIRP |a1|) + (EQ (QCAR |a1|) '|Equation|) + (PROGN + (setq |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL))) + (PAIRP |a2|) + (EQ (QCAR |a2|) '|List|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |a2e| + (QCAR |ISTMP#1|)) + t))) + (PAIRP |a2e|) + (EQ (QCAR |a2e|) '|Equation|) + (PROGN + (setq |ISTMP#1| (QCDR |a2e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))) + (setq |target| + (|resolveTT| |a1| |a2e|)) + (COND + ((AND |target| + (NULL + (BOOT-EQUAL |target| |$Any|))) + (|putTarget| |opNode| |target|)) + (t (setq |target| NIL))) + |target|) + ((OR (AND (PAIRP |a2|) + (EQ (QCAR |a2|) '|Equation|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |a2e| + (QCAR |ISTMP#1|)) + t)))) + (AND (PAIRP |a2|) + (EQ (QCAR |a2|) '|List|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |ISTMP#2| + (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) + '|Equation|) + (PROGN + (setq |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (setq |a2e| + (QCAR |ISTMP#3|)) + t))))))))) + (PROGN + (setq |target| + (|resolveTT| |a1| |a2e|)) + (COND + ((AND |target| + (NULL + (BOOT-EQUAL |target| |$Any|))) + (|putTarget| |opNode| |target|)) + (t (setq |target| NIL))) + |target|)))) + ((OR (BOOT-EQUAL |op| '**) + (BOOT-EQUAL |op| '^)) + (COND + ((BOOT-EQUAL |a2| |$Integer|) + (COND + ((setq |target| + (|resolveTCat| |a1| + '(|Field|))) + (|putTarget| |opNode| |target|))) + |target|) + ((AND (BOOT-EQUAL |a1| + '(|AlgebraicNumber|)) + (OR (BOOT-EQUAL |a2| |$Float|) + (BOOT-EQUAL |a2| |$DoubleFloat|))) + (setq |target| + (CONS '|Expression| + (CONS |a2| NIL))) + (|putTarget| |opNode| |target|) + |target|) + ((AND (BOOT-EQUAL |a1| + '(|AlgebraicNumber|)) + (PAIRP |a2|) + (EQ (QCAR |a2|) '|Complex|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |a3| + (QCAR |ISTMP#1|)) + t))) + (OR (BOOT-EQUAL |a3| |$Float|) + (BOOT-EQUAL |a3| |$DoubleFloat|))) + (setq |target| + (CONS '|Expression| + (CONS |a3| NIL))) + (|putTarget| |opNode| |target|) + |target|) + ((AND (BOOT-EQUAL |a2| |$RationalNumber|) + (OR (|typeIsASmallInteger| |a1|) + (|isEqualOrSubDomain| |a1| + |$Integer|))) + (|putTarget| |opNode| + (setq |target| + '(|AlgebraicNumber|))) + |target|) + ((AND (BOOT-EQUAL |a2| |$RationalNumber|) + (OR (|isAVariableType| |a1|) + (AND (PAIRP |a1|) + (EQ (QCAR |a1|) '|Polynomial|) + (PROGN + (setq |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))) + (AND (PAIRP |a1|) + (EQ (QCAR |a1|) + '|RationalFunction|) + (PROGN + (setq |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))))) + (|putTarget| |opNode| + (setq |target| + (|defaultTargetFE| |a1|))) + |target|) + ((AND (|isAVariableType| |a1|) + (OR + (BOOT-EQUAL |a2| + |$PositiveInteger|) + (BOOT-EQUAL |a2| + |$NonNegativeInteger|))) + (|putTarget| |opNode| + (setq |target| + '(|Polynomial| (|Integer|)))) + |target|) + ((|isAVariableType| |a2|) + (|putTarget| |opNode| + (setq |target| + (|defaultTargetFE| |a1|))) + |target|) + ((AND (PAIRP |a2|) + (EQ (QCAR |a2|) '|Polynomial|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq D (QCAR |ISTMP#1|)) + t)))) + (COND + ((OR (BOOT-EQUAL |a1| |a2|) + (|isAVariableType| |a1|) + (AND (PAIRP |a1|) + (EQ (QCAR |a1|) + '|RationalFunction|) + (PROGN + (setq |ISTMP#1| + (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq D1 + (QCAR |ISTMP#1|)) + t))) + (BOOT-EQUAL D1 D)) + (BOOT-EQUAL |a1| D) + (AND (PAIRP |a1|) + (EQUAL (QCAR |a1|) + |$QuotientField|) + (PROGN + (setq |ISTMP#1| + (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq D1 + (QCAR |ISTMP#1|)) + t))) + (BOOT-EQUAL D1 |a1|))) + (|putTarget| |opNode| + (setq |target| + (|defaultTargetFE| |a2|))) + |target|) + (t |target|))) + ((AND (PAIRP |a2|) + (EQ (QCAR |a2|) + '|RationalFunction|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq D (QCAR |ISTMP#1|)) + t)))) + (COND + ((OR (BOOT-EQUAL |a1| |a2|) + (|isAVariableType| |a1|) + (AND (PAIRP |a1|) + (EQ (QCAR |a1|) + '|RationalFunction|) + (PROGN + (setq |ISTMP#1| + (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq D1 + (QCAR |ISTMP#1|)) + t))) + (BOOT-EQUAL D1 D)) + (BOOT-EQUAL |a1| D) + (AND (PAIRP |a1|) + (EQUAL (QCAR |a1|) + |$QuotientField|) + (PROGN + (setq |ISTMP#1| + (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq D1 + (QCAR |ISTMP#1|)) + t))) + (BOOT-EQUAL D1 |a1|))) + (|putTarget| |opNode| + (setq |target| + (|defaultTargetFE| |a2|))) + |target|) + (t |target|))) + (t |target|))) + ((BOOT-EQUAL |op| '/) + (COND + ((AND (|isEqualOrSubDomain| |a1| + |$Integer|) + (|isEqualOrSubDomain| |a2| + |$Integer|)) + (|putTarget| |opNode| + (setq |target| |$RationalNumber|)) + |target|) + ((BOOT-EQUAL |a1| |a2|) + (COND + ((setq |target| + (|resolveTCat| (CAR |args|) + '(|Field|))) + (|putTarget| |opNode| |target|))) + |target|) + ((AND (PAIRP |a1|) + (EQ (QCAR |a1|) '|Variable|) + (PROGN + (setq |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL))) + (PAIRP |a2|) + (EQ (QCAR |a2|) '|Variable|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))) + (|putTarget| |opNode| + (setq |target| + (|mkRationalFunction| '(|Integer|)))) + |target|) + ((AND (|isEqualOrSubDomain| |a1| + |$Integer|) + (PAIRP |a2|) + (EQ (QCAR |a2|) '|Variable|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))) + (|putTarget| |opNode| + (setq |target| + (|mkRationalFunction| '(|Integer|)))) + |target|) + (t + (AND (PAIRP |a1|) + (EQ (QCAR |a1|) '|Variable|) + (PROGN + (setq |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL))) + (COND + ((AND (PAIRP |a2|) + (EQ (QCAR |a2|) '|Polynomial|) + (PROGN + (setq |ISTMP#1| + (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq D + (QCAR |ISTMP#1|)) + t)))) + (|putTarget| |opNode| + (setq |target| + (|mkRationalFunction| D))) + |target|) + (t |target|))) + (AND (PAIRP |a2|) + (EQ (QCAR |a2|) '|Variable|) + (PROGN + (setq |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL))) + (COND + ((AND (PAIRP |a1|) + (EQ (QCAR |a1|) '|Polynomial|) + (PROGN + (setq |ISTMP#1| + (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq D + (QCAR |ISTMP#1|)) + t)))) + (|putTarget| |opNode| + (setq |target| + (|mkRationalFunction| D))) + |target|) + (t |target|))) + (COND + ((AND (PAIRP |a2|) + (EQ (QCAR |a2|) '|Polynomial|) + (PROGN + (setq |ISTMP#1| + (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq D + (QCAR |ISTMP#1|)) + t))) + (BOOT-EQUAL |a1| D)) + (|putTarget| |opNode| + (setq |target| + (|mkRationalFunction| D))) + |target|) + (t |target|))))))) + (t (setq |a3| (CADDR |args|)) + (SEQ (COND + ((EQL |nargs| 3) + (COND + ((BOOT-EQUAL |op| '|eval|) + (EXIT + (COND + ((AND (PAIRP |a3|) + (EQ (QCAR |a3|) '|List|) + (PROGN + (setq |ISTMP#1| + (QCDR |a3|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |a3e| + (QCAR |ISTMP#1|)) + t)))) + (setq |target| + (|resolveTT| |a1| |a3e|)) + (COND + ((NULL + (BOOT-EQUAL |target| + |$Any|)) + (|putTarget| |opNode| + |target|)) + (t (setq |target| NIL))) + |target|) + (t + (setq |target| + (|resolveTT| |a1| |a3|)) + (COND + ((NULL + (BOOT-EQUAL |target| + |$Any|)) + (|putTarget| |opNode| + |target|)) + (t (setq |target| NIL))) + |target|)))))) + (t |target|)))))))))))))))) ;mkRationalFunction D == ['Fraction, ['Polynomial, D]] -(DEFUN |mkRationalFunction| (D) - (CONS (QUOTE |Fraction|) - (CONS (CONS (QUOTE |Polynomial|) (CONS D NIL)) NIL))) +(defun |mkRationalFunction| (d) + `(|Fraction| (|Polynomial| ,d))) ;defaultTargetFE(a,:options) == ; a is ['Variable,.] or a = $RationalNumber or MEMQ(QCAR a, @@ -1433,66 +1676,52 @@ isPartialMode m == ; IFCAR options => [$FunctionalExpression, ['Complex, a]] ; [$FunctionalExpression, a] -(DEFUN |defaultTargetFE| (&REST #0=#:G166758 &AUX |options| |a|) - (DSETQ (|a| . |options|) #0#) - (PROG (D |uD| |ISTMP#1|) - (RETURN - (COND - ((OR - (AND - (PAIRP |a|) - (EQ (QCAR |a|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - (BOOT-EQUAL |a| |$RationalNumber|) - (MEMQ - (QCAR |a|) - (CONS - (QCAR |$Symbol|) - (CONS (QUOTE |RationalRadicals|) (CONS (QUOTE |Pi|) NIL)))) - (|typeIsASmallInteger| |a|) - (|isEqualOrSubDomain| |a| |$Integer|) - (BOOT-EQUAL |a| (QUOTE (|AlgebraicNumber|)))) - (COND - ((IFCAR |options|) - (CONS |$FunctionalExpression| - (CONS (CONS (QUOTE |Complex|) (CONS |$Integer| NIL)) NIL))) - ((QUOTE T) - (CONS |$FunctionalExpression| (CONS |$Integer| NIL))))) - ((AND - (PAIRP |a|) - (EQ (QCAR |a|) (QUOTE |Complex|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |uD| (QCAR |ISTMP#1|)) (QUOTE T))))) - (|defaultTargetFE| |uD| (QUOTE T))) - ((AND - (PAIRP |a|) - (PROGN - (SPADLET D (QCAR |a|)) - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |uD| (QCAR |ISTMP#1|)) (QUOTE T)))) - (MEMQ D (QUOTE (|Polynomial| |RationalFunction| |Fraction|)))) - (|defaultTargetFE| |uD| (IFCAR |options|))) - ((AND - (PAIRP |a|) - (EQUAL (QCAR |a|) |$FunctionalExpression|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - |a|) - ((IFCAR |options|) - (CONS |$FunctionalExpression| - (CONS (CONS (QUOTE |Complex|) (CONS |a| NIL)) NIL))) - ((QUOTE T) - (CONS |$FunctionalExpression| (CONS |a| NIL))))))) +(DEFUN |defaultTargetFE| (&REST G166758 &AUX |options| |a|) + (DSETQ (|a| . |options|) G166758) + (PROG (D |uD| |ISTMP#1|) + (declare (special |$FunctionalExpression| |$Integer| |$Symbol| + |$RationalNumber|)) + (RETURN + (COND + ((OR (AND (PAIRP |a|) (EQ (QCAR |a|) '|Variable|) + (PROGN + (setq |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (BOOT-EQUAL |a| |$RationalNumber|) + (MEMQ (QCAR |a|) + (CONS (QCAR |$Symbol|) + (CONS '|RationalRadicals| (CONS '|Pi| NIL)))) + (|typeIsASmallInteger| |a|) + (|isEqualOrSubDomain| |a| |$Integer|) + (BOOT-EQUAL |a| '(|AlgebraicNumber|))) + (COND + ((IFCAR |options|) + (CONS |$FunctionalExpression| + (CONS (CONS '|Complex| (CONS |$Integer| NIL)) NIL))) + (t (CONS |$FunctionalExpression| (CONS |$Integer| NIL))))) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|Complex|) + (PROGN + (setq |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |uD| (QCAR |ISTMP#1|)) t)))) + (|defaultTargetFE| |uD| t)) + ((AND (PAIRP |a|) + (PROGN + (setq D (QCAR |a|)) + (setq |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |uD| (QCAR |ISTMP#1|)) t))) + (MEMQ D '(|Polynomial| |RationalFunction| |Fraction|))) + (|defaultTargetFE| |uD| (IFCAR |options|))) + ((AND (PAIRP |a|) (EQUAL (QCAR |a|) |$FunctionalExpression|) + (PROGN + (setq |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + |a|) + ((IFCAR |options|) + (CONS |$FunctionalExpression| + (CONS (CONS '|Complex| (CONS |a| NIL)) NIL))) + (t (CONS |$FunctionalExpression| (CONS |a| NIL))))))) ;altTypeOf(type,val,$declaredMode) == ; (EQCAR(type,'Symbol) or EQCAR(type,'Variable)) and @@ -1507,38 +1736,32 @@ isPartialMode m == ; type = '(List (PositiveInteger)) => '(List (Integer)) ; NIL -(DEFUN |altTypeOf| (|type| |val| |$declaredMode|) - (DECLARE (SPECIAL |$declaredMode|)) - (PROG (|ISTMP#1| |vl| |val1| |a|) - (RETURN - (COND - ((AND - (OR - (EQCAR |type| (QUOTE |Symbol|)) - (EQCAR |type| (QUOTE |Variable|))) - (SPADLET |a| - (|getMinimalVarMode| - (|objValUnwrap| (|getValue| |val|)) |$declaredMode|))) - |a|) - ((AND (PAIRP |type|) - (EQ (QCAR |type|) (QUOTE |OrderedVariableList|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |type|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |vl| (QCAR |ISTMP#1|)) (QUOTE T)))) - (INTEGERP (SPADLET |val1| (|objValUnwrap| (|getValue| |val|)))) - (SPADLET |a| - (|getMinimalVarMode| - (ELT |vl| (SPADDIFFERENCE |val1| 1)) - |$declaredMode|))) - |a|) - ((BOOT-EQUAL |type| |$PositiveInteger|) |$Integer|) - ((BOOT-EQUAL |type| |$NonNegativeInteger|) |$Integer|) - ((BOOT-EQUAL |type| (QUOTE (|List| (|PositiveInteger|)))) - (QUOTE (|List| (|Integer|)))) - ((QUOTE T) NIL))))) +(defun |altTypeOf| (type val |$declaredMode|) + (declare (special |$declaredMode|)) + (let (tmp1 vl val1 a) + (declare (special |$Integer| |$NonNegativeInteger| |$PositiveInteger| + |$declaredMode|)) + (cond + ((and + (or (eqcar type '|Symbol|) (eqcar type '|Variable|)) + (setq a (|getMinimalVarMode| (|objValUnwrap| (|getValue| val)) + |$declaredMode|))) + a) + ((and + (pairp type) + (eq (qcar type) '|OrderedVariableList|) + (progn + (setq tmp1 (qcdr type)) + (and (pairp tmp1) + (eq (qcdr tmp1) nil) + (progn (setq vl (qcar tmp1)) t))) + (integerp (setq val1 (|objValUnwrap| (|getValue| val)))) + (setq a (|getMinimalVarMode| (elt vl (- val1 1)) |$declaredMode|))) + a) + ((BOOT-EQUAL type |$PositiveInteger|) |$Integer|) + ((BOOT-EQUAL type |$NonNegativeInteger|) |$Integer|) + ((BOOT-EQUAL type '(|List| (|PositiveInteger|))) '(|List| (|Integer|))) + (t nil)))) ;getOpArgTypes(opname, args) == ; l := getOpArgTypes1(opname, args) @@ -1551,46 +1774,22 @@ isPartialMode m == ; x ; x -(DEFUN |getOpArgTypes,f| (|x| |op|) - (PROG (|ISTMP#1| |g| |m|) - (RETURN - (SEQ - (IF (AND - (AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |FunctionCalled|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |g| (QCAR |ISTMP#1|)) (QUOTE T))))) - (NEQUAL |op| (QUOTE |name|))) - (EXIT - (SEQ - (IF (SPADLET |m| (|get| |g| (QUOTE |mode|) |$e|)) - (EXIT - (SEQ - (IF (AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Mapping|))) - (EXIT |m|)) - (EXIT |x|)))) - (EXIT |x|)))) - (EXIT |x|))))) - -(DEFUN |getOpArgTypes| (|opname| |args|) - (PROG (|l|) - (RETURN - (SEQ - (PROGN - (SPADLET |l| (|getOpArgTypes1| |opname| |args|)) - (PROG (#0=#:G166792) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166797 |l| (CDR #1#)) (|a| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |a| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# (CONS (|getOpArgTypes,f| |a| |opname|) #0#)))))))))))) +(defun |getOpArgTypes,f| (x op) + (let ( m (result x)) + (declare (special |$e|)) + (if (and (eq (car x) '|FunctionCalled|) (not (eq op '|name|))) + (if (and (cdr x) (setq m (|get| (cdr x) '|mode| |$e|))) + (if (eq (car m) '|Mapping|) + (setq result m)))) + result)) + +(defun |getOpArgTypes| (opname args) + (let (l g1) + (setq l (|getOpArgTypes1| opname args)) + (do ((g2 l (cdr g2)) (a nil)) + ((or (atom g2) (progn (setq a (car g2)) nil)) + (nreverse0 g1)) + (setq g1 (cons (|getOpArgTypes,f| a opname) g1))))) ;getOpArgTypes1(opname, args) == ; null args => NIL @@ -1617,98 +1816,87 @@ isPartialMode m == ; nreverse mss (DEFUN |getOpArgTypes1| (|opname| |args|) - (PROG (|b| |n| |ISTMP#1| |d| |ISTMP#2| |c| |nargs| |v| |ms| |mss|) - (RETURN - (SEQ - (COND - ((NULL |args|) NIL) - ((AND - (BOOT-EQUAL |opname| (QUOTE |coef|)) - (PAIRP |args|) - (PROGN - (SPADLET |b| (QCAR |args|)) - (SPADLET |ISTMP#1| (QCDR |args|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |n| (QCAR |ISTMP#1|)) (QUOTE T))))) - (CONS - (CAR (|getModeSet| |b|)) - (CONS (CAR (|getModeSetUseSubdomain| |n|)) NIL))) - ((AND - (BOOT-EQUAL |opname| (QUOTE |monom|)) - (PAIRP |args|) - (PROGN - (SPADLET |d| (QCAR |args|)) - (SPADLET |ISTMP#1| (QCDR |args|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |c| (QCAR |ISTMP#1|)) (QUOTE T))))) - (CONS - (CAR (|getModeSetUseSubdomain| |d|)) - (CONS (CAR (|getModeSet| |c|)) NIL))) - ((AND - (BOOT-EQUAL |opname| (QUOTE |monom|)) - (PAIRP |args|) - (PROGN - (SPADLET |v| (QCAR |args|)) - (SPADLET |ISTMP#1| (QCDR |args|)) - (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 |c| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (CONS - (CAR (|getModeSet| |v|)) - (CONS - (CAR (|getModeSetUseSubdomain| |d|)) - (CONS (CAR (|getModeSet| |c|)) NIL)))) - ((AND - (BOOT-EQUAL |opname| (QUOTE |cons|)) - (EQL 2 (|#| |args|)) - (BOOT-EQUAL (CADR |args|) (QUOTE |nil|))) - (SPADLET |ms| - (PROG (#0=#:G166858) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166863 |args| (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (CAR (|getModeSet| |x|)) #0#)))))))) - (COND - ((BOOT-EQUAL (CADR |ms|) (QUOTE (|List| (|None|)))) - (SPADLET |ms| - (CONS - (CAR |ms|) - (CONS (CONS (QUOTE |List|) (CONS (CAR |ms|) NIL)) NIL))))) - |ms|) - ((QUOTE T) - (SPADLET |nargs| (|#| |args|)) - (SPADLET |v| (|argCouldBelongToSubdomain| |opname| |nargs|)) - (SPADLET |mss| NIL) - (DO ((#2=#:G166875 (SPADDIFFERENCE |nargs| 1)) - (|i| 0 (QSADD1 |i|)) - (#3=#:G166876 |args| (CDR #3#)) - (|x| NIL)) - ((OR - (QSGREATERP |i| #2#) - (ATOM #3#) - (PROGN (SETQ |x| (CAR #3#)) NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |ms| - (COND - ((EQL (ELT |v| |i|) 0) (CAR (|getModeSet| |x|))) - ((QUOTE T) (CAR (|getModeSetUseSubdomain| |x|))))) - (SPADLET |mss| (CONS |ms| |mss|)))))) - (NREVERSE |mss|))))))) + (PROG (|b| |n| |ISTMP#1| |d| |ISTMP#2| |c| |nargs| |v| |ms| |mss|) + (RETURN + (SEQ (COND + ((NULL |args|) NIL) + ((AND (BOOT-EQUAL |opname| '|coef|) (PAIRP |args|) + (PROGN + (setq |b| (QCAR |args|)) + (setq |ISTMP#1| (QCDR |args|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |n| (QCAR |ISTMP#1|)) t)))) + (CONS (CAR (|getModeSet| |b|)) + (CONS (CAR (|getModeSetUseSubdomain| |n|)) NIL))) + ((AND (BOOT-EQUAL |opname| '|monom|) (PAIRP |args|) + (PROGN + (setq |d| (QCAR |args|)) + (setq |ISTMP#1| (QCDR |args|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |c| (QCAR |ISTMP#1|)) t)))) + (CONS (CAR (|getModeSetUseSubdomain| |d|)) + (CONS (CAR (|getModeSet| |c|)) NIL))) + ((AND (BOOT-EQUAL |opname| '|monom|) (PAIRP |args|) + (PROGN + (setq |v| (QCAR |args|)) + (setq |ISTMP#1| (QCDR |args|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |d| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |c| (QCAR |ISTMP#2|)) + t)))))) + (CONS (CAR (|getModeSet| |v|)) + (CONS (CAR (|getModeSetUseSubdomain| |d|)) + (CONS (CAR (|getModeSet| |c|)) NIL)))) + ((AND (BOOT-EQUAL |opname| '|cons|) (EQL 2 (|#| |args|)) + (BOOT-EQUAL (CADR |args|) '|nil|)) + (setq |ms| + (PROG (G166858) + (setq G166858 NIL) + (RETURN + (DO ((G166863 |args| (CDR G166863)) + (|x| NIL)) + ((OR (ATOM G166863) + (PROGN + (SETQ |x| (CAR G166863)) + NIL)) + (NREVERSE0 G166858)) + (SEQ (EXIT (SETQ G166858 + (CONS (CAR (|getModeSet| |x|)) + G166858)))))))) + (COND + ((BOOT-EQUAL (CADR |ms|) '(|List| (|None|))) + (setq |ms| + (CONS (CAR |ms|) + (CONS (CONS '|List| + (CONS (CAR |ms|) NIL)) + NIL))))) + |ms|) + (t (setq |nargs| (|#| |args|)) + (setq |v| + (|argCouldBelongToSubdomain| |opname| |nargs|)) + (setq |mss| NIL) + (DO ((G166875 (SPADDIFFERENCE |nargs| 1)) + (|i| 0 (QSADD1 |i|)) + (G166876 |args| (CDR G166876)) (|x| NIL)) + ((OR (QSGREATERP |i| G166875) (ATOM G166876) + (PROGN (SETQ |x| (CAR G166876)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (setq |ms| + (COND + ((EQL (ELT |v| |i|) 0) + (CAR (|getModeSet| |x|))) + (t + (CAR + (|getModeSetUseSubdomain| + |x|))))) + (setq |mss| (CONS |ms| |mss|)))))) + (NREVERSE |mss|))))))) ;argCouldBelongToSubdomain(op, nargs) == ; -- this returns a vector containing 0 or ^0 for each argument. @@ -1729,48 +1917,51 @@ isPartialMode m == ; v (DEFUN |argCouldBelongToSubdomain| (|op| |nargs|) - (PROG (|v| |mms| |sig| |cond|) - (RETURN - (SEQ - (COND - ((EQL |nargs| 0) NIL) - ((QUOTE T) - (SPADLET |v| (GETZEROVEC |nargs|)) - (COND - ((|isMap| |op|) |v|) - ((QUOTE T) - (SPADLET |mms| (|getModemapsFromDatabase| |op| |nargs|)) - (COND - ((NULL |mms|) |v|) - ((QUOTE T) - (SPADLET |nargs| (SPADDIFFERENCE |nargs| 1)) - (SEQ - (DO ((#0=#:G166914 |mms| (CDR #0#)) (#1=#:G166905 NIL)) - ((OR - (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |sig| (CAR #1#)) - (SPADLET |cond| (CADR #1#)) - #1#) - NIL)) - NIL) - (SEQ - (EXIT - (DO ((#2=#:G166925 (CDDR |sig|) (CDR #2#)) - (|t| NIL) - (|i| 0 (QSADD1 |i|))) - ((OR - (ATOM #2#) - (PROGN (SETQ |t| (CAR #2#)) NIL) - (QSGREATERP |i| |nargs|)) NIL) - (SEQ - (EXIT + (PROG (|v| |mms| |sig| |cond|) + (RETURN + (SEQ (COND + ((EQL |nargs| 0) NIL) + (t (setq |v| (GETZEROVEC |nargs|)) + (COND + ((|isMap| |op|) |v|) + (t + (setq |mms| + (|getModemapsFromDatabase| |op| |nargs|)) (COND - ((|CONTAINEDisDomain| |t| |cond|) - (EXIT (SETELT |v| |i| (PLUS 1 (ELT |v| |i|)))))))))))) - (EXIT |v|)))))))))))) + ((NULL |mms|) |v|) + (t (setq |nargs| (SPADDIFFERENCE |nargs| 1)) + (SEQ (DO ((G166914 |mms| (CDR G166914)) + (G166905 NIL)) + ((OR (ATOM G166914) + (PROGN + (SETQ G166905 (CAR G166914)) + NIL) + (PROGN + (PROGN + (setq |sig| (CAR G166905)) + (setq |cond| (CADR G166905)) + G166905) + NIL)) + NIL) + (SEQ (EXIT (DO + ((G166925 (CDDR |sig|) + (CDR G166925)) + (|t| NIL) (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G166925) + (PROGN + (SETQ |t| (CAR G166925)) + NIL) + (QSGREATERP |i| |nargs|)) + NIL) + (SEQ + (EXIT + (COND + ((|CONTAINEDisDomain| |t| + |cond|) + (EXIT + (SETELT |v| |i| + (PLUS 1 (ELT |v| |i|)))))))))))) + (EXIT |v|)))))))))))) ;CONTAINEDisDomain(symbol,cond) == ;-- looks for [isSubDomain,symbol,[domain]] in cond: returning T or NIL @@ -1784,53 +1975,54 @@ isPartialMode m == ; false (DEFUN |CONTAINEDisDomain| (|symbol| |cond|) - (PROG (|dom|) - (RETURN - (SEQ - (COND - ((ATOM |cond|) NIL) - ((MEMQ (QCAR |cond|) (QUOTE (AND OR |and| |or|))) - (PROG (#0=#:G166941) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166947 NIL #0#) - (#2=#:G166948 (QCDR |cond|) (CDR #2#)) - (|u| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |u| (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (OR #0# (|CONTAINEDisDomain| |symbol| |u|))))))))) - ((EQ (QCAR |cond|) (QUOTE |isDomain|)) - (AND - (EQ |symbol| (CADR |cond|)) - (PAIRP (SPADLET |dom| (CADDR |cond|))) - (MEMQ |dom| (QUOTE (|PositiveInteger| |NonNegativeInteger|))))) - ((QUOTE T) NIL)))))) + (PROG (|dom|) + (RETURN + (SEQ (COND + ((ATOM |cond|) NIL) + ((MEMQ (QCAR |cond|) '(AND OR |and| |or|)) + (PROG (G166941) + (setq G166941 NIL) + (RETURN + (DO ((G166947 NIL G166941) + (G166948 (QCDR |cond|) (CDR G166948)) + (|u| NIL)) + ((OR G166947 (ATOM G166948) + (PROGN (SETQ |u| (CAR G166948)) NIL)) + G166941) + (SEQ (EXIT (SETQ G166941 + (OR G166941 + (|CONTAINEDisDomain| |symbol| + |u|))))))))) + ((EQ (QCAR |cond|) '|isDomain|) + (AND (EQ |symbol| (CADR |cond|)) + (PAIRP (setq |dom| (CADDR |cond|))) + (MEMQ |dom| + '(|PositiveInteger| |NonNegativeInteger|)))) + (t NIL)))))) ;selectDollarMms(dc,name,types1,types2) == ; -- finds functions for name in domain dc ; isPartialMode dc => throwKeyedMsg("S2IF0001",NIL) -; mmS := findFunctionInDomain(name,dc,NIL,types1,types2,'T,'T) => +; mmS := findFunctionInDomain(name,dc,NIL,types1,types2,t,t) => ; orderMms(name, mmS,types1,types2,NIL) ; if $reportBottomUpFlag then sayMSG ; ["%b",'" function not found in ",prefix2String dc,"%d","%l"] ; NIL -(DEFUN |selectDollarMms| (|dc| |name| |types1| |types2|) - (PROG (|mmS|) - (RETURN - (COND - ((|isPartialMode| |dc|) (|throwKeyedMsg| (QUOTE S2IF0001) NIL)) - ((SPADLET |mmS| - (|findFunctionInDomain| |name| |dc| NIL |types1| |types2| - (QUOTE T) (QUOTE T))) - (|orderMms| |name| |mmS| |types1| |types2| NIL)) - ((QUOTE T) - (COND - (|$reportBottomUpFlag| - (|sayMSG| - (CONS (QUOTE |%b|) - (CONS " function not found in " - (CONS (|prefix2String| |dc|) - (CONS (QUOTE |%d|) (CONS (QUOTE |%l|) NIL)))))))) NIL))))) +(defun |selectDollarMms| (dc name types1 types2) + (let (mmS) + (declare (special |$reportBottomUpFlag|)) + (cond + ((|isPartialMode| dc) + (|throwKeyedMsg| 'S2IF0001 nil)) + ((setq mmS (|findFunctionInDomain| name dc nil types1 types2 t t)) + (|orderMms| name mmS types1 types2 nil)) + (t + (when |$reportBottomUpFlag| + (|sayMSG| + `(|%b| " function not found in " + ,(|prefix2String| dc) |%d| |%l|))) + nil)))) ;selectLocalMms(op,name,types,tar) == ; -- partial rewrite, looks now for exact local modemap @@ -1839,24 +2031,19 @@ isPartialMode m == ; obj and (objVal obj is ['MAP,:mapDef]) and ; analyzeMap(op,types,mapDef,tar) and getLocalMms(name,types,tar) -(DEFUN |selectLocalMms| (|op| |name| |types| |tar|) - (PROG (|mmS| |obj| |ISTMP#1| |mapDef|) - (RETURN - (COND - ((SPADLET |mmS| (|getLocalMms| |name| |types| |tar|)) |mmS|) - ((QUOTE T) - (SPADLET |obj| (|getValue| |op|)) - (AND - |obj| - (PROGN (SPADLET |ISTMP#1| (|objVal| |obj|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) - (PROGN - (SPADLET |mapDef| (QCDR |ISTMP#1|)) - (QUOTE T)))) - (|analyzeMap| |op| |types| |mapDef| |tar|) - (|getLocalMms| |name| |types| |tar|))))))) +(defun |selectLocalMms| (op name types tar) + (let (mmS obj tmp1 mapDef) + (cond + ((setq mmS (|getLocalMms| name types tar)) mmS) + (t (setq obj (|getValue| op)) + (and obj + (progn + (setq tmp1 (|objVal| obj)) + (and (pairp tmp1) + (eq (qcar tmp1) 'map) + (progn (setq mapDef (qcdr tmp1)) t))) + (|analyzeMap| op types mapDef tar) + (|getLocalMms| name types tar)))))) ;-- next defn may be better, test when more time. RSS 3/11/94 ;-- selectLocalMms(op,name,types,tar) == @@ -1897,71 +2084,87 @@ isPartialMode m == ; mmS := [mm,:mmS] ; nreverse mmS -(DEFUN |getLocalMms,f| (|x| |y| |subsume|) - (IF |subsume| (|isEqualOrSubDomain| |x| |y|) (BOOT-EQUAL |x| |y|))) +(defun |getLocalMms,f| (x y subsume) + (if subsume + (|isEqualOrSubDomain| x y) + (BOOT-EQUAL x y))) (DEFUN |getLocalMms| (|name| |types| |tar|) - (PROG (|dcSig| |dc| |ISTMP#1| |result| |args| |subsume| - |acceptableArgs| |mmS|) - (RETURN - (SEQ - (PROGN - (SPADLET |mmS| NIL) - (DO ((#0=#:G167010 (|get| |name| (QUOTE |localModemap|) |$e|) (CDR #0#)) - (|mm| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |mm| (CAR #0#)) NIL) - (PROGN (PROGN (SPADLET |dcSig| (CAR |mm|)) |mm|) NIL)) - NIL) - (SEQ - (EXIT - (COND - ((NULL - (AND - (PAIRP |dcSig|) - (PROGN - (SPADLET |dc| (QCAR |dcSig|)) - (SPADLET |ISTMP#1| (QCDR |dcSig|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |result| (QCAR |ISTMP#1|)) - (SPADLET |args| (QCDR |ISTMP#1|)) - (QUOTE T)))))) - NIL) - ((NEQUAL (|#| |types|) (|#| |args|)) NIL) - ((QUOTE T) - (SPADLET |subsume| - (OR - (NULL |$useIntegerSubdomain|) - (BOOT-EQUAL |tar| |result|) - (|get| |name| (QUOTE |recursive|) |$e|))) - (SPADLET |acceptableArgs| - (PROG (#1=#:G167017) - (SPADLET #1# (QUOTE T)) - (RETURN - (DO ((#2=#:G167024 NIL (NULL #1#)) - (#3=#:G167025 |args| (CDR #3#)) - (|a| NIL) - (#4=#:G167026 |types| (CDR #4#)) - (|b| NIL)) - ((OR #2# - (ATOM #3#) - (PROGN (SETQ |a| (CAR #3#)) NIL) - (ATOM #4#) - (PROGN (SETQ |b| (CAR #4#)) NIL)) - #1#) - (SEQ - (EXIT - (SETQ #1# (AND #1# (|getLocalMms,f| |b| |a| |subsume|))))))))) - (COND - ((NULL |acceptableArgs|) - (COND - ((AND (BOOT-EQUAL |dc| (QUOTE |interpOnly|)) (NULL |$Coerce|)) - (SPADLET |mmS| (CONS |mm| |mmS|))) - ((QUOTE T) NIL))) - ((QUOTE T) (SPADLET |mmS| (CONS |mm| |mmS|))))))))) - (NREVERSE |mmS|)))))) + (PROG (|dcSig| |dc| |ISTMP#1| |result| |args| |subsume| + |acceptableArgs| |mmS|) + (declare (special |$Coerce| |$e| |$useIntegerSubdomain|)) + (RETURN + (SEQ (PROGN + (setq |mmS| NIL) + (DO ((G167010 (|get| |name| '|localModemap| |$e|) + (CDR G167010)) + (|mm| NIL)) + ((OR (ATOM G167010) + (PROGN (SETQ |mm| (CAR G167010)) NIL) + (PROGN + (PROGN (setq |dcSig| (CAR |mm|)) |mm|) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (AND (PAIRP |dcSig|) + (PROGN + (setq |dc| (QCAR |dcSig|)) + (setq |ISTMP#1| + (QCDR |dcSig|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |result| + (QCAR |ISTMP#1|)) + (setq |args| + (QCDR |ISTMP#1|)) + t))))) + NIL) + ((NEQUAL (|#| |types|) (|#| |args|)) NIL) + (t + (setq |subsume| + (OR (NULL |$useIntegerSubdomain|) + (BOOT-EQUAL |tar| |result|) + (|get| |name| '|recursive| |$e|))) + (setq |acceptableArgs| + (PROG (G167017) + (setq G167017 t) + (RETURN + (DO + ((G167024 NIL + (NULL G167017)) + (G167025 |args| + (CDR G167025)) + (|a| NIL) + (G167026 |types| + (CDR G167026)) + (|b| NIL)) + ((OR G167024 + (ATOM G167025) + (PROGN + (SETQ |a| + (CAR G167025)) + NIL) + (ATOM G167026) + (PROGN + (SETQ |b| + (CAR G167026)) + NIL)) + G167017) + (SEQ + (EXIT + (SETQ G167017 + (AND G167017 + (|getLocalMms,f| |b| + |a| |subsume|))))))))) + (COND + ((NULL |acceptableArgs|) + (COND + ((AND (BOOT-EQUAL |dc| '|interpOnly|) + (NULL |$Coerce|)) + (setq |mmS| (CONS |mm| |mmS|))) + (t NIL))) + (t (setq |mmS| (CONS |mm| |mmS|))))))))) + (NREVERSE |mmS|)))))) @ mmCost assigns a penalty to each signature according to the following @@ -2000,25 +2203,32 @@ the types A and B themselves are not sorted by preference. ; cost (DEFUN |mmCost| (|name| |sig| |cond| |tar| |args1| |args2|) - (PROG (|cost| |res|) - (RETURN - (PROGN - (SPADLET |cost| (|mmCost0| |name| |sig| |cond| |tar| |args1| |args2|)) - (SPADLET |res| (CADR |sig|)) - (COND - ((BOOT-EQUAL |res| |$PositiveInteger|) (SPADDIFFERENCE |cost| 2)) - ((BOOT-EQUAL |res| |$NonNegativeInteger|) (SPADDIFFERENCE |cost| 1)) - ((BOOT-EQUAL |res| |$DoubleFloat|) (PLUS |cost| 1)) - ((QUOTE T) - (COND - (|$reportBottomUpFlag| - (|sayMSG| - (CONS "cost=" - (CONS (|prefix2String| |cost|) - (CONS " for " - (CONS |name| - (CONS ": " (|formatSignature| (CDR |sig|)))))))))) - |cost|)))))) + (PROG (|cost| |res|) + (declare (special |$reportBottomUpFlag| |$DoubleFloat| |$PositiveInteger| + |$NonNegativeInteger|)) + (RETURN + (PROGN + (setq |cost| + (|mmCost0| |name| |sig| |cond| |tar| |args1| |args2|)) + (setq |res| (CADR |sig|)) + (COND + ((BOOT-EQUAL |res| |$PositiveInteger|) + (SPADDIFFERENCE |cost| 2)) + ((BOOT-EQUAL |res| |$NonNegativeInteger|) + (SPADDIFFERENCE |cost| 1)) + ((BOOT-EQUAL |res| |$DoubleFloat|) (PLUS |cost| 1)) + (t + (COND + (|$reportBottomUpFlag| + (|sayMSG| + (CONS "cost=" + (CONS (|prefix2String| |cost|) + (CONS " for " + (CONS |name| + (CONS ": " + (|formatSignature| + (CDR |sig|)))))))))) + |cost|)))))) ;mmCost0(name, sig,cond,tar,args1,args2) == ; sigArgs := CDDR sig @@ -2027,8 +2237,7 @@ the types A and B themselves are not sorted by preference. ; not (or/cond) => 1 ; 0 ; -- try to favor homogeneous multiplication -;--if name = "*" and 2 = #sigArgs and - first sigArgs ^= first rest sigArgs then n := n + 1 +;--if name = "*" and 2 = #sigArgs and first sigArgs ^= first rest sigArgs then n := n + 1 ; -- because of obscure problem in evalMm, sometimes we will have extra ; -- modemaps with the wrong number of arguments if we want to the one ; -- with no arguments and the name is overloaded. Thus check for this. @@ -2047,61 +2256,82 @@ the types A and B themselves are not sorted by preference. ; 10000*n + 1000*domainDepth(res) + hitListOfTarget(res) (DEFUN |mmCost0| (|name| |sig| |cond| |tar| |args1| |args2|) - (PROG (|sigArgs| |topcon| |topcon2| |n| |res|) - (RETURN - (SEQ - (PROGN - (SPADLET |sigArgs| (CDDR |sig|)) - (SPADLET |n| - (COND - ((NULL |cond|) 1) - ((NULL - (PROG (#0=#:G167060) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167066 NIL #0#) - (#2=#:G167067 |cond| (CDR #2#)) - (#3=#:G167056 NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ #3# (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (OR #0# #3#)))))))) - 1) - ((QUOTE T) 0))) - (COND - (|args1| - (DO ((#4=#:G167079 |args1| (CDR #4#)) - (|x1| NIL) - (#5=#:G167080 |args2| (CDR #5#)) - (|x2| NIL) - (#6=#:G167081 |sigArgs| (CDR #6#)) - (|x3| NIL)) - ((OR (ATOM #4#) - (PROGN (SETQ |x1| (CAR #4#)) NIL) - (ATOM #5#) - (PROGN (SETQ |x2| (CAR #5#)) NIL) - (ATOM #6#) - (PROGN (SETQ |x3| (CAR #6#)) NIL)) - NIL) - (SEQ - (EXIT - (SPADLET |n| - (PLUS |n| - (COND - ((|isEqualOrSubDomain| |x1| |x3|) 0) - ((QUOTE T) - (SPADLET |topcon| (CAR (|deconstructT| |x1|))) - (SPADLET |topcon2| (CAR (|deconstructT| |x3|))) - (COND - ((BOOT-EQUAL |topcon| |topcon2|) 3) - ((BOOT-EQUAL (CAR |topcon2|) (QUOTE |Mapping|)) 2) - ((QUOTE T) 4)))))))))) - (|sigArgs| (SPADLET |n| (PLUS |n| 100000000000))) ((QUOTE T) NIL)) - (SPADLET |res| (CADR |sig|)) - (COND - ((BOOT-EQUAL |res| |tar|) (TIMES 10000 |n|)) - ((QUOTE T) - (PLUS - (PLUS (TIMES 10000 |n|) (TIMES 1000 (|domainDepth| |res|))) - (|hitListOfTarget| |res|))))))))) + (declare (ignore |name|)) + (PROG (|sigArgs| |topcon| |topcon2| |n| |res|) + (RETURN + (SEQ (PROGN + (setq |sigArgs| (CDDR |sig|)) + (setq |n| + (COND + ((NULL |cond|) 1) + ((NULL (PROG (G167060) + (setq G167060 NIL) + (RETURN + (DO + ((G167066 NIL G167060) + (G167067 |cond| (CDR G167067)) + (G167056 NIL)) + ((OR G167066 (ATOM G167067) + (PROGN + (SETQ G167056 + (CAR G167067)) + NIL)) + G167060) + (SEQ + (EXIT + (SETQ G167060 + (OR G167060 G167056)))))))) + 1) + (t 0))) + (COND + (|args1| (DO ((G167079 |args1| (CDR G167079)) + (|x1| NIL) + (G167080 |args2| (CDR G167080)) + (|x2| NIL) + (G167081 |sigArgs| (CDR G167081)) + (|x3| NIL)) + ((OR (ATOM G167079) + (PROGN + (SETQ |x1| (CAR G167079)) + NIL) + (ATOM G167080) + (PROGN + (SETQ |x2| (CAR G167080)) + NIL) + (ATOM G167081) + (PROGN + (SETQ |x3| (CAR G167081)) + NIL)) + NIL) + (SEQ (EXIT (setq |n| + (PLUS |n| + (COND + ((|isEqualOrSubDomain| |x1| + |x3|) + 0) + (t + (setq |topcon| + (CAR (|deconstructT| |x1|))) + (setq |topcon2| + (CAR (|deconstructT| |x3|))) + (COND + ((BOOT-EQUAL |topcon| + |topcon2|) + 3) + ((BOOT-EQUAL + (CAR |topcon2|) + '|Mapping|) + 2) + (t 4)))))))))) + (|sigArgs| (setq |n| (PLUS |n| 100000000000))) + (t NIL)) + (setq |res| (CADR |sig|)) + (COND + ((BOOT-EQUAL |res| |tar|) (TIMES 10000 |n|)) + (t + (PLUS (PLUS (TIMES 10000 |n|) + (TIMES 1000 (|domainDepth| |res|))) + (|hitListOfTarget| |res|))))))))) ;orderMms(name, mmS,args1,args2,tar) == ; -- it counts the number of necessary coercions of the argument types @@ -2111,7 +2341,7 @@ the types A and B themselves are not sorted by preference. ; N:= NIL ; for mm in MSORT mmS repeat ; [sig,.,cond]:= mm -; b:= 'T +; b:= t ; p:= CONS(m := mmCost(name, sig,cond,tar,args1,args2),mm) ; mS:= ; null mS => list p @@ -2125,60 +2355,64 @@ the types A and B themselves are not sorted by preference. ; mmS and [CDR p for p in mS] (DEFUN |orderMms| (|name| |mmS| |args1| |args2| |tar|) - (PROG (N |sig| |cond| |m| |p| |b| S |mS|) - (RETURN - (SEQ - (COND - ((AND |mmS| (NULL (CDR |mmS|))) |mmS|) - ((QUOTE T) - (SPADLET |mS| NIL) - (SPADLET N NIL) - (DO ((#0=#:G167119 (MSORT |mmS|) (CDR #0#)) (|mm| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |sig| (CAR |mm|)) - (SPADLET |cond| (CADDR |mm|)) - (SPADLET |b| (QUOTE T)) - (SPADLET |p| - (CONS - (SPADLET |m| - (|mmCost| |name| |sig| |cond| |tar| |args1| |args2|)) |mm|)) - (SPADLET |mS| - (COND - ((NULL |mS|) (LIST |p|)) - ((> (CAAR |mS|) |m|) (CONS |p| |mS|)) - ((QUOTE T) - (SPADLET S |mS|) - (DO ((#1=#:G167128 NIL |b|)) - (#1# NIL) - (SEQ - (EXIT - (COND - ((SPADLET |b| (OR (NULL (CDR S)) (> (CAADR S) |m|))) - (RPLACD S (CONS |p| (CDR S)))) - ((QUOTE T) (SPADLET S (CDR S))))))) - |mS|))))))) - (AND - |mmS| - (PROG (#2=#:G167136) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G167141 |mS| (CDR #3#)) (|p| NIL)) - ((OR (ATOM #3#) (PROGN (SETQ |p| (CAR #3#)) NIL)) (NREVERSE0 #2#)) - (SEQ (EXIT (SETQ #2# (CONS (CDR |p|) #2#)))))))))))))) + (PROG (N |sig| |cond| |m| |p| |b| S |mS|) + (RETURN + (SEQ (COND + ((AND |mmS| (NULL (CDR |mmS|))) |mmS|) + (t (setq |mS| NIL) (setq N NIL) + (DO ((G167119 (MSORT |mmS|) (CDR G167119)) + (|mm| NIL)) + ((OR (ATOM G167119) + (PROGN (SETQ |mm| (CAR G167119)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (setq |sig| (CAR |mm|)) + (setq |cond| (CADDR |mm|)) + (setq |b| t) + (setq |p| + (CONS + (setq |m| + (|mmCost| |name| |sig| |cond| + |tar| |args1| |args2|)) + |mm|)) + (setq |mS| + (COND + ((NULL |mS|) (LIST |p|)) + ((> (CAAR |mS|) |m|) + (CONS |p| |mS|)) + (t (setq S |mS|) + (DO ((G167128 NIL |b|)) + (G167128 NIL) + (SEQ + (EXIT + (COND + ((setq |b| + (OR (NULL (CDR S)) + (> (CAADR S) |m|))) + (RPLACD S + (CONS |p| (CDR S)))) + (t (setq S (CDR S))))))) + |mS|))))))) + (AND |mmS| + (PROG (G167136) + (setq G167136 NIL) + (RETURN + (DO ((G167141 |mS| (CDR G167141)) (|p| NIL)) + ((OR (ATOM G167141) + (PROGN (SETQ |p| (CAR G167141)) NIL)) + (NREVERSE0 G167136)) + (SEQ (EXIT (SETQ G167136 + (CONS (CDR |p|) G167136)))))))))))))) ;domainDepth(d) == ; -- computes the depth of lisp structure d ; atom d => 0 ; MAX(domainDepth(CAR d)+1,domainDepth(CDR d)) -(DEFUN |domainDepth| (|d|) - (COND - ((ATOM |d|) 0) - ((QUOTE T) - (MAX (PLUS (|domainDepth| (CAR |d|)) 1) (|domainDepth| (CDR |d|)))))) +(defun |domainDepth| (d) + (if (atom d) + 0 + (max (+ (|domainDepth| (car d)) 1) (|domainDepth| (cdr d))))) ;hitListOfTarget(t) == ; -- assigns a number between 1 and 998 to a type t @@ -2193,17 +2427,17 @@ the types A and B themselves are not sorted by preference. ; EQ(CAR t,'Expression) => 1600 ; 500 -(DEFUN |hitListOfTarget| (|t|) - (COND - ((BOOT-EQUAL |t| (QUOTE (|Polynomial| (|Pi|)))) 90000) - ((EQ (CAR |t|) (QUOTE |Polynomial|)) 300) - ((EQ (CAR |t|) (QUOTE |List|)) 400) - ((EQ (CAR |t|) (QUOTE |Matrix|)) 910) - ((EQ (CAR |t|) (QUOTE |UniversalSegment|)) 501) - ((EQ (CAR |t|) (QUOTE |RationalFunction|)) 900) - ((EQ (CAR |t|) (QUOTE |Union|)) 999) - ((EQ (CAR |t|) (QUOTE |Expression|)) 1600) - ((QUOTE T) 500))) +(defun |hitListOfTarget| (arg) + (cond + ((BOOT-EQUAL arg '(|Polynomial| (|Pi|))) 90000) + ((eq (car arg) '|Polynomial|) 300) + ((eq (car arg) '|List|) 400) + ((eq (car arg) '|Matrix|) 910) + ((eq (car arg) '|UniversalSegment|) 501) + ((eq (car arg) '|RationalFunction|) 900) + ((eq (car arg) '|Union|) 999) + ((eq (car arg) '|Expression|) 1600) + (t 500))) ;getFunctionFromDomain(op,dc,args) == ; -- finds the function op with argument types args in dc @@ -2222,33 +2456,37 @@ the types A and B themselves are not sorted by preference. ; throwKeyedMsg("S2IF0004",[op,dc]) (DEFUN |getFunctionFromDomain| (|op| |dc| |args|) - (PROG (|$reportBottomUpFlag| |p| |domain| |osig| |nsig| |b|) - (DECLARE (SPECIAL |$reportBottomUpFlag|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$reportBottomUpFlag| NIL) - (COND - ((|member| (CAR |dc|) |$nonLisplibDomains|) - (|throwKeyedMsg| (QUOTE S2IF0002) (CONS (CAR |dc|) NIL))) - ((NULL (|constructor?| (CAR |dc|))) - (|throwKeyedMsg| (QUOTE S2IF0003) (CONS (CAR |dc|) NIL))) - ((SPADLET |p| - (|findFunctionInDomain| |op| |dc| NIL |args| |args| NIL NIL)) - (SPADLET |domain| (|evalDomain| |dc|)) - (DO ((#0=#:G167183 (NREVERSE |p|) (CDR #0#)) - (|mm| NIL) - (#1=#:G167184 NIL |b|)) - ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL) #1#) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |osig| (CDAR |mm|)) - (SPADLET |nsig| (CADR |mm|)) - (SPADLET |b| (|compiledLookup| |op| |nsig| |domain|)))))) - (OR |b| (|throwKeyedMsg| (QUOTE S2IS0023) (CONS |op| (CONS |dc| NIL))))) - ((QUOTE T) - (|throwKeyedMsg| (QUOTE S2IF0004) (CONS |op| (CONS |dc| NIL)))))))))) + (PROG (|$reportBottomUpFlag| |p| |domain| |osig| |nsig| |b|) + (DECLARE (SPECIAL |$reportBottomUpFlag| |$nonLisplibDomains|)) + (RETURN + (SEQ (PROGN + (setq |$reportBottomUpFlag| NIL) + (COND + ((|member| (CAR |dc|) |$nonLisplibDomains|) + (|throwKeyedMsg| 'S2IF0002 (CONS (CAR |dc|) NIL))) + ((NULL (|constructor?| (CAR |dc|))) + (|throwKeyedMsg| 'S2IF0003 (CONS (CAR |dc|) NIL))) + ((setq |p| + (|findFunctionInDomain| |op| |dc| NIL |args| + |args| NIL NIL)) + (setq |domain| (|evalDomain| |dc|)) + (DO ((G167183 (NREVERSE |p|) (CDR G167183)) + (|mm| NIL) (G167184 NIL |b|)) + ((OR (ATOM G167183) + (PROGN (SETQ |mm| (CAR G167183)) NIL) + G167184) + NIL) + (SEQ (EXIT (PROGN + (setq |osig| (CDAR |mm|)) + (setq |nsig| (CADR |mm|)) + (setq |b| + (|compiledLookup| |op| |nsig| + |domain|)))))) + (OR |b| + (|throwKeyedMsg| 'S2IS0023 + (CONS |op| (CONS |dc| NIL))))) + (t + (|throwKeyedMsg| 'S2IF0004 (CONS |op| (CONS |dc| NIL)))))))))) ;isOpInDomain(opName,dom,nargs) == ; -- returns true only if there is an op in the given domain with @@ -2263,30 +2501,32 @@ the types A and B themselves are not sorted by preference. ; gotOne (DEFUN |isOpInDomain| (|opName| |dom| |nargs|) - (PROG (|mmList| |gotOne|) - (RETURN - (SEQ - (PROGN - (SPADLET |mmList| - (ASSQ |opName| (|getOperationAlistFromLisplib| (CAR |dom|)))) - (SPADLET |mmList| (|subCopy| |mmList| (|constructSubst| |dom|))) - (COND - ((NULL |mmList|) NIL) - ((QUOTE T) - (SPADLET |gotOne| NIL) - (SPADLET |nargs| (PLUS |nargs| 1)) - (SEQ - (DO ((#0=#:G167207 (CDR |mmList|) (CDR #0#)) (|mm| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |mm| (CAR #0#)) NIL) - (NULL (NULL |gotOne|))) - NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |nargs| (|#| (CAR |mm|))) - (EXIT (SPADLET |gotOne| (CONS |mm| |gotOne|)))))))) - (EXIT |gotOne|))))))))) + (PROG (|mmList| |gotOne|) + (RETURN + (SEQ (PROGN + (setq |mmList| + (ASSQ |opName| + (|getOperationAlistFromLisplib| + (CAR |dom|)))) + (setq |mmList| + (|subCopy| |mmList| (|constructSubst| |dom|))) + (COND + ((NULL |mmList|) NIL) + (t (setq |gotOne| NIL) + (setq |nargs| (PLUS |nargs| 1)) + (SEQ (DO ((G167207 (CDR |mmList|) (CDR G167207)) + (|mm| NIL)) + ((OR (ATOM G167207) + (PROGN (SETQ |mm| (CAR G167207)) NIL) + (NULL (NULL |gotOne|))) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |nargs| + (|#| (CAR |mm|))) + (EXIT + (setq |gotOne| + (CONS |mm| |gotOne|)))))))) + (EXIT |gotOne|))))))))) ;findCommonSigInDomain(opName,dom,nargs) == ; -- this looks at all signatures in dom with given opName and nargs @@ -2308,43 +2548,55 @@ the types A and B themselves are not sorted by preference. ; VEC2LIST vec (DEFUN |findCommonSigInDomain| (|opName| |dom| |nargs|) - (PROG (|mmList| |gotOne| |vec|) - (RETURN - (SEQ - (COND - ((|member| (CAR |dom|) (QUOTE (|Union| |Record| |Mapping|))) NIL) - ((QUOTE T) - (SPADLET |mmList| - (ASSQ |opName| (|getOperationAlistFromLisplib| (CAR |dom|)))) - (SPADLET |mmList| (|subCopy| |mmList| (|constructSubst| |dom|))) - (COND - ((NULL |mmList|) NIL) - ((QUOTE T) - (SPADLET |gotOne| NIL) - (SPADLET |nargs| (PLUS |nargs| 1)) - (SPADLET |vec| NIL) - (SEQ - (DO ((#0=#:G167227 (CDR |mmList|) (CDR #0#)) (|mm| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |nargs| (|#| (CAR |mm|))) - (EXIT + (PROG (|mmList| |gotOne| |vec|) + (RETURN + (SEQ (COND + ((|member| (CAR |dom|) '(|Union| |Record| |Mapping|)) NIL) + (t + (setq |mmList| + (ASSQ |opName| + (|getOperationAlistFromLisplib| + (CAR |dom|)))) + (setq |mmList| + (|subCopy| |mmList| (|constructSubst| |dom|))) (COND - ((NULL |vec|) (SPADLET |vec| (LIST2VEC (CAR |mm|)))) - ((QUOTE T) - (DO ((|i| 0 (QSADD1 |i|)) - (#1=#:G167237 (CAR |mm|) (CDR #1#)) - (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((AND (ELT |vec| |i|) (NEQUAL (ELT |vec| |i|) |x|)) - (SETELT |vec| |i| NIL)) - ((QUOTE T) NIL))))))))))))) - (VEC2LIST |vec|)))))))))) + ((NULL |mmList|) NIL) + (t (setq |gotOne| NIL) + (setq |nargs| (PLUS |nargs| 1)) (setq |vec| NIL) + (SEQ (DO ((G167227 (CDR |mmList|) (CDR G167227)) + (|mm| NIL)) + ((OR (ATOM G167227) + (PROGN (SETQ |mm| (CAR G167227)) NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |nargs| + (|#| (CAR |mm|))) + (EXIT + (COND + ((NULL |vec|) + (setq |vec| + (LIST2VEC (CAR |mm|)))) + (t + (DO + ((|i| 0 (QSADD1 |i|)) + (G167237 (CAR |mm|) + (CDR G167237)) + (|x| NIL)) + ((OR (ATOM G167237) + (PROGN + (SETQ |x| + (CAR G167237)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((AND (ELT |vec| |i|) + (NEQUAL + (ELT |vec| |i|) |x|)) + (SETELT |vec| |i| NIL)) + (t NIL))))))))))))) + (VEC2LIST |vec|)))))))))) ;findUniqueOpInDomain(op,opName,dom) == ; -- return function named op in domain dom if unique, choose one if not @@ -2371,42 +2623,48 @@ the types A and B themselves are not sorted by preference. ; putModeSet(op,[m]) (DEFUN |findUniqueOpInDomain| (|op| |opName| |dom|) - (PROG (|mmList| |mm| |sig| |slot| |fun| |binVal| |m|) - (RETURN - (PROGN - (SPADLET |mmList| - (ASSQ |opName| (|getOperationAlistFromLisplib| (CAR |dom|)))) - (SPADLET |mmList| (|subCopy| |mmList| (|constructSubst| |dom|))) - (COND - ((NULL |mmList|) - (|throwKeyedMsg| (QUOTE S2IS0021) (CONS |opName| (CONS |dom| NIL)))) - ((QUOTE T) - (COND - ((> (|#| (CDR |mmList|)) 1) - (SPADLET |mm| (|selectMostGeneralMm| (CDR |mmList|))) - (|sayKeyedMsg| (QUOTE S2IS0022) - (CONS |opName| - (CONS |dom| - (CONS (CONS (QUOTE |Mapping|) (CAR |mm|)) NIL))))) - ((QUOTE T) (SPADLET |mm| (CADR |mmList|)))) - (SPADLET |sig| (CAR |mm|)) - (SPADLET |slot| (CADR |mm|)) - (SPADLET |fun| - (COND - (|$genValue| - (|compiledLookupCheck| |opName| |sig| (|evalDomain| |dom|))) - ((QUOTE T) - (|NRTcompileEvalForm| |opName| |sig| (|evalDomain| |dom|))))) - (COND - ((OR (NULL |fun|) (NULL (PAIRP |fun|))) NIL) - ((BOOT-EQUAL (CAR |fun|) (|function| |Undef|)) - (|throwKeyedMsg| (QUOTE S2IS0023) (CONS |opName| (CONS |dom| NIL)))) - ((QUOTE T) - (SPADLET |binVal| - (COND (|$genValue| (|wrap| |fun|)) ((QUOTE T) |fun|))) - (|putValue| |op| - (|objNew| |binVal| (SPADLET |m| (CONS (QUOTE |Mapping|) |sig|)))) - (|putModeSet| |op| (CONS |m| NIL)))))))))) + (PROG (|mmList| |mm| |sig| |slot| |fun| |binVal| |m|) + (declare (special |$genValue|)) + (RETURN + (PROGN + (setq |mmList| + (ASSQ |opName| + (|getOperationAlistFromLisplib| (CAR |dom|)))) + (setq |mmList| + (|subCopy| |mmList| (|constructSubst| |dom|))) + (COND + ((NULL |mmList|) + (|throwKeyedMsg| 'S2IS0021 (CONS |opName| (CONS |dom| NIL)))) + (t + (COND + ((> (|#| (CDR |mmList|)) 1) + (setq |mm| (|selectMostGeneralMm| (CDR |mmList|))) + (|sayKeyedMsg| 'S2IS0022 + (CONS |opName| + (CONS |dom| + (CONS (CONS '|Mapping| (CAR |mm|)) NIL))))) + (t (setq |mm| (CADR |mmList|)))) + (setq |sig| (CAR |mm|)) (setq |slot| (CADR |mm|)) + (setq |fun| + (COND + (|$genValue| + (|compiledLookupCheck| |opName| |sig| + (|evalDomain| |dom|))) + (t + (|NRTcompileEvalForm| |opName| |sig| + (|evalDomain| |dom|))))) + (COND + ((OR (NULL |fun|) (NULL (PAIRP |fun|))) NIL) + ((BOOT-EQUAL (CAR |fun|) (|function| |Undef|)) + (|throwKeyedMsg| 'S2IS0023 + (CONS |opName| (CONS |dom| NIL)))) + (t + (setq |binVal| + (COND (|$genValue| (|wrap| |fun|)) (t |fun|))) + (|putValue| |op| + (|objNew| |binVal| + (setq |m| (CONS '|Mapping| |sig|)))) + (|putModeSet| |op| (CONS |m| NIL)))))))))) ;selectMostGeneralMm mmList == ; -- selects the modemap in mmList with arguments all the other @@ -2429,67 +2687,80 @@ the types A and B themselves are not sorted by preference. ; for genMmArg in CDAR genMm] => genMm := mm ; genMm +; NO UNIT TEST (DEFUN |selectMostGeneralMm| (|mmList|) - (PROG (|sz| |met| |min| |fsz| |LETTMP#1| |mm| |mml| |genMm|) - (RETURN - (SEQ - (PROGN - (SPADLET |min| 100) - (SPADLET |mml| |mmList|) - (DO () - ((NULL |mml|) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |LETTMP#1| |mml|) - (SPADLET |mm| (CAR |LETTMP#1|)) - (SPADLET |mml| (CDR |LETTMP#1|)) - (SPADLET |sz| (|#| (CAR |mm|))) - (COND - ((> |min| (SPADLET |met| (ABS (SPADDIFFERENCE |sz| 3)))) - (SPADLET |min| |met|) (SPADLET |fsz| |sz|)) - ((QUOTE T) NIL)))))) - (SPADLET |mmList| - (PROG (#0=#:G167305) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167311 |mmList| (CDR #1#)) (|mm| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |mm| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL (|#| (CAR |mm|)) |fsz|) - (SETQ #0# (CONS |mm| #0#)))))))))) - (SPADLET |mml| (CDR |mmList|)) - (SPADLET |genMm| (CAR |mmList|)) - (DO () - ((NULL |mml|) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |LETTMP#1| |mml|) - (SPADLET |mm| (CAR |LETTMP#1|)) - (SPADLET |mml| (CDR |LETTMP#1|)) - (COND - ((PROG (#2=#:G167327) - (SPADLET #2# (QUOTE T)) - (RETURN - (DO ((#3=#:G167334 NIL (NULL #2#)) - (#4=#:G167335 (CDAR |mm|) (CDR #4#)) - (|mmArg| NIL) - (#5=#:G167336 (CDAR |genMm|) (CDR #5#)) - (|genMmArg| NIL)) - ((OR #3# - (ATOM #4#) - (PROGN (SETQ |mmArg| (CAR #4#)) NIL) - (ATOM #5#) - (PROGN (SETQ |genMmArg| (CAR #5#)) NIL)) - #2#) - (SEQ - (EXIT - (SETQ #2# (AND #2# (|canCoerceFrom| |genMmArg| |mmArg|)))))))) - (SPADLET |genMm| |mm|))))))) - |genMm|))))) + (PROG (|sz| |met| |min| |fsz| |LETTMP#1| |mm| |mml| |genMm|) + (RETURN + (SEQ (PROGN + (setq |min| 100) + (setq |mml| |mmList|) + (DO () ((NULL |mml|) NIL) + (SEQ (EXIT (PROGN + (setq |LETTMP#1| |mml|) + (setq |mm| (CAR |LETTMP#1|)) + (setq |mml| (CDR |LETTMP#1|)) + (setq |sz| (|#| (CAR |mm|))) + (COND + ((> |min| + (setq |met| + (ABS + (SPADDIFFERENCE |sz| 3)))) + (setq |min| |met|) + (setq |fsz| |sz|)) + (t NIL)))))) + (setq |mmList| + (PROG (G167305) + (setq G167305 NIL) + (RETURN + (DO ((G167311 |mmList| (CDR G167311)) + (|mm| NIL)) + ((OR (ATOM G167311) + (PROGN + (SETQ |mm| (CAR G167311)) + NIL)) + (NREVERSE0 G167305)) + (SEQ (EXIT (COND + ((BOOT-EQUAL (|#| (CAR |mm|)) + |fsz|) + (SETQ G167305 + (CONS |mm| G167305)))))))))) + (setq |mml| (CDR |mmList|)) + (setq |genMm| (CAR |mmList|)) + (DO () ((NULL |mml|) NIL) + (SEQ (EXIT (PROGN + (setq |LETTMP#1| |mml|) + (setq |mm| (CAR |LETTMP#1|)) + (setq |mml| (CDR |LETTMP#1|)) + (COND + ((PROG (G167327) + (setq G167327 t) + (RETURN + (DO + ((G167334 NIL (NULL G167327)) + (G167335 (CDAR |mm|) + (CDR G167335)) + (|mmArg| NIL) + (G167336 (CDAR |genMm|) + (CDR G167336)) + (|genMmArg| NIL)) + ((OR G167334 (ATOM G167335) + (PROGN + (SETQ |mmArg| (CAR G167335)) + NIL) + (ATOM G167336) + (PROGN + (SETQ |genMmArg| + (CAR G167336)) + NIL)) + G167327) + (SEQ + (EXIT + (SETQ G167327 + (AND G167327 + (|canCoerceFrom| |genMmArg| + |mmArg|)))))))) + (setq |genMm| |mm|))))))) + |genMm|))))) ;findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) == ; -- looks for a modemap for op with signature args1 -> tar @@ -2542,113 +2813,132 @@ the types A and B themselves are not sorted by preference. ; fun (DEFUN |findFunctionInDomain| - (|op| |dc| |tar| |args1| |args2| |$Coerce| |$SubDom|) - (DECLARE (SPECIAL |$Coerce| |$SubDom|)) - (PROG (|dcName| |p| SL |q| |r| |fun|) - (RETURN - (SEQ - (COND - ((NULL (|isLegitimateMode| |tar| NIL NIL)) NIL) - ((QUOTE T) - (SPADLET |dcName| (CAR |dc|)) - (COND - ((|member| |dcName| (QUOTE (|Union| |Record| |Mapping| |Enumeration|))) - (COND - ((BOOT-EQUAL |op| (QUOTE =)) - (COND - ((OR - (NEQUAL (|#| |args1|) 2) - (NEQUAL (ELT |args1| 0) |dc|) - (NEQUAL (ELT |args1| 1) |dc|)) - NIL) - ((AND |tar| (NEQUAL |tar| (QUOTE (|Boolean|)))) NIL) - ((QUOTE T) - (CONS - (CONS - (CONS |dc| - (CONS (QUOTE (|Boolean|)) (CONS |dc| (CONS |dc| NIL)))) - (CONS - (CONS (QUOTE (|Boolean|)) - (CONS (QUOTE $) (CONS (QUOTE $) NIL))) - (CONS (CONS NIL (CONS NIL NIL)) NIL))) - NIL)))) - ((BOOT-EQUAL |op| (QUOTE |coerce|)) - (COND - ((AND - (BOOT-EQUAL |dcName| (QUOTE |Enumeration|)) - (OR - (BOOT-EQUAL (ELT |args1| 0) |$Symbol|) - (BOOT-EQUAL |tar| |dc|))) - (CONS - (CONS - (CONS |dc| (CONS |dc| (CONS |$Symbol| NIL))) - (CONS - (CONS (QUOTE $) (CONS |$Symbol| NIL)) - (CONS (CONS NIL (CONS NIL NIL)) NIL))) - NIL)) - ((NEQUAL (ELT |args1| 0) |dc|) NIL) - ((AND |tar| (NEQUAL |tar| |$Expression|)) NIL) - ((QUOTE T) - (CONS - (CONS - (CONS |dc| (CONS |$Expression| (CONS |dc| NIL))) - (CONS - (CONS |$Expression| (CONS (QUOTE $) NIL)) - (CONS (CONS NIL (CONS NIL NIL)) NIL))) - NIL)))) - ((|member| |dcName| (QUOTE (|Record| |Union|))) - (|findFunctionInCategory| |op| |dc| |tar| |args1| |args2| - |$Coerce| |$SubDom|)) - ((QUOTE T) NIL))) - ((QUOTE T) - (SPADLET |fun| NIL) - (AND - (SPADLET |p| (ASSQ |op| (|getOperationAlistFromLisplib| |dcName|))) - (PROGN - (SPADLET SL (|constructSubst| |dc|)) - (COND - ((|isHomogeneousList| |args1|) - (SPADLET |q| NIL) - (SPADLET |r| NIL) - (DO ((#0=#:G167376 (CDR |p|) (CDR #0#)) (|mm| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((|isHomogeneousList| (CDAR |mm|)) - (SPADLET |q| (CONS |mm| |q|))) - ((QUOTE T) (SPADLET |r| (CONS |mm| |r|))))))) - (SPADLET |q| (|allOrMatchingMms| |q| |args1| |tar| |dc|)) - (DO ((#1=#:G167385 |q| (CDR #1#)) (|mm| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |mm| (CAR #1#)) NIL)) NIL) - (SEQ - (EXIT - (SPADLET |fun| - (NCONC |fun| - (|findFunctionInDomain1| |mm| |op| |tar| - |args1| |args2| SL)))))) - (SPADLET |r| (REVERSE |r|))) - ((QUOTE T) (SPADLET |r| (CDR |p|)))) - (SPADLET |r| (|allOrMatchingMms| |r| |args1| |tar| |dc|)) - (COND - ((NULL |fun|) - (DO ((#2=#:G167394 |r| (CDR #2#)) (|mm| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |mm| (CAR #2#)) NIL)) NIL) - (SEQ - (EXIT - (SPADLET |fun| - (NCONC |fun| - (|findFunctionInDomain1| |mm| |op| |tar| - |args1| |args2| SL))))))) - ((QUOTE T) NIL)))) - (COND - ((AND (NULL |fun|) |$reportBottomUpFlag|) - (|sayMSG| - (|concat| - (CONS " -> no appropriate" - (APPEND (|bright| |op|) - (CONS "found in" (|bright| (|prefix2String| |dc|))))))))) - |fun|)))))))) + (|op| |dc| |tar| |args1| |args2| |$Coerce| |$SubDom|) + (DECLARE (SPECIAL |$Coerce| |$SubDom|)) + (PROG (|dcName| |p| SL |q| |r| |fun|) + (declare (special |$reportBottomUpFlag| |$SubDom| |$Coerce| |$Expression| + |$Symbol|)) + (RETURN + (SEQ (COND + ((NULL (|isLegitimateMode| |tar| NIL NIL)) NIL) + (t (setq |dcName| (CAR |dc|)) + (COND + ((|member| |dcName| + '(|Union| |Record| |Mapping| |Enumeration|)) + (COND + ((BOOT-EQUAL |op| '=) + (COND + ((OR (NEQUAL (|#| |args1|) 2) + (NEQUAL (ELT |args1| 0) |dc|) + (NEQUAL (ELT |args1| 1) |dc|)) + NIL) + ((AND |tar| (NEQUAL |tar| '(|Boolean|))) NIL) + (t + (CONS (CONS (CONS |dc| + (CONS '(|Boolean|) + (CONS |dc| (CONS |dc| NIL)))) + (CONS + (CONS '(|Boolean|) + (CONS '$ (CONS '$ NIL))) + (CONS (CONS NIL (CONS NIL NIL)) + NIL))) + NIL)))) + ((BOOT-EQUAL |op| '|coerce|) + (COND + ((AND (BOOT-EQUAL |dcName| '|Enumeration|) + (OR (BOOT-EQUAL (ELT |args1| 0) |$Symbol|) + (BOOT-EQUAL |tar| |dc|))) + (CONS (CONS (CONS |dc| + (CONS |dc| (CONS |$Symbol| NIL))) + (CONS (CONS '$ (CONS |$Symbol| NIL)) + (CONS (CONS NIL (CONS NIL NIL)) + NIL))) + NIL)) + ((NEQUAL (ELT |args1| 0) |dc|) NIL) + ((AND |tar| (NEQUAL |tar| |$Expression|)) NIL) + (t + (CONS (CONS (CONS |dc| + (CONS |$Expression| + (CONS |dc| NIL))) + (CONS + (CONS |$Expression| (CONS '$ NIL)) + (CONS (CONS NIL (CONS NIL NIL)) + NIL))) + NIL)))) + ((|member| |dcName| '(|Record| |Union|)) + (|findFunctionInCategory| |op| |dc| |tar| |args1| + |args2| |$Coerce| |$SubDom|)) + (t NIL))) + (t (setq |fun| NIL) + (AND (setq |p| + (ASSQ |op| + (|getOperationAlistFromLisplib| + |dcName|))) + (PROGN + (setq SL (|constructSubst| |dc|)) + (COND + ((|isHomogeneousList| |args1|) + (setq |q| NIL) (setq |r| NIL) + (DO ((G167376 (CDR |p|) (CDR G167376)) + (|mm| NIL)) + ((OR (ATOM G167376) + (PROGN + (SETQ |mm| (CAR G167376)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((|isHomogeneousList| + (CDAR |mm|)) + (setq |q| + (CONS |mm| |q|))) + (t + (setq |r| + (CONS |mm| |r|))))))) + (setq |q| + (|allOrMatchingMms| |q| |args1| + |tar| |dc|)) + (DO ((G167385 |q| (CDR G167385)) + (|mm| NIL)) + ((OR (ATOM G167385) + (PROGN + (SETQ |mm| (CAR G167385)) + NIL)) + NIL) + (SEQ (EXIT (setq |fun| + (NCONC |fun| + (|findFunctionInDomain1| |mm| + |op| |tar| |args1| |args2| + SL)))))) + (setq |r| (REVERSE |r|))) + (t (setq |r| (CDR |p|)))) + (setq |r| + (|allOrMatchingMms| |r| |args1| |tar| + |dc|)) + (COND + ((NULL |fun|) + (DO ((G167394 |r| (CDR G167394)) + (|mm| NIL)) + ((OR (ATOM G167394) + (PROGN + (SETQ |mm| (CAR G167394)) + NIL)) + NIL) + (SEQ (EXIT (setq |fun| + (NCONC |fun| + (|findFunctionInDomain1| |mm| + |op| |tar| |args1| |args2| + SL))))))) + (t NIL)))) + (COND + ((AND (NULL |fun|) |$reportBottomUpFlag|) + (|sayMSG| + (|concat| + (CONS " -> no appropriate" + (APPEND (|bright| |op|) + (CONS "found in" + (|bright| + (|prefix2String| |dc|))))))))) + |fun|)))))))) ;allOrMatchingMms(mms,args1,tar,dc) == ; -- if there are exact matches on the arg types, return them @@ -2664,28 +2954,26 @@ the types A and B themselves are not sorted by preference. ; else mms (DEFUN |allOrMatchingMms| (|mms| |args1| |tar| |dc|) - (PROG (|sig| |LETTMP#1| |res| |args| |x|) - (RETURN - (SEQ - (COND - ((OR (NULL |mms|) (NULL (CDR |mms|))) |mms|) - ((QUOTE T) - (SPADLET |x| NIL) - (DO ((#0=#:G167437 |mms| (CDR #0#)) (|mm| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |sig| (CAR |mm|)) - (SPADLET |LETTMP#1| (MSUBSTQ |dc| (QUOTE $) |sig|)) - (SPADLET |res| (CAR |LETTMP#1|)) - (SPADLET |args| (CDR |LETTMP#1|)) - (COND - ((NEQUAL |args| |args1|) NIL) - ((QUOTE T) (SPADLET |x| (CONS |mm| |x|)))))))) - (COND - (|x| |x|) - ((QUOTE T) |mms|)))))))) + (declare (ignore |tar|)) + (PROG (|sig| |LETTMP#1| |res| |args| |x|) + (RETURN + (SEQ (COND + ((OR (NULL |mms|) (NULL (CDR |mms|))) |mms|) + (t (setq |x| NIL) + (DO ((G167437 |mms| (CDR G167437)) (|mm| NIL)) + ((OR (ATOM G167437) + (PROGN (SETQ |mm| (CAR G167437)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (setq |sig| (CAR |mm|)) + (setq |LETTMP#1| + (MSUBSTQ |dc| '$ |sig|)) + (setq |res| (CAR |LETTMP#1|)) + (setq |args| (CDR |LETTMP#1|)) + (COND + ((NEQUAL |args| |args1|) NIL) + (t (setq |x| (CONS |mm| |x|)))))))) + (COND (|x| |x|) (t |mms|)))))))) ;isHomogeneousList y == ; y is [x] => true @@ -2694,26 +2982,13 @@ the types A and B themselves are not sorted by preference. ; "and"/[x = z for x in CDR y] ; NIL -(DEFUN |isHomogeneousList| (|y|) - (PROG (|x| |z|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |y|) - (EQ (QCDR |y|) NIL) - (PROGN (SPADLET |x| (QCAR |y|)) (QUOTE T))) - (QUOTE T)) - ((AND |y| (CDR |y|)) - (SPADLET |z| (CAR |y|)) - (PROG (#0=#:G167454) - (SPADLET #0# (QUOTE T)) - (RETURN - (DO ((#1=#:G167460 NIL (NULL #0#)) - (#2=#:G167461 (CDR |y|) (CDR #2#)) - (|x| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (AND #0# (BOOT-EQUAL |x| |z|))))))))) - ((QUOTE T) NIL)))))) +(defun |isHomogeneousList| (y) + (let (x) + (if (and (listp y) (= (length y) 1)) + t + (progn + (setq x (car y)) + (every #'(lambda (z) (BOOT-EQUAL x z)) (cdr y)))))) ;findFunctionInDomain1(omm,op,tar,args1,args2,SL) == ; dc:= CDR (dollarPair := ASSQ('$,SL)) @@ -2744,76 +3019,84 @@ the types A and B themselves are not sorted by preference. ; NIL (DEFUN |findFunctionInDomain1| (|omm| |op| |tar| |args1| |args2| SL) - (PROG ($RTC |dollarPair| |dc| |mm| |slot| |cond| |osig| |sig| |y| - |ISTMP#1| |args| |f|) - (DECLARE (SPECIAL $RTC)) - (RETURN - (SEQ - (PROGN - (SPADLET |dc| (CDR (SPADLET |dollarPair| (ASSQ (QUOTE $) SL)))) - (SPADLET |mm| (|subCopy| |omm| SL)) - (SPADLET $RTC NIL) - (SPADLET |sig| (CAR |mm|)) - (SPADLET |slot| (CADR |mm|)) - (SPADLET |cond| (CADDR |mm|)) - (SPADLET |y| (CADDDR |mm|)) - (SPADLET |osig| (CAR |omm|)) - (SPADLET |osig| - (|subCopy| |osig| (SUBSTQ (CONS (QUOTE $) (QUOTE $)) |dollarPair| SL))) - (COND - ((OR - (CONTAINED (QUOTE |#|) |sig|) - (CONTAINED (QUOTE |construct|) |sig|)) - (SPADLET |sig| - (PROG (#0=#:G167493) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167498 |sig| (CDR #1#)) (|t| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |t| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS (|replaceSharpCalls| |t|) #0#)))))))))) - (AND - (|matchMmCond| |cond|) - (|matchMmSig| |mm| |tar| |args1| |args2|) - (PROGN - (AND - (EQ |y| (QUOTE |Subsumed|)) - (PROGN - (SPADLET |y| (QUOTE ELT)) - (COND - ((AND - (NULL |$SubDom|) - (NULL - (PROGN - (SPADLET |ISTMP#1| (CAR |sig|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE |Union|))))) - (PAIRP |slot|) - (PROGN - (SPADLET |tar| (QCAR |slot|)) - (SPADLET |args| (QCDR |slot|)) - (QUOTE T)) - (SPADLET |f| - (|findFunctionInDomain| |op| |dc| |tar| |args| |args| NIL NIL))) - |f|)))) - (COND - ((EQ |y| (QUOTE ELT)) - (CONS - (CONS (CONS |dc| |sig|) (CONS |osig| (CONS (NREVERSE $RTC) NIL))) - NIL)) - ((EQ |y| (QUOTE CONST)) - (CONS - (CONS (CONS |dc| |sig|) (CONS |osig| (CONS (NREVERSE $RTC) NIL))) - NIL)) - ((EQ |y| (QUOTE ASCONST)) - (CONS - (CONS (CONS |dc| |sig|) (CONS |osig| (CONS (NREVERSE $RTC) NIL))) - NIL)) - ((AND (PAIRP |y|) (EQ (QCAR |y|) (QUOTE XLAM))) - (CONS - (CONS (CONS |dc| |sig|) (CONS |y| (CONS (NREVERSE $RTC) NIL))) - NIL)) - ((QUOTE T) - (|sayKeyedMsg| (QUOTE S2IF0006) (CONS |y| NIL)) NIL))))))))) + (PROG ($RTC |dollarPair| |dc| |mm| |slot| |cond| |osig| |sig| |y| + |ISTMP#1| |args| |f|) + (DECLARE (SPECIAL $RTC |$SubDom|)) + (RETURN + (SEQ (PROGN + (setq |dc| (CDR (setq |dollarPair| (ASSQ '$ SL)))) + (setq |mm| (|subCopy| |omm| SL)) + (setq $RTC NIL) + (setq |sig| (CAR |mm|)) + (setq |slot| (CADR |mm|)) + (setq |cond| (CADDR |mm|)) + (setq |y| (CADDDR |mm|)) + (setq |osig| (CAR |omm|)) + (setq |osig| + (|subCopy| |osig| + (SUBSTQ (CONS '$ '$) |dollarPair| SL))) + (COND + ((OR (CONTAINED '|#| |sig|) + (CONTAINED '|construct| |sig|)) + (setq |sig| + (PROG (G167493) + (setq G167493 NIL) + (RETURN + (DO ((G167498 |sig| (CDR G167498)) + (|t| NIL)) + ((OR (ATOM G167498) + (PROGN + (SETQ |t| (CAR G167498)) + NIL)) + (NREVERSE0 G167493)) + (SEQ (EXIT + (SETQ G167493 + (CONS (|replaceSharpCalls| |t|) + G167493)))))))))) + (AND (|matchMmCond| |cond|) + (|matchMmSig| |mm| |tar| |args1| |args2|) + (PROGN + (AND (EQ |y| '|Subsumed|) + (PROGN + (setq |y| 'ELT) + (COND + ((AND (NULL |$SubDom|) + (NULL + (PROGN + (setq |ISTMP#1| (CAR |sig|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Union|)))) + (PAIRP |slot|) + (PROGN + (setq |tar| (QCAR |slot|)) + (setq |args| (QCDR |slot|)) + t) + (setq |f| + (|findFunctionInDomain| |op| |dc| + |tar| |args| |args| NIL NIL))) + |f|)))) + (COND + ((EQ |y| 'ELT) + (CONS (CONS (CONS |dc| |sig|) + (CONS |osig| + (CONS (NREVERSE $RTC) NIL))) + NIL)) + ((EQ |y| 'CONST) + (CONS (CONS (CONS |dc| |sig|) + (CONS |osig| + (CONS (NREVERSE $RTC) NIL))) + NIL)) + ((EQ |y| 'ASCONST) + (CONS (CONS (CONS |dc| |sig|) + (CONS |osig| + (CONS (NREVERSE $RTC) NIL))) + NIL)) + ((AND (PAIRP |y|) (EQ (QCAR |y|) 'XLAM)) + (CONS (CONS (CONS |dc| |sig|) + (CONS |y| + (CONS (NREVERSE $RTC) NIL))) + NIL)) + (t (|sayKeyedMsg| 'S2IF0006 (CONS |y| NIL)) NIL))))))))) ;findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) == ; -- looks for a modemap for op with signature args1 -> tar @@ -2851,98 +3134,109 @@ the types A and B themselves are not sorted by preference. ; :bright prefix2String dc] ; fun -(DEFUN |findFunctionInCategory| - (|op| |dc| |tar| |args1| |args2| |$Coerce| |$SubDom|) - (DECLARE (SPECIAL |$Coerce| |$SubDom|)) - (PROG (|dcName| |makeFunc| |LETTMP#1| |funlist| |a| |b| |d| |ISTMP#1| - |xargs| |maxargs| |impls| SL |fun|) - (RETURN - (SEQ - (PROGN - (SPADLET |dcName| (CAR |dc|)) - (COND - ((NULL (MEMQ |dcName| (QUOTE (|Record| |Union| |Enumeration|)))) NIL) - ((QUOTE T) - (SPADLET |fun| NIL) - (SPADLET |makeFunc| - (OR - (GETL |dcName| (QUOTE |makeFunctionList|)) - (|systemErrorHere| (MAKESTRING "findFunctionInCategory")))) - (SPADLET |LETTMP#1| - (FUNCALL |makeFunc| (QUOTE $) |dc| |$CategoryFrame|)) - (SPADLET |funlist| (CAR |LETTMP#1|)) - (SPADLET |maxargs| (SPADDIFFERENCE 1)) - (SPADLET |impls| NIL) - (DO ((#0=#:G167553 |funlist| (CDR #0#)) (#1=#:G167537 NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |a| (CAR #1#)) - (SPADLET |b| (CADR #1#)) - (SPADLET |d| (CADDR #1#)) - #1#) - NIL)) - NIL) - (SEQ - (EXIT - (COND - ((NULL (EQ |a| |op|)) NIL) - ((AND (PAIRP |d|) - (EQ (QCAR |d|) (QUOTE XLAM)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |d|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |xargs| (QCAR |ISTMP#1|)) (QUOTE T))))) +(DEFUN |findFunctionInCategory| + (|op| |dc| |tar| |args1| |args2| |$Coerce| |$SubDom|) + (DECLARE (SPECIAL |$Coerce| |$SubDom|)) + (PROG (|dcName| |makeFunc| |LETTMP#1| |funlist| |a| |b| |d| |ISTMP#1| + |xargs| |maxargs| |impls| SL |fun|) + (declare (special |$reportBottomUpFlag| |$CategoryFrame|)) + (RETURN + (SEQ (PROGN + (setq |dcName| (CAR |dc|)) (COND - ((PAIRP |xargs|) - (SPADLET |maxargs| (MAX |maxargs| (|#| |xargs|)))) - ((QUOTE T) - (SPADLET |maxargs| (MAX |maxargs| 1)))) - (SPADLET |impls| - (CONS - (CONS |b| (CONS NIL (CONS (QUOTE T) (CONS |d| NIL)))) - |impls|))) - ((QUOTE T) - (SPADLET |impls| - (CONS - (CONS |b| (CONS |d| (CONS (QUOTE T) (CONS |d| NIL)))) - |impls|))))))) - (SPADLET |impls| (NREVERSE |impls|)) - (COND - ((NEQUAL |maxargs| (SPADDIFFERENCE 1)) - (SPADLET SL NIL) - (DO ((|i| 1 (QSADD1 |i|))) - ((QSGREATERP |i| |maxargs|) NIL) - (SEQ - (EXIT - (SPADLET |impls| - (SUBSTQ (GENSYM) (INTERNL "#" (STRINGIMAGE |i|)) |impls|))))))) - (AND - |impls| - (PROGN - (SPADLET SL (|constructSubst| |dc|)) - (DO ((#2=#:G167569 |impls| (CDR #2#)) (|mm| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |mm| (CAR #2#)) NIL)) NIL) - (SEQ - (EXIT - (SPADLET |fun| - (NCONC |fun| - (|findFunctionInDomain1| |mm| |op| |tar| - |args1| |args2| SL)))))))) - (COND - ((AND (NULL |fun|) |$reportBottomUpFlag|) - (|sayMSG| - (|concat| - (CONS " -> no appropriate" - (APPEND (|bright| |op|) - (CONS "found in" (|bright| (|prefix2String| |dc|))))))))) - |fun|))))))) + ((NULL (MEMQ |dcName| '(|Record| |Union| |Enumeration|))) + NIL) + (t (setq |fun| NIL) + (setq |makeFunc| + (OR (GETL |dcName| '|makeFunctionList|) + (|systemErrorHere| + "findFunctionInCategory"))) + (setq |LETTMP#1| + (FUNCALL |makeFunc| '$ |dc| |$CategoryFrame|)) + (setq |funlist| (CAR |LETTMP#1|)) + (setq |maxargs| (SPADDIFFERENCE 1)) + (setq |impls| NIL) + (DO ((G167553 |funlist| (CDR G167553)) + (G167537 NIL)) + ((OR (ATOM G167553) + (PROGN (SETQ G167537 (CAR G167553)) NIL) + (PROGN + (PROGN + (setq |a| (CAR G167537)) + (setq |b| (CADR G167537)) + (setq |d| (CADDR G167537)) + G167537) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (EQ |a| |op|)) NIL) + ((AND (PAIRP |d|) (EQ (QCAR |d|) 'XLAM) + (PROGN + (setq |ISTMP#1| (QCDR |d|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |xargs| + (QCAR |ISTMP#1|)) + t)))) + (COND + ((PAIRP |xargs|) + (setq |maxargs| + (MAX |maxargs| (|#| |xargs|)))) + (t + (setq |maxargs| + (MAX |maxargs| 1)))) + (setq |impls| + (CONS + (CONS |b| + (CONS NIL + (CONS t (CONS |d| NIL)))) + |impls|))) + (t + (setq |impls| + (CONS + (CONS |b| + (CONS |d| + (CONS t (CONS |d| NIL)))) + |impls|))))))) + (setq |impls| (NREVERSE |impls|)) + (COND + ((NEQUAL |maxargs| (SPADDIFFERENCE 1)) + (setq SL NIL) + (DO ((|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| |maxargs|) NIL) + (SEQ (EXIT (setq |impls| + (SUBSTQ (GENSYM) + (INTERNL "#" + (STRINGIMAGE |i|)) + |impls|))))))) + (AND |impls| + (PROGN + (setq SL (|constructSubst| |dc|)) + (DO ((G167569 |impls| (CDR G167569)) + (|mm| NIL)) + ((OR (ATOM G167569) + (PROGN + (SETQ |mm| (CAR G167569)) + NIL)) + NIL) + (SEQ (EXIT (setq |fun| + (NCONC |fun| + (|findFunctionInDomain1| |mm| + |op| |tar| |args1| |args2| SL)))))))) + (COND + ((AND (NULL |fun|) |$reportBottomUpFlag|) + (|sayMSG| + (|concat| + (CONS " -> no appropriate" + (APPEND (|bright| |op|) + (CONS "found in" + (|bright| + (|prefix2String| |dc|))))))))) + |fun|))))))) ;matchMmCond(cond) == ; -- tests the condition, which comes with a modemap -; -- cond is 'T or a list, but I hate to test for 'T (ALBI) +; -- cond is t or a list, but I hate to test for t (ALBI) ; $domPvar: local := nil ; atom cond or ; cond is ['AND,:conds] or cond is ['and,:conds] => @@ -2956,70 +3250,84 @@ the types A and B themselves are not sorted by preference. ; ['"matchMmCond",'"unknown form of condition"]) (DEFUN |matchMmCond| (|cond|) - (PROG (|$domPvar| |conds| |dom| |ISTMP#2| |x| |ISTMP#1| |cond1|) - (DECLARE (SPECIAL |$domPvar|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$domPvar| NIL) - (OR - (ATOM |cond|) - (COND - ((OR - (AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE AND)) - (PROGN (SPADLET |conds| (QCDR |cond|)) (QUOTE T))) - (AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |and|)) - (PROGN (SPADLET |conds| (QCDR |cond|)) (QUOTE T)))) - (PROG (#0=#:G167622) - (SPADLET #0# (QUOTE T)) - (RETURN - (DO ((#1=#:G167628 NIL (NULL #0#)) - (#2=#:G167629 |conds| (CDR #2#)) - (|c| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |c| (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (AND #0# (|matchMmCond| |c|))))))))) - ((OR - (AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE OR)) - (PROGN (SPADLET |conds| (QCDR |cond|)) (QUOTE T))) - (AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |or|)) - (PROGN (SPADLET |conds| (QCDR |cond|)) (QUOTE T)))) - (PROG (#3=#:G167636) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G167642 NIL #3#) - (#5=#:G167643 |conds| (CDR #5#)) - (|c| NIL)) - ((OR #4# (ATOM #5#) (PROGN (SETQ |c| (CAR #5#)) NIL)) #3#) - (SEQ (EXIT (SETQ #3# (OR #3# (|matchMmCond| |c|))))))))) - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cond|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |dom| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |x| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (NEQUAL (|hasCaty| |dom| |x| NIL) (QUOTE |failed|))) - ((AND (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |not|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cond|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |cond1| (QCAR |ISTMP#1|)) (QUOTE T))))) - (NULL (|matchMmCond| |cond1|))) - ((QUOTE T) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "matchMmCond" (CONS "unknown form of condition" NIL))))))))))) + (PROG (|$domPvar| |conds| |dom| |ISTMP#2| |x| |ISTMP#1| |cond1|) + (DECLARE (SPECIAL |$domPvar|)) + (RETURN + (SEQ (PROGN + (setq |$domPvar| NIL) + (OR (ATOM |cond|) + (COND + ((OR (AND (PAIRP |cond|) (EQ (QCAR |cond|) 'AND) + (PROGN + (setq |conds| (QCDR |cond|)) + t)) + (AND (PAIRP |cond|) (EQ (QCAR |cond|) '|and|) + (PROGN + (setq |conds| (QCDR |cond|)) + t))) + (PROG (G167622) + (setq G167622 t) + (RETURN + (DO ((G167628 NIL (NULL G167622)) + (G167629 |conds| (CDR G167629)) + (|c| NIL)) + ((OR G167628 (ATOM G167629) + (PROGN + (SETQ |c| (CAR G167629)) + NIL)) + G167622) + (SEQ (EXIT (SETQ G167622 + (AND G167622 + (|matchMmCond| |c|))))))))) + ((OR (AND (PAIRP |cond|) (EQ (QCAR |cond|) 'OR) + (PROGN + (setq |conds| (QCDR |cond|)) + t)) + (AND (PAIRP |cond|) (EQ (QCAR |cond|) '|or|) + (PROGN + (setq |conds| (QCDR |cond|)) + t))) + (PROG (G167636) + (setq G167636 NIL) + (RETURN + (DO ((G167642 NIL G167636) + (G167643 |conds| (CDR G167643)) + (|c| NIL)) + ((OR G167642 (ATOM G167643) + (PROGN + (SETQ |c| (CAR G167643)) + NIL)) + G167636) + (SEQ (EXIT (SETQ G167636 + (OR G167636 + (|matchMmCond| |c|))))))))) + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|has|) + (PROGN + (setq |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |dom| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |x| (QCAR |ISTMP#2|)) + t)))))) + (NEQUAL (|hasCaty| |dom| |x| NIL) '|failed|)) + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|not|) + (PROGN + (setq |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |cond1| (QCAR |ISTMP#1|)) + t)))) + (NULL (|matchMmCond| |cond1|))) + (t + (|keyedSystemError| 'S2GE0016 + (CONS "matchMmCond" + (CONS "unknown form of condition" + NIL))))))))))) ;matchMmSig(mm,tar,args1,args2) == ; -- matches the modemap signature against args1 -> tar @@ -3042,85 +3350,94 @@ the types A and B themselves are not sorted by preference. ; if x is ['SubDomain,y,:.] then x:= y ; b := isEqualOrSubDomain(x1,x) or ; (STRINGP(x) and (x1 is ['Variable,v]) and (x = PNAME v)) or -; $SubDom and isSubDomain(x,x1) => rtc:= 'T +; $SubDom and isSubDomain(x,x1) => rtc:= t ; $Coerce => x2=x or canCoerceFrom(x1,x) ; x1 is ['Variable,:.] and x = '(Symbol) ; $RTC:= CONS(rtc,$RTC) ; null args1 and null a and b and matchMmSigTar(tar,CAR sig) (DEFUN |matchMmSig| (|mm| |tar| |args1| |args2|) - (PROG (|sig| |arg| |x1| |x2| |a| |y| |x| |ISTMP#1| |v| |rtc| |b|) - (RETURN - (SEQ - (PROGN - (SPADLET |sig| (CAR |mm|)) - (COND - ((CONTAINED (QUOTE |#|) |sig|) - (SPADLET |sig| - (PROG (#0=#:G167685) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G167690 |sig| (CDR #1#)) (|t| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |t| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# (CONS (|replaceSharpCalls| (COPY |t|)) #0#)))))))))) - (COND - ((NULL |args1|) (|matchMmSigTar| |tar| (CAR |sig|))) - ((QUOTE T) - (SPADLET |a| (CDR |sig|)) - (SPADLET |arg| NIL) - (DO ((|i| 1 (QSADD1 |i|)) (#2=#:G167719 NIL (NULL |b|))) - ((OR (NULL (AND |args1| |args2| |a|)) #2#) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |x1| (CAR |args1|)) - (SPADLET |args1| (CDR |args1|)) - (SPADLET |x2| (CAR |args2|)) - (SPADLET |args2| (CDR |args2|)) - (SPADLET |x| (CAR |a|)) - (SPADLET |a| (CDR |a|)) - (SPADLET |rtc| NIL) - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |SubDomain|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |x| |y|))) - (SPADLET |b| - (OR - (|isEqualOrSubDomain| |x1| |x|) - (AND - (STRINGP |x|) - (PAIRP |x1|) - (EQ (QCAR |x1|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) (QUOTE T)))) - (BOOT-EQUAL |x| (PNAME |v|))) + (PROG (|sig| |arg| |x1| |x2| |a| |y| |x| |ISTMP#1| |v| |rtc| |b|) + (declare (special $RTC |$Coerce| |$SubDom|)) + (RETURN + (SEQ (PROGN + (setq |sig| (CAR |mm|)) + (COND + ((CONTAINED '|#| |sig|) + (setq |sig| + (PROG (G167685) + (setq G167685 NIL) + (RETURN + (DO ((G167690 |sig| (CDR G167690)) + (|t| NIL)) + ((OR (ATOM G167690) + (PROGN + (SETQ |t| (CAR G167690)) + NIL)) + (NREVERSE0 G167685)) + (SEQ (EXIT + (SETQ G167685 + (CONS + (|replaceSharpCalls| (COPY |t|)) + G167685)))))))))) (COND - ((AND |$SubDom| (|isSubDomain| |x| |x1|)) - (SPADLET |rtc| (QUOTE T))) - (|$Coerce| - (OR (BOOT-EQUAL |x2| |x|) (|canCoerceFrom| |x1| |x|))) - ((QUOTE T) - (AND (PAIRP |x1|) - (EQ (QCAR |x1|) (QUOTE |Variable|)) - (BOOT-EQUAL |x| (QUOTE (|Symbol|)))))))) - (SPADLET $RTC (CONS |rtc| $RTC)))))) - (AND - (NULL |args1|) - (NULL |a|) - |b| - (|matchMmSigTar| |tar| (CAR |sig|)))))))))) + ((NULL |args1|) (|matchMmSigTar| |tar| (CAR |sig|))) + (t (setq |a| (CDR |sig|)) (setq |arg| NIL) + (DO ((|i| 1 (QSADD1 |i|)) (G167719 NIL (NULL |b|))) + ((OR (NULL (AND |args1| |args2| |a|)) G167719) + NIL) + (SEQ (EXIT (PROGN + (setq |x1| (CAR |args1|)) + (setq |args1| (CDR |args1|)) + (setq |x2| (CAR |args2|)) + (setq |args2| (CDR |args2|)) + (setq |x| (CAR |a|)) + (setq |a| (CDR |a|)) + (setq |rtc| NIL) + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '|SubDomain|) + (PROGN + (setq |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |y| + (QCAR |ISTMP#1|)) + t)))) + (setq |x| |y|))) + (setq |b| + (OR + (|isEqualOrSubDomain| |x1| + |x|) + (AND (STRINGP |x|) + (PAIRP |x1|) + (EQ (QCAR |x1|) '|Variable|) + (PROGN + (setq |ISTMP#1| + (QCDR |x1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |v| + (QCAR |ISTMP#1|)) + t))) + (BOOT-EQUAL |x| (PNAME |v|))) + (COND + ((AND |$SubDom| + (|isSubDomain| |x| |x1|)) + (setq |rtc| t)) + (|$Coerce| + (OR (BOOT-EQUAL |x2| |x|) + (|canCoerceFrom| |x1| |x|))) + (t + (AND (PAIRP |x1|) + (EQ (QCAR |x1|) + '|Variable|) + (BOOT-EQUAL |x| + '(|Symbol|))))))) + (setq $RTC (CONS |rtc| $RTC)))))) + (AND (NULL |args1|) (NULL |a|) |b| + (|matchMmSigTar| |tar| (CAR |sig|)))))))))) ;matchMmSigTar(t1,t2) == ; -- t1 is a target type specified by :: or by a declared variable @@ -3137,38 +3454,37 @@ the types A and B themselves are not sorted by preference. ; canCoerceFrom(t2,t1) (DEFUN |matchMmSigTar| (|t1| |t2|) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) - (RETURN - (OR - (NULL |t1|) - (COND - ((|isEqualOrSubDomain| |t2| |t1|) (QUOTE T)) - ((QUOTE T) - (COND - ((AND (PAIRP |t2|) - (EQ (QCAR |t2|) (QUOTE |Union|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |t2|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (COND - ((BOOT-EQUAL |a| (MAKESTRING "failed")) - (RETURN (|matchMmSigTar| |t1| |b|)))) - (COND - ((BOOT-EQUAL |b| (MAKESTRING "failed")) - (RETURN (|matchMmSigTar| |t1| |a|))) - ((QUOTE T) NIL)))) - (AND |$Coerce| - (COND - ((|isPartialMode| |t1|) (|resolveTM| |t2| |t1|)) - ((QUOTE T) (|canCoerceFrom| |t2| |t1|)))))))))) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) + (declare (special |$Coerce|)) + (RETURN + (OR (NULL |t1|) + (COND + ((|isEqualOrSubDomain| |t2| |t1|) t) + (t + (COND + ((AND (PAIRP |t2|) (EQ (QCAR |t2|) '|Union|) + (PROGN + (setq |ISTMP#1| (QCDR |t2|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |a| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |b| (QCAR |ISTMP#2|)) + t)))))) + (COND + ((BOOT-EQUAL |a| "failed") + (RETURN (|matchMmSigTar| |t1| |b|)))) + (COND + ((BOOT-EQUAL |b| "failed") + (RETURN (|matchMmSigTar| |t1| |a|))) + (t NIL)))) + (AND |$Coerce| + (COND + ((|isPartialMode| |t1|) (|resolveTM| |t2| |t1|)) + (t (|canCoerceFrom| |t2| |t1|)))))))))) ;constructSubst(d) == ; -- constructs a substitution which substitutes d for $ @@ -3178,21 +3494,14 @@ the types A and B themselves are not sorted by preference. ; SL:= CONS(CONS(INTERNL('"#",STRINGIMAGE i),x),SL) ; SL -(DEFUN |constructSubst| (|d|) - (PROG (SL) - (RETURN - (SEQ - (PROGN - (SPADLET SL (LIST (CONS (QUOTE $) |d|))) - (DO ((#0=#:G167778 (CDR |d|) (CDR #0#)) (|x| NIL) (|i| 1 (QSADD1 |i|))) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (SPADLET SL - (CONS - (CONS (INTERNL (MAKESTRING "#") (STRINGIMAGE |i|)) |x|) - SL))))) - SL))))) +(defun |constructSubst| (d) + (let (sl (i 0)) + (setq sl (list (cons '$ d))) + (when (listp d) + (dolist (x (cdr d)) + (setq i (1+ i)) + (setq sl (cons (cons (internl "#" (stringimage i)) x) sl)))) + sl)) ;filterModemapsFromPackages(mms, names, op) == ; -- mms is a list of modemaps @@ -3227,55 +3536,69 @@ the types A and B themselves are not sorted by preference. ; [good,bad] (DEFUN |filterModemapsFromPackages| (|mms| |names| |op|) - (PROG (|mpolys| |mpacks| |type| |name| |found| |good| |bad|) - (RETURN - (SEQ - (PROGN - (SPADLET |good| NIL) - (SPADLET |bad| NIL) - (SPADLET |mpolys| - (QUOTE ("Polynomial" - "MultivariatePolynomial" - "DistributedMultivariatePolynomial" - "HomogeneousDistributedMultivariatePolynomial"))) - (SPADLET |mpacks| (QUOTE ("MFactorize" "MRationalFactorize"))) - (DO ((#0=#:G167795 |mms| (CDR #0#)) (|mm| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((|isFreeFunctionFromMm| |mm|) (SPADLET |bad| (CONS |mm| |bad|))) - ((QUOTE T) - (SPADLET |type| (|getDomainFromMm| |mm|)) - (COND - ((NULL |type|) (SPADLET |bad| (CONS |mm| |bad|))) - ((QUOTE T) - (COND ((PAIRP |type|) (SPADLET |type| (CAR |type|)))) - (COND - ((BOOT-EQUAL - (GETDATABASE |type| (QUOTE CONSTRUCTORKIND)) - (QUOTE |category|)) - (SPADLET |bad| (CONS |mm| |bad|))) - ((QUOTE T) - (SPADLET |name| (|object2String| |type|)) - (SPADLET |found| NIL) - (DO ((#1=#:G167805 |names| (CDR #1#)) (|n| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |n| (CAR #1#)) NIL) - (NULL (NULL |found|))) - NIL) - (SEQ - (EXIT - (COND - ((STRPOS |n| |name| 0 NIL) (SPADLET |found| (QUOTE T))) - ((AND (BOOT-EQUAL |op| (QUOTE |factor|)) - (|member| |n| |mpolys|) - (|member| |name| |mpacks|)) - (SPADLET |found| (QUOTE T))))))) - (COND - (|found| (SPADLET |good| (CONS |mm| |good|))) - ((QUOTE T) (SPADLET |bad| (CONS |mm| |bad|))))))))))))) - (CONS |good| (CONS |bad| NIL))))))) + (PROG (|mpolys| |mpacks| |type| |name| |found| |good| |bad|) + (RETURN + (SEQ (PROGN + (setq |good| NIL) + (setq |bad| NIL) + (setq |mpolys| + '("Polynomial" "MultivariatePolynomial" + "DistributedMultivariatePolynomial" + "HomogeneousDistributedMultivariatePolynomial")) + (setq |mpacks| '("MFactorize" "MRationalFactorize")) + (DO ((G167795 |mms| (CDR G167795)) (|mm| NIL)) + ((OR (ATOM G167795) + (PROGN (SETQ |mm| (CAR G167795)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|isFreeFunctionFromMm| |mm|) + (setq |bad| (CONS |mm| |bad|))) + (t + (setq |type| (|getDomainFromMm| |mm|)) + (COND + ((NULL |type|) + (setq |bad| (CONS |mm| |bad|))) + (t + (COND + ((PAIRP |type|) + (setq |type| (CAR |type|)))) + (COND + ((BOOT-EQUAL + (GETDATABASE |type| + 'CONSTRUCTORKIND) + '|category|) + (setq |bad| (CONS |mm| |bad|))) + (t + (setq |name| + (|object2String| |type|)) + (setq |found| NIL) + (DO + ((G167805 |names| + (CDR G167805)) + (|n| NIL)) + ((OR (ATOM G167805) + (PROGN + (SETQ |n| (CAR G167805)) + NIL) + (NULL (NULL |found|))) + NIL) + (SEQ + (EXIT + (COND + ((STRPOS |n| |name| 0 NIL) + (setq |found| t)) + ((AND + (BOOT-EQUAL |op| '|factor|) + (|member| |n| |mpolys|) + (|member| |name| |mpacks|)) + (setq |found| t)))))) + (COND + (|found| + (setq |good| + (CONS |mm| |good|))) + (t + (setq |bad| (CONS |mm| |bad|))))))))))))) + (CONS |good| (CONS |bad| NIL))))))) ;isTowerWithSubdomain(towerType,elem) == ; not PAIRP towerType => NIL @@ -3284,20 +3607,14 @@ the types A and B themselves are not sorted by preference. ; s := underDomainOf(towerType) ; isEqualOrSubDomain(s,elem) and constructM(first dt,[elem]) -(DEFUN |isTowerWithSubdomain| (|towerType| |elem|) - (PROG (|dt| |s|) - (RETURN - (COND - ((NULL (PAIRP |towerType|)) NIL) - ((QUOTE T) - (SPADLET |dt| (|deconstructT| |towerType|)) - (COND - ((NEQUAL 2 (|#| |dt|)) NIL) - ((QUOTE T) - (SPADLET |s| (|underDomainOf| |towerType|)) - (AND - (|isEqualOrSubDomain| |s| |elem|) - (|constructM| (CAR |dt|) (CONS |elem| NIL)))))))))) +(defun |isTowerWithSubdomain| (towerType elem) + (let (dt s) + (when (pairp towerType) + (setq dt (|deconstructT| towerType)) + (when (= (|#| dt) 2) + (setq s (|underDomainOf| towerType)) + (and (|isEqualOrSubDomain| s elem) + (|constructM| (car dt) (cons elem nil))))))) ;selectMmsGen(op,tar,args1,args2) == ; -- general modemap evaluation of op with argument types args1 @@ -3395,214 +3712,263 @@ the types A and B themselves are not sorted by preference. ; mmS (DEFUN |selectMmsGen,exact?| (|mmS| |tar| |args|) - (PROG (|sig| |mmC| |c| |t| |a| |ok| |ex| |inex|) - (RETURN - (SEQ - (SPADLET |ex| (SPADLET |inex| NIL)) - (DO ((#0=#:G167880 |mmS| (CDR #0#)) (|mm| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |mm| (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |sig| (CAR |mm|)) - (SPADLET |mmC| (CAADR |mm|)) - |mm|) - NIL)) - NIL) - (SEQ - (PROGN - (SPADLET |c| (CAR |sig|)) - (SPADLET |t| (CADR |sig|)) - (SPADLET |a| (CDDR |sig|)) - |sig|) - (SPADLET |ok| (QUOTE T)) - (DO ((#1=#:G167892 |a| (CDR #1#)) - (|pat| NIL) - (#2=#:G167893 |args| (CDR #2#)) - (|arg| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |pat| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |arg| (CAR #2#)) NIL) - (NULL |ok|)) - NIL) - (SEQ - (EXIT - (IF (NULL - (CONTAINED - (CONS (QUOTE |isDomain|) (CONS |pat| (CONS |arg| NIL))) - |mmC|)) - (EXIT (SPADLET |ok| NIL)))))) - (IF |ok| (EXIT (SPADLET |ex| (CONS |mm| |ex|)))) - (EXIT (SPADLET |inex| (CONS |mm| |inex|))))) - (EXIT (CONS |ex| (CONS |inex| NIL))))))) + (declare (ignore |tar|)) + (PROG (|sig| |mmC| |c| |t| |a| |ok| |ex| |inex|) + (RETURN + (SEQ (setq |ex| (setq |inex| NIL)) + (DO ((G167880 |mmS| (CDR G167880)) (|mm| NIL)) + ((OR (ATOM G167880) + (PROGN (SETQ |mm| (CAR G167880)) NIL) + (PROGN + (PROGN + (setq |sig| (CAR |mm|)) + (setq |mmC| (CAADR |mm|)) + |mm|) + NIL)) + NIL) + (SEQ (PROGN + (setq |c| (CAR |sig|)) + (setq |t| (CADR |sig|)) + (setq |a| (CDDR |sig|)) + |sig|) + (setq |ok| t) + (DO ((G167892 |a| (CDR G167892)) (|pat| NIL) + (G167893 |args| (CDR G167893)) (|arg| NIL)) + ((OR (ATOM G167892) + (PROGN (SETQ |pat| (CAR G167892)) NIL) + (ATOM G167893) + (PROGN (SETQ |arg| (CAR G167893)) NIL) + (NULL |ok|)) + NIL) + (SEQ (EXIT (IF (NULL + (CONTAINED + (CONS '|isDomain| + (CONS |pat| (CONS |arg| NIL))) + |mmC|)) + (EXIT (setq |ok| NIL)))))) + (IF |ok| (EXIT (setq |ex| (CONS |mm| |ex|)))) + (EXIT (setq |inex| (CONS |mm| |inex|))))) + (EXIT (CONS |ex| (CONS |inex| NIL))))))) (DEFUN |selectMmsGen,matchMms| (|mmaps| |op| |tar| |args1| |args2|) - (PROG (|sig| |mmC| |res| |c| |t| |a| |mmS|) - (RETURN - (SEQ - (SPADLET |mmS| NIL) - (DO ((#0=#:G167949 |mmaps| (CDR #0#)) (#1=#:G167936 NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN (SPADLET |sig| (CAR #1#)) (SPADLET |mmC| (CADR #1#)) #1#) - NIL)) - NIL) - (SEQ - (SPADLET |$Subst| - (SEQ - (IF (AND |tar| (NULL (|isPartialMode| |tar|))) - (EXIT - (SEQ - (SPADLET |res| (CADR |sig|)) - (IF (|member| |res| (CDDR |sig|)) (EXIT NIL)) - (EXIT (CONS (CONS |res| |tar|) NIL))))) - (EXIT NIL))) - (PROGN - (SPADLET |c| (CAR |sig|)) - (SPADLET |t| (CADR |sig|)) - (SPADLET |a| (CDDR |sig|)) |sig|) - (IF |a| (|matchTypes| |a| |args1| |args2|) NIL) - (EXIT - (IF (NULL (EQ |$Subst| (QUOTE |failed|))) - (EXIT - (SPADLET |mmS| (NCONC (|evalMm| |op| |tar| |sig| |mmC|) |mmS|))))))) - (EXIT |mmS|))))) + (PROG (|sig| |mmC| |res| |c| |t| |a| |mmS|) + (declare (special |$Subst|)) + (RETURN + (SEQ (setq |mmS| NIL) + (DO ((G167949 |mmaps| (CDR G167949)) (G167936 NIL)) + ((OR (ATOM G167949) + (PROGN (SETQ G167936 (CAR G167949)) NIL) + (PROGN + (PROGN + (setq |sig| (CAR G167936)) + (setq |mmC| (CADR G167936)) + G167936) + NIL)) + NIL) + (SEQ (setq |$Subst| + (SEQ (IF (AND |tar| + (NULL (|isPartialMode| |tar|))) + (EXIT + (SEQ (setq |res| (CADR |sig|)) + (IF (|member| |res| (CDDR |sig|)) + (EXIT NIL)) + (EXIT + (CONS (CONS |res| |tar|) NIL))))) + (EXIT NIL))) + (PROGN + (setq |c| (CAR |sig|)) + (setq |t| (CADR |sig|)) + (setq |a| (CDDR |sig|)) + |sig|) + (IF |a| (|matchTypes| |a| |args1| |args2|) NIL) + (EXIT (IF (NULL (EQ |$Subst| '|failed|)) + (EXIT (setq |mmS| + (NCONC + (|evalMm| |op| |tar| |sig| + |mmC|) + |mmS|))))))) + (EXIT |mmS|))))) (DEFUN |selectMmsGen| (|op| |tar| |args1| |args2|) - (PROG (|$Subst| |$SymbolType| S |ISTMP#1| |ISTMP#2| |ISTMP#3| |elem| |a| - |args| |fa| |conNames| |haves| |havenots| |havesExact| - |havesInexact| |LETTMP#1| |havesNExact| |havesNInexact| |mmS|) - (DECLARE (SPECIAL |$Subst| |$SymbolType|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$Subst| NIL) - (SPADLET |$SymbolType| NIL) - (COND - ((NULL (SPADLET S (|getModemapsFromDatabase| |op| (QLENGTH |args1|)))) - NIL) - ((QUOTE T) - (COND - ((AND - (BOOT-EQUAL |op| (QUOTE |map|)) - (EQL 2 (|#| |args1|)) - (PROGN - (SPADLET |ISTMP#1| (CAR |args1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN (SPADLET |elem| (QCAR |ISTMP#3|)) (QUOTE T)))))))) - (SPADLET |a| (|isTowerWithSubdomain| (CADR |args1|) |elem|))) - (SPADLET |args1| (CONS (CAR |args1|) (CONS |a| NIL))))) - (SPADLET |conNames| NIL) - (COND - ((BOOT-EQUAL |op| (QUOTE |reshape|)) - (SPADLET |args| (APPEND (CDR |args1|) (CDR |args2|)))) - ((QUOTE T) (SPADLET |args| (APPEND |args1| |args2|)))) - (COND (|tar| (SPADLET |args| (CONS |tar| |args|)))) - (SEQ - (DO ((#0=#:G167986 (REMDUP |args|) (CDR #0#)) (|a| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |a| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - (|a| - (EXIT - (COND - ((ATOM |a|) NIL) - ((QUOTE T) - (SPADLET |fa| (QCAR |a|)) + (PROG (|$Subst| |$SymbolType| S |ISTMP#1| |ISTMP#2| |ISTMP#3| |elem| + |a| |args| |fa| |conNames| |haves| |havenots| |havesExact| + |havesInexact| |LETTMP#1| |havesNExact| |havesNInexact| + |mmS|) + (DECLARE (SPECIAL |$Subst| |$SymbolType| |$reportBottomUpFlag|)) + (RETURN + (SEQ (PROGN + (setq |$Subst| NIL) + (setq |$SymbolType| NIL) + (COND + ((NULL (setq S + (|getModemapsFromDatabase| |op| + (QLENGTH |args1|)))) + NIL) + (t (COND - ((|member| |fa| (QUOTE (|Record| |Union|))) NIL) - ((QUOTE T) - (SPADLET |conNames| - (|insert| (STRINGIMAGE |fa|) |conNames|)))))))))))) - (COND - (|conNames| - (SPADLET |LETTMP#1| (|filterModemapsFromPackages| S |conNames| |op|)) - (SPADLET |haves| (CAR |LETTMP#1|)) - (SPADLET |havenots| (CADR |LETTMP#1|)) |LETTMP#1|) - ((QUOTE T) (SPADLET |haves| NIL) (SPADLET |havenots| S))) - (SPADLET |mmS| NIL) - (COND - (|$reportBottomUpFlag| - (|sayMSG| - (CONS (QUOTE |%l|) - (|bright| "Modemaps from Associated Packages"))))) - (COND - (|haves| - (SPADLET |LETTMP#1| (|selectMmsGen,exact?| |haves| |tar| |args1|)) - (SPADLET |havesExact| (CAR |LETTMP#1|)) - (SPADLET |havesInexact| (CADR |LETTMP#1|)) - (COND - (|$reportBottomUpFlag| - (DO ((#1=#:G167996 (APPEND |havesExact| |havesInexact|) (CDR #1#)) - (|mm| NIL) - (|i| 1 (QSADD1 |i|))) - ((OR (ATOM #1#) (PROGN (SETQ |mm| (CAR #1#)) NIL)) NIL) - (SEQ (EXIT (|sayModemapWithNumber| |mm| |i|)))))) - (COND - (|havesExact| - (SPADLET |mmS| - (|selectMmsGen,matchMms| |havesExact| |op| |tar| |args1| |args2|)) - (COND - (|mmS| - (COND - (|$reportBottomUpFlag| - (|sayMSG| (MAKESTRING " found an exact match!")))) - (RETURN |mmS|)) - ((QUOTE T) NIL)))) - (SPADLET |mmS| - (|selectMmsGen,matchMms| |havesInexact| |op| |tar| - |args1| |args2|))) - (|$reportBottomUpFlag| - (|sayMSG| (MAKESTRING " no modemaps"))) ((QUOTE T) NIL)) - (COND (|mmS| (EXIT |mmS|))) - (COND - (|$reportBottomUpFlag| - (|sayMSG| - (CONS (QUOTE |%l|) (|bright| "Remaining General Modemaps"))))) - (COND - (|havenots| - (SPADLET |LETTMP#1| (|selectMmsGen,exact?| |havenots| |tar| |args1|)) - (SPADLET |havesNExact| (CAR |LETTMP#1|)) - (SPADLET |havesNInexact| (CADR |LETTMP#1|)) - (COND - (|$reportBottomUpFlag| - (DO ((#2=#:G168006 - (APPEND |havesNExact| |havesNInexact|) (CDR #2#)) - (|mm| NIL) - (|i| 1 (QSADD1 |i|))) - ((OR (ATOM #2#) (PROGN (SETQ |mm| (CAR #2#)) NIL)) NIL) - (SEQ (EXIT (|sayModemapWithNumber| |mm| |i|)))))) - (COND - (|havesNExact| - (SPADLET |mmS| - (|selectMmsGen,matchMms| |havesNExact| |op| |tar| - |args1| |args2|)) - (COND - (|mmS| - (COND - (|$reportBottomUpFlag| (|sayMSG| " found an exact match!"))) - (RETURN |mmS|)) - ((QUOTE T) NIL)))) - (SPADLET |mmS| - (|selectMmsGen,matchMms| |havesNInexact| |op| |tar| - |args1| |args2|))) - (|$reportBottomUpFlag| (|sayMSG| (MAKESTRING " no modemaps"))) - ((QUOTE T) NIL)) - (EXIT |mmS|))))))))) + ((AND (BOOT-EQUAL |op| '|map|) (EQL 2 (|#| |args1|)) + (PROGN + (setq |ISTMP#1| (CAR |args1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (setq |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (setq |elem| + (QCAR |ISTMP#3|)) + t))))))) + (setq |a| + (|isTowerWithSubdomain| (CADR |args1|) + |elem|))) + (setq |args1| + (CONS (CAR |args1|) (CONS |a| NIL))))) + (setq |conNames| NIL) + (COND + ((BOOT-EQUAL |op| '|reshape|) + (setq |args| + (APPEND (CDR |args1|) (CDR |args2|)))) + (t (setq |args| (APPEND |args1| |args2|)))) + (COND (|tar| (setq |args| (CONS |tar| |args|)))) + (SEQ (DO ((G167986 (REMDUP |args|) (CDR G167986)) + (|a| NIL)) + ((OR (ATOM G167986) + (PROGN (SETQ |a| (CAR G167986)) NIL)) + NIL) + (SEQ (EXIT (COND + (|a| + (EXIT + (COND + ((ATOM |a|) NIL) + (t (setq |fa| (QCAR |a|)) + (COND + ((|member| |fa| + '(|Record| |Union|)) + NIL) + (t + (setq |conNames| + (|insert| + (STRINGIMAGE |fa|) + |conNames|)))))))))))) + (COND + (|conNames| + (setq |LETTMP#1| + (|filterModemapsFromPackages| S + |conNames| |op|)) + (setq |haves| (CAR |LETTMP#1|)) + (setq |havenots| (CADR |LETTMP#1|)) + |LETTMP#1|) + (t (setq |haves| NIL) + (setq |havenots| S))) + (setq |mmS| NIL) + (COND + (|$reportBottomUpFlag| + (|sayMSG| + (CONS '|%l| + (|bright| + "Modemaps from Associated Packages"))))) + (COND + (|haves| (setq |LETTMP#1| + (|selectMmsGen,exact?| |haves| + |tar| |args1|)) + (setq |havesExact| (CAR |LETTMP#1|)) + (setq |havesInexact| + (CADR |LETTMP#1|)) + (COND + (|$reportBottomUpFlag| + (DO + ((G167996 + (APPEND |havesExact| + |havesInexact|) + (CDR G167996)) + (|mm| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G167996) + (PROGN + (SETQ |mm| (CAR G167996)) + NIL)) + NIL) + (SEQ + (EXIT + (|sayModemapWithNumber| |mm| + |i|)))))) + (COND + (|havesExact| + (setq |mmS| + (|selectMmsGen,matchMms| + |havesExact| |op| |tar| |args1| + |args2|)) + (COND + (|mmS| + (COND + (|$reportBottomUpFlag| + (|sayMSG| + " found an exact match!"))) + (RETURN |mmS|)) + (t NIL)))) + (setq |mmS| + (|selectMmsGen,matchMms| + |havesInexact| |op| |tar| + |args1| |args2|))) + (|$reportBottomUpFlag| + (|sayMSG| " no modemaps")) + (t NIL)) + (COND (|mmS| (EXIT |mmS|))) + (COND + (|$reportBottomUpFlag| + (|sayMSG| + (CONS '|%l| + (|bright| + "Remaining General Modemaps"))))) + (COND + (|havenots| + (setq |LETTMP#1| + (|selectMmsGen,exact?| |havenots| + |tar| |args1|)) + (setq |havesNExact| (CAR |LETTMP#1|)) + (setq |havesNInexact| (CADR |LETTMP#1|)) + (COND + (|$reportBottomUpFlag| + (DO ((G168006 + (APPEND |havesNExact| + |havesNInexact|) + (CDR G168006)) + (|mm| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G168006) + (PROGN + (SETQ |mm| (CAR G168006)) + NIL)) + NIL) + (SEQ + (EXIT + (|sayModemapWithNumber| |mm| |i|)))))) + (COND + (|havesNExact| + (setq |mmS| + (|selectMmsGen,matchMms| + |havesNExact| |op| |tar| + |args1| |args2|)) + (COND + (|mmS| + (COND + (|$reportBottomUpFlag| + (|sayMSG| + " found an exact match!"))) + (RETURN |mmS|)) + (t NIL)))) + (setq |mmS| + (|selectMmsGen,matchMms| + |havesNInexact| |op| |tar| |args1| + |args2|))) + (|$reportBottomUpFlag| + (|sayMSG| " no modemaps")) + (t NIL)) + (EXIT |mmS|))))))))) ;matchTypes(pm,args1,args2) == ; -- pm is a list of pattern variables, args1 a list of argument types, @@ -3626,56 +3992,56 @@ the types A and B themselves are not sorted by preference. ; if EQCAR(t1,'Symbol) and t2 then $SymbolType:= CONS(CONS(v,t2),$SymbolType) (DEFUN |matchTypes| (|pm| |args1| |args2|) - (PROG (|p| |t3| |q| |t| |t1| |t0|) - (RETURN - (SEQ - (DO ((#0=#:G168059 |pm| (CDR #0#)) - (|v| NIL) - (#1=#:G168060 |args1| (CDR #1#)) - (|t1| NIL) - (#2=#:G168061 |args2| (CDR #2#)) - (|t2| NIL) - (#3=#:G168062 NIL (BOOT-EQUAL |$Subst| (QUOTE |failed|)))) - ((OR (ATOM #0#) - (PROGN (SETQ |v| (CAR #0#)) NIL) - (ATOM #1#) - (PROGN (SETQ |t1| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |t2| (CAR #2#)) NIL) - #3#) - NIL) - (SEQ - (EXIT - (COND - ((SPADLET |p| (ASSQ |v| |$Subst|)) - (SPADLET |t| (CDR |p|)) - (COND - ((BOOT-EQUAL |t| |t1|) - (AND - |$Coerce| - (EQCAR |t1| (QUOTE |Symbol|)) - (SPADLET |q| (ASSQ |v| |$SymbolType|)) - |t2| - (SPADLET |t3| (|resolveTT| (CDR |q|) |t2|)) - (RPLACD |q| |t3|))) - (|$Coerce| - (COND - ((AND - (EQCAR |t| (QUOTE |Symbol|)) - (SPADLET |q| (ASSQ |v| |$SymbolType|))) - (SPADLET |t| (CDR |q|)))) - (COND - ((AND (EQCAR |t1| (QUOTE |Symbol|)) |t2|) (SPADLET |t1| |t2|))) - (COND - ((SPADLET |t0| (|resolveTT| |t| |t1|)) (RPLACD |p| |t0|)) - ((QUOTE T) (SPADLET |$Subst| (QUOTE |failed|))))) - ((QUOTE T) (SPADLET |$Subst| (QUOTE |failed|))))) - ((QUOTE T) - (SPADLET |$Subst| (CONS (CONS |v| |t1|) |$Subst|)) - (COND - ((AND (EQCAR |t1| (QUOTE |Symbol|)) |t2|) - (SPADLET |$SymbolType| (CONS (CONS |v| |t2|) |$SymbolType|))) - ((QUOTE T) NIL))))))))))) + (PROG (|p| |t3| |q| |t| |t0|) + (declare (special |$SymbolType| |$Subst| |$Coerce|)) + (RETURN + (SEQ (DO ((G168059 |pm| (CDR G168059)) (|v| NIL) + (G168060 |args1| (CDR G168060)) (|t1| NIL) + (G168061 |args2| (CDR G168061)) (|t2| NIL) + (G168062 NIL (BOOT-EQUAL |$Subst| '|failed|))) + ((OR (ATOM G168059) + (PROGN (SETQ |v| (CAR G168059)) NIL) + (ATOM G168060) + (PROGN (SETQ |t1| (CAR G168060)) NIL) + (ATOM G168061) + (PROGN (SETQ |t2| (CAR G168061)) NIL) G168062) + NIL) + (SEQ (EXIT (COND + ((setq |p| (ASSQ |v| |$Subst|)) + (setq |t| (CDR |p|)) + (COND + ((BOOT-EQUAL |t| |t1|) + (AND |$Coerce| (EQCAR |t1| '|Symbol|) + (setq |q| + (ASSQ |v| |$SymbolType|)) + |t2| + (setq |t3| + (|resolveTT| (CDR |q|) |t2|)) + (RPLACD |q| |t3|))) + (|$Coerce| + (COND + ((AND (EQCAR |t| '|Symbol|) + (setq |q| + (ASSQ |v| |$SymbolType|))) + (setq |t| (CDR |q|)))) + (COND + ((AND (EQCAR |t1| '|Symbol|) |t2|) + (setq |t1| |t2|))) + (COND + ((setq |t0| + (|resolveTT| |t| |t1|)) + (RPLACD |p| |t0|)) + (t (setq |$Subst| '|failed|)))) + (t (setq |$Subst| '|failed|)))) + (t + (setq |$Subst| + (CONS (CONS |v| |t1|) |$Subst|)) + (COND + ((AND (EQCAR |t1| '|Symbol|) |t2|) + (setq |$SymbolType| + (CONS (CONS |v| |t2|) + |$SymbolType|))) + (t NIL))))))))))) ;evalMm(op,tar,sig,mmC) == ; -- evaluates a modemap with signature sig and condition mmC @@ -3689,75 +4055,99 @@ the types A and B themselves are not sorted by preference. ; SL := fixUpTypeArgs SL ; sig:= [subCopy(deepSubCopy(x,SL),$Subst) for x in sig] ; not containsVars sig => -; isFreeFunctionFromMmCond mmC and -; (m := evalMmFreeFunction(op,tar,sig,mmC)) => +; isFreeFunctionFromMmCond mmC and (m := evalMmFreeFunction(op,tar,sig,mmC)) => ; mS:= nconc(m,mS) ; "or"/[^isValidType(arg) for arg in sig] => nil ; [dc,t,:args]:= sig ; $Coerce or null tar or tar=t => -; mS:= nconc(findFunctionInDomain(op,dc,t,args,args,NIL,'T),mS) +; mS:= nconc(findFunctionInDomain(op,dc,t,args,args,NIL,t),mS) ; mS (DEFUN |evalMm| (|op| |tar| |sig| |mmC|) - (PROG (SL |m| |dc| |t| |args| |mS|) - (RETURN - (SEQ - (PROGN - (SPADLET |mS| NIL) - (DO ((#0=#:G168106 (|evalMmStack| |mmC|) (CDR #0#)) (|st| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |st| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET SL (|evalMmCond| |op| |sig| |st|)) - (COND - ((NULL (EQ SL (QUOTE |failed|))) - (PROGN - (SPADLET SL (|fixUpTypeArgs| SL)) - (SPADLET |sig| - (PROG (#1=#:G168116) - (SPADLET #1# NIL) - (RETURN - (DO ((#2=#:G168121 |sig| (CDR #2#)) (|x| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) - (NREVERSE0 #1#)) - (SEQ - (EXIT - (SETQ #1# - (CONS - (|subCopy| (|deepSubCopy| |x| SL) |$Subst|) - #1#)))))))) - (COND - ((NULL (|containsVars| |sig|)) - (COND - ((AND - (|isFreeFunctionFromMmCond| |mmC|) - (SPADLET |m| (|evalMmFreeFunction| |op| |tar| |sig| |mmC|))) - (SPADLET |mS| (NCONC |m| |mS|))) - ((PROG (#3=#:G168127) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G168133 NIL #3#) - (#5=#:G168134 |sig| (CDR #5#)) - (|arg| NIL)) - ((OR #4# (ATOM #5#) (PROGN (SETQ |arg| (CAR #5#)) NIL)) - #3#) - (SEQ - (EXIT - (SETQ #3# (OR #3# (NULL (|isValidType| |arg|))))))))) - NIL) - ((QUOTE T) - (SPADLET |dc| (CAR |sig|)) - (SPADLET |t| (CADR |sig|)) - (SPADLET |args| (CDDR |sig|)) - (COND - ((OR |$Coerce| (NULL |tar|) (BOOT-EQUAL |tar| |t|)) - (SPADLET |mS| - (NCONC - (|findFunctionInDomain| |op| |dc| |t| |args| - |args| NIL (QUOTE T)) - |mS|))))))))))))))) - |mS|))))) + (PROG (SL |m| |dc| |t| |args| |mS|) + (declare (special |$Coerce| |$Subst|)) + (RETURN + (SEQ (PROGN + (setq |mS| NIL) + (DO ((G168106 (|evalMmStack| |mmC|) (CDR G168106)) + (|st| NIL)) + ((OR (ATOM G168106) + (PROGN (SETQ |st| (CAR G168106)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (setq SL (|evalMmCond| |op| |sig| |st|)) + (COND + ((NULL (EQ SL '|failed|)) + (PROGN + (setq SL (|fixUpTypeArgs| SL)) + (setq |sig| + (PROG (G168116) + (setq G168116 NIL) + (RETURN + (DO + ((G168121 |sig| + (CDR G168121)) + (|x| NIL)) + ((OR (ATOM G168121) + (PROGN + (SETQ |x| + (CAR G168121)) + NIL)) + (NREVERSE0 G168116)) + (SEQ + (EXIT + (SETQ G168116 + (CONS + (|subCopy| + (|deepSubCopy| |x| + SL) + |$Subst|) + G168116)))))))) + (COND + ((NULL (|containsVars| |sig|)) + (COND + ((AND + (|isFreeFunctionFromMmCond| + |mmC|) + (setq |m| + (|evalMmFreeFunction| |op| + |tar| |sig| |mmC|))) + (setq |mS| (NCONC |m| |mS|))) + ((PROG (G168127) + (setq G168127 NIL) + (RETURN + (DO + ((G168133 NIL G168127) + (G168134 |sig| + (CDR G168134)) + (|arg| NIL)) + ((OR G168133 + (ATOM G168134) + (PROGN + (SETQ |arg| + (CAR G168134)) + NIL)) + G168127) + (SEQ + (EXIT + (SETQ G168127 + (OR G168127 + (NULL + (|isValidType| |arg|))))))))) + NIL) + (t (setq |dc| (CAR |sig|)) + (setq |t| (CADR |sig|)) + (setq |args| (CDDR |sig|)) + (COND + ((OR |$Coerce| (NULL |tar|) + (BOOT-EQUAL |tar| |t|)) + (setq |mS| + (NCONC + (|findFunctionInDomain| + |op| |dc| |t| |args| + |args| NIL t) + |mS|))))))))))))))) + |mS|))))) ;evalMmFreeFunction(op,tar,sig,mmC) == ; [dc,t,:args]:= sig @@ -3767,26 +4157,30 @@ the types A and B themselves are not sorted by preference. ; [[[["__FreeFunction__",:dc],t,:args], [t, :args], nilArgs]] ; nil +; NO UNIT TEST (DEFUN |evalMmFreeFunction| (|op| |tar| |sig| |mmC|) - (PROG (|dc| |t| |args| |nilArgs|) - (RETURN - (SEQ - (PROGN - (SPADLET |dc| (CAR |sig|)) - (SPADLET |t| (CADR |sig|)) - (SPADLET |args| (CDDR |sig|)) - (COND - ((OR |$Coerce| (NULL |tar|) (BOOT-EQUAL |tar| |t|)) - (SPADLET |nilArgs| NIL) - (DO ((#0=#:G168165 |args| (CDR #0#)) (|a| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |a| (CAR #0#)) NIL)) NIL) - (SEQ (EXIT (SPADLET |nilArgs| (CONS NIL |nilArgs|))))) - (CONS - (CONS - (CONS (CONS (QUOTE |_FreeFunction_|) |dc|) (CONS |t| |args|)) - (CONS (CONS |t| |args|) (CONS |nilArgs| NIL))) - NIL)) - ((QUOTE T) NIL))))))) + (declare (ignore |op| |mmC|)) + (PROG (|dc| |t| |args| |nilArgs|) + (declare (special |$Coerce|)) + (RETURN + (SEQ (PROGN + (setq |dc| (CAR |sig|)) + (setq |t| (CADR |sig|)) + (setq |args| (CDDR |sig|)) + (COND + ((OR |$Coerce| (NULL |tar|) (BOOT-EQUAL |tar| |t|)) + (setq |nilArgs| NIL) + (DO ((G168165 |args| (CDR G168165)) (|a| NIL)) + ((OR (ATOM G168165) + (PROGN (SETQ |a| (CAR G168165)) NIL)) + NIL) + (SEQ (EXIT (setq |nilArgs| (CONS NIL |nilArgs|))))) + (CONS (CONS (CONS (CONS '|_FreeFunction_| |dc|) + (CONS |t| |args|)) + (CONS (CONS |t| |args|) + (CONS |nilArgs| NIL))) + NIL)) + (t NIL))))))) ;evalMmStack(mmC) == ; -- translates the modemap condition mmC into a list of stacks @@ -3804,95 +4198,100 @@ the types A and B themselves are not sorted by preference. ; [[mmC]] (DEFUN |evalMmStack| (|mmC|) - (PROG (|a| |mmD| |pvar| |cat| |args| |ISTMP#1| |pat| |ISTMP#2| |x|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |mmC|) - (EQ (QCAR |mmC|) (QUOTE AND)) - (PROGN (SPADLET |a| (QCDR |mmC|)) (QUOTE T))) - (CONS - (PROG (#0=#:G168213) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G168218 |a| (CDR #1#)) (|cond| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |cond| (CAR #1#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (NCONC #0# (|evalMmStackInner| |cond|)))))))) - NIL)) - ((AND (PAIRP |mmC|) - (EQ (QCAR |mmC|) (QUOTE OR)) - (PROGN (SPADLET |args| (QCDR |mmC|)) (QUOTE T))) - (PROG (#2=#:G168224) - (SPADLET #2# NIL) - (RETURN - (DO ((#3=#:G168229 |args| (CDR #3#)) (|a| NIL)) - ((OR (ATOM #3#) (PROGN (SETQ |a| (CAR #3#)) NIL)) #2#) - (SEQ (EXIT (SETQ #2# (APPEND #2# (|evalMmStack| |a|))))))))) - ((AND (PAIRP |mmC|) - (EQ (QCAR |mmC|) (QUOTE |partial|)) - (PROGN (SPADLET |mmD| (QCDR |mmC|)) (QUOTE T))) - (|evalMmStack| |mmD|)) - ((AND - (PAIRP |mmC|) - (EQ (QCAR |mmC|) (QUOTE |ofCategory|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |mmC|)) - (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) - (PROGN (SPADLET |cat| (QCAR |ISTMP#2|)) (QUOTE T)))))) - (PAIRP |cat|) - (EQ (QCAR |cat|) (QUOTE |Join|)) - (PROGN (SPADLET |args| (QCDR |cat|)) (QUOTE T))) - (|evalMmStack| - (CONS - (QUOTE AND) - (PROG (#4=#:G168239) - (SPADLET #4# NIL) - (RETURN - (DO ((#5=#:G168244 |args| (CDR #5#)) (|c| NIL)) - ((OR (ATOM #5#) (PROGN (SETQ |c| (CAR #5#)) NIL)) - (NREVERSE0 #4#)) - (SEQ - (EXIT - (SETQ #4# - (CONS - (CONS (QUOTE |ofCategory|) (CONS |pvar| (CONS |c| NIL))) - #4#)))))))))) - ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) (QUOTE |ofType|))) (CONS NIL NIL)) - ((AND (PAIRP |mmC|) - (EQ (QCAR |mmC|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |mmC|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |pat| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |x| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (COND - ((MEMQ |x| (QUOTE (ATTRIBUTE SIGNATURE))) - (CONS - (CONS - (CONS - (QUOTE |ofCategory|) - (CONS |pat| - (CONS - (CONS (QUOTE CATEGORY) (CONS (QUOTE |unknown|) (CONS |x| NIL))) - NIL))) - NIL) - NIL)) - ((QUOTE T) - (CONS (CONS (QUOTE |ofCategory|) (CONS |pat| (CONS |x| NIL))) NIL)))) - ((QUOTE T) (CONS (CONS |mmC| NIL) NIL))))))) + (PROG (|a| |mmD| |pvar| |cat| |args| |ISTMP#1| |pat| |ISTMP#2| |x|) + (RETURN + (SEQ (COND + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) 'AND) + (PROGN (setq |a| (QCDR |mmC|)) t)) + (CONS (PROG (G168213) + (setq G168213 NIL) + (RETURN + (DO ((G168218 |a| (CDR G168218)) + (|cond| NIL)) + ((OR (ATOM G168218) + (PROGN + (SETQ |cond| (CAR G168218)) + NIL)) + G168213) + (SEQ (EXIT (SETQ G168213 + (NCONC G168213 + (|evalMmStackInner| |cond|)))))))) + NIL)) + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) 'OR) + (PROGN (setq |args| (QCDR |mmC|)) t)) + (PROG (G168224) + (setq G168224 NIL) + (RETURN + (DO ((G168229 |args| (CDR G168229)) (|a| NIL)) + ((OR (ATOM G168229) + (PROGN (SETQ |a| (CAR G168229)) NIL)) + G168224) + (SEQ (EXIT (SETQ G168224 + (APPEND G168224 + (|evalMmStack| |a|))))))))) + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) '|partial|) + (PROGN (setq |mmD| (QCDR |mmC|)) t)) + (|evalMmStack| |mmD|)) + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) '|ofCategory|) + (PROGN + (setq |ISTMP#1| (QCDR |mmC|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |pvar| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |cat| (QCAR |ISTMP#2|)) + t))))) + (PAIRP |cat|) (EQ (QCAR |cat|) '|Join|) + (PROGN (setq |args| (QCDR |cat|)) t)) + (|evalMmStack| + (CONS 'AND + (PROG (G168239) + (setq G168239 NIL) + (RETURN + (DO ((G168244 |args| (CDR G168244)) + (|c| NIL)) + ((OR (ATOM G168244) + (PROGN + (SETQ |c| (CAR G168244)) + NIL)) + (NREVERSE0 G168239)) + (SEQ (EXIT + (SETQ G168239 + (CONS + (CONS '|ofCategory| + (CONS |pvar| (CONS |c| NIL))) + G168239)))))))))) + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) '|ofType|)) + (CONS NIL NIL)) + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) '|has|) + (PROGN + (setq |ISTMP#1| (QCDR |mmC|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |pat| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |x| (QCAR |ISTMP#2|)) + t)))))) + (COND + ((MEMQ |x| '(ATTRIBUTE SIGNATURE)) + (CONS (CONS (CONS '|ofCategory| + (CONS |pat| + (CONS + (CONS 'CATEGORY + (CONS '|unknown| (CONS |x| NIL))) + NIL))) + NIL) + NIL)) + (t + (CONS (CONS '|ofCategory| (CONS |pat| (CONS |x| NIL))) + NIL)))) + (t (CONS (CONS |mmC| NIL) NIL))))))) ;evalMmStackInner(mmC) == ; mmC is ['OR,:args] => @@ -3910,90 +4309,83 @@ the types A and B themselves are not sorted by preference. ; [mmC] (DEFUN |evalMmStackInner| (|mmC|) - (PROG (|mmD| |pvar| |cat| |args| |ISTMP#1| |pat| |ISTMP#2| |x|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |mmC|) - (EQ (QCAR |mmC|) (QUOTE OR)) - (PROGN (SPADLET |args| (QCDR |mmC|)) (QUOTE T))) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "evalMmStackInner" - (CONS "OR condition nested inside an AND" NIL)))) - ((AND (PAIRP |mmC|) - (EQ (QCAR |mmC|) (QUOTE |partial|)) - (PROGN (SPADLET |mmD| (QCDR |mmC|)) (QUOTE T))) - (|evalMmStackInner| |mmD|)) - ((AND (PAIRP |mmC|) - (EQ (QCAR |mmC|) (QUOTE |ofCategory|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |mmC|)) - (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) - (PROGN (SPADLET |cat| (QCAR |ISTMP#2|)) (QUOTE T)))))) - (PAIRP |cat|) - (EQ (QCAR |cat|) (QUOTE |Join|)) - (PROGN (SPADLET |args| (QCDR |cat|)) (QUOTE T))) - (PROG (#0=#:G168306) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G168311 |args| (CDR #1#)) (|c| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |c| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# - (CONS - (CONS (QUOTE |ofCategory|) (CONS |pvar| (CONS |c| NIL))) - #0#)))))))) - ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) (QUOTE |ofType|))) NIL) - ((AND (PAIRP |mmC|) - (EQ (QCDR |mmC|) NIL) - (EQ (QCAR |mmC|) (QUOTE |isAsConstant|))) - NIL) - ((AND (PAIRP |mmC|) - (EQ (QCAR |mmC|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |mmC|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |pat| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |x| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (COND - ((MEMQ |x| (QUOTE (ATTRIBUTE SIGNATURE))) - (CONS - (CONS - (QUOTE |ofCategory|) - (CONS |pat| - (CONS - (CONS (QUOTE CATEGORY) (CONS (QUOTE |unknown|) (CONS |x| NIL))) - NIL))) - NIL)) - ((QUOTE T) - (CONS (CONS (QUOTE |ofCategory|) (CONS |pat| (CONS |x| NIL))) NIL)))) - ((QUOTE T) (CONS |mmC| NIL))))))) + (PROG (|mmD| |pvar| |cat| |args| |ISTMP#1| |pat| |ISTMP#2| |x|) + (RETURN + (SEQ (COND + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) 'OR) + (PROGN (setq |args| (QCDR |mmC|)) t)) + (|keyedSystemError| 'S2GE0016 + (CONS "evalMmStackInner" + (CONS "OR condition nested inside an AND" + NIL)))) + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) '|partial|) + (PROGN (setq |mmD| (QCDR |mmC|)) t)) + (|evalMmStackInner| |mmD|)) + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) '|ofCategory|) + (PROGN + (setq |ISTMP#1| (QCDR |mmC|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |pvar| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |cat| (QCAR |ISTMP#2|)) + t))))) + (PAIRP |cat|) (EQ (QCAR |cat|) '|Join|) + (PROGN (setq |args| (QCDR |cat|)) t)) + (PROG (G168306) + (setq G168306 NIL) + (RETURN + (DO ((G168311 |args| (CDR G168311)) (|c| NIL)) + ((OR (ATOM G168311) + (PROGN (SETQ |c| (CAR G168311)) NIL)) + (NREVERSE0 G168306)) + (SEQ (EXIT (SETQ G168306 + (CONS + (CONS '|ofCategory| + (CONS |pvar| (CONS |c| NIL))) + G168306)))))))) + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) '|ofType|)) NIL) + ((AND (PAIRP |mmC|) (EQ (QCDR |mmC|) NIL) + (EQ (QCAR |mmC|) '|isAsConstant|)) + NIL) + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) '|has|) + (PROGN + (setq |ISTMP#1| (QCDR |mmC|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |pat| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |x| (QCAR |ISTMP#2|)) + t)))))) + (COND + ((MEMQ |x| '(ATTRIBUTE SIGNATURE)) + (CONS (CONS '|ofCategory| + (CONS |pat| + (CONS + (CONS 'CATEGORY + (CONS '|unknown| (CONS |x| NIL))) + NIL))) + NIL)) + (t + (CONS (CONS '|ofCategory| (CONS |pat| (CONS |x| NIL))) + NIL)))) + (t (CONS |mmC| NIL))))))) ;evalMmCond(op,sig,st) == ; $insideEvalMmCondIfTrue : local := true ; evalMmCond0(op,sig,st) -(DEFUN |evalMmCond| (|op| |sig| |st|) - (PROG (|$insideEvalMmCondIfTrue|) - (DECLARE (SPECIAL |$insideEvalMmCondIfTrue|)) - (RETURN - (PROGN - (SPADLET |$insideEvalMmCondIfTrue| (QUOTE T)) - (|evalMmCond0| |op| |sig| |st|))))) +(defun |evalMmCond| (op sig st) + (let (|$insideEvalMmCondIfTrue|) + (declare (special |$insideEvalMmCondIfTrue|)) + (setq |$insideEvalMmCondIfTrue| t) + (|evalMmCond0| op sig st))) ;evalMmCond0(op,sig,st) == ; -- evaluates the nonempty list of modemap conditions st @@ -4014,68 +4406,86 @@ the types A and B themselves are not sorted by preference. ; -- goes the opposite direction ; (t1 = $AnonymousFunction and t is ['Mapping, :.]) => t ; CAR p = CADR sig and not member(CAR p, CDDR sig) => -; canCoerceFrom(t,t1) => 'T +; canCoerceFrom(t,t1) => t ; NIL -; canCoerceFrom(t1,t) => 'T +; canCoerceFrom(t1,t) => t ; isSubDomain(t,t1) => RPLACD(p,t1) ; EQCAR(t1,'Symbol) and canCoerceFrom(getSymbolType CAR p,t) ; ( SL and p1 and not b and 'failed ) or evalMmCat(op,sig,st,SL) (DEFUN |evalMmCond0| (|op| |sig| |st|) - (PROG (SL |p1| |t| |t1| |b|) - (RETURN - (SEQ - (PROGN - (SPADLET SL (|evalMmDom| |st|)) - (COND - ((BOOT-EQUAL SL (QUOTE |failed|)) (QUOTE |failed|)) - ((QUOTE T) - (DO ((#0=#:G168355 SL (CDR #0#)) - (|p| NIL) - (#1=#:G168356 NIL (AND |p1| (NULL |b|)))) - ((OR (ATOM #0#) (PROGN (SETQ |p| (CAR #0#)) NIL) #1#) NIL) - (SEQ - (EXIT - (SPADLET |b| - (PROGN - (SPADLET |p1| (ASSQ (CAR |p|) |$Subst|)) - (AND |p1| - (PROGN - (SPADLET |t1| (CDR |p1|)) - (SPADLET |t| (CDR |p|)) - (OR - (BOOT-EQUAL |t| |t1|) - (COND - ((|containsVars| |t|) - (COND - ((AND |$Coerce| (EQCAR |t1| (QUOTE |Symbol|))) - (SPADLET |t1| (|getSymbolType| (CAR |p|))))) - (|resolveTM1| |t1| |t|)) - ((QUOTE T) - (AND - |$Coerce| - (COND - ((AND - (BOOT-EQUAL |t1| |$AnonymousFunction|) - (PAIRP |t|) - (EQ (QCAR |t|) (QUOTE |Mapping|))) - |t|) - ((AND - (BOOT-EQUAL (CAR |p|) (CADR |sig|)) - (NULL (|member| (CAR |p|) (CDDR |sig|)))) - (COND - ((|canCoerceFrom| |t| |t1|) (QUOTE T)) - ((QUOTE T) NIL))) - ((|canCoerceFrom| |t1| |t|) (QUOTE T)) - ((|isSubDomain| |t| |t1|) (RPLACD |p| |t1|)) - ((QUOTE T) - (AND - (EQCAR |t1| (QUOTE |Symbol|)) - (|canCoerceFrom| - (|getSymbolType| (CAR |p|)) |t|))))))))))))))) - (OR - (AND SL |p1| (NULL |b|) (QUOTE |failed|)) - (|evalMmCat| |op| |sig| |st| SL))))))))) + (PROG (SL |p1| |t| |t1| |b|) + (declare (special |$AnonymousFunction| |$Coerce| |$Subst|)) + (RETURN + (SEQ (PROGN + (setq SL (|evalMmDom| |st|)) + (COND + ((BOOT-EQUAL SL '|failed|) '|failed|) + (t + (DO ((G168355 SL (CDR G168355)) (|p| NIL) + (G168356 NIL (AND |p1| (NULL |b|)))) + ((OR (ATOM G168355) + (PROGN (SETQ |p| (CAR G168355)) NIL) + G168356) + NIL) + (SEQ (EXIT (setq |b| + (PROGN + (setq |p1| + (ASSQ (CAR |p|) |$Subst|)) + (AND |p1| + (PROGN + (setq |t1| (CDR |p1|)) + (setq |t| (CDR |p|)) + (OR (BOOT-EQUAL |t| |t1|) + (COND + ((|containsVars| |t|) + (COND + ((AND |$Coerce| + (EQCAR |t1| + '|Symbol|)) + (setq |t1| + (|getSymbolType| + (CAR |p|))))) + (|resolveTM1| |t1| |t|)) + (t + (AND |$Coerce| + (COND + ((AND + (BOOT-EQUAL |t1| + |$AnonymousFunction|) + (PAIRP |t|) + (EQ (QCAR |t|) + '|Mapping|)) + |t|) + ((AND + (BOOT-EQUAL + (CAR |p|) + (CADR |sig|)) + (NULL + (|member| + (CAR |p|) + (CDDR |sig|)))) + (COND + ((|canCoerceFrom| + |t| |t1|) + t) + (t NIL))) + ((|canCoerceFrom| + |t1| |t|) + t) + ((|isSubDomain| |t| + |t1|) + (RPLACD |p| |t1|)) + (t + (AND + (EQCAR |t1| + '|Symbol|) + (|canCoerceFrom| + (|getSymbolType| + (CAR |p|)) + |t|))))))))))))))) + (OR (AND SL |p1| (NULL |b|) '|failed|) + (|evalMmCat| |op| |sig| |st| SL))))))))) ;fixUpTypeArgs SL == ; for (p := [v, :t2]) in SL repeat @@ -4085,34 +4495,38 @@ the types A and B themselves are not sorted by preference. ; SL (DEFUN |fixUpTypeArgs| (SL) - (PROG (|v| |t2| |t1|) - (RETURN - (SEQ - (PROGN - (DO ((#0=#:G168383 SL (CDR #0#)) (|p| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |p| (CAR #0#)) NIL) - (PROGN - (PROGN (SPADLET |v| (CAR |p|)) (SPADLET |t2| (CDR |p|)) |p|) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |t1| (LASSOC |v| |$Subst|)) - (COND - ((NULL |t1|) (RPLACD |p| (|replaceSharpCalls| |t2|))) - ((QUOTE T) (RPLACD |p| (|coerceTypeArgs| |t1| |t2| SL)))))))) - SL))))) + (PROG (|v| |t2| |t1|) + (declare (special |$Subst|)) + (RETURN + (SEQ (PROGN + (DO ((G168383 SL (CDR G168383)) (|p| NIL)) + ((OR (ATOM G168383) + (PROGN (SETQ |p| (CAR G168383)) NIL) + (PROGN + (PROGN + (setq |v| (CAR |p|)) + (setq |t2| (CDR |p|)) + |p|) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (setq |t1| (LASSOC |v| |$Subst|)) + (COND + ((NULL |t1|) + (RPLACD |p| (|replaceSharpCalls| |t2|))) + (t + (RPLACD |p| + (|coerceTypeArgs| |t1| |t2| SL)))))))) + SL))))) ;replaceSharpCalls t == ; noSharpCallsHere t => t ; doReplaceSharpCalls t -(DEFUN |replaceSharpCalls| (|t|) - (COND - ((|noSharpCallsHere| |t|) |t|) - ((QUOTE T) (|doReplaceSharpCalls| |t|)))) +(defun |replaceSharpCalls| (arg) + (if (|noSharpCallsHere| arg) + arg + (|doReplaceSharpCalls| arg))) ;doReplaceSharpCalls t == ; ATOM t => t @@ -4121,35 +4535,34 @@ the types A and B themselves are not sorted by preference. ; [CAR t,:[ doReplaceSharpCalls u for u in CDR t]] (DEFUN |doReplaceSharpCalls| (|t|) - (PROG (|ISTMP#1| |l|) - (RETURN - (SEQ - (COND - ((ATOM |t|) |t|) - ((AND (PAIRP |t|) - (EQ (QCAR |t|) (QUOTE |#|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |l| (QCAR |ISTMP#1|)) (QUOTE T))))) - (|#| |l|)) - ((AND (PAIRP |t|) - (EQ (QCAR |t|) (QUOTE |construct|)) - (PROGN (SPADLET |l| (QCDR |t|)) (QUOTE T))) - (EVAL (CONS (QUOTE LIST) |l|))) - ((QUOTE T) - (CONS - (CAR |t|) - (PROG (#0=#:G168409) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G168414 (CDR |t|) (CDR #1#)) (|u| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |u| (CAR #1#)) NIL)) (NREVERSE0 #0#)) - (SEQ - (EXIT - (SETQ #0# (CONS (|doReplaceSharpCalls| |u|) #0#)))))))))))))) + (PROG (|ISTMP#1| |l|) + (RETURN + (SEQ (COND + ((ATOM |t|) |t|) + ((AND (PAIRP |t|) (EQ (QCAR |t|) '|#|) + (PROGN + (setq |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |l| (QCAR |ISTMP#1|)) t)))) + (|#| |l|)) + ((AND (PAIRP |t|) (EQ (QCAR |t|) '|construct|) + (PROGN (setq |l| (QCDR |t|)) t)) + (EVAL (CONS 'LIST |l|))) + (t + (CONS (CAR |t|) + (PROG (G168409) + (setq G168409 NIL) + (RETURN + (DO ((G168414 (CDR |t|) (CDR G168414)) + (|u| NIL)) + ((OR (ATOM G168414) + (PROGN + (SETQ |u| (CAR G168414)) + NIL)) + (NREVERSE0 G168409)) + (SEQ (EXIT (SETQ G168409 + (CONS (|doReplaceSharpCalls| |u|) + G168409)))))))))))))) ;noSharpCallsHere t == ; t isnt [con, :args] => true @@ -4157,28 +4570,28 @@ the types A and B themselves are not sorted by preference. ; and/[noSharpCallsHere u for u in args] (DEFUN |noSharpCallsHere| (|t|) - (PROG (|con| |args|) - (RETURN - (SEQ - (COND - ((NULL - (AND - (PAIRP |t|) - (PROGN - (SPADLET |con| (QCAR |t|)) - (SPADLET |args| (QCDR |t|)) - (QUOTE T)))) - (QUOTE T)) - ((MEMQ |con| (QUOTE (|construct| |#|))) NIL) - ((QUOTE T) - (PROG (#0=#:G168431) - (SPADLET #0# (QUOTE T)) - (RETURN - (DO ((#1=#:G168437 NIL (NULL #0#)) - (#2=#:G168438 |args| (CDR #2#)) - (|u| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |u| (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (AND #0# (|noSharpCallsHere| |u|)))))))))))))) + (PROG (|con| |args|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (setq |con| (QCAR |t|)) + (setq |args| (QCDR |t|)) + t))) + t) + ((MEMQ |con| '(|construct| |#|)) NIL) + (t + (PROG (G168431) + (setq G168431 t) + (RETURN + (DO ((G168437 NIL (NULL G168431)) + (G168438 |args| (CDR G168438)) (|u| NIL)) + ((OR G168437 (ATOM G168438) + (PROGN (SETQ |u| (CAR G168438)) NIL)) + G168431) + (SEQ (EXIT (SETQ G168431 + (AND G168431 + (|noSharpCallsHere| |u|)))))))))))))) ;coerceTypeArgs(t1, t2, SL) == ; -- if the type t has type-valued arguments, coerce them to the new types, @@ -4198,78 +4611,90 @@ the types A and B themselves are not sorted by preference. ; for cs in coSig]] (DEFUN |coerceTypeArgs| (|t1| |t2| SL) - (PROG (|con1| |args1| |con2| |args2| |coSig| |csub1| |csub2| |cs1| |cs2|) - (RETURN - (SEQ - (COND - ((OR - (NULL - (AND - (PAIRP |t1|) - (PROGN - (SPADLET |con1| (QCAR |t1|)) - (SPADLET |args1| (QCDR |t1|)) - (QUOTE T)))) - (NULL - (AND - (PAIRP |t2|) - (PROGN - (SPADLET |con2| (QCAR |t2|)) - (SPADLET |args2| (QCDR |t2|)) - (QUOTE T))))) - |t2|) - ((NEQUAL |con1| |con2|) |t2|) - ((QUOTE T) - (SPADLET |coSig| (CDR (GETDATABASE (CAR |t1|) (QUOTE COSIG)))) - (COND - ((PROG (#0=#:G168459) - (SPADLET #0# (QUOTE T)) - (RETURN - (DO ((#1=#:G168465 NIL (NULL #0#)) - (#2=#:G168466 |coSig| (CDR #2#)) - (#3=#:G168451 NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ #3# (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (AND #0# #3#))))))) - |t2|) - ((QUOTE T) - (SPADLET |csub1| (|constructSubst| |t1|)) - (SPADLET |csub2| (|constructSubst| |t2|)) - (SPADLET |cs1| (CDR (|getConstructorSignature| |con1|))) - (SPADLET |cs2| (CDR (|getConstructorSignature| |con2|))) - (CONS |con1| - (PROG (#4=#:G168481) - (SPADLET #4# NIL) - (RETURN - (DO ((#5=#:G168490 |args1| (CDR #5#)) - (|arg1| NIL) - (#6=#:G168491 |args2| (CDR #6#)) - (|arg2| NIL) - (#7=#:G168492 |cs1| (CDR #7#)) - (|c1| NIL) - (#8=#:G168493 |cs2| (CDR #8#)) - (|c2| NIL) - (#9=#:G168494 |coSig| (CDR #9#)) - (|cs| NIL)) - ((OR (ATOM #5#) - (PROGN (SETQ |arg1| (CAR #5#)) NIL) - (ATOM #6#) - (PROGN (SETQ |arg2| (CAR #6#)) NIL) - (ATOM #7#) - (PROGN (SETQ |c1| (CAR #7#)) NIL) - (ATOM #8#) - (PROGN (SETQ |c2| (CAR #8#)) NIL) - (ATOM #9#) - (PROGN (SETQ |cs| (CAR #9#)) NIL)) - (NREVERSE0 #4#)) - (SEQ - (EXIT - (SETQ #4# - (CONS - (|makeConstrArg| |arg1| |arg2| - (|constrArg| |c1| |csub1| SL) - (|constrArg| |c2| |csub2| SL) - |cs|) - #4#)))))))))))))))) + (PROG (|con1| |args1| |con2| |args2| |coSig| |csub1| |csub2| |cs1| + |cs2|) + (RETURN + (SEQ (COND + ((OR (NULL (AND (PAIRP |t1|) + (PROGN + (setq |con1| (QCAR |t1|)) + (setq |args1| (QCDR |t1|)) + t))) + (NULL (AND (PAIRP |t2|) + (PROGN + (setq |con2| (QCAR |t2|)) + (setq |args2| (QCDR |t2|)) + t)))) + |t2|) + ((NEQUAL |con1| |con2|) |t2|) + (t + (setq |coSig| (CDR (GETDATABASE (CAR |t1|) 'COSIG))) + (COND + ((PROG (G168459) + (setq G168459 t) + (RETURN + (DO ((G168465 NIL (NULL G168459)) + (G168466 |coSig| (CDR G168466)) + (G168451 NIL)) + ((OR G168465 (ATOM G168466) + (PROGN + (SETQ G168451 (CAR G168466)) + NIL)) + G168459) + (SEQ (EXIT (SETQ G168459 + (AND G168459 G168451))))))) + |t2|) + (t (setq |csub1| (|constructSubst| |t1|)) + (setq |csub2| (|constructSubst| |t2|)) + (setq |cs1| + (CDR (|getConstructorSignature| |con1|))) + (setq |cs2| + (CDR (|getConstructorSignature| |con2|))) + (CONS |con1| + (PROG (G168481) + (setq G168481 NIL) + (RETURN + (DO ((G168490 |args1| (CDR G168490)) + (|arg1| NIL) + (G168491 |args2| (CDR G168491)) + (|arg2| NIL) + (G168492 |cs1| (CDR G168492)) + (|c1| NIL) + (G168493 |cs2| (CDR G168493)) + (|c2| NIL) + (G168494 |coSig| (CDR G168494)) + (|cs| NIL)) + ((OR (ATOM G168490) + (PROGN + (SETQ |arg1| (CAR G168490)) + NIL) + (ATOM G168491) + (PROGN + (SETQ |arg2| (CAR G168491)) + NIL) + (ATOM G168492) + (PROGN + (SETQ |c1| (CAR G168492)) + NIL) + (ATOM G168493) + (PROGN + (SETQ |c2| (CAR G168493)) + NIL) + (ATOM G168494) + (PROGN + (SETQ |cs| (CAR G168494)) + NIL)) + (NREVERSE0 G168481)) + (SEQ (EXIT (SETQ G168481 + (CONS + (|makeConstrArg| |arg1| + |arg2| + (|constrArg| |c1| |csub1| + SL) + (|constrArg| |c2| |csub2| + SL) + |cs|) + G168481)))))))))))))))) ;constrArg(v,sl,SL) == ; x := LASSOC(v,sl) => @@ -4279,17 +4704,17 @@ the types A and B themselves are not sorted by preference. ; y := LASSOC(x, $Subst) => y ; v -(DEFUN |constrArg| (|v| |sl| SL) - (PROG (|x| |y|) - (RETURN - (COND - ((SPADLET |x| (LASSOC |v| |sl|)) - (COND - ((SPADLET |y| (LASSOC |x| SL)) |y|) - ((SPADLET |y| (LASSOC |x| |$Subst|)) |y|) - ((QUOTE T) |x|))) - ((SPADLET |y| (LASSOC |x| |$Subst|)) |y|) - ((QUOTE T) |v|))))) +(defun |constrArg| (v sl sl1) + (let (x y) + (declare (special |$Subst|)) + (cond + ((setq x (LASSOC v sl)) + (cond + ((setq y (LASSOC x sl1)) y) + ((setq y (LASSOC x |$Subst|)) y) + (t x))) + ((setq y (LASSOC x |$Subst|)) y) + (t v)))) ;makeConstrArg(arg1, arg2, t1, t2, cs) == ; if arg1 is ['_#, l] then arg1 := # l @@ -4302,39 +4727,33 @@ the types A and B themselves are not sorted by preference. ; objValUnwrap obj2 (DEFUN |makeConstrArg| (|arg1| |arg2| |t1| |t2| |cs|) - (PROG (|ISTMP#1| |l| |obj1| |obj2|) - (RETURN - (PROGN - (COND - ((AND (PAIRP |arg1|) - (EQ (QCAR |arg1|) (QUOTE |#|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |arg1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |l| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |arg1| (|#| |l|)))) - (COND - ((AND (PAIRP |arg2|) - (EQ (QCAR |arg2|) (QUOTE |#|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |arg2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |l| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |arg2| (|#| |l|)))) - (COND - (|cs| |arg2|) - ((BOOT-EQUAL |t1| |t2|) |arg2|) - ((QUOTE T) - (SPADLET |obj1| (|objNewWrap| |arg1| |t1|)) - (SPADLET |obj2| (|coerceInt| |obj1| |t2|)) - (COND - ((NULL |obj2|) - (|throwKeyedMsgCannotCoerceWithValue| (|wrap| |arg1|) |t1| |t2|)) - ((QUOTE T) (|objValUnwrap| |obj2|))))))))) + (PROG (|ISTMP#1| |l| |obj1| |obj2|) + (RETURN + (PROGN + (COND + ((AND (PAIRP |arg1|) (EQ (QCAR |arg1|) '|#|) + (PROGN + (setq |ISTMP#1| (QCDR |arg1|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |l| (QCAR |ISTMP#1|)) t)))) + (setq |arg1| (|#| |l|)))) + (COND + ((AND (PAIRP |arg2|) (EQ (QCAR |arg2|) '|#|) + (PROGN + (setq |ISTMP#1| (QCDR |arg2|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |l| (QCAR |ISTMP#1|)) t)))) + (setq |arg2| (|#| |l|)))) + (COND + (|cs| |arg2|) + ((BOOT-EQUAL |t1| |t2|) |arg2|) + (t (setq |obj1| (|objNewWrap| |arg1| |t1|)) + (setq |obj2| (|coerceInt| |obj1| |t2|)) + (COND + ((NULL |obj2|) + (|throwKeyedMsgCannotCoerceWithValue| (|wrap| |arg1|) + |t1| |t2|)) + (t (|objValUnwrap| |obj2|))))))))) ;evalMmDom(st) == ; -- evals all isDomain(v,d) of st @@ -4351,57 +4770,65 @@ the types A and B themselves are not sorted by preference. ; SL (DEFUN |evalMmDom| (|st|) - (PROG (|d| |p| |d1| |ISTMP#1| |v| |ISTMP#2| |fun| SL) - (RETURN - (SEQ - (PROGN - (SPADLET SL NIL) - (DO ((#0=#:G168608 |st| (CDR #0#)) - (|mmC| NIL) - (#1=#:G168609 NIL (BOOT-EQUAL SL (QUOTE |failed|)))) - ((OR (ATOM #0#) (PROGN (SETQ |mmC| (CAR #0#)) NIL) #1#) NIL) - (SEQ - (EXIT - (COND - ((AND (PAIRP |mmC|) - (EQ (QCAR |mmC|) (QUOTE |isDomain|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |mmC|)) - (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 |d| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (COND - ((STRINGP |d|) (SPADLET SL (QUOTE |failed|))) - ((SPADLET |p| - (AND (ASSQ |v| SL) (NULL (BOOT-EQUAL |d| (CDR |p|))))) - (SPADLET SL (QUOTE |failed|))) - ((QUOTE T) - (SPADLET |d1| (|subCopy| |d| SL)) - (COND - ((AND (CONSP |d1|) (MEMQ |v| |d1|)) - (SPADLET SL (QUOTE |failed|))) - ((QUOTE T) - (SPADLET SL (|augmentSub| |v| |d1| SL))))))) - ((AND (PAIRP |mmC|) - (EQ (QCAR |mmC|) (QUOTE |isFreeFunction|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |mmC|)) - (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 |fun| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (SPADLET SL (|augmentSub| |v| (|subCopy| |fun| SL) SL))))))) - SL))))) + (PROG (|d| |p| |d1| |ISTMP#1| |v| |ISTMP#2| |fun| SL) + (RETURN + (SEQ (PROGN + (setq SL NIL) + (DO ((G168608 |st| (CDR G168608)) (|mmC| NIL) + (G168609 NIL (BOOT-EQUAL SL '|failed|))) + ((OR (ATOM G168608) + (PROGN (SETQ |mmC| (CAR G168608)) NIL) + G168609) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) '|isDomain|) + (PROGN + (setq |ISTMP#1| (QCDR |mmC|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |v| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |d| + (QCAR |ISTMP#2|)) + t)))))) + (COND + ((STRINGP |d|) (setq SL '|failed|)) + ((setq |p| + (AND (ASSQ |v| SL) + (NULL + (BOOT-EQUAL |d| (CDR |p|))))) + (setq SL '|failed|)) + (t (setq |d1| (|subCopy| |d| SL)) + (COND + ((AND (CONSP |d1|) (MEMQ |v| |d1|)) + (setq SL '|failed|)) + (t + (setq SL + (|augmentSub| |v| |d1| SL))))))) + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) '|isFreeFunction|) + (PROGN + (setq |ISTMP#1| (QCDR |mmC|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |v| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |fun| + (QCAR |ISTMP#2|)) + t)))))) + (setq SL + (|augmentSub| |v| + (|subCopy| |fun| SL) SL))))))) + SL))))) ;orderMmCatStack st == ; -- tries to reorder stack so that free pattern variables appear @@ -4424,57 +4851,64 @@ the types A and B themselves are not sorted by preference. ; SORT(st, function mmCatComp) (DEFUN |orderMmCatStack| (|st|) - (PROG (|vars| |cat| |mem| |havevars| |haventvars|) - (RETURN - (SEQ - (COND - ((OR (NULL |st|) (NULL (CDR |st|))) |st|) - ((QUOTE T) - (SPADLET |vars| - (DELETE-DUPLICATES - (PROG (#0=#:G168643) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G168649 |st| (CDR #1#)) (|s| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |s| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (COND - ((|isPatternVar| (CADR |s|)) - (SETQ #0# (CONS (CADR |s|) #0#))))))))))) - (COND - ((NULL |vars|) |st|) - ((QUOTE T) - (SPADLET |havevars| NIL) - (SPADLET |haventvars| NIL) - (DO ((#2=#:G168662 |st| (CDR #2#)) (|s| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |s| (CAR #2#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |cat| (CADDR |s|)) - (SPADLET |mem| NIL) - (DO ((#3=#:G168672 |vars| (CDR #3#)) (|v| NIL)) - ((OR (ATOM #3#) - (PROGN (SETQ |v| (CAR #3#)) NIL) - (NULL (NULL |mem|))) - NIL) - (SEQ - (EXIT - (COND - ((MEMQ |v| |cat|) - (SPADLET |mem| (QUOTE T)) - (SPADLET |havevars| (CONS |s| |havevars|))) - ((QUOTE T) NIL))))) - (COND - ((NULL |mem|) (SPADLET |haventvars| (CONS |s| |haventvars|))) - ((QUOTE T) NIL)))))) - (COND - ((NULL |havevars|) |st|) - ((QUOTE T) - (SPADLET |st| (NREVERSE (NCONC |haventvars| |havevars|))) - (SORT |st| (|function| |mmCatComp|)))))))))))) + (PROG (|vars| |cat| |mem| |havevars| |haventvars|) + (RETURN + (SEQ (COND + ((OR (NULL |st|) (NULL (CDR |st|))) |st|) + (t + (setq |vars| + (DELETE-DUPLICATES + (PROG (G168643) + (setq G168643 NIL) + (RETURN + (DO ((G168649 |st| (CDR G168649)) + (|s| NIL)) + ((OR (ATOM G168649) + (PROGN + (SETQ |s| (CAR G168649)) + NIL)) + (NREVERSE0 G168643)) + (SEQ (EXIT + (COND + ((|isPatternVar| (CADR |s|)) + (SETQ G168643 + (CONS (CADR |s|) G168643))))))))))) + (COND + ((NULL |vars|) |st|) + (t (setq |havevars| NIL) (setq |haventvars| NIL) + (DO ((G168662 |st| (CDR G168662)) (|s| NIL)) + ((OR (ATOM G168662) + (PROGN (SETQ |s| (CAR G168662)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (setq |cat| (CADDR |s|)) + (setq |mem| NIL) + (DO ((G168672 |vars| (CDR G168672)) + (|v| NIL)) + ((OR (ATOM G168672) + (PROGN + (SETQ |v| (CAR G168672)) + NIL) + (NULL (NULL |mem|))) + NIL) + (SEQ (EXIT + (COND + ((MEMQ |v| |cat|) + (setq |mem| t) + (setq |havevars| + (CONS |s| |havevars|))) + (t NIL))))) + (COND + ((NULL |mem|) + (setq |haventvars| + (CONS |s| |haventvars|))) + (t NIL)))))) + (COND + ((NULL |havevars|) |st|) + (t + (setq |st| + (NREVERSE (NCONC |haventvars| |havevars|))) + (SORT |st| (|function| |mmCatComp|)))))))))))) ;mmCatComp(c1, c2) == ; b1 := ASSQ(CADR c1, $Subst) @@ -4482,13 +4916,9 @@ the types A and B themselves are not sorted by preference. ; b1 and null(b2) => true ; false -(DEFUN |mmCatComp| (|c1| |c2|) - (PROG (|b1| |b2|) - (RETURN - (PROGN - (SPADLET |b1| (ASSQ (CADR |c1|) |$Subst|)) - (SPADLET |b2| (ASSQ (CADR |c2|) |$Subst|)) - (COND ((AND |b1| (NULL |b2|)) (QUOTE T)) ((QUOTE T) NIL)))))) +(defun |mmCatComp| (c1 c2) + (declare (special |$Subst|)) + (and (assq (cadr c1) |$Subst|) (null (assq (cadr c2) |$Subst|)))) ;evalMmCat(op,sig,stack,SL) == ; -- evaluates all ofCategory's of stack as soon as possible @@ -4505,56 +4935,68 @@ the types A and B themselves are not sorted by preference. ; stack:= CONS(mmC,stack) ; S = 'failed => return S ; not atom S => -; makingProgress:= 'T +; makingProgress:= t ; SL:= mergeSubs(S,SL) ; if stack or S='failed then 'failed else SL (DEFUN |evalMmCat| (|op| |sig| |stack| SL) - (PROG (|$hope| |numConds| |st| S |makingProgress|) - (DECLARE (SPECIAL |$hope|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$hope| NIL) - (SPADLET |numConds| (|#| |stack|)) - (SPADLET |stack| - (|orderMmCatStack| - (PROG (#0=#:G168707) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G168713 |stack| (CDR #1#)) (|mmC| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |mmC| (CAR #1#)) NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (COND - ((EQCAR |mmC| (QUOTE |ofCategory|)) - (SETQ #0# (CONS |mmC| #0#))))))))))) - (DO ((#2=#:G168731 NIL (NULL |makingProgress|))) - ((OR (NULL |stack|) #2#) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |st| |stack|) - (SPADLET |stack| NIL) - (SPADLET |makingProgress| NIL) - (DO ((#3=#:G168743 |st| (CDR #3#)) (|mmC| NIL)) - ((OR (ATOM #3#) (PROGN (SETQ |mmC| (CAR #3#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET S (|evalMmCat1| |mmC| |op| SL)) + (declare (ignore |sig|)) + (PROG (|$hope| |numConds| |st| S |makingProgress|) + (DECLARE (SPECIAL |$hope|)) + (RETURN + (SEQ (PROGN + (setq |$hope| NIL) + (setq |numConds| (|#| |stack|)) + (setq |stack| + (|orderMmCatStack| + (PROG (G168707) + (setq G168707 NIL) + (RETURN + (DO ((G168713 |stack| (CDR G168713)) + (|mmC| NIL)) + ((OR (ATOM G168713) + (PROGN + (SETQ |mmC| (CAR G168713)) + NIL)) + (NREVERSE0 G168707)) + (SEQ (EXIT + (COND + ((EQCAR |mmC| '|ofCategory|) + (SETQ G168707 + (CONS |mmC| G168707))))))))))) + (DO ((G168731 NIL (NULL |makingProgress|))) + ((OR (NULL |stack|) G168731) NIL) + (SEQ (EXIT (PROGN + (setq |st| |stack|) + (setq |stack| NIL) + (setq |makingProgress| NIL) + (DO ((G168743 |st| (CDR G168743)) + (|mmC| NIL)) + ((OR (ATOM G168743) + (PROGN + (SETQ |mmC| (CAR G168743)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (setq S + (|evalMmCat1| |mmC| |op| SL)) + (COND + ((AND (BOOT-EQUAL S '|failed|) + |$hope|) + (setq |stack| + (CONS |mmC| |stack|))) + ((BOOT-EQUAL S '|failed|) + (RETURN S)) + ((NULL (ATOM S)) + (PROGN + (setq |makingProgress| + t) + (setq SL + (|mergeSubs| S SL))))))))))))) (COND - ((AND (BOOT-EQUAL S (QUOTE |failed|)) |$hope|) - (SPADLET |stack| (CONS |mmC| |stack|))) - ((BOOT-EQUAL S (QUOTE |failed|)) (RETURN S)) - ((NULL (ATOM S)) - (PROGN - (SPADLET |makingProgress| (QUOTE T)) - (SPADLET SL (|mergeSubs| S SL))))))))))))) - (COND - ((OR |stack| (BOOT-EQUAL S (QUOTE |failed|))) (QUOTE |failed|)) - ((QUOTE T) SL))))))) + ((OR |stack| (BOOT-EQUAL S '|failed|)) '|failed|) + (t SL))))))) ;evalMmCat1(mmC is ['ofCategory,d,c],op, SL) == ; -- evaluates mmC using information from the lisplib @@ -4589,47 +5031,42 @@ the types A and B themselves are not sorted by preference. ; NSL (DEFUN |evalMmCat1| (|mmC| |op| SL) - (PROG (|$domPvar| |d| |c| |p| |dom| NSL) - (DECLARE (SPECIAL |$domPvar|)) - (RETURN - (SEQ - (PROGN - (SPADLET |d| (CADR |mmC|)) - (SPADLET |c| (CADDR |mmC|)) - (SPADLET |$domPvar| NIL) - (SPADLET |$hope| NIL) - (SPADLET NSL (|hasCate| |d| |c| SL)) - (COND - ((AND - (BOOT-EQUAL NSL (QUOTE |failed|)) - (|isPatternVar| |d|) - |$Coerce| - (SPADLET |p| (ASSQ |d| |$Subst|)) - (OR - (EQCAR (CDR |p|) (QUOTE |Variable|)) - (EQCAR (CDR |p|) (QUOTE |Symbol|)))) - (RPLACD |p| (|getSymbolType| |d|)) (|hasCate| |d| |c| SL)) - ((AND (BOOT-EQUAL NSL (QUOTE |failed|)) (|isPatternVar| |d|)) - (SPADLET |dom| (|defaultTypeForCategory| |c| SL)) - (SEQ - (COND - ((NULL |dom|) - (EXIT - (COND ((NEQUAL |op| (QUOTE |coerce|)) (EXIT (QUOTE |failed|)))))) - ((NULL (SPADLET |p| (ASSQ |d| |$Subst|))) - (EXIT - (COND - (|dom| (SPADLET NSL (CONS (CONS |d| |dom|) NIL))) - ((NEQUAL |op| (QUOTE |coerce|)) (QUOTE |failed|)))))) - (COND - ((|containsVars| |dom|) - (SPADLET |dom| (|resolveTM| (CDR |p|) |dom|)))) - (COND - ((AND |$Coerce| (|canCoerce| (CDR |p|) |dom|)) - (SPADLET NSL (CONS (CONS |d| |dom|) NIL))) - ((NEQUAL |op| (QUOTE |coerce|)) - (QUOTE |failed|))))) - ((QUOTE T) NSL))))))) + (PROG (|$domPvar| |d| |c| |p| |dom| NSL) + (DECLARE (SPECIAL |$domPvar| |$Coerce| |$Subst| |$hope| |$domPvar|)) + (RETURN + (SEQ (PROGN + (setq |d| (CADR |mmC|)) + (setq |c| (CADDR |mmC|)) + (setq |$domPvar| NIL) + (setq |$hope| NIL) + (setq NSL (|hasCate| |d| |c| SL)) + (COND + ((AND (BOOT-EQUAL NSL '|failed|) (|isPatternVar| |d|) + |$Coerce| (setq |p| (ASSQ |d| |$Subst|)) + (OR (EQCAR (CDR |p|) '|Variable|) + (EQCAR (CDR |p|) '|Symbol|))) + (RPLACD |p| (|getSymbolType| |d|)) + (|hasCate| |d| |c| SL)) + ((AND (BOOT-EQUAL NSL '|failed|) (|isPatternVar| |d|)) + (setq |dom| (|defaultTypeForCategory| |c| SL)) + (SEQ (COND + ((NULL |dom|) + (EXIT (COND + ((NEQUAL |op| '|coerce|) + (EXIT '|failed|))))) + ((NULL (setq |p| (ASSQ |d| |$Subst|))) + (EXIT (COND + (|dom| (setq NSL + (CONS (CONS |d| |dom|) NIL))) + ((NEQUAL |op| '|coerce|) '|failed|))))) + (COND + ((|containsVars| |dom|) + (setq |dom| (|resolveTM| (CDR |p|) |dom|)))) + (COND + ((AND |$Coerce| (|canCoerce| (CDR |p|) |dom|)) + (setq NSL (CONS (CONS |d| |dom|) NIL))) + ((NEQUAL |op| '|coerce|) '|failed|)))) + (t NSL))))))) ;hasCate(dom,cat,SL) == ; -- asks whether dom has cat under SL @@ -4643,64 +5080,69 @@ the types A and B themselves are not sorted by preference. ; S:= hasCate1(CDR p,cat,SL, dom) ; not (S='failed) => S ; hasCateSpecial(dom,CDR p,cat,SL) -; if SL ^= 'failed then $hope:= 'T +; if SL ^= 'failed then $hope:= t ; 'failed ; SL1 := [[v,:d] for [v,:d] in SL | not containsVariables d] ; if SL1 then cat := subCopy(cat, SL1) ; hasCaty(dom,cat,SL) (DEFUN |hasCate| (|dom| |cat| SL) - (PROG (NSL |p| S |v| |d| SL1) - (RETURN - (SEQ - (COND - ((BOOT-EQUAL |dom| |$EmptyMode|) NIL) - ((|isPatternVar| |dom|) - (COND - ((AND (SPADLET |p| (ASSQ |dom| SL)) - (NEQUAL - (SPADLET NSL (|hasCate| (CDR |p|) |cat| SL)) - (QUOTE |failed|))) - NSL) - ((OR (SPADLET |p| (ASSQ |dom| |$Subst|)) (SPADLET |p| (ASSQ |dom| SL))) - (SPADLET S (|hasCate1| (CDR |p|) |cat| SL |dom|)) - (COND - ((NULL (BOOT-EQUAL S (QUOTE |failed|))) S) - ((QUOTE T) (|hasCateSpecial| |dom| (CDR |p|) |cat| SL)))) - ((QUOTE T) - (COND ((NEQUAL SL (QUOTE |failed|)) (SPADLET |$hope| (QUOTE T)))) - (QUOTE |failed|)))) - ((QUOTE T) - (SPADLET SL1 - (PROG (#0=#:G168806) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G168813 SL (CDR #1#)) (#2=#:G168795 NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ #2# (CAR #1#)) NIL) - (PROGN - (PROGN (SPADLET |v| (CAR #2#)) (SPADLET |d| (CDR #2#)) #2#) - NIL)) - (NREVERSE0 #0#)) - (SEQ - (EXIT - (COND - ((NULL (|containsVariables| |d|)) - (SETQ #0# (CONS (CONS |v| |d|) #0#)))))))))) - (COND (SL1 (SPADLET |cat| (|subCopy| |cat| SL1)))) - (|hasCaty| |dom| |cat| SL))))))) + (PROG (NSL |p| S |v| |d| SL1) + (declare (special |$hope| |$Subst| |$EmptyMode|)) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |dom| |$EmptyMode|) NIL) + ((|isPatternVar| |dom|) + (COND + ((AND (setq |p| (ASSQ |dom| SL)) + (NEQUAL (setq NSL + (|hasCate| (CDR |p|) |cat| SL)) + '|failed|)) + NSL) + ((OR (setq |p| (ASSQ |dom| |$Subst|)) + (setq |p| (ASSQ |dom| SL))) + (setq S (|hasCate1| (CDR |p|) |cat| SL |dom|)) + (COND + ((NULL (BOOT-EQUAL S '|failed|)) S) + (t (|hasCateSpecial| |dom| (CDR |p|) |cat| SL)))) + (t (COND ((NEQUAL SL '|failed|) (setq |$hope| t))) + '|failed|))) + (t + (setq SL1 + (PROG (G168806) + (setq G168806 NIL) + (RETURN + (DO ((G168813 SL (CDR G168813)) + (G168795 NIL)) + ((OR (ATOM G168813) + (PROGN + (SETQ G168795 (CAR G168813)) + NIL) + (PROGN + (PROGN + (setq |v| (CAR G168795)) + (setq |d| (CDR G168795)) + G168795) + NIL)) + (NREVERSE0 G168806)) + (SEQ (EXIT (COND + ((NULL + (|containsVariables| |d|)) + (SETQ G168806 + (CONS (CONS |v| |d|) + G168806)))))))))) + (COND (SL1 (setq |cat| (|subCopy| |cat| SL1)))) + (|hasCaty| |dom| |cat| SL))))))) ;hasCate1(dom, cat, SL, domPvar) == ; $domPvar:local := domPvar ; hasCate(dom, cat, SL) -(DEFUN |hasCate1| (|dom| |cat| SL |domPvar|) - (PROG (|$domPvar|) - (DECLARE (SPECIAL |$domPvar|)) - (RETURN - (PROGN - (SPADLET |$domPvar| |domPvar|) - (|hasCate| |dom| |cat| SL))))) +(defun |hasCate1| (dom cat sl domPvar) + (let (|$domPvar|) + (declare (special |$domPvar|)) + (setq |$domPvar| domPvar) + (|hasCate| dom cat sl))) ;hasCateSpecial(v,dom,cat,SL) == ; -- v is a pattern variable, dom it's binding under $Subst @@ -4728,45 +5170,49 @@ the types A and B themselves are not sorted by preference. ; hasCateSpecialNew(v, dom, cat, SL) (DEFUN |hasCateSpecial| (|v| |dom| |cat| SL) - (PROG (|arg| |ISTMP#1| |d| |dom'| NSL) - (RETURN - (COND - ((AND (PAIRP |dom|) - (EQ (QCAR |dom|) (QUOTE |FactoredForm|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |dom|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |arg| (QCAR |ISTMP#1|)) (QUOTE T))))) - (COND ((|isSubDomain| |arg| |$Integer|) (SPADLET |arg| |$Integer|))) - (SPADLET |d| (CONS (QUOTE |FactoredRing|) (CONS |arg| NIL))) - (SPADLET SL (|hasCate| |arg| (QUOTE (|Ring|)) (|augmentSub| |v| |d| SL))) - (COND - ((BOOT-EQUAL SL (QUOTE |failed|)) (QUOTE |failed|)) - ((QUOTE T) (|hasCaty| |d| |cat| SL)))) - ((OR (EQCAR |cat| (QUOTE |Field|)) (EQCAR |cat| (QUOTE |DivisionRing|))) - (COND ((|isSubDomain| |dom| |$Integer|) (SPADLET |dom| |$Integer|))) - (SPADLET |d| (|eqType| (CONS |$QuotientField| (CONS |dom| NIL)))) - (|hasCaty| |dom| (QUOTE (|IntegralDomain|)) (|augmentSub| |v| |d| SL))) - ((AND (PAIRP |cat|) - (EQ (QCAR |cat|) (QUOTE |PolynomialCategory|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cat|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |d| (QCAR |ISTMP#1|)) (QUOTE T))))) - (SPADLET |dom'| (CONS (QUOTE |Polynomial|) (CONS |d| NIL))) - (AND - (OR (|containsVars| |d|) (|canCoerceFrom| |dom| |dom'|)) - (|hasCaty| |dom'| |cat| (|augmentSub| |v| |dom'| SL)))) - ((|isSubDomain| |dom| |$Integer|) - (SPADLET NSL - (|hasCate| |$Integer| |cat| (|augmentSub| |v| |$Integer| SL))) - (COND - ((BOOT-EQUAL NSL (QUOTE |failed|)) - (|hasCateSpecialNew| |v| |dom| |cat| SL)) - ((QUOTE T) (|hasCaty| |$Integer| |cat| NSL)))) - ((QUOTE T) (|hasCateSpecialNew| |v| |dom| |cat| SL)))))) + (PROG (|arg| |ISTMP#1| |d| |dom'| NSL) + (declare (special |$Integer| |$QuotientField|)) + (RETURN + (COND + ((AND (PAIRP |dom|) (EQ (QCAR |dom|) '|FactoredForm|) + (PROGN + (setq |ISTMP#1| (QCDR |dom|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |arg| (QCAR |ISTMP#1|)) t)))) + (COND + ((|isSubDomain| |arg| |$Integer|) + (setq |arg| |$Integer|))) + (setq |d| (CONS '|FactoredRing| (CONS |arg| NIL))) + (setq SL + (|hasCate| |arg| '(|Ring|) (|augmentSub| |v| |d| SL))) + (COND + ((BOOT-EQUAL SL '|failed|) '|failed|) + (t (|hasCaty| |d| |cat| SL)))) + ((OR (EQCAR |cat| '|Field|) (EQCAR |cat| '|DivisionRing|)) + (COND + ((|isSubDomain| |dom| |$Integer|) + (setq |dom| |$Integer|))) + (setq |d| + (|eqType| (CONS |$QuotientField| (CONS |dom| NIL)))) + (|hasCaty| |dom| '(|IntegralDomain|) + (|augmentSub| |v| |d| SL))) + ((AND (PAIRP |cat|) (EQ (QCAR |cat|) '|PolynomialCategory|) + (PROGN + (setq |ISTMP#1| (QCDR |cat|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (setq |d| (QCAR |ISTMP#1|)) t)))) + (setq |dom'| (CONS '|Polynomial| (CONS |d| NIL))) + (AND (OR (|containsVars| |d|) (|canCoerceFrom| |dom| |dom'|)) + (|hasCaty| |dom'| |cat| (|augmentSub| |v| |dom'| SL)))) + ((|isSubDomain| |dom| |$Integer|) + (setq NSL + (|hasCate| |$Integer| |cat| + (|augmentSub| |v| |$Integer| SL))) + (COND + ((BOOT-EQUAL NSL '|failed|) + (|hasCateSpecialNew| |v| |dom| |cat| SL)) + (t (|hasCaty| |$Integer| |cat| NSL)))) + (t (|hasCateSpecialNew| |v| |dom| |cat| SL)))))) ;-- to be used in $newSystem only ;hasCateSpecialNew(v,dom,cat,SL) == @@ -4817,79 +5263,77 @@ the types A and B themselves are not sorted by preference. ; hasCaty(d, cat, partialResult) (DEFUN |hasCateSpecialNew| (|v| |dom| |cat| SL) - (PROG (|fe| |alg| |fefull| |d| |partialResult|) - (RETURN - (PROGN - (SPADLET |fe| - (|member| (QCAR |cat|) - (QUOTE ( - |ElementaryFunctionCategory| - |TrigonometricFunctionCategory| - |ArcTrigonometricFunctionCategory| - |HyperbolicFunctionCategory| - |ArcHyperbolicFunctionCategory| - |PrimitiveFunctionCategory| - |SpecialFunctionCategory| - |Evalable| - |CombinatorialOpsCategory| - |TranscendentalFunctionCategory| - |AlgebraicallyClosedFunctionSpace| - |ExpressionSpace| - |LiouvillianFunctionCategory| - |FunctionSpace|)))) - (SPADLET |alg| - (|member| (QCAR |cat|) - (QUOTE (|RadicalCategory| |AlgebraicallyClosedField|)))) - (SPADLET |fefull| - (OR |fe| |alg| (EQCAR |cat| (QUOTE |CombinatorialFunctionCategory|)))) - (SPADLET |partialResult| - (COND - ((OR (EQCAR |dom| (QUOTE |Variable|)) (EQCAR |dom| (QUOTE |Symbol|))) - (COND - ((|member| (CAR |cat|) - (QUOTE ( - |SemiGroup| - |AbelianSemiGroup| - |Monoid| - |AbelianGroup| - |AbelianMonoid| - |PartialDifferentialRing| - |Ring| - |InputForm|))) - (SPADLET |d| - (CONS (QUOTE |Polynomial|) - (CONS |$Integer| NIL))) (|augmentSub| |v| |d| SL)) - ((EQCAR |cat| (QUOTE |Group|)) - (SPADLET |d| - (CONS - (QUOTE |Fraction|) - (CONS (CONS (QUOTE |Polynomial|) (CONS |$Integer| NIL)) NIL))) - (|augmentSub| |v| |d| SL)) - (|fefull| - (SPADLET |d| (|defaultTargetFE| |dom|)) (|augmentSub| |v| |d| SL)) - ((QUOTE T) (QUOTE |failed|)))) - ((|isEqualOrSubDomain| |dom| |$Integer|) - (COND - (|fe| - (SPADLET |d| (|defaultTargetFE| |$Integer|)) - (|augmentSub| |v| |d| SL)) - (|alg| - (SPADLET |d| (QUOTE (|AlgebraicNumber|))) - (|augmentSub| |v| |d| SL)) - ((QUOTE T) (QUOTE |failed|)))) - ((BOOT-EQUAL (|underDomainOf| |dom|) |$ComplexInteger|) - (SPADLET |d| (|defaultTargetFE| |$ComplexInteger|)) - (|hasCaty| |d| |cat| (|augmentSub| |v| |d| SL))) - ((AND (BOOT-EQUAL |dom| |$RationalNumber|) |alg|) - (SPADLET |d| (QUOTE (|AlgebraicNumber|))) - (|augmentSub| |v| |d| SL)) - (|fefull| - (SPADLET |d| (|defaultTargetFE| |dom|)) - (|augmentSub| |v| |d| SL)) - ((QUOTE T) (QUOTE |failed|)))) - (COND - ((BOOT-EQUAL |partialResult| (QUOTE |failed|)) (QUOTE |failed|)) - ((QUOTE T) (|hasCaty| |d| |cat| |partialResult|))))))) + (PROG (|fe| |alg| |fefull| |d| |partialResult|) + (declare (special |$RationalNumber| |$ComplexInteger| |$Integer|)) + (RETURN + (PROGN + (setq |fe| + (|member| (QCAR |cat|) + '(|ElementaryFunctionCategory| + |TrigonometricFunctionCategory| + |ArcTrigonometricFunctionCategory| + |HyperbolicFunctionCategory| + |ArcHyperbolicFunctionCategory| + |PrimitiveFunctionCategory| + |SpecialFunctionCategory| |Evalable| + |CombinatorialOpsCategory| + |TranscendentalFunctionCategory| + |AlgebraicallyClosedFunctionSpace| + |ExpressionSpace| + |LiouvillianFunctionCategory| + |FunctionSpace|))) + (setq |alg| + (|member| (QCAR |cat|) + '(|RadicalCategory| |AlgebraicallyClosedField|))) + (setq |fefull| + (OR |fe| |alg| + (EQCAR |cat| '|CombinatorialFunctionCategory|))) + (setq |partialResult| + (COND + ((OR (EQCAR |dom| '|Variable|) + (EQCAR |dom| '|Symbol|)) + (COND + ((|member| (CAR |cat|) + '(|SemiGroup| |AbelianSemiGroup| |Monoid| + |AbelianGroup| |AbelianMonoid| + |PartialDifferentialRing| |Ring| + |InputForm|)) + (setq |d| + (CONS '|Polynomial| + (CONS |$Integer| NIL))) + (|augmentSub| |v| |d| SL)) + ((EQCAR |cat| '|Group|) + (setq |d| + (CONS '|Fraction| + (CONS + (CONS '|Polynomial| + (CONS |$Integer| NIL)) + NIL))) + (|augmentSub| |v| |d| SL)) + (|fefull| (setq |d| (|defaultTargetFE| |dom|)) + (|augmentSub| |v| |d| SL)) + (t '|failed|))) + ((|isEqualOrSubDomain| |dom| |$Integer|) + (COND + (|fe| (setq |d| + (|defaultTargetFE| |$Integer|)) + (|augmentSub| |v| |d| SL)) + (|alg| (setq |d| '(|AlgebraicNumber|)) + (|augmentSub| |v| |d| SL)) + (t '|failed|))) + ((BOOT-EQUAL (|underDomainOf| |dom|) + |$ComplexInteger|) + (setq |d| (|defaultTargetFE| |$ComplexInteger|)) + (|hasCaty| |d| |cat| (|augmentSub| |v| |d| SL))) + ((AND (BOOT-EQUAL |dom| |$RationalNumber|) |alg|) + (setq |d| '(|AlgebraicNumber|)) + (|augmentSub| |v| |d| SL)) + (|fefull| (setq |d| (|defaultTargetFE| |dom|)) + (|augmentSub| |v| |d| SL)) + (t '|failed|))) + (COND + ((BOOT-EQUAL |partialResult| '|failed|) '|failed|) + (t (|hasCaty| |d| |cat| |partialResult|))))))) ;hasCaty(d,cat,SL) == ; -- calls hasCat, which looks up a hashtable and returns: @@ -4924,187 +5368,221 @@ the types A and B themselves are not sorted by preference. ; 'failed (DEFUN |hasCaty| (|d| |cat| SL) - (PROG (|foo| |sig| |a| |x| |y| S |z| |cond| |p| |S'| |dom| |z'| S1 |ncond| - |ISTMP#1| |ISTMP#2|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |cat|) - (EQ (QCAR |cat|) (QUOTE CATEGORY)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cat|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |y| (QCDR |ISTMP#1|)) (QUOTE T))))) - (|hasAttSig| |d| (|subCopy| |y| (|constructSubst| |d|)) SL)) - ((AND (PAIRP |cat|) - (EQ (QCAR |cat|) (QUOTE SIGNATURE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cat|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |foo| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |sig| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (|hasSig| |d| |foo| (|subCopy| |sig| (|constructSubst| |d|)) SL)) - ((AND (PAIRP |cat|) - (EQ (QCAR |cat|) (QUOTE ATTRIBUTE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cat|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T))))) - (|hasAtt| |d| (|subCopy| |a| (|constructSubst| |d|)) SL)) - ((SPADLET |x| (|hasCat| (|opOf| |d|) (|opOf| |cat|))) - (COND - ((SPADLET |y| (KDR |cat|)) - (SPADLET S (|constructSubst| |d|)) - (DO ((#0=#:G168962 |x| (CDR #0#)) - (#1=#:G168932 NIL) - (#2=#:G168963 NIL (NULL (BOOT-EQUAL S1 (QUOTE |failed|))))) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |z| (CAR #1#)) - (SPADLET |cond| (CDR #1#)) - #1#) - NIL) - #2#) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |S'| - (PROG (#3=#:G168976) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G168982 S (CDR #4#)) (#5=#:G168919 NIL)) - ((OR (ATOM #4#) - (PROGN (SETQ #5# (CAR #4#)) NIL) - (PROGN - (PROGN - (SPADLET |p| (CAR #5#)) - (SPADLET |d| (CDR #5#)) - #5#) - NIL)) - (NREVERSE0 #3#)) - (SEQ - (EXIT - (SETQ #3# - (CONS (CONS |p| (|mkDomPvar| |p| |d| |z| |y|)) #3#)))))))) - (COND - (|$domPvar| - (SPADLET |dom| - (CONS (CAR |d|) - (PROG (#6=#:G168994) - (SPADLET #6# NIL) - (RETURN - (DO ((|i| 0 (QSADD1 |i|)) - (#7=#:G169000 (CDR |d|) (CDR #7#)) - (|arg| NIL)) - ((OR (ATOM #7#) (PROGN (SETQ |arg| (CAR #7#)) NIL)) - (NREVERSE0 #6#)) - (SEQ - (EXIT - (SETQ #6# (CONS (|domArg| |arg| |i| |z| |y|) #6#))))))))) - (SPADLET SL (|augmentSub| |$domPvar| |dom| (COPY SL))))) - (SPADLET |z'| - (PROG (#8=#:G169010) - (SPADLET #8# NIL) - (RETURN - (DO ((#9=#:G169015 |z| (CDR #9#)) (|a| NIL)) - ((OR (ATOM #9#) (PROGN (SETQ |a| (CAR #9#)) NIL)) - (NREVERSE0 #8#)) - (SEQ (EXIT (SETQ #8# (CONS (|domArg2| |a| S |S'|) #8#)))))))) - (SPADLET S1 (|unifyStruct| |y| |z'| (COPY SL))) - (COND - ((NULL (BOOT-EQUAL S1 (QUOTE |failed|))) - (SPADLET S1 + (PROG (|foo| |sig| |a| |x| |y| S |z| |cond| |p| |S'| |dom| |z'| S1 + |ncond| |ISTMP#1| |ISTMP#2|) + (declare (special |$domPvar|)) + (RETURN + (SEQ (COND + ((AND (PAIRP |cat|) (EQ (QCAR |cat|) 'CATEGORY) + (PROGN + (setq |ISTMP#1| (QCDR |cat|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (setq |y| (QCDR |ISTMP#1|)) t)))) + (|hasAttSig| |d| (|subCopy| |y| (|constructSubst| |d|)) + SL)) + ((AND (PAIRP |cat|) (EQ (QCAR |cat|) 'SIGNATURE) + (PROGN + (setq |ISTMP#1| (QCDR |cat|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |foo| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |sig| (QCAR |ISTMP#2|)) + t)))))) + (|hasSig| |d| |foo| + (|subCopy| |sig| (|constructSubst| |d|)) SL)) + ((AND (PAIRP |cat|) (EQ (QCAR |cat|) 'ATTRIBUTE) + (PROGN + (setq |ISTMP#1| (QCDR |cat|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |a| (QCAR |ISTMP#1|)) t)))) + (|hasAtt| |d| (|subCopy| |a| (|constructSubst| |d|)) SL)) + ((setq |x| (|hasCat| (|opOf| |d|) (|opOf| |cat|))) (COND - ((ATOM |cond|) S1) - ((QUOTE T) - (SPADLET |ncond| (|subCopy| |cond| S)) - (COND - ((AND (PAIRP |ncond|) - (EQ (QCAR |ncond|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |ncond|)) - (AND - (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |d|) + ((setq |y| (KDR |cat|)) + (setq S (|constructSubst| |d|)) + (DO ((G168962 |x| (CDR G168962)) (G168932 NIL) + (G168963 NIL (NULL (BOOT-EQUAL S1 '|failed|)))) + ((OR (ATOM G168962) + (PROGN (SETQ G168932 (CAR G168962)) NIL) + (PROGN + (PROGN + (setq |z| (CAR G168932)) + (setq |cond| (CDR G168932)) + G168932) + NIL) + G168963) + NIL) + (SEQ (EXIT (PROGN + (setq |S'| + (PROG (G168976) + (setq G168976 NIL) + (RETURN + (DO + ((G168982 S + (CDR G168982)) + (G168919 NIL)) + ((OR (ATOM G168982) + (PROGN + (SETQ G168919 + (CAR G168982)) + NIL) + (PROGN + (PROGN + (setq |p| + (CAR G168919)) + (setq |d| + (CDR G168919)) + G168919) + NIL)) + (NREVERSE0 G168976)) + (SEQ + (EXIT + (SETQ G168976 + (CONS + (CONS |p| + (|mkDomPvar| |p| + |d| |z| |y|)) + G168976)))))))) + (COND + (|$domPvar| + (setq |dom| + (CONS (CAR |d|) + (PROG (G168994) + (setq G168994 NIL) + (RETURN + (DO + ((|i| 0 (QSADD1 |i|)) + (G169000 (CDR |d|) + (CDR G169000)) + (|arg| NIL)) + ((OR (ATOM G169000) + (PROGN + (SETQ |arg| + (CAR G169000)) + NIL)) + (NREVERSE0 G168994)) + (SEQ + (EXIT + (SETQ G168994 + (CONS + (|domArg| |arg| |i| + |z| |y|) + G168994))))))))) + (setq SL + (|augmentSub| |$domPvar| |dom| + (COPY SL))))) + (setq |z'| + (PROG (G169010) + (setq G169010 NIL) + (RETURN + (DO + ((G169015 |z| + (CDR G169015)) + (|a| NIL)) + ((OR (ATOM G169015) + (PROGN + (SETQ |a| + (CAR G169015)) + NIL)) + (NREVERSE0 G169010)) + (SEQ + (EXIT + (SETQ G169010 + (CONS + (|domArg2| |a| S + |S'|) + G169010)))))))) + (setq S1 + (|unifyStruct| |y| |z'| + (COPY SL))) + (COND + ((NULL (BOOT-EQUAL S1 '|failed|)) + (setq S1 + (COND + ((ATOM |cond|) S1) + (t + (setq |ncond| + (|subCopy| |cond| S)) + (COND + ((AND (PAIRP |ncond|) + (EQ (QCAR |ncond|) '|has|) + (PROGN + (setq |ISTMP#1| + (QCDR |ncond|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |d|) + (PROGN + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (EQUAL + (QCAR |ISTMP#2|) + |cat|)))))) + '|failed|) + (t (|hasCaty1| |ncond| S1))))))) + (t NIL)))))) + S1) + ((ATOM |x|) SL) + (t + (setq |ncond| + (|subCopy| |x| (|constructSubst| |d|))) + (COND + ((AND (PAIRP |ncond|) (EQ (QCAR |ncond|) '|has|) (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (EQUAL (QCAR |ISTMP#2|) |cat|)))))) - (QUOTE |failed|)) - ((QUOTE T) (|hasCaty1| |ncond| S1))))))) - ((QUOTE T) NIL)))))) - S1) - ((ATOM |x|) SL) - ((QUOTE T) - (SPADLET |ncond| (|subCopy| |x| (|constructSubst| |d|))) - (COND - ((AND (PAIRP |ncond|) - (EQ (QCAR |ncond|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |ncond|)) - (AND - (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) |d|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (EQUAL (QCAR |ISTMP#2|) |cat|)))))) - (QUOTE |failed|)) - ((QUOTE T) (|hasCaty1| |ncond| SL)))))) - ((QUOTE T) (QUOTE |failed|))))))) + (setq |ISTMP#1| (QCDR |ncond|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |d|) + (PROGN + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (EQUAL (QCAR |ISTMP#2|) |cat|)))))) + '|failed|) + (t (|hasCaty1| |ncond| SL)))))) + (t '|failed|)))))) ;mkDomPvar(p, d, subs, y) == ; l := MEMQ(p, $FormalMapVariableList) => ; domArg(d, #$FormalMapVariableList - #l, subs, y) ; d -(DEFUN |mkDomPvar| (|p| |d| |subs| |y|) - (PROG (|l|) - (RETURN - (COND - ((SPADLET |l| (MEMQ |p| |$FormalMapVariableList|)) - (|domArg| |d| - (SPADDIFFERENCE (|#| |$FormalMapVariableList|) (|#| |l|)) |subs| |y|)) - ((QUOTE T) |d|))))) +(defun |mkDomPvar| (p d subs y) + (let (l) + (declare (special |$FormalMapVariableList|)) + (if (setq l (memq p |$FormalMapVariableList|)) + (|domArg| d (- (|#| |$FormalMapVariableList|) (|#| l)) subs y) + d))) ;domArg(type, i, subs, y) == ; p := MEMQ($FormalMapVariableList.i, subs) => ; y.(#subs - #p) ; type -(DEFUN |domArg| (|type| |i| |subs| |y|) - (PROG (|p|) - (RETURN - (COND - ((SPADLET |p| (MEMQ (ELT |$FormalMapVariableList| |i|) |subs|)) - (ELT |y| (SPADDIFFERENCE (|#| |subs|) (|#| |p|)))) - ((QUOTE T) |type|))))) +(defun |domArg| (type i subs y) + (let (p) + (declare (special |$FormalMapVariableList|)) + (if (setq p (memq (elt |$FormalMapVariableList| i) subs)) + (elt y (- (|#| subs) (|#| p))) + type))) ;domArg2(arg, SL1, SL2) == ; isSharpVar arg => subCopy(arg, SL1) ; arg = '_$ and $domPvar => $domPvar ; subCopy(arg, SL2) -(DEFUN |domArg2| (|arg| SL1 SL2) - (COND - ((|isSharpVar| |arg|) (|subCopy| |arg| SL1)) - ((AND (BOOT-EQUAL |arg| (QUOTE $)) |$domPvar|) |$domPvar|) - ((QUOTE T) (|subCopy| |arg| SL2)))) +(defun |domArg2| (arg sl1 sl2) + (declare (special |$domPvar|)) + (cond + ((|isSharpVar| arg) (|subCopy| arg sl1)) + ((and (eq arg '$) |$domPvar|) |$domPvar|) + (t (|subCopy| arg sl2)))) ;hasCaty1(cond,SL) == ; -- cond is either a (has a b) or an OR clause of such conditions @@ -5131,131 +5609,143 @@ the types A and B themselves are not sorted by preference. ; ['"hasCaty1",'"unexpected condition from category table"]) (DEFUN |hasCaty1| (|cond| SL) - (PROG (|$domPvar| |args| |ISTMP#1| |ISTMP#2| |a| |ISTMP#3| |b| S) - (DECLARE (SPECIAL |$domPvar|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$domPvar| NIL) - (COND - ((AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cond|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (|hasCate| |a| |b| SL)) - ((AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE AND)) - (PROGN (SPADLET |args| (QCDR |cond|)) (QUOTE T))) - (DO ((#0=#:G169191 |args| (CDR #0#)) (|x| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |x| (CAR #0#)) NIL) - (NULL (NULL (BOOT-EQUAL S (QUOTE |failed|))))) - NIL) - (SEQ - (EXIT - (SPADLET S - (COND - ((AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (|hasCate| |a| |b| SL)) - ((AND - (PAIRP |x|) - (EQ (QCDR |x|) NIL) - (PROGN - (SPADLET |ISTMP#1| (QCAR |x|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#3|)) (QUOTE T))))))))) - (|hasCate| |a| |b| SL)) - ((QUOTE T) (|hasCaty1| |x| SL))))))) - S) - ((AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE OR)) - (PROGN (SPADLET |args| (QCDR |cond|)) (QUOTE T))) - (DO ((#1=#:G169218 |args| (CDR #1#)) - (|x| NIL) - (#2=#:G169219 NIL (NULL (BOOT-EQUAL S (QUOTE |failed|))))) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL) #2#) NIL) - (SEQ - (EXIT - (SPADLET S - (COND - ((AND - (PAIRP |x|) - (EQ (QCAR |x|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (|hasCate| |a| |b| (COPY SL))) - ((AND - (PAIRP |x|) - (EQ (QCDR |x|) NIL) - (PROGN - (SPADLET |ISTMP#1| (QCAR |x|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#3|)) (QUOTE T))))))))) - (|hasCate| |a| |b| (COPY SL))) - ((QUOTE T) (|hasCaty1| |x| (COPY SL)))))))) - S) - ((QUOTE T) - (|keyedSystemError| 'S2GE0016 - (CONS "hasCaty1" - (CONS "unexpected condition from category table" NIL)))))))))) + (PROG (|$domPvar| |args| |ISTMP#1| |ISTMP#2| |a| |ISTMP#3| |b| S) + (DECLARE (SPECIAL |$domPvar|)) + (RETURN + (SEQ (PROGN + (setq |$domPvar| NIL) + (COND + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|has|) + (PROGN + (setq |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |a| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |b| (QCAR |ISTMP#2|)) + t)))))) + (|hasCate| |a| |b| SL)) + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'AND) + (PROGN (setq |args| (QCDR |cond|)) t)) + (DO ((G169191 |args| (CDR G169191)) (|x| NIL)) + ((OR (ATOM G169191) + (PROGN (SETQ |x| (CAR G169191)) NIL) + (NULL (NULL (BOOT-EQUAL S '|failed|)))) + NIL) + (SEQ (EXIT (setq S + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '|has|) + (PROGN + (setq |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |a| + (QCAR |ISTMP#1|)) + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (setq |b| + (QCAR |ISTMP#2|)) + t)))))) + (|hasCate| |a| |b| SL)) + ((AND (PAIRP |x|) + (EQ (QCDR |x|) NIL) + (PROGN + (setq |ISTMP#1| + (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|has|) + (PROGN + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (setq |a| + (QCAR |ISTMP#2|)) + (setq |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) + NIL) + (PROGN + (setq |b| + (QCAR |ISTMP#3|)) + t)))))))) + (|hasCate| |a| |b| SL)) + (t (|hasCaty1| |x| SL))))))) + S) + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'OR) + (PROGN (setq |args| (QCDR |cond|)) t)) + (DO ((G169218 |args| (CDR G169218)) (|x| NIL) + (G169219 NIL (NULL (BOOT-EQUAL S '|failed|)))) + ((OR (ATOM G169218) + (PROGN (SETQ |x| (CAR G169218)) NIL) + G169219) + NIL) + (SEQ (EXIT (setq S + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '|has|) + (PROGN + (setq |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |a| + (QCAR |ISTMP#1|)) + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (setq |b| + (QCAR |ISTMP#2|)) + t)))))) + (|hasCate| |a| |b| (COPY SL))) + ((AND (PAIRP |x|) + (EQ (QCDR |x|) NIL) + (PROGN + (setq |ISTMP#1| + (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|has|) + (PROGN + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (setq |a| + (QCAR |ISTMP#2|)) + (setq |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) + NIL) + (PROGN + (setq |b| + (QCAR |ISTMP#3|)) + t)))))))) + (|hasCate| |a| |b| (COPY SL))) + (t (|hasCaty1| |x| (COPY SL)))))))) + S) + (t + (|keyedSystemError| 'S2GE0016 + (CONS "hasCaty1" + (CONS "unexpected condition from category table" + NIL)))))))))) ;hasAttSig(d,x,SL) == ; -- d is domain, x a list of attributes and signatures @@ -5268,49 +5758,52 @@ the types A and B themselves are not sorted by preference. ; SL (DEFUN |hasAttSig| (|d| |x| SL) - (PROG (|a| |ISTMP#1| |foo| |ISTMP#2| |s|) - (RETURN - (SEQ - (PROGN - (DO ((#0=#:G169295 |x| (CDR #0#)) - (|y| NIL) - (#1=#:G169296 NIL (BOOT-EQUAL SL (QUOTE |failed|)))) - ((OR (ATOM #0#) (PROGN (SETQ |y| (CAR #0#)) NIL) #1#) NIL) - (SEQ - (EXIT - (SPADLET SL - (COND - ((AND - (PAIRP |y|) - (EQ (QCAR |y|) (QUOTE ATTRIBUTE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T))))) - (|hasAtt| |d| |a| SL)) - ((AND - (PAIRP |y|) - (EQ (QCAR |y|) (QUOTE SIGNATURE)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |foo| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |s| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (|hasSig| |d| |foo| |s| SL)) - ((QUOTE T) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "hasAttSig" - (CONS "unexpected form of unnamed category" NIL))))))))) - SL))))) - + (PROG (|a| |ISTMP#1| |foo| |ISTMP#2| |s|) + (RETURN + (SEQ (PROGN + (DO ((G169295 |x| (CDR G169295)) (|y| NIL) + (G169296 NIL (BOOT-EQUAL SL '|failed|))) + ((OR (ATOM G169295) + (PROGN (SETQ |y| (CAR G169295)) NIL) G169296) + NIL) + (SEQ (EXIT (setq SL + (COND + ((AND (PAIRP |y|) + (EQ (QCAR |y|) 'ATTRIBUTE) + (PROGN + (setq |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (setq |a| + (QCAR |ISTMP#1|)) + t)))) + (|hasAtt| |d| |a| SL)) + ((AND (PAIRP |y|) + (EQ (QCAR |y|) 'SIGNATURE) + (PROGN + (setq |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |foo| + (QCAR |ISTMP#1|)) + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |s| + (QCAR |ISTMP#2|)) + t)))))) + (|hasSig| |d| |foo| |s| SL)) + (t + (|keyedSystemError| 'S2GE0016 + (CONS "hasAttSig" + (CONS + "unexpected form of unnamed category" + NIL))))))))) + SL))))) + ;hasSigAnd(andCls, S0, SL) == ; dead := NIL ; SA := 'failed @@ -5325,46 +5818,51 @@ the types A and B themselves are not sorted by preference. ; SA (DEFUN |hasSigAnd| (|andCls| S0 SL) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b| SA |dead|) - (RETURN - (SEQ - (PROGN - (SPADLET |dead| NIL) - (SPADLET SA (QUOTE |failed|)) - (DO ((#0=#:G169345 |andCls| (CDR #0#)) (|cls| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |cls| (CAR #0#)) NIL) - (NULL (NULL |dead|))) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET SA - (COND - ((ATOM |cls|) (COPY SL)) - ((AND - (PAIRP |cls|) - (EQ (QCAR |cls|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cls|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (|hasCate| (|subCopy| |a| S0) (|subCopy| |b| S0) (COPY SL))) - ((QUOTE T) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "hasSigAnd" - (CONS "unexpected condition for signature" NIL)))))) - (COND - ((BOOT-EQUAL SA (QUOTE |failed|)) (SPADLET |dead| (QUOTE T))) - ((QUOTE T) NIL)))))) - SA))))) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| SA |dead|) + (RETURN + (SEQ (PROGN + (setq |dead| NIL) + (setq SA '|failed|) + (DO ((G169345 |andCls| (CDR G169345)) (|cls| NIL)) + ((OR (ATOM G169345) + (PROGN (SETQ |cls| (CAR G169345)) NIL) + (NULL (NULL |dead|))) + NIL) + (SEQ (EXIT (PROGN + (setq SA + (COND + ((ATOM |cls|) (COPY SL)) + ((AND (PAIRP |cls|) + (EQ (QCAR |cls|) '|has|) + (PROGN + (setq |ISTMP#1| + (QCDR |cls|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |a| + (QCAR |ISTMP#1|)) + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (setq |b| + (QCAR |ISTMP#2|)) + t)))))) + (|hasCate| (|subCopy| |a| S0) + (|subCopy| |b| S0) (COPY SL))) + (t + (|keyedSystemError| 'S2GE0016 + (CONS "hasSigAnd" + (CONS + "unexpected condition for signature" + NIL)))))) + (COND + ((BOOT-EQUAL SA '|failed|) + (setq |dead| t)) + (t NIL)))))) + SA))))) ;hasSigOr(orCls, S0, SL) == ; found := NIL @@ -5382,55 +5880,66 @@ the types A and B themselves are not sorted by preference. ; SA (DEFUN |hasSigOr| (|orCls| S0 SL) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |andCls| SA |found|) - (RETURN - (SEQ - (PROGN - (SPADLET |found| NIL) - (SPADLET SA (QUOTE |failed|)) - (DO ((#0=#:G169399 |orCls| (CDR #0#)) - (|cls| NIL) - (#1=#:G169400 NIL |found|)) - ((OR (ATOM #0#) (PROGN (SETQ |cls| (CAR #0#)) NIL) #1#) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET SA - (COND - ((ATOM |cls|) (COPY SL)) - ((AND - (PAIRP |cls|) - (EQ (QCAR |cls|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cls|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (|hasCate| (|subCopy| |a| S0) (|subCopy| |b| S0) (COPY SL))) - ((OR - (AND - (PAIRP |cls|) - (EQ (QCAR |cls|) (QUOTE AND)) - (PROGN (SPADLET |andCls| (QCDR |cls|)) (QUOTE T))) - (AND - (PAIRP |cls|) - (EQ (QCAR |cls|) (QUOTE |and|)) - (PROGN (SPADLET |andCls| (QCDR |cls|)) (QUOTE T)))) - (|hasSigAnd| |andCls| S0 SL)) - ((QUOTE T) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "hasSigOr" - (CONS "unexpected condition for signature" NIL)))))) - (COND - ((NEQUAL SA (QUOTE |failed|)) (SPADLET |found| (QUOTE T))) - ((QUOTE T) NIL)))))) - SA))))) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |andCls| SA |found|) + (RETURN + (SEQ (PROGN + (setq |found| NIL) + (setq SA '|failed|) + (DO ((G169399 |orCls| (CDR G169399)) (|cls| NIL) + (G169400 NIL |found|)) + ((OR (ATOM G169399) + (PROGN (SETQ |cls| (CAR G169399)) NIL) + G169400) + NIL) + (SEQ (EXIT (PROGN + (setq SA + (COND + ((ATOM |cls|) (COPY SL)) + ((AND (PAIRP |cls|) + (EQ (QCAR |cls|) '|has|) + (PROGN + (setq |ISTMP#1| + (QCDR |cls|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |a| + (QCAR |ISTMP#1|)) + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (setq |b| + (QCAR |ISTMP#2|)) + t)))))) + (|hasCate| (|subCopy| |a| S0) + (|subCopy| |b| S0) (COPY SL))) + ((OR + (AND (PAIRP |cls|) + (EQ (QCAR |cls|) 'AND) + (PROGN + (setq |andCls| + (QCDR |cls|)) + t)) + (AND (PAIRP |cls|) + (EQ (QCAR |cls|) '|and|) + (PROGN + (setq |andCls| + (QCDR |cls|)) + t))) + (|hasSigAnd| |andCls| S0 SL)) + (t + (|keyedSystemError| 'S2GE0016 + (CONS "hasSigOr" + (CONS + "unexpected condition for signature" + NIL)))))) + (COND + ((NEQUAL SA '|failed|) + (setq |found| t)) + (t NIL)))))) + SA))))) ;hasSig(dom,foo,sig,SL) == ; -- tests whether domain dom has function foo with signature sig @@ -5456,83 +5965,113 @@ the types A and B themselves are not sorted by preference. ; 'failed (DEFUN |hasSig| (|dom| |foo| |sig| SL) - (PROG (|$domPvar| |fun| S0 |p| |x| |cond| |ISTMP#1| |a| |ISTMP#2| |b| - |andCls| |orCls| S) - (DECLARE (SPECIAL |$domPvar|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$domPvar| NIL) - (COND - ((SPADLET |fun| (|constructor?| (CAR |dom|))) - (SPADLET S0 (|constructSubst| |dom|)) - (COND - ((SPADLET |p| - (ASSQ |foo| (|getOperationAlistFromLisplib| (CAR |dom|)))) - (DO ((#0=#:G169467 (CDR |p|) (CDR #0#)) - (#1=#:G169438 NIL) - (#2=#:G169468 NIL (NULL (BOOT-EQUAL S (QUOTE |failed|))))) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |x| (CAR #1#)) - (SPADLET |cond| (CADDR #1#)) - #1#) - NIL) - #2#) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET S - (COND - ((ATOM |cond|) (COPY SL)) - ((AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cond|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (|hasCate| (|subCopy| |a| S0) (|subCopy| |b| S0) (COPY SL))) - ((OR - (AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE AND)) - (PROGN (SPADLET |andCls| (QCDR |cond|)) (QUOTE T))) - (AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |and|)) - (PROGN (SPADLET |andCls| (QCDR |cond|)) (QUOTE T)))) - (|hasSigAnd| |andCls| S0 SL)) - ((OR - (AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE OR)) - (PROGN (SPADLET |orCls| (QCDR |cond|)) (QUOTE T))) - (AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |or|)) - (PROGN (SPADLET |orCls| (QCDR |cond|)) (QUOTE T)))) - (|hasSigOr| |orCls| S0 SL)) - ((QUOTE T) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "hasSig" - (CONS "unexpected condition for signature" NIL)))))) + (PROG (|$domPvar| |fun| S0 |p| |x| |cond| |ISTMP#1| |a| |ISTMP#2| |b| + |andCls| |orCls| S) + (DECLARE (SPECIAL |$domPvar|)) + (RETURN + (SEQ (PROGN + (setq |$domPvar| NIL) (COND - ((NULL (BOOT-EQUAL S (QUOTE |failed|))) - (SPADLET S (|unifyStruct| (|subCopy| |x| S0) |sig| S)))))))) - S) - ((QUOTE T) (QUOTE |failed|)))) - ((QUOTE T) (QUOTE |failed|)))))))) + ((setq |fun| (|constructor?| (CAR |dom|))) + (setq S0 (|constructSubst| |dom|)) + (COND + ((setq |p| + (ASSQ |foo| + (|getOperationAlistFromLisplib| + (CAR |dom|)))) + (DO ((G169467 (CDR |p|) (CDR G169467)) + (G169438 NIL) + (G169468 NIL (NULL (BOOT-EQUAL S '|failed|)))) + ((OR (ATOM G169467) + (PROGN + (SETQ G169438 (CAR G169467)) + NIL) + (PROGN + (PROGN + (setq |x| (CAR G169438)) + (setq |cond| (CADDR G169438)) + G169438) + NIL) + G169468) + NIL) + (SEQ (EXIT (PROGN + (setq S + (COND + ((ATOM |cond|) (COPY SL)) + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) + '|has|) + (PROGN + (setq |ISTMP#1| + (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |a| + (QCAR |ISTMP#1|)) + (setq |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ + (QCDR |ISTMP#2|) + NIL) + (PROGN + (setq |b| + (QCAR + |ISTMP#2|)) + t)))))) + (|hasCate| + (|subCopy| |a| S0) + (|subCopy| |b| S0) + (COPY SL))) + ((OR + (AND (PAIRP |cond|) + (EQ (QCAR |cond|) 'AND) + (PROGN + (setq |andCls| + (QCDR |cond|)) + t)) + (AND (PAIRP |cond|) + (EQ (QCAR |cond|) + '|and|) + (PROGN + (setq |andCls| + (QCDR |cond|)) + t))) + (|hasSigAnd| |andCls| S0 + SL)) + ((OR + (AND (PAIRP |cond|) + (EQ (QCAR |cond|) 'OR) + (PROGN + (setq |orCls| + (QCDR |cond|)) + t)) + (AND (PAIRP |cond|) + (EQ (QCAR |cond|) + '|or|) + (PROGN + (setq |orCls| + (QCDR |cond|)) + t))) + (|hasSigOr| |orCls| S0 + SL)) + (t + (|keyedSystemError| + 'S2GE0016 + (CONS + "hasSig" + (CONS + "unexpected condition for signature" + NIL)))))) + (COND + ((NULL (BOOT-EQUAL S '|failed|)) + (setq S + (|unifyStruct| (|subCopy| |x| S0) + |sig| S)))))))) + S) + (t '|failed|))) + (t '|failed|))))))) ;hasAtt(dom,att,SL) == ; -- tests whether dom has attribute att under SL @@ -5554,70 +6093,76 @@ the types A and B themselves are not sorted by preference. ; 'failed (DEFUN |hasAtt| (|dom| |att| SL) - (PROG (|$domPvar| |fun| |atts| |u| |x| |cond| S) - (DECLARE (SPECIAL |$domPvar|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$domPvar| NIL) - (COND - ((SPADLET |fun| (CAR |dom|)) - (COND - ((SPADLET |atts| - (|subCopy| - (GETDATABASE |fun| (QUOTE ATTRIBUTES)) - (|constructSubst| |dom|))) - (COND - ((PAIRP (SPADLET |u| (|getInfovec| (CAR |dom|)))) - (DO ((#0=#:G169518 |atts| (CDR #0#)) - (#1=#:G169498 NIL) - (#2=#:G169519 NIL (NULL (BOOT-EQUAL S (QUOTE |failed|))))) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN - (SPADLET |x| (CAR #1#)) - (SPADLET |cond| (CDR #1#)) - #1#) - NIL) - #2#) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET S (|unifyStruct| |x| |att| (COPY SL))) - (COND - ((AND - (NULL (ATOM |cond|)) - (NULL (BOOT-EQUAL S (QUOTE |failed|)))) - (SPADLET S (|hasCatExpression| |cond| S)))))))) - S) - ((QUOTE T) - (DO ((#3=#:G169534 |atts| (CDR #3#)) - (#4=#:G169504 NIL) - (#5=#:G169535 NIL (NULL (BOOT-EQUAL S (QUOTE |failed|))))) - ((OR (ATOM #3#) - (PROGN (SETQ #4# (CAR #3#)) NIL) - (PROGN - (PROGN - (SPADLET |x| (CAR #4#)) - (SPADLET |cond| (CADR #4#)) - #4#) - NIL) - #5#) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET S (|unifyStruct| |x| |att| (COPY SL))) - (COND - ((AND - (NULL (ATOM |cond|)) - (NULL (BOOT-EQUAL S (QUOTE |failed|)))) - (SPADLET S (|hasCatExpression| |cond| S)))))))) - S))) - ((QUOTE T) (QUOTE |failed|)))) - ((QUOTE T) (QUOTE |failed|)))))))) + (PROG (|$domPvar| |fun| |atts| |u| |x| |cond| S) + (DECLARE (SPECIAL |$domPvar|)) + (RETURN + (SEQ (PROGN + (setq |$domPvar| NIL) + (COND + ((setq |fun| (CAR |dom|)) + (COND + ((setq |atts| + (|subCopy| (GETDATABASE |fun| 'ATTRIBUTES) + (|constructSubst| |dom|))) + (COND + ((PAIRP (setq |u| (|getInfovec| (CAR |dom|)))) + (DO ((G169518 |atts| (CDR G169518)) + (G169498 NIL) + (G169519 NIL + (NULL (BOOT-EQUAL S '|failed|)))) + ((OR (ATOM G169518) + (PROGN + (SETQ G169498 (CAR G169518)) + NIL) + (PROGN + (PROGN + (setq |x| (CAR G169498)) + (setq |cond| (CDR G169498)) + G169498) + NIL) + G169519) + NIL) + (SEQ (EXIT (PROGN + (setq S + (|unifyStruct| |x| |att| + (COPY SL))) + (COND + ((AND (NULL (ATOM |cond|)) + (NULL + (BOOT-EQUAL S '|failed|))) + (setq S + (|hasCatExpression| |cond| S)))))))) + S) + (t + (DO ((G169534 |atts| (CDR G169534)) + (G169504 NIL) + (G169535 NIL + (NULL (BOOT-EQUAL S '|failed|)))) + ((OR (ATOM G169534) + (PROGN + (SETQ G169504 (CAR G169534)) + NIL) + (PROGN + (PROGN + (setq |x| (CAR G169504)) + (setq |cond| (CADR G169504)) + G169504) + NIL) + G169535) + NIL) + (SEQ (EXIT (PROGN + (setq S + (|unifyStruct| |x| |att| + (COPY SL))) + (COND + ((AND (NULL (ATOM |cond|)) + (NULL + (BOOT-EQUAL S '|failed|))) + (setq S + (|hasCatExpression| |cond| S)))))))) + S))) + (t '|failed|))) + (t '|failed|))))))) ;hasCatExpression(cond,SL) == ; cond is ['OR,:l] => @@ -5629,66 +6174,63 @@ the types A and B themselves are not sorted by preference. ; ['"hasSig",'"unexpected condition for attribute"]) (DEFUN |hasCatExpression| (|cond| SL) - (PROG (|y| |l| |ISTMP#1| |a| |ISTMP#2| |b|) - (RETURN - (SEQ - (COND - ((AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE OR)) - (PROGN (SPADLET |l| (QCDR |cond|)) (QUOTE T))) - (COND - ((PROG (#0=#:G169577) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G169583 NIL #0#) (#2=#:G169584 |l| (CDR #2#)) (|x| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #0#) - (SEQ - (EXIT - (SETQ #0# - (OR #0# - (NEQUAL - (SPADLET |y| (|hasCatExpression| |x| SL)) - (QUOTE |failed|))))))))) - (EXIT |y|)))) - ((AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE AND)) - (PROGN (SPADLET |l| (QCDR |cond|)) (QUOTE T))) - (COND - ((PROG (#3=#:G169591) - (SPADLET #3# (QUOTE T)) - (RETURN - (DO ((#4=#:G169597 NIL (NULL #3#)) - (#5=#:G169598 |l| (CDR #5#)) - (|x| NIL)) - ((OR #4# (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) #3#) - (SEQ - (EXIT - (SETQ #3# - (AND #3# - (NEQUAL - (SPADLET SL (|hasCatExpression| |x| SL)) - (QUOTE |failed|))))))))) - (EXIT SL)))) - ((AND - (PAIRP |cond|) - (EQ (QCAR |cond|) (QUOTE |has|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cond|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) - (|hasCate| |a| |b| SL)) - ((QUOTE T) - (|keyedSystemError| (QUOTE S2GE0016) - (CONS "hasSig" (CONS "unexpected condition for attribute" NIL))))))))) + (PROG (|y| |l| |ISTMP#1| |a| |ISTMP#2| |b|) + (RETURN + (SEQ (COND + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'OR) + (PROGN (setq |l| (QCDR |cond|)) t)) + (COND + ((PROG (G169577) + (setq G169577 NIL) + (RETURN + (DO ((G169583 NIL G169577) + (G169584 |l| (CDR G169584)) (|x| NIL)) + ((OR G169583 (ATOM G169584) + (PROGN (SETQ |x| (CAR G169584)) NIL)) + G169577) + (SEQ (EXIT (SETQ G169577 + (OR G169577 + (NEQUAL + (setq |y| + (|hasCatExpression| |x| SL)) + '|failed|)))))))) + (EXIT |y|)))) + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) 'AND) + (PROGN (setq |l| (QCDR |cond|)) t)) + (COND + ((PROG (G169591) + (setq G169591 t) + (RETURN + (DO ((G169597 NIL (NULL G169591)) + (G169598 |l| (CDR G169598)) (|x| NIL)) + ((OR G169597 (ATOM G169598) + (PROGN (SETQ |x| (CAR G169598)) NIL)) + G169591) + (SEQ (EXIT (SETQ G169591 + (AND G169591 + (NEQUAL + (setq SL + (|hasCatExpression| |x| SL)) + '|failed|)))))))) + (EXIT SL)))) + ((AND (PAIRP |cond|) (EQ (QCAR |cond|) '|has|) + (PROGN + (setq |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |a| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |b| (QCAR |ISTMP#2|)) + t)))))) + (|hasCate| |a| |b| SL)) + (t + (|keyedSystemError| 'S2GE0016 + (CONS "hasSig" + (CONS "unexpected condition for attribute" + NIL))))))))) ;unifyStruct(s1,s2,SL) == ; -- tests for equality of s1 and s2 under substitutions SL and $Subst @@ -5710,60 +6252,57 @@ the types A and B themselves are not sorted by preference. ; SL (DEFUN |unifyStruct| (|s1| |s2| SL) - (PROG (|ISTMP#1| |x| |ISTMP#2|) - (RETURN - (SEQ - (COND - ((BOOT-EQUAL |s1| |s2|) SL) - ((QUOTE T) - (COND - ((AND - (PAIRP |s1|) - (EQ (QCAR |s1|) (QUOTE |:|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |s1|)) - (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)))))) - (SPADLET |s1| |x|))) - (COND - ((AND - (PAIRP |s2|) - (EQ (QCAR |s2|) (QUOTE |:|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |s2|)) - (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)))))) - (SPADLET |s2| |x|))) - (COND - ((AND (NULL (ATOM |s1|)) (BOOT-EQUAL (CAR |s1|) (QUOTE |#|))) - (SPADLET |s1| (LENGTH (CADR |s1|))))) - (COND - ((AND (NULL (ATOM |s2|)) (BOOT-EQUAL (CAR |s2|) (QUOTE |#|))) - (SPADLET |s2| (LENGTH (CADR |s2|))))) - (COND - ((BOOT-EQUAL |s1| |s2|) SL) - ((|isPatternVar| |s1|) (|unifyStructVar| |s1| |s2| SL)) - ((|isPatternVar| |s2|) (|unifyStructVar| |s2| |s1| SL)) - ((OR (ATOM |s1|) (ATOM |s2|)) (QUOTE |failed|)) - ((QUOTE T) - (DO ((#0=#:G169646 NIL - (OR (NULL |s1|) (NULL |s2|) (BOOT-EQUAL SL (QUOTE |failed|))))) - (#0# NIL) - (SEQ - (EXIT - (PROGN - (SPADLET SL (|unifyStruct| (CAR |s1|) (CAR |s2|) SL)) - (SPADLET |s1| (CDR |s1|)) - (SPADLET |s2| (CDR |s2|)))))) - (COND ((OR |s1| |s2|) (QUOTE |failed|)) ((QUOTE T) SL)))))))))) + (PROG (|ISTMP#1| |x| |ISTMP#2|) + (declare (special |$domPvar| |$hope| |$Coerce| |$Subst|)) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |s1| |s2|) SL) + (t + (COND + ((AND (PAIRP |s1|) (EQ (QCAR |s1|) '|:|) + (PROGN + (setq |ISTMP#1| (QCDR |s1|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |x| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (setq |s1| |x|))) + (COND + ((AND (PAIRP |s2|) (EQ (QCAR |s2|) '|:|) + (PROGN + (setq |ISTMP#1| (QCDR |s2|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |x| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (setq |s2| |x|))) + (COND + ((AND (NULL (ATOM |s1|)) (BOOT-EQUAL (CAR |s1|) '|#|)) + (setq |s1| (LENGTH (CADR |s1|))))) + (COND + ((AND (NULL (ATOM |s2|)) (BOOT-EQUAL (CAR |s2|) '|#|)) + (setq |s2| (LENGTH (CADR |s2|))))) + (COND + ((BOOT-EQUAL |s1| |s2|) SL) + ((|isPatternVar| |s1|) (|unifyStructVar| |s1| |s2| SL)) + ((|isPatternVar| |s2|) (|unifyStructVar| |s2| |s1| SL)) + ((OR (ATOM |s1|) (ATOM |s2|)) '|failed|) + (t + (DO ((G169646 NIL + (OR (NULL |s1|) (NULL |s2|) + (BOOT-EQUAL SL '|failed|)))) + (G169646 NIL) + (SEQ (EXIT (PROGN + (setq SL + (|unifyStruct| (CAR |s1|) + (CAR |s2|) SL)) + (setq |s1| (CDR |s1|)) + (setq |s2| (CDR |s2|)))))) + (COND ((OR |s1| |s2|) '|failed|) (t SL)))))))))) ;unifyStructVar(v,s,SL) == ; -- the first argument is a pattern variable, which is not substituted @@ -5779,7 +6318,7 @@ the types A and B themselves are not sorted by preference. ; ns0 := subCopy(s0, SL) ; ns1 := subCopy(s1, SL) ; containsVars ns0 or containsVars ns1 => -; $hope:= 'T +; $hope:= t ; 'failed ; if canCoerce(ns0, ns1) then s3 := s1 ; else if canCoerce(ns1, ns0) then s3 := s0 @@ -5803,58 +6342,66 @@ the types A and B themselves are not sorted by preference. ; augmentSub(v,s,SL) (DEFUN |unifyStructVar| (|v| |s| SL) - (PROG (|ps| |s1| |s0| S |ns0| |ns1| |s3|) - (RETURN - (COND - ((CONTAINED |v| |s|) (QUOTE |failed|)) - ((QUOTE T) - (SPADLET |ps| (LASSOC |s| SL)) - (SPADLET |s1| (COND (|ps| |ps|) ((QUOTE T) |s|))) - (COND - ((OR (SPADLET |s0| (LASSOC |v| SL)) (SPADLET |s0| (LASSOC |v| |$Subst|))) - (SPADLET S (|unifyStruct| |s0| |s1| (COPY SL))) - (COND - ((BOOT-EQUAL S (QUOTE |failed|)) + (PROG (|ps| |s1| |s0| S |ns0| |ns1| |s3|) + (declare (special |$domPvar| |$hope| |$Coerce| |$Subst|)) + (RETURN + (COND + ((CONTAINED |v| |s|) '|failed|) + (t (setq |ps| (LASSOC |s| SL)) + (setq |s1| (COND (|ps| |ps|) (t |s|))) (COND - ((AND |$Coerce| (NULL (ATOM |s0|)) (|constructor?| (CAR |s0|))) - (COND - ((OR (|containsVars| |s0|) (|containsVars| |s1|)) - (SPADLET |ns0| (|subCopy| |s0| SL)) - (SPADLET |ns1| (|subCopy| |s1| SL)) - (COND - ((OR (|containsVars| |ns0|) (|containsVars| |ns1|)) - (SPADLET |$hope| (QUOTE T)) - (QUOTE |failed|)) - ((QUOTE T) - (COND - ((|canCoerce| |ns0| |ns1|) (SPADLET |s3| |s1|)) - ((|canCoerce| |ns1| |ns0|) (SPADLET |s3| |s0|)) - ((QUOTE T) (SPADLET |s3| NIL))) - (COND - (|s3| - (COND - ((NEQUAL |s3| |s0|) - (SPADLET SL (|augmentSub| |v| |s3| SL)))) - (COND - ((AND (NEQUAL |s3| |s1|) (|isPatternVar| |s|)) - (SPADLET SL (|augmentSub| |s| |s3| SL)))) - SL) - ((QUOTE T) (QUOTE |failed|)))))) - (|$domPvar| - (SPADLET |s3| (|resolveTT| |s0| |s1|)) - (COND - (|s3| - (COND - ((NEQUAL |s3| |s0|) (SPADLET SL (|augmentSub| |v| |s3| SL)))) + ((OR (setq |s0| (LASSOC |v| SL)) + (setq |s0| (LASSOC |v| |$Subst|))) + (setq S (|unifyStruct| |s0| |s1| (COPY SL))) + (COND + ((BOOT-EQUAL S '|failed|) (COND - ((AND (NEQUAL |s3| |s1|) (|isPatternVar| |s|)) - (SPADLET SL (|augmentSub| |s| |s3| SL)))) - SL) - ((QUOTE T) (QUOTE |failed|)))) - ((QUOTE T) (QUOTE |failed|)))) - ((QUOTE T) (QUOTE |failed|)))) - ((QUOTE T) (|augmentSub| |v| |s| S)))) - ((QUOTE T) (|augmentSub| |v| |s| SL)))))))) + ((AND |$Coerce| (NULL (ATOM |s0|)) + (|constructor?| (CAR |s0|))) + (COND + ((OR (|containsVars| |s0|) (|containsVars| |s1|)) + (setq |ns0| (|subCopy| |s0| SL)) + (setq |ns1| (|subCopy| |s1| SL)) + (COND + ((OR (|containsVars| |ns0|) + (|containsVars| |ns1|)) + (setq |$hope| t) '|failed|) + (t + (COND + ((|canCoerce| |ns0| |ns1|) + (setq |s3| |s1|)) + ((|canCoerce| |ns1| |ns0|) + (setq |s3| |s0|)) + (t (setq |s3| NIL))) + (COND + (|s3| (COND + ((NEQUAL |s3| |s0|) + (setq SL + (|augmentSub| |v| |s3| SL)))) + (COND + ((AND (NEQUAL |s3| |s1|) + (|isPatternVar| |s|)) + (setq SL + (|augmentSub| |s| |s3| SL)))) + SL) + (t '|failed|))))) + (|$domPvar| (setq |s3| (|resolveTT| |s0| |s1|)) + (COND + (|s3| (COND + ((NEQUAL |s3| |s0|) + (setq SL + (|augmentSub| |v| |s3| SL)))) + (COND + ((AND (NEQUAL |s3| |s1|) + (|isPatternVar| |s|)) + (setq SL + (|augmentSub| |s| |s3| SL)))) + SL) + (t '|failed|))) + (t '|failed|))) + (t '|failed|))) + (t (|augmentSub| |v| |s| S)))) + (t (|augmentSub| |v| |s| SL)))))))) ;ofCategory(dom,cat) == ; -- entry point to category evaluation from other points than type @@ -5866,28 +6413,14 @@ the types A and B themselves are not sorted by preference. ; cat is ['Join,:cats] => and/[ofCategory(dom,c) for c in cats] ; (hasCaty(dom,cat,NIL) ^= 'failed) -(DEFUN |ofCategory| (|dom| |cat|) - (PROG (|$Subst| |$hope| |cats|) - (DECLARE (SPECIAL |$Subst| |$hope|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$Subst| NIL) - (SPADLET |$hope| NIL) - (COND - ((IDENTP |dom|) NIL) - ((AND (PAIRP |cat|) - (EQ (QCAR |cat|) (QUOTE |Join|)) - (PROGN (SPADLET |cats| (QCDR |cat|)) (QUOTE T))) - (PROG (#0=#:G169696) - (SPADLET #0# (QUOTE T)) - (RETURN - (DO ((#1=#:G169702 NIL (NULL #0#)) - (#2=#:G169703 |cats| (CDR #2#)) - (|c| NIL)) - ((OR #1# (ATOM #2#) (PROGN (SETQ |c| (CAR #2#)) NIL)) #0#) - (SEQ (EXIT (SETQ #0# (AND #0# (|ofCategory| |dom| |c|))))))))) - ((QUOTE T) (NEQUAL (|hasCaty| |dom| |cat| NIL) (QUOTE |failed|))))))))) +(defun |ofCategory| (dom cat) + (let (|$Subst| |$hope| cats) + (declare (special |$Subst| |$hope|)) + (cond + ((identp dom) nil) + ((and (listp cat) (eq (car cat) '|Join|)) + (every #'(lambda (c) (|ofCategory| dom c)) (cdr cat))) + (t (NEQUAL (|hasCaty| dom cat nil) '|failed|))))) ;printMms(mmS) == ; -- mmS a list of modemap signatures @@ -5905,55 +6438,68 @@ the types A and B themselves are not sorted by preference. ; '" from ",prefix2String CAR sig) ; sayMSG '" " +; NO UNIT TEST (DEFUN |printMms| (|mmS|) - (PROG (|sig| |imp| |istr|) - (RETURN - (SEQ - (PROGN - (|sayMSG| (MAKESTRING " ")) - (DO ((#0=#:G169736 |mmS| (CDR #0#)) - (#1=#:G169722 NIL) - (|i| 1 (QSADD1 |i|))) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN - (PROGN (SPADLET |sig| (CAR #1#)) (SPADLET |imp| (CADR #1#)) #1#) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |istr| - (STRCONC (MAKESTRING "[") (STRINGIMAGE |i|) (MAKESTRING "]"))) - (COND - ((EQL (QCSIZE |istr|) 3) - (SPADLET |istr| (STRCONC |istr| (MAKESTRING " "))))) - (|sayMSG| - (APPEND (|bright| |istr|) - (CONS "signature: " (|formatSignature| (CDR |sig|))))) - (COND - ((BOOT-EQUAL (CAR |sig|) (QUOTE |local|)) - (|sayMSG| - (CONS " implemented: local function " (CONS |imp| NIL)))) - ((AND (PAIRP |imp|) (EQ (QCAR |imp|) (QUOTE XLAM))) - (|sayMSG| - (|concat| " implemented: XLAM from " - (|prefix2String| (CAR |sig|))))) - ((QUOTE T) - (|sayMSG| - (|concat| " implemented: slot " |imp| - " from " (|prefix2String| (CAR |sig|)))))))))) - (|sayMSG| (MAKESTRING " "))))))) + (PROG (|sig| |imp| |istr|) + (RETURN + (SEQ (PROGN + (|sayMSG| " ") + (DO ((G169736 |mmS| (CDR G169736)) (G169722 NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G169736) + (PROGN (SETQ G169722 (CAR G169736)) NIL) + (PROGN + (PROGN + (setq |sig| (CAR G169722)) + (setq |imp| (CADR G169722)) + G169722) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (setq |istr| + (STRCONC "[" + (STRINGIMAGE |i|) + "]")) + (COND + ((EQL (QCSIZE |istr|) 3) + (setq |istr| + (STRCONC |istr| + " ")))) + (|sayMSG| + (APPEND (|bright| |istr|) + (CONS + "signature: " + (|formatSignature| + (CDR |sig|))))) + (COND + ((BOOT-EQUAL (CAR |sig|) '|local|) + (|sayMSG| + (CONS + " implemented: local function " + (CONS |imp| NIL)))) + ((AND (PAIRP |imp|) + (EQ (QCAR |imp|) 'XLAM)) + (|sayMSG| + (|concat| + " implemented: XLAM from " + (|prefix2String| (CAR |sig|))))) + (t + (|sayMSG| + (|concat| + " implemented: slot " + |imp| " from " + (|prefix2String| (CAR |sig|)))))))))) + (|sayMSG| " ")))))) ;containsVars(t) == ; -- tests whether term t contains a * variable ; atom t => isPatternVar t ; containsVars1(t) -(DEFUN |containsVars| (|t|) - (COND - ((ATOM |t|) (|isPatternVar| |t|)) - ((QUOTE T) (|containsVars1| |t|)))) +(defun |containsVars| (arg) + (if (atom arg) + (|isPatternVar| arg) + (|containsVars1| arg))) ;containsVars1(t) == ; -- recursive version, which works on a list @@ -5966,30 +6512,20 @@ the types A and B themselves are not sorted by preference. ; atom t2 => isPatternVar t2 ; containsVars1(t2) -(DEFUN |containsVars1| (|t|) - (PROG (|t1| |t2|) - (RETURN - (PROGN - (SPADLET |t1| (CAR |t|)) - (SPADLET |t2| (CDR |t|)) - (COND - ((ATOM |t1|) - (OR - (|isPatternVar| |t1|) - (COND - ((ATOM |t2|) (|isPatternVar| |t2|)) - ((QUOTE T) (|containsVars1| |t2|))))) - ((QUOTE T) - (OR - (|containsVars1| |t1|) - (COND - ((ATOM |t2|) (|isPatternVar| |t2|)) - ((QUOTE T) (|containsVars1| |t2|)))))))))) +(defun |containsVars1| (arg) + (let ((t1 (car arg)) (t2 (cdr arg))) + (if (atom t1) + (or (|isPatternVar| t1) + (if (atom t2) (|isPatternVar| t2) (|containsVars1| t2))) + (or (|containsVars1| t1) + (if (atom t2) (|isPatternVar| t2) (|containsVars1| t2)))))) ;isPartialMode m == ; CONTAINED($EmptyMode,m) -(DEFUN |isPartialMode| (|m|) (CONTAINED |$EmptyMode| |m|)) +(defun |isPartialMode| (|m|) + (declare (special |$EmptyMode|)) + (contained |$EmptyMode| |m|)) ;getSymbolType var == ;-- var is a pattern variable @@ -5998,14 +6534,15 @@ the types A and B themselves are not sorted by preference. ; $SymbolType:= CONS(CONS(var,t),$SymbolType) ; t -(DEFUN |getSymbolType| (|var|) - (PROG (|p| |t|) - (RETURN - (COND - ((SPADLET |p| (ASSQ |var| |$SymbolType|)) (CDR |p|)) - ((QUOTE T) - (SPADLET |t| (QUOTE (|Polynomial| (|Integer|)))) - (SPADLET |$SymbolType| (CONS (CONS |var| |t|) |$SymbolType|)) |t|))))) +(defun |getSymbolType| (var) + (let (p tmp) + (declare (special |$SymbolType|)) + (if (setq p (assq var |$SymbolType|)) + (cdr p) + (progn + (setq tmp '(|Polynomial| (|Integer|))) + (setq |$SymbolType| (cons (cons var tmp) |$SymbolType|)) + tmp)))) ;isEqualOrSubDomain(d1,d2) == ; -- last 2 parts are for tagged unions (hack for now, RSS) @@ -6014,38 +6551,27 @@ the types A and B themselves are not sorted by preference. ; or (atom(d2) and ((d1 is ['Variable,=d2]) or (d1 is [=d2]))) (DEFUN |isEqualOrSubDomain| (|d1| |d2|) - (PROG (|ISTMP#1|) - (RETURN - (OR - (BOOT-EQUAL |d1| |d2|) - (|isSubDomain| |d1| |d2|) - (AND - (ATOM |d1|) - (OR - (AND (PAIRP |d2|) - (EQ (QCAR |d2|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |d2|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (EQUAL (QCAR |ISTMP#1|) |d1|)))) - (AND (PAIRP |d2|) (EQ (QCDR |d2|) NIL) (EQUAL (QCAR |d2|) |d1|)))) - (AND - (ATOM |d2|) - (OR - (AND (PAIRP |d1|) - (EQ (QCAR |d1|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |d1|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (EQUAL (QCAR |ISTMP#1|) |d2|)))) - (AND - (PAIRP |d1|) - (EQ (QCDR |d1|) NIL) - (EQUAL (QCAR |d1|) |d2|)))))))) + (PROG (|ISTMP#1|) + (RETURN + (OR (BOOT-EQUAL |d1| |d2|) (|isSubDomain| |d1| |d2|) + (AND (ATOM |d1|) + (OR (AND (PAIRP |d2|) (EQ (QCAR |d2|) '|Variable|) + (PROGN + (setq |ISTMP#1| (QCDR |d2|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (EQUAL (QCAR |ISTMP#1|) |d1|)))) + (AND (PAIRP |d2|) (EQ (QCDR |d2|) NIL) + (EQUAL (QCAR |d2|) |d1|)))) + (AND (ATOM |d2|) + (OR (AND (PAIRP |d1|) (EQ (QCAR |d1|) '|Variable|) + (PROGN + (setq |ISTMP#1| (QCDR |d1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (EQUAL (QCAR |ISTMP#1|) |d2|)))) + (AND (PAIRP |d1|) (EQ (QCDR |d1|) NIL) + (EQUAL (QCAR |d1|) |d2|)))))))) ;defaultTypeForCategory(cat, SL) == ; -- this function returns a domain belonging to cat @@ -6078,124 +6604,112 @@ the types A and B themselves are not sorted by preference. ; NIL (DEFUN |defaultTypeForCategory| (|cat| SL) - (PROG (|c| |p1| |p2| |p3| |ISTMP#1| |d| |ISTMP#2| |ISTMP#3| |ISTMP#4| - |ISTMP#5| |ISTMP#6| |ISTMP#7|) - (RETURN - (PROGN - (SPADLET |cat| (|subCopy| |cat| SL)) - (SPADLET |c| (CAR |cat|)) - (SPADLET |d| (GETDATABASE |c| (QUOTE DEFAULTDOMAIN))) - (COND - (|d| (CONS |d| (CDR |cat|))) - ((AND (PAIRP |cat|) - (EQ (QCDR |cat|) NIL) - (PROGN (SPADLET |c| (QCAR |cat|)) (QUOTE T))) - (COND - ((BOOT-EQUAL |c| (QUOTE |Field|)) |$RationalNumber|) - ((|member| |c| - (QUOTE (|Ring| - |IntegralDomain| - |EuclideanDomain| - |GcdDomain| - |OrderedRing| - |DifferentialRing|))) - (QUOTE (|Integer|))) - ((BOOT-EQUAL |c| (QUOTE |OrderedSet|)) |$Symbol|) - ((BOOT-EQUAL |c| (QUOTE |FloatingPointSystem|)) (QUOTE (|Float|))) - ((QUOTE T) NIL))) - ((AND (PAIRP |cat|) - (PROGN - (SPADLET |c| (QCAR |cat|)) - (SPADLET |ISTMP#1| (QCDR |cat|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |p1| (QCAR |ISTMP#1|)) (QUOTE T))))) - (COND - ((BOOT-EQUAL |c| (QUOTE |FiniteLinearAggregate|)) - (CONS (QUOTE |Vector|) (CONS |p1| NIL))) - ((BOOT-EQUAL |c| (QUOTE |VectorCategory|)) - (CONS (QUOTE |Vector|) (CONS |p1| NIL))) - ((BOOT-EQUAL |c| (QUOTE |SetAggregate|)) - (CONS (QUOTE |Set|) (CONS |p1| NIL))) - ((BOOT-EQUAL |c| (QUOTE |SegmentCategory|)) - (CONS (QUOTE |Segment|) (CONS |p1| NIL))) - ((QUOTE T) NIL))) - ((AND (PAIRP |cat|) - (PROGN - (SPADLET |c| (QCAR |cat|)) - (SPADLET |ISTMP#1| (QCDR |cat|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |p1| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |p2| (QCAR |ISTMP#2|)) (QUOTE T))))))) - NIL) - ((AND (PAIRP |cat|) - (PROGN - (SPADLET |c| (QCAR |cat|)) - (SPADLET |ISTMP#1| (QCDR |cat|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |p1| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |p2| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN (SPADLET |p3| (QCAR |ISTMP#3|)) (QUOTE T))))))))) - (COND - ((AND (PAIRP |cat|) - (EQ (QCAR |cat|) (QUOTE |MatrixCategory|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cat|)) - (AND - (PAIRP |ISTMP#1|) + (PROG (|c| |p1| |p2| |p3| |ISTMP#1| |d| |ISTMP#2| |ISTMP#3| |ISTMP#4| + |ISTMP#5| |ISTMP#6| |ISTMP#7|) + (declare (special |$Symbol| |$RationalNumber|)) + (RETURN + (PROGN + (setq |cat| (|subCopy| |cat| SL)) + (setq |c| (CAR |cat|)) + (setq |d| (GETDATABASE |c| 'DEFAULTDOMAIN)) + (COND + (|d| (CONS |d| (CDR |cat|))) + ((AND (PAIRP |cat|) (EQ (QCDR |cat|) NIL) + (PROGN (setq |c| (QCAR |cat|)) t)) + (COND + ((BOOT-EQUAL |c| '|Field|) |$RationalNumber|) + ((|member| |c| + '(|Ring| |IntegralDomain| |EuclideanDomain| + |GcdDomain| |OrderedRing| + |DifferentialRing|)) + '(|Integer|)) + ((BOOT-EQUAL |c| '|OrderedSet|) |$Symbol|) + ((BOOT-EQUAL |c| '|FloatingPointSystem|) '(|Float|)) + (t NIL))) + ((AND (PAIRP |cat|) (PROGN - (SPADLET |d| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) (QUOTE |Vector|)) - (PROGN - (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) - (AND - (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (EQUAL (QCAR |ISTMP#4|) |d|))))) - (PROGN - (SPADLET |ISTMP#5| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |ISTMP#6| (QCAR |ISTMP#5|)) - (AND - (PAIRP |ISTMP#6|) - (EQ (QCAR |ISTMP#6|) (QUOTE |Vector|)) - (PROGN - (SPADLET |ISTMP#7| (QCDR |ISTMP#6|)) - (AND - (PAIRP |ISTMP#7|) - (EQ (QCDR |ISTMP#7|) NIL) - (EQUAL (QCAR |ISTMP#7|) |d|)))))))))))) - (CONS (QUOTE |Matrix|) (CONS |d| NIL))) - ((QUOTE T) NIL))) - ((QUOTE T) NIL)))))) - + (setq |c| (QCAR |cat|)) + (setq |ISTMP#1| (QCDR |cat|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (setq |p1| (QCAR |ISTMP#1|)) t)))) + (COND + ((BOOT-EQUAL |c| '|FiniteLinearAggregate|) + (CONS '|Vector| (CONS |p1| NIL))) + ((BOOT-EQUAL |c| '|VectorCategory|) + (CONS '|Vector| (CONS |p1| NIL))) + ((BOOT-EQUAL |c| '|SetAggregate|) + (CONS '|Set| (CONS |p1| NIL))) + ((BOOT-EQUAL |c| '|SegmentCategory|) + (CONS '|Segment| (CONS |p1| NIL))) + (t NIL))) + ((AND (PAIRP |cat|) + (PROGN + (setq |c| (QCAR |cat|)) + (setq |ISTMP#1| (QCDR |cat|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |p1| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (setq |p2| (QCAR |ISTMP#2|)) + t)))))) + NIL) + ((AND (PAIRP |cat|) + (PROGN + (setq |c| (QCAR |cat|)) + (setq |ISTMP#1| (QCDR |cat|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |p1| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (setq |p2| (QCAR |ISTMP#2|)) + (setq |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (setq |p3| (QCAR |ISTMP#3|)) + t)))))))) + (COND + ((AND (PAIRP |cat|) (EQ (QCAR |cat|) '|MatrixCategory|) + (PROGN + (setq |ISTMP#1| (QCDR |cat|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (setq |d| (QCAR |ISTMP#1|)) + (setq |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (setq |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) '|Vector|) + (PROGN + (setq |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (EQUAL (QCAR |ISTMP#4|) |d|))))) + (PROGN + (setq |ISTMP#5| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (setq |ISTMP#6| + (QCAR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) + (EQ (QCAR |ISTMP#6|) '|Vector|) + (PROGN + (setq |ISTMP#7| + (QCDR |ISTMP#6|)) + (AND (PAIRP |ISTMP#7|) + (EQ (QCDR |ISTMP#7|) NIL) + (EQUAL (QCAR |ISTMP#7|) |d|)))))))))))) + (CONS '|Matrix| (CONS |d| NIL))) + (t NIL))) + (t NIL)))))) @ \eject