From 6c0cc18deacadb592fe3d68c5585979f6902cd1a Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 3 May 2010 20:51:40 +0000 Subject: Generate more readable code for functor definitions. * interp/nruncomp.boot (washFunctorBody): New. (buildFunctor): Use it. * interp/g-opt.boot (optBind): New. (optLIST): Likewise. --- src/algebra/strap/QFCAT-.lsp | 238 ++++++++++++++++++++----------------------- 1 file changed, 112 insertions(+), 126 deletions(-) (limited to 'src/algebra/strap/QFCAT-.lsp') diff --git a/src/algebra/strap/QFCAT-.lsp b/src/algebra/strap/QFCAT-.lsp index 3d8412d1..aa8a25a6 100644 --- a/src/algebra/strap/QFCAT-.lsp +++ b/src/algebra/strap/QFCAT-.lsp @@ -302,132 +302,118 @@ (|getShellEntry| $ 112)))))))) (DEFUN |QuotientFieldCategory&| (|#1| |#2|) - (PROG (|dv$1| |dv$2| |dv$| $ |pv$|) - (RETURN - (PROGN - (LETT |dv$1| (|devaluate| |#1|) - . #0=(|QuotientFieldCategory&|)) - (LETT |dv$2| (|devaluate| |#2|) . #0#) - (LETT |dv$| - (LIST '|QuotientFieldCategory&| |dv$1| |dv$2|) . #0#) - (LETT $ (|newShell| 123) . #0#) - (|setShellEntry| $ 0 |dv$|) - (|setShellEntry| $ 3 - (LETT |pv$| - (|buildPredVector| 0 0 - (LIST (|HasCategory| |#2| - '(|PolynomialFactorizationExplicit|)) - (|HasCategory| |#2| - '(|IntegerNumberSystem|)) - (|HasCategory| |#2| '(|EuclideanDomain|)) - (|HasCategory| |#2| - '(|RetractableTo| (|Symbol|))) - (|HasCategory| |#2| - '(|CharacteristicNonZero|)) - (|HasCategory| |#2| - '(|CharacteristicZero|)) - (|HasCategory| |#2| - '(|ConvertibleTo| (|InputForm|))) - (|HasCategory| |#2| '(|RealConstant|)) - (|HasCategory| |#2| - '(|OrderedIntegralDomain|)) - (|HasCategory| |#2| '(|OrderedSet|)) - (|HasCategory| |#2| - '(|RetractableTo| (|Integer|))) - (|HasCategory| |#2| '(|StepThrough|)))) . #0#)) - (|stuffDomainSlots| $) - (|setShellEntry| $ 6 |#1|) - (|setShellEntry| $ 7 |#2|) - (COND - ((|testBitVector| |pv$| 12) - (PROGN - (|setShellEntry| $ 16 - (CONS (|dispatchFunction| |QFCAT-;init;A;3|) $)) - (|setShellEntry| $ 20 - (CONS (|dispatchFunction| |QFCAT-;nextItem;AU;4|) $))))) - (COND - ((|testBitVector| |pv$| 7) - (|setShellEntry| $ 40 - (CONS (|dispatchFunction| |QFCAT-;convert;AIf;9|) $)))) - (COND - ((|testBitVector| |pv$| 8) - (PROGN - (|setShellEntry| $ 44 - (CONS (|dispatchFunction| |QFCAT-;convert;AF;10|) $)) - (|setShellEntry| $ 48 - (CONS (|dispatchFunction| |QFCAT-;convert;ADf;11|) $))))) - (COND - ((|testBitVector| |pv$| 9) - (COND - ((|HasAttribute| |#2| '|canonicalUnitNormal|) - (|setShellEntry| $ 51 - (CONS (|dispatchFunction| |QFCAT-;<;2AB;12|) $))) - ('T - (|setShellEntry| $ 51 - (CONS (|dispatchFunction| |QFCAT-;<;2AB;13|) $))))) - ((|testBitVector| |pv$| 10) - (|setShellEntry| $ 51 - (CONS (|dispatchFunction| |QFCAT-;<;2AB;14|) $)))) - (COND - ((|testBitVector| |pv$| 3) - (|setShellEntry| $ 55 - (CONS (|dispatchFunction| |QFCAT-;fractionPart;2A;15|) - $)))) - (COND - ((|testBitVector| |pv$| 4) - (PROGN - (|setShellEntry| $ 58 - (CONS (|dispatchFunction| |QFCAT-;coerce;SA;16|) $)) - (|setShellEntry| $ 61 - (CONS (|dispatchFunction| |QFCAT-;retract;AS;17|) $)) - (|setShellEntry| $ 66 - (CONS (|dispatchFunction| |QFCAT-;retractIfCan;AU;18|) - $))))) - (COND - ((|HasCategory| |#2| - '(|ConvertibleTo| (|Pattern| (|Integer|)))) - (PROGN - (|setShellEntry| $ 71 - (CONS (|dispatchFunction| |QFCAT-;convert;AP;19|) $)) - (COND - ((|HasCategory| |#2| '(|PatternMatchable| (|Integer|))) - (|setShellEntry| $ 76 - (CONS (|dispatchFunction| - |QFCAT-;patternMatch;AP2Pmr;20|) - $))))))) - (COND - ((|HasCategory| |#2| - '(|ConvertibleTo| (|Pattern| (|Float|)))) - (PROGN - (|setShellEntry| $ 80 - (CONS (|dispatchFunction| |QFCAT-;convert;AP;21|) $)) - (COND - ((|HasCategory| |#2| '(|PatternMatchable| (|Float|))) - (|setShellEntry| $ 85 - (CONS (|dispatchFunction| - |QFCAT-;patternMatch;AP2Pmr;22|) - $))))))) - (COND - ((|testBitVector| |pv$| 11) - (PROGN - (|setShellEntry| $ 91 - (CONS (|dispatchFunction| |QFCAT-;coerce;FA;23|) $)) - (COND - ((|domainEqual| |#2| (|Integer|))) - ('T - (PROGN - (|setShellEntry| $ 93 - (CONS (|dispatchFunction| |QFCAT-;retract;AI;24|) - $)) - (|setShellEntry| $ 96 - (CONS (|dispatchFunction| - |QFCAT-;retractIfCan;AU;25|) - $)))))))) - (COND - ((|testBitVector| |pv$| 2) - (|setShellEntry| $ 99 - (CONS (|dispatchFunction| |QFCAT-;random;A;26|) $)))) - $)))) + (LET* ((|dv$1| (|devaluate| |#1|)) (|dv$2| (|devaluate| |#2|)) + (|dv$| (LIST '|QuotientFieldCategory&| |dv$1| |dv$2|)) + ($ (|newShell| 123)) + (|pv$| (|buildPredVector| 0 0 + (LIST (|HasCategory| |#2| + '(|PolynomialFactorizationExplicit|)) + (|HasCategory| |#2| '(|IntegerNumberSystem|)) + (|HasCategory| |#2| '(|EuclideanDomain|)) + (|HasCategory| |#2| + (LIST '|RetractableTo| '(|Symbol|))) + (|HasCategory| |#2| + '(|CharacteristicNonZero|)) + (|HasCategory| |#2| '(|CharacteristicZero|)) + (|HasCategory| |#2| + (LIST '|ConvertibleTo| '(|InputForm|))) + (|HasCategory| |#2| '(|RealConstant|)) + (|HasCategory| |#2| + '(|OrderedIntegralDomain|)) + (|HasCategory| |#2| '(|OrderedSet|)) + (|HasCategory| |#2| + (LIST '|RetractableTo| '(|Integer|))) + (|HasCategory| |#2| '(|StepThrough|)))))) + (|setShellEntry| $ 0 |dv$|) + (|setShellEntry| $ 3 |pv$|) + (|stuffDomainSlots| $) + (|setShellEntry| $ 6 |#1|) + (|setShellEntry| $ 7 |#2|) + (COND + ((|testBitVector| |pv$| 12) + (PROGN + (|setShellEntry| $ 16 + (CONS (|dispatchFunction| |QFCAT-;init;A;3|) $)) + (|setShellEntry| $ 20 + (CONS (|dispatchFunction| |QFCAT-;nextItem;AU;4|) $))))) + (COND + ((|testBitVector| |pv$| 7) + (|setShellEntry| $ 40 + (CONS (|dispatchFunction| |QFCAT-;convert;AIf;9|) $)))) + (COND + ((|testBitVector| |pv$| 8) + (PROGN + (|setShellEntry| $ 44 + (CONS (|dispatchFunction| |QFCAT-;convert;AF;10|) $)) + (|setShellEntry| $ 48 + (CONS (|dispatchFunction| |QFCAT-;convert;ADf;11|) $))))) + (COND + ((|testBitVector| |pv$| 9) + (COND + ((|HasAttribute| |#2| '|canonicalUnitNormal|) + (|setShellEntry| $ 51 + (CONS (|dispatchFunction| |QFCAT-;<;2AB;12|) $))) + ('T + (|setShellEntry| $ 51 + (CONS (|dispatchFunction| |QFCAT-;<;2AB;13|) $))))) + ((|testBitVector| |pv$| 10) + (|setShellEntry| $ 51 + (CONS (|dispatchFunction| |QFCAT-;<;2AB;14|) $)))) + (COND + ((|testBitVector| |pv$| 3) + (|setShellEntry| $ 55 + (CONS (|dispatchFunction| |QFCAT-;fractionPart;2A;15|) $)))) + (COND + ((|testBitVector| |pv$| 4) + (PROGN + (|setShellEntry| $ 58 + (CONS (|dispatchFunction| |QFCAT-;coerce;SA;16|) $)) + (|setShellEntry| $ 61 + (CONS (|dispatchFunction| |QFCAT-;retract;AS;17|) $)) + (|setShellEntry| $ 66 + (CONS (|dispatchFunction| |QFCAT-;retractIfCan;AU;18|) $))))) + (COND + ((|HasCategory| |#2| '(|ConvertibleTo| (|Pattern| (|Integer|)))) + (PROGN + (|setShellEntry| $ 71 + (CONS (|dispatchFunction| |QFCAT-;convert;AP;19|) $)) + (COND + ((|HasCategory| |#2| '(|PatternMatchable| (|Integer|))) + (|setShellEntry| $ 76 + (CONS (|dispatchFunction| + |QFCAT-;patternMatch;AP2Pmr;20|) + $))))))) + (COND + ((|HasCategory| |#2| '(|ConvertibleTo| (|Pattern| (|Float|)))) + (PROGN + (|setShellEntry| $ 80 + (CONS (|dispatchFunction| |QFCAT-;convert;AP;21|) $)) + (COND + ((|HasCategory| |#2| '(|PatternMatchable| (|Float|))) + (|setShellEntry| $ 85 + (CONS (|dispatchFunction| + |QFCAT-;patternMatch;AP2Pmr;22|) + $))))))) + (COND + ((|testBitVector| |pv$| 11) + (PROGN + (|setShellEntry| $ 91 + (CONS (|dispatchFunction| |QFCAT-;coerce;FA;23|) $)) + (COND + ((|domainEqual| |#2| (|Integer|))) + ('T + (PROGN + (|setShellEntry| $ 93 + (CONS (|dispatchFunction| |QFCAT-;retract;AI;24|) $)) + (|setShellEntry| $ 96 + (CONS (|dispatchFunction| + |QFCAT-;retractIfCan;AU;25|) + $)))))))) + (COND + ((|testBitVector| |pv$| 2) + (|setShellEntry| $ 99 + (CONS (|dispatchFunction| |QFCAT-;random;A;26|) $)))) + $)) (MAKEPROP '|QuotientFieldCategory&| '|infovec| (LIST '#(NIL NIL NIL NIL NIL NIL (|local| |#1|) (|local| |#2|) -- cgit v1.2.3