diff --git a/changelog b/changelog index 4db8b59..37929d4 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +20091006 tpd src/axiom-website/patches.html 20091006.03.tpd.patch +20091006 tpd src/interp/i-analy.lisp cleanup 20091006 tpd src/axiom-website/patches.html 20091006.02.tpd.patch 20091006 tpd src/interp/i-code.lisp cleanup 20091006 tpd src/axiom-website/patches.html 20091006.01.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 9d4c878..55e56ff 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2111,5 +2111,7 @@ src/interp/i-coerfn.lisp cleanup
src/interp/i-coerce.lisp cleanup
20091006.02.tpd.patch src/interp/i-code.lisp cleanup
+20091006.03.tpd.patch +src/interp/i-analy.lisp cleanup
diff --git a/src/interp/i-analy.lisp.pamphlet b/src/interp/i-analy.lisp.pamphlet index e46d539..e5f860e 100644 --- a/src/interp/i-analy.lisp.pamphlet +++ b/src/interp/i-analy.lisp.pamphlet @@ -18,7 +18,9 @@ ;--% Basic Object Type Identification ;getBasicMode x == getBasicMode0(x,$useIntegerSubdomain) -(DEFUN |getBasicMode| (|x|) (|getBasicMode0| |x| |$useIntegerSubdomain|)) +(DEFUN |getBasicMode| (|x|) + (DECLARE (SPECIAL |$useIntegerSubdomain|)) + (|getBasicMode0| |x| |$useIntegerSubdomain|)) ;getBasicMode0(x,useIntegerSubdomain) == ; -- if x is one of the basic types (Integer String Float Boolean) then @@ -36,21 +38,24 @@ ; nil (DEFUN |getBasicMode0| (|x| |useIntegerSubdomain|) - (COND - ((NULL |x|) |$EmptyMode|) - ((STRINGP |x|) |$String|) - ((INTEGERP |x|) - (COND - (|useIntegerSubdomain| + (DECLARE (SPECIAL |$NoValueMode| |$DoubleFloat| |$Integer| + |$PositiveInteger| |$NonNegativeInteger| |$String| + |$EmptyMode|)) + (COND + ((NULL |x|) |$EmptyMode|) + ((STRINGP |x|) |$String|) + ((INTEGERP |x|) (COND - ((> |x| 0) |$PositiveInteger|) - ((EQL |x| 0) |$NonNegativeInteger|) - ((QUOTE T) |$Integer|))) - ((QUOTE T) |$Integer|))) - ((FLOATP |x|) |$DoubleFloat|) - ((OR (BOOT-EQUAL |x| (QUOTE |noBranch|)) (BOOT-EQUAL |x| (QUOTE |noValue|))) - |$NoValueMode|) - ((QUOTE T) NIL))) + (|useIntegerSubdomain| + (COND + ((> |x| 0) |$PositiveInteger|) + ((EQL |x| 0) |$NonNegativeInteger|) + ('T |$Integer|))) + ('T |$Integer|))) + ((FLOATP |x|) |$DoubleFloat|) + ((OR (BOOT-EQUAL |x| '|noBranch|) (BOOT-EQUAL |x| '|noValue|)) + |$NoValueMode|) + ('T NIL))) ;getBasicObject x == ; INTEGERP x => @@ -65,20 +70,23 @@ ; NIL (DEFUN |getBasicObject| (|x|) - (PROG (|t|) - (RETURN - (COND - ((INTEGERP |x|) - (SPADLET |t| + (PROG (|t|) + (DECLARE (SPECIAL |$DoubleFloat| |$String| |$Integer| + |$NonNegativeInteger| |$PositiveInteger| + |$useIntegerSubdomain|)) + (RETURN (COND - ((NULL |$useIntegerSubdomain|) |$Integer|) - ((> |x| 0) |$PositiveInteger|) - ((EQL |x| 0) |$NonNegativeInteger|) - ((QUOTE T) |$Integer|))) - (|objNewWrap| |x| |t|)) - ((STRINGP |x|) (|objNewWrap| |x| |$String|)) - ((FLOATP |x|) (|objNewWrap| |x| |$DoubleFloat|)) - ((QUOTE T) NIL))))) + ((INTEGERP |x|) + (SPADLET |t| + (COND + ((NULL |$useIntegerSubdomain|) |$Integer|) + ((> |x| 0) |$PositiveInteger|) + ((EQL |x| 0) |$NonNegativeInteger|) + ('T |$Integer|))) + (|objNewWrap| |x| |t|)) + ((STRINGP |x|) (|objNewWrap| |x| |$String|)) + ((FLOATP |x|) (|objNewWrap| |x| |$DoubleFloat|)) + ('T NIL))))) ;getMinimalVariableTower(var,t) == ; -- gets the minimal polynomial subtower of t that contains the @@ -104,90 +112,78 @@ ; getMinimalVariableTower(var,t') (DEFUN |getMinimalVariableTower| (|var| |t|) - (PROG (D |ISTMP#3| |up| |mp| |ISTMP#1| |u| |ISTMP#2| |t'|) - (RETURN - (COND - ((OR (STRINGP |t|) (IDENTP |t|)) NIL) - ((BOOT-EQUAL |t| |$Symbol|) |t|) - ((AND (PAIRP |t|) - (EQ (QCAR |t|) (QUOTE |Variable|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |u| (QCAR |ISTMP#1|)) (QUOTE T))))) - (COND ((BOOT-EQUAL |u| |var|) |t|) ((QUOTE T) NIL))) - ((AND (PAIRP |t|) - (EQ (QCAR |t|) (QUOTE |Polynomial|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - |t|) - ((AND (PAIRP |t|) - (EQ (QCAR |t|) (QUOTE |RationalFunction|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) - (CONS (QUOTE |Polynomial|) (CONS D NIL))) - ((AND (PAIRP |t|) - (PROGN - (SPADLET |up| (QCAR |t|)) - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |t'| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) + (PROG (D |ISTMP#3| |up| |mp| |ISTMP#1| |u| |ISTMP#2| |t'|) + (DECLARE (SPECIAL |$multivariateDomains| |$univariateDomains| + |$Symbol|)) + (RETURN + (COND + ((OR (STRINGP |t|) (IDENTP |t|)) NIL) + ((BOOT-EQUAL |t| |$Symbol|) |t|) + ((AND (PAIRP |t|) (EQ (QCAR |t|) '|Variable|) (PROGN - (SPADLET |u| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL))))))) - (MEMQ |up| |$univariateDomains|)) - (COND - ((BOOT-EQUAL |u| |var|) |t|) - ((QUOTE T) (|getMinimalVariableTower| |var| |t'|)))) - ((AND (PAIRP |t|) - (PROGN - (SPADLET |up| (QCAR |t|)) - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |u| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |t'| (QCAR |ISTMP#2|)) (QUOTE T)))))) - (MEMQ |up| |$univariateDomains|)) - (COND - ((BOOT-EQUAL |u| |var|) |t|) - ((QUOTE T) (|getMinimalVariableTower| |var| |t'|)))) - ((AND (PAIRP |t|) - (PROGN - (SPADLET |mp| (QCAR |t|)) - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |u| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |t'| (QCAR |ISTMP#2|)) (QUOTE T)))))) - (MEMQ |mp| |$multivariateDomains|)) - (COND - ((|member| |var| |u|) |t|) - ((QUOTE T) (|getMinimalVariableTower| |var| |t'|)))) - ((NULL (SPADLET |t'| (|underDomainOf| |t|))) NIL) - ((QUOTE T) (|getMinimalVariableTower| |var| |t'|)))))) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |u| (QCAR |ISTMP#1|)) 'T)))) + (COND ((BOOT-EQUAL |u| |var|) |t|) ('T NIL))) + ((AND (PAIRP |t|) (EQ (QCAR |t|) '|Polynomial|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + |t|) + ((AND (PAIRP |t|) (EQ (QCAR |t|) '|RationalFunction|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) 'T)))) + (CONS '|Polynomial| (CONS D NIL))) + ((AND (PAIRP |t|) + (PROGN + (SPADLET |up| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |t'| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |u| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL))))))) + (MEMQ |up| |$univariateDomains|)) + (COND + ((BOOT-EQUAL |u| |var|) |t|) + ('T (|getMinimalVariableTower| |var| |t'|)))) + ((AND (PAIRP |t|) + (PROGN + (SPADLET |up| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |u| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |t'| (QCAR |ISTMP#2|)) 'T))))) + (MEMQ |up| |$univariateDomains|)) + (COND + ((BOOT-EQUAL |u| |var|) |t|) + ('T (|getMinimalVariableTower| |var| |t'|)))) + ((AND (PAIRP |t|) + (PROGN + (SPADLET |mp| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |u| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |t'| (QCAR |ISTMP#2|)) 'T))))) + (MEMQ |mp| |$multivariateDomains|)) + (COND + ((|member| |var| |u|) |t|) + ('T (|getMinimalVariableTower| |var| |t'|)))) + ((NULL (SPADLET |t'| (|underDomainOf| |t|))) NIL) + ('T (|getMinimalVariableTower| |var| |t'|)))))) ;getMinimalVarMode(id,m) == ; -- This function finds the minimum polynomial subtower type of the @@ -206,21 +202,20 @@ ; defaultMode (DEFUN |getMinimalVarMode| (|id| |m|) - (PROG (|defaultMode| |vl| |um|) - (RETURN - (COND - ((AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Mapping|))) |m|) - ((QUOTE T) - (SPADLET |defaultMode| |$Symbol|) - (COND - ((NULL |m|) |defaultMode|) - ((AND (SPADLET |vl| (|polyVarlist| |m|)) - (OR - (|member| |id| |vl|) - (|member| (QUOTE |all|) |vl|))) - (SUBSTQ (QUOTE (|Integer|)) |$EmptyMode| |m|)) - ((SPADLET |um| (|underDomainOf| |m|)) (|getMinimalVarMode| |id| |um|)) - ((QUOTE T) |defaultMode|))))))) + (PROG (|defaultMode| |vl| |um|) + (DECLARE (SPECIAL |$EmptyMode| |$Symbol|)) + (RETURN + (COND + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Mapping|)) |m|) + ('T (SPADLET |defaultMode| |$Symbol|) + (COND + ((NULL |m|) |defaultMode|) + ((AND (SPADLET |vl| (|polyVarlist| |m|)) + (OR (|member| |id| |vl|) (|member| '|all| |vl|))) + (SUBSTQ '(|Integer|) |$EmptyMode| |m|)) + ((SPADLET |um| (|underDomainOf| |m|)) + (|getMinimalVarMode| |id| |um|)) + ('T |defaultMode|))))))) ;polyVarlist m == ; -- If m is a polynomial type this function returns a list of its @@ -243,40 +238,37 @@ ; nil (DEFUN |polyVarlist| (|m|) - (PROG (|op| |ISTMP#1| |a|) - (RETURN - (COND - ((AND (PAIRP |m|) - (EQUAL (QCAR |m|) |$QuotientField|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |m|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |op| (QCAR |ISTMP#1|)) (QUOTE T))))) - (|polyVarlist| |op|)) - ((AND (PAIRP |m|) - (PROGN - (SPADLET |op| (QCAR |m|)) - (SPADLET |ISTMP#1| (QCDR |m|)) - (AND - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T))))) - (COND - ((|member| |op| - (QUOTE (|UnivariateTaylorSeries| - |UnivariateLaurentSeries| - |UnivariatePuiseuxSeries|))) - (SPADLET |a| (CADDR |m|)) - (SPADLET |a| (|removeQuote| |a|)) (CONS |a| NIL)) - ((|member| |op| (QUOTE (|Polynomial| |RationalFunction| |Expression|))) - (QUOTE (|all|))) - ((QUOTE T) - (SPADLET |a| (|removeQuote| |a|)) - (COND - ((|member| |op| (QUOTE (|UnivariatePolynomial|))) (CONS |a| NIL)) - ((|member| |op| |$multivariateDomains|) |a|))))) - ((QUOTE T) NIL))))) + (PROG (|op| |ISTMP#1| |a|) + (DECLARE (SPECIAL |$multivariateDomains| |$QuotientField|)) + (RETURN + (COND + ((AND (PAIRP |m|) (EQUAL (QCAR |m|) |$QuotientField|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |op| (QCAR |ISTMP#1|)) 'T)))) + (|polyVarlist| |op|)) + ((AND (PAIRP |m|) + (PROGN + (SPADLET |op| (QCAR |m|)) + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) + (COND + ((|member| |op| + '(|UnivariateTaylorSeries| |UnivariateLaurentSeries| + |UnivariatePuiseuxSeries|)) + (SPADLET |a| (CADDR |m|)) (SPADLET |a| (|removeQuote| |a|)) + (CONS |a| NIL)) + ((|member| |op| + '(|Polynomial| |RationalFunction| |Expression|)) + '(|all|)) + ('T (SPADLET |a| (|removeQuote| |a|)) + (COND + ((|member| |op| '(|UnivariatePolynomial|)) + (CONS |a| NIL)) + ((|member| |op| |$multivariateDomains|) |a|))))) + ('T NIL))))) ;--% Pushing Down Target Information ;pushDownTargetInfo(op,target,arglist) == @@ -323,157 +315,195 @@ ; NIL (DEFUN |pushDownTargetInfo| (|op| |target| |arglist|) - (PROG (|n| |pdArgs| |nargs| |x| |targ| |ISTMP#1| S) - (RETURN - (SEQ - (COND - ((BOOT-EQUAL |target| |$OutputForm|) NIL) - ((BOOT-EQUAL |target| |$Any|) NIL) - ((QUOTE T) - (SPADLET |n| (LENGTH |arglist|)) - (|pushDownOnArithmeticVariables| |op| |target| |arglist|) - (COND - ((SPADLET |pdArgs| (|pushDownOp?| |op| |n|)) - (DO ((#0=#:G166265 |pdArgs| (CDR #0#)) (|i| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |i| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |x| (ELT |arglist| |i|)) - (COND - ((NULL (|getTarget| |x|)) (|putTarget| |x| |target|)) - ((QUOTE T) NIL))))))) - ((QUOTE T) - (SPADLET |nargs| (|#| |arglist|)) - (SEQ - (COND - ((EQL 1 |nargs|) - (COND - ((AND - (BOOT-EQUAL |op| (QUOTE SEGMENT)) - (PAIRP |target|) - (EQ (QCAR |target|) (QUOTE |UniversalSegment|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) - (EXIT - (DO ((#1=#:G166274 |arglist| (CDR #1#)) (|x| NIL)) - ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((NULL (|getTarget| |x|)) (|putTarget| |x| S)) - ((QUOTE T) NIL))))))))) - ((EQL 2 |nargs|) - (COND - ((BOOT-EQUAL |op| (QUOTE *)) - (COND - ((NULL (|getTarget| (CADR |arglist|))) - (|putTarget| (CADR |arglist|) |target|))) - (COND - ((|getTarget| (SPADLET |x| (CAR |arglist|))) NIL) - ((NEQUAL (|getUnname| |x|) |$immediateDataSymbol|) - (|putTarget| |x| |target|)) - ((QUOTE T) NIL))) - ((OR (BOOT-EQUAL |op| (QUOTE **)) (BOOT-EQUAL |op| (QUOTE ^))) - (COND - ((NULL (|getTarget| (CAR |arglist|))) - (|putTarget| (CAR |arglist|) |target|)) - ((QUOTE T) NIL))) - ((AND - (BOOT-EQUAL |op| (QUOTE |equation|)) - (PAIRP |target|) - (EQ (QCAR |target|) (QUOTE |Equation|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) - (DO ((#2=#:G166283 |arglist| (CDR #2#)) (|x| NIL)) - ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((NULL (|getTarget| |x|)) (|putTarget| |x| S)) - ((QUOTE T) NIL)))))) - ((AND - (BOOT-EQUAL |op| (QUOTE |gauss|)) - (PAIRP |target|) - (EQ (QCAR |target|) (QUOTE |Gaussian|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) - (DO ((#3=#:G166292 |arglist| (CDR #3#)) (|x| NIL)) - ((OR (ATOM #3#) (PROGN (SETQ |x| (CAR #3#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((NULL (|getTarget| |x|)) (|putTarget| |x| S)) - ((QUOTE T) NIL)))))) - ((BOOT-EQUAL |op| (QUOTE /)) - (SPADLET |targ| + (PROG (|n| |pdArgs| |nargs| |x| |targ| |ISTMP#1| S) + (DECLARE (SPECIAL |$immediateDataSymbol| |$Any| |$OutputForm|)) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |target| |$OutputForm|) NIL) + ((BOOT-EQUAL |target| |$Any|) NIL) + ('T (SPADLET |n| (LENGTH |arglist|)) + (|pushDownOnArithmeticVariables| |op| |target| |arglist|) (COND - ((AND - (PAIRP |target|) - (EQ (QCAR |target|) (QUOTE |Fraction|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) - S) - ((QUOTE T) |target|))) - (DO ((#4=#:G166301 |arglist| (CDR #4#)) (|x| NIL)) - ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((NULL (|getTarget| |x|)) (|putTarget| |x| |targ|)) - ((QUOTE T) NIL)))))) - ((AND - (BOOT-EQUAL |op| (QUOTE SEGMENT)) - (PAIRP |target|) - (EQ (QCAR |target|) (QUOTE |Segment|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) - (DO ((#5=#:G166310 |arglist| (CDR #5#)) (|x| NIL)) - ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((NULL (|getTarget| |x|)) (|putTarget| |x| S)) - ((QUOTE T) NIL)))))) - ((AND - (BOOT-EQUAL |op| (QUOTE SEGMENT)) - (PAIRP |target|) - (EQ (QCAR |target|) (QUOTE |UniversalSegment|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET S (QCAR |ISTMP#1|)) (QUOTE T))))) - (DO ((#6=#:G166319 |arglist| (CDR #6#)) (|x| NIL)) - ((OR (ATOM #6#) (PROGN (SETQ |x| (CAR #6#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((NULL (|getTarget| |x|)) (|putTarget| |x| S)) - ((QUOTE T) NIL)))))) - ((QUOTE T) NIL))) - ((QUOTE T) NIL))))))))))) + ((SPADLET |pdArgs| (|pushDownOp?| |op| |n|)) + (DO ((G166265 |pdArgs| (CDR G166265)) (|i| NIL)) + ((OR (ATOM G166265) + (PROGN (SETQ |i| (CAR G166265)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (ELT |arglist| |i|)) + (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| |target|)) + ('T NIL))))))) + ('T (SPADLET |nargs| (|#| |arglist|)) + (SEQ (COND + ((EQL 1 |nargs|) + (COND + ((AND (BOOT-EQUAL |op| 'SEGMENT) + (PAIRP |target|) + (EQ (QCAR |target|) + '|UniversalSegment|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET S (QCAR |ISTMP#1|)) + 'T)))) + (EXIT (DO ((G166274 |arglist| + (CDR G166274)) + (|x| NIL)) + ((OR (ATOM G166274) + (PROGN + (SETQ |x| (CAR G166274)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| S)) + ('T NIL))))))))) + ((EQL 2 |nargs|) + (COND + ((BOOT-EQUAL |op| '*) + (COND + ((NULL (|getTarget| (CADR |arglist|))) + (|putTarget| (CADR |arglist|) |target|))) + (COND + ((|getTarget| + (SPADLET |x| (CAR |arglist|))) + NIL) + ((NEQUAL (|getUnname| |x|) + |$immediateDataSymbol|) + (|putTarget| |x| |target|)) + ('T NIL))) + ((OR (BOOT-EQUAL |op| '**) + (BOOT-EQUAL |op| '^)) + (COND + ((NULL (|getTarget| (CAR |arglist|))) + (|putTarget| (CAR |arglist|) |target|)) + ('T NIL))) + ((AND (BOOT-EQUAL |op| '|equation|) + (PAIRP |target|) + (EQ (QCAR |target|) '|Equation|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET S (QCAR |ISTMP#1|)) + 'T)))) + (DO ((G166283 |arglist| (CDR G166283)) + (|x| NIL)) + ((OR (ATOM G166283) + (PROGN + (SETQ |x| (CAR G166283)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| S)) + ('T NIL)))))) + ((AND (BOOT-EQUAL |op| '|gauss|) + (PAIRP |target|) + (EQ (QCAR |target|) '|Gaussian|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET S (QCAR |ISTMP#1|)) + 'T)))) + (DO ((G166292 |arglist| (CDR G166292)) + (|x| NIL)) + ((OR (ATOM G166292) + (PROGN + (SETQ |x| (CAR G166292)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| S)) + ('T NIL)))))) + ((BOOT-EQUAL |op| '/) + (SPADLET |targ| + (COND + ((AND (PAIRP |target|) + (EQ (QCAR |target|) + '|Fraction|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET S + (QCAR |ISTMP#1|)) + 'T)))) + S) + ('T |target|))) + (DO ((G166301 |arglist| (CDR G166301)) + (|x| NIL)) + ((OR (ATOM G166301) + (PROGN + (SETQ |x| (CAR G166301)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| |targ|)) + ('T NIL)))))) + ((AND (BOOT-EQUAL |op| 'SEGMENT) + (PAIRP |target|) + (EQ (QCAR |target|) '|Segment|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET S (QCAR |ISTMP#1|)) + 'T)))) + (DO ((G166310 |arglist| (CDR G166310)) + (|x| NIL)) + ((OR (ATOM G166310) + (PROGN + (SETQ |x| (CAR G166310)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| S)) + ('T NIL)))))) + ((AND (BOOT-EQUAL |op| 'SEGMENT) + (PAIRP |target|) + (EQ (QCAR |target|) + '|UniversalSegment|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET S (QCAR |ISTMP#1|)) + 'T)))) + (DO ((G166319 |arglist| (CDR G166319)) + (|x| NIL)) + ((OR (ATOM G166319) + (PROGN + (SETQ |x| (CAR G166319)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| S)) + ('T NIL)))))) + ('T NIL))) + ('T NIL))))))))))) ;pushDownOnArithmeticVariables(op,target,arglist) == ; -- tries to push appropriate target information onto variable @@ -493,37 +523,46 @@ ; arglist (DEFUN |pushDownOnArithmeticVariables| (|op| |target| |arglist|) - (PROG (|xn| |t| |op'| |arglist'|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |target|) (BOOT-EQUAL (CAR |target|) (QUOTE |Variable|))) - NIL) - ((NULL (MEMQ |op| (QUOTE (+ - * ** /)))) NIL) - ((NULL (|containsPolynomial| |target|)) NIL) - ((QUOTE T) - (DO ((#0=#:G166357 |arglist| (CDR #0#)) (|x| NIL) (|i| 1 (QSADD1 |i|))) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((VECP |x|) - (|transferPropsToNode| (SPADLET |xn| (|getUnname| |x|)) |x|) - (COND - ((OR (|getValue| |x|) (BOOT-EQUAL |xn| |$immediateDataSymbol|)) - NIL) - ((QUOTE T) - (SPADLET |t| - (OR (|getMinimalVariableTower| |xn| |target|) |target|)) - (COND - ((NULL (|getTarget| |x|)) (|putTarget| |x| |t|)) - ((QUOTE T) NIL))))) - ((PAIRP |x|) - (SPADLET |op'| (CAR |x|)) - (SPADLET |arglist'| (CDR |x|)) - (|pushDownOnArithmeticVariables| - (|getUnname| |op'|) |target| |arglist'|)))))) - |arglist|)))))) + (PROG (|xn| |t| |op'| |arglist'|) + (DECLARE (SPECIAL |$immediateDataSymbol|)) + (RETURN + (SEQ (COND + ((AND (PAIRP |target|) + (BOOT-EQUAL (CAR |target|) '|Variable|)) + NIL) + ((NULL (MEMQ |op| '(+ - * ** /))) NIL) + ((NULL (|containsPolynomial| |target|)) NIL) + ('T + (DO ((G166357 |arglist| (CDR G166357)) (|x| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G166357) + (PROGN (SETQ |x| (CAR G166357)) NIL)) + NIL) + (SEQ (EXIT (COND + ((VECP |x|) + (|transferPropsToNode| + (SPADLET |xn| (|getUnname| |x|)) |x|) + (COND + ((OR (|getValue| |x|) + (BOOT-EQUAL |xn| + |$immediateDataSymbol|)) + NIL) + ('T + (SPADLET |t| + (OR + (|getMinimalVariableTower| + |xn| |target|) + |target|)) + (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| |t|)) + ('T NIL))))) + ((PAIRP |x|) (SPADLET |op'| (CAR |x|)) + (SPADLET |arglist'| (CDR |x|)) + (|pushDownOnArithmeticVariables| + (|getUnname| |op'|) |target| + |arglist'|)))))) + |arglist|)))))) ;pushDownOp?(op,n) == ; -- determine if for op with n arguments whether for all modemaps @@ -548,67 +587,82 @@ ; reverse ok (DEFUN |pushDownOp?| (|op| |n|) - (PROG (|sig| |ops| |sameAsTarg| |numMms| |targ| |argl| |ok|) - (RETURN - (SEQ - (PROGN - (SPADLET |ops| - (PROG (#0=#:G166383) - (SPADLET #0# NIL) - (RETURN - (DO ((#1=#:G166389 (|getModemapsFromDatabase| |op| |n|) (CDR #1#)) - (#2=#:G166370 NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ #2# (CAR #1#)) NIL) - (PROGN (PROGN (SPADLET |sig| (CAR #2#)) #2#) NIL)) - (NREVERSE0 #0#)) - (SEQ (EXIT (SETQ #0# (CONS |sig| #0#)))))))) - (COND - ((NULL |ops|) NIL) - ((|member| |op| (QUOTE (+ * - |exquo|))) - (PROG (#3=#:G166400) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G166405 (SPADDIFFERENCE |n| 1)) (|i| 0 (QSADD1 |i|))) - ((QSGREATERP |i| #4#) (NREVERSE0 #3#)) - (SEQ (EXIT (SETQ #3# (CONS |i| #3#)))))))) - ((QUOTE T) - (SPADLET |sameAsTarg| (GETZEROVEC |n|)) - (SPADLET |numMms| (LENGTH |ops|)) - (SEQ - (DO ((#5=#:G166413 |ops| (CDR #5#)) (#6=#:G166373 NIL)) - ((OR (ATOM #5#) - (PROGN (SETQ #6# (CAR #5#)) NIL) - (PROGN - (PROGN - (SPADLET |targ| (CADR #6#)) - (SPADLET |argl| (CDDR #6#)) - #6#) - NIL)) - NIL) - (SEQ - (EXIT - (DO ((#7=#:G166424 |argl| (CDR #7#)) - (|arg| NIL) - (|i| 0 (QSADD1 |i|))) - ((OR (ATOM #7#) (PROGN (SETQ |arg| (CAR #7#)) NIL)) NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |targ| |arg|) - (EXIT - (SETELT |sameAsTarg| |i| - (PLUS 1 (ELT |sameAsTarg| |i|)))))))))))) - (SPADLET |ok| NIL) - (DO ((#8=#:G166433 (SPADDIFFERENCE |n| 1)) (|i| 0 (QSADD1 |i|))) - ((QSGREATERP |i| #8#) NIL) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL |numMms| (ELT |sameAsTarg| |i|)) - (SPADLET |ok| (CONS |i| |ok|))) - ((QUOTE T) NIL))))) - (REVERSE |ok|))))))))) + (PROG (|sig| |ops| |sameAsTarg| |numMms| |targ| |argl| |ok|) + (RETURN + (SEQ (PROGN + (SPADLET |ops| + (PROG (G166383) + (SPADLET G166383 NIL) + (RETURN + (DO ((G166389 + (|getModemapsFromDatabase| |op| |n|) + (CDR G166389)) + (G166370 NIL)) + ((OR (ATOM G166389) + (PROGN + (SETQ G166370 (CAR G166389)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| (CAR G166370)) + G166370) + NIL)) + (NREVERSE0 G166383)) + (SEQ (EXIT (SETQ G166383 + (CONS |sig| G166383)))))))) + (COND + ((NULL |ops|) NIL) + ((|member| |op| '(+ * - |exquo|)) + (PROG (G166400) + (SPADLET G166400 NIL) + (RETURN + (DO ((G166405 (SPADDIFFERENCE |n| 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G166405) + (NREVERSE0 G166400)) + (SEQ (EXIT (SETQ G166400 (CONS |i| G166400)))))))) + ('T (SPADLET |sameAsTarg| (GETZEROVEC |n|)) + (SPADLET |numMms| (LENGTH |ops|)) + (SEQ (DO ((G166413 |ops| (CDR G166413)) + (G166373 NIL)) + ((OR (ATOM G166413) + (PROGN + (SETQ G166373 (CAR G166413)) + NIL) + (PROGN + (PROGN + (SPADLET |targ| (CADR G166373)) + (SPADLET |argl| (CDDR G166373)) + G166373) + NIL)) + NIL) + (SEQ (EXIT (DO ((G166424 |argl| + (CDR G166424)) + (|arg| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G166424) + (PROGN + (SETQ |arg| (CAR G166424)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |targ| |arg|) + (EXIT + (SETELT |sameAsTarg| |i| + (PLUS 1 + (ELT |sameAsTarg| |i|)))))))))))) + (SPADLET |ok| NIL) + (DO ((G166433 (SPADDIFFERENCE |n| 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G166433) NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |numMms| + (ELT |sameAsTarg| |i|)) + (SPADLET |ok| (CONS |i| |ok|))) + ('T NIL))))) + (REVERSE |ok|))))))))) ;--% Bottom Up Processing ;-- Also see I-SPEC BOOT for special handlers and I-MAP BOOT for @@ -674,131 +728,163 @@ ; keyedSystemError("S2GE0016",['"bottomUp",'"unknown object form"]) (DEFUN |bottomUp| (|t|) - (PROG (|argl| |v| |om| |r| |opName| |opVal| |dol| |fn| |u| |nargs| |ISTMP#1| - |t1| |t2| |tar| |argModeSetList| |ms| |op| |val| |bm| |m| |id|) - (RETURN - (SEQ - (COND - ((AND (PAIRP |t|) - (PROGN - (SPADLET |op| (QCAR |t|)) - (SPADLET |argl| (QCDR |t|)) - (QUOTE T))) - (SPADLET |tar| (|getTarget| |op|)) - (COND - ((AND (NEQUAL (|getUnname| |op|) |$immediateDataSymbol|) - (SPADLET |v| (|getValue| |op|))) - (SPADLET |om| (|objMode| |v|)) - (COND - ((NULL |tar|) (CONS |om| NIL)) - ((SPADLET |r| (|resolveTM| |om| |tar|)) (CONS |r| NIL)) - ((QUOTE T) (CONS |om| NIL)))) - ((QUOTE T) - (COND - ((ATOM |op|) - (SPADLET |opName| (|getUnname| |op|)) - (COND - ((|member| |opName| |$localVars|) - (|putModeSet| |op| (|bottomUpIdentifier| |op| |opName|))) - ((QUOTE T) (|transferPropsToNode| |opName| |op|)))) - ((QUOTE T) (SPADLET |opName| NIL) (|bottomUp| |op|))) - (SPADLET |opVal| (|getValue| |op|)) - (SPADLET |dol| - (AND (|getAtree| |op| (QUOTE |dollar|)) - (NEQUAL |opName| (QUOTE |construct|)))) - (COND - ((AND (NULL |dol|) - (SPADLET |fn| (GETL |opName| (QUOTE |up|))) - (SPADLET |u| (FUNCALL |fn| |t|))) - |u|) - ((QUOTE T) - (SPADLET |nargs| (|#| |argl|)) - (COND - (|opName| - (DO ((#0=#:G166479 |argl| (CDR #0#)) - (|x| NIL) - (|i| 1 (QSADD1 |i|))) - ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (|putAtree| |x| (QUOTE |callingFunction|) |opName|) - (|putAtree| |x| (QUOTE |argumentNumber|) |i|) - (|putAtree| |x| (QUOTE |totalArgs|) |nargs|))))))) - (COND (|tar| (|pushDownTargetInfo| |opName| |tar| |argl|))) - (COND - ((AND - |opVal| - (PROGN - (SPADLET |ISTMP#1| (|objVal| |opVal|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE MAP)))) - (PROGN - (SPADLET |ISTMP#1| (|getMode| |op|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) - (PROGN (SPADLET |ms| (QCDR |ISTMP#1|)) (QUOTE T)))) - (BOOT-EQUAL (PLUS |nargs| 1) (|#| |ms|))) - (DO ((#1=#:G166489 (CDR |ms|) (CDR #1#)) - (|m| NIL) - (#2=#:G166490 |argl| (CDR #2#)) - (|x| NIL)) - ((OR (ATOM #1#) - (PROGN (SETQ |m| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |x| (CAR #2#)) NIL)) - NIL) - (SEQ (EXIT (|putTarget| |x| |m|)))))) - (SPADLET |argModeSetList| - (PROG (#3=#:G166503) - (SPADLET #3# NIL) - (RETURN - (DO ((#4=#:G166508 |argl| (CDR #4#)) (|x| NIL)) - ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) - (NREVERSE0 #3#)) - (SEQ (EXIT (SETQ #3# (CONS (|bottomUp| |x|) #3#)))))))) - (COND - ((AND (NULL |tar|) (BOOT-EQUAL |opName| (QUOTE *)) (EQL |nargs| 2)) - (SPADLET |t1| (CAAR |argModeSetList|)) - (SPADLET |t2| (CAADR |argModeSetList|)) - (SPADLET |tar| (|computeTypeWithVariablesTarget| |t1| |t2|)) - (COND - (|tar| - (PROGN - (|pushDownTargetInfo| |opName| |tar| |argl|) - (SPADLET |argModeSetList| - (PROG (#5=#:G166518) - (SPADLET #5# NIL) - (RETURN - (DO ((#6=#:G166523 |argl| (CDR #6#)) (|x| NIL)) - ((OR (ATOM #6#) (PROGN (SETQ |x| (CAR #6#)) NIL)) - (NREVERSE0 #5#)) - (SEQ - (EXIT - (SETQ #5# (CONS (|bottomUp| |x|) #5#))))))))))))) - (SPADLET |ms| - (|bottomUpForm| |t| |op| |opName| |argl| |argModeSetList|)) - (SPADLET |op| (CAR |t|)) - (COND - ((AND |$useIntegerSubdomain| - (NULL |tar|) - (NULL |dol|) - (|isEqualOrSubDomain| (CAR |ms|) |$Integer|)) - (SPADLET |val| (|objVal| (|getValue| |op|))) - (COND - ((|isWrapped| |val|) - (SPADLET |val| (|unwrap| |val|)) - (SPADLET |bm| (|getBasicMode| |val|)) - (|putValue| |op| (|objNewWrap| |val| |bm|)) - (|putModeSet| |op| (CONS |bm| NIL))) - ((QUOTE T) |ms|))) - ((QUOTE T) |ms|))))))) - ((SPADLET |m| (|getBasicMode| |t|)) (CONS |m| NIL)) - ((IDENTP (SPADLET |id| (|getUnname| |t|))) - (|putModeSet| |t| (|bottomUpIdentifier| |t| |id|))) - ((QUOTE T) - (|keyedSystemError| 'S2GE0016 - (CONS "bottomUp" (CONS "unknown object form" NIL))))))))) + (PROG (|argl| |v| |om| |r| |opName| |opVal| |dol| |fn| |u| |nargs| + |ISTMP#1| |t1| |t2| |tar| |argModeSetList| |ms| |op| + |val| |bm| |m| |id|) + (DECLARE (SPECIAL |$Integer| |$useIntegerSubdomain| |$localVars| + |$immediateDataSymbol|)) + (RETURN + (SEQ (COND + ((AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |argl| (QCDR |t|)) + 'T)) + (SPADLET |tar| (|getTarget| |op|)) + (COND + ((AND (NEQUAL (|getUnname| |op|) + |$immediateDataSymbol|) + (SPADLET |v| (|getValue| |op|))) + (SPADLET |om| (|objMode| |v|)) + (COND + ((NULL |tar|) (CONS |om| NIL)) + ((SPADLET |r| (|resolveTM| |om| |tar|)) + (CONS |r| NIL)) + ('T (CONS |om| NIL)))) + ('T + (COND + ((ATOM |op|) (SPADLET |opName| (|getUnname| |op|)) + (COND + ((|member| |opName| |$localVars|) + (|putModeSet| |op| + (|bottomUpIdentifier| |op| |opName|))) + ('T (|transferPropsToNode| |opName| |op|)))) + ('T (SPADLET |opName| NIL) (|bottomUp| |op|))) + (SPADLET |opVal| (|getValue| |op|)) + (SPADLET |dol| + (AND (|getAtree| |op| '|dollar|) + (NEQUAL |opName| '|construct|))) + (COND + ((AND (NULL |dol|) + (SPADLET |fn| (GETL |opName| '|up|)) + (SPADLET |u| (FUNCALL |fn| |t|))) + |u|) + ('T (SPADLET |nargs| (|#| |argl|)) + (COND + (|opName| + (DO ((G166479 |argl| (CDR G166479)) + (|x| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G166479) + (PROGN + (SETQ |x| (CAR G166479)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|putAtree| |x| + '|callingFunction| |opName|) + (|putAtree| |x| + '|argumentNumber| |i|) + (|putAtree| |x| '|totalArgs| + |nargs|))))))) + (COND + (|tar| (|pushDownTargetInfo| |opName| |tar| + |argl|))) + (COND + ((AND |opVal| + (PROGN + (SPADLET |ISTMP#1| (|objVal| |opVal|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) 'MAP))) + (PROGN + (SPADLET |ISTMP#1| (|getMode| |op|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ms| (QCDR |ISTMP#1|)) + 'T))) + (BOOT-EQUAL (PLUS |nargs| 1) (|#| |ms|))) + (DO ((G166489 (CDR |ms|) (CDR G166489)) + (|m| NIL) + (G166490 |argl| (CDR G166490)) + (|x| NIL)) + ((OR (ATOM G166489) + (PROGN (SETQ |m| (CAR G166489)) NIL) + (ATOM G166490) + (PROGN (SETQ |x| (CAR G166490)) NIL)) + NIL) + (SEQ (EXIT (|putTarget| |x| |m|)))))) + (SPADLET |argModeSetList| + (PROG (G166503) + (SPADLET G166503 NIL) + (RETURN + (DO ((G166508 |argl| + (CDR G166508)) + (|x| NIL)) + ((OR (ATOM G166508) + (PROGN + (SETQ |x| (CAR G166508)) + NIL)) + (NREVERSE0 G166503)) + (SEQ + (EXIT + (SETQ G166503 + (CONS (|bottomUp| |x|) G166503)))))))) + (COND + ((AND (NULL |tar|) (BOOT-EQUAL |opName| '*) + (EQL |nargs| 2)) + (SPADLET |t1| (CAAR |argModeSetList|)) + (SPADLET |t2| (CAADR |argModeSetList|)) + (SPADLET |tar| + (|computeTypeWithVariablesTarget| |t1| + |t2|)) + (COND + (|tar| (PROGN + (|pushDownTargetInfo| |opName| |tar| + |argl|) + (SPADLET |argModeSetList| + (PROG (G166518) + (SPADLET G166518 NIL) + (RETURN + (DO + ((G166523 |argl| + (CDR G166523)) + (|x| NIL)) + ((OR (ATOM G166523) + (PROGN + (SETQ |x| + (CAR G166523)) + NIL)) + (NREVERSE0 G166518)) + (SEQ + (EXIT + (SETQ G166518 + (CONS + (|bottomUp| |x|) + G166518))))))))))))) + (SPADLET |ms| + (|bottomUpForm| |t| |op| |opName| |argl| + |argModeSetList|)) + (SPADLET |op| (CAR |t|)) + (COND + ((AND |$useIntegerSubdomain| (NULL |tar|) + (NULL |dol|) + (|isEqualOrSubDomain| (CAR |ms|) + |$Integer|)) + (SPADLET |val| (|objVal| (|getValue| |op|))) + (COND + ((|isWrapped| |val|) + (SPADLET |val| (|unwrap| |val|)) + (SPADLET |bm| (|getBasicMode| |val|)) + (|putValue| |op| (|objNewWrap| |val| |bm|)) + (|putModeSet| |op| (CONS |bm| NIL))) + ('T |ms|))) + ('T |ms|))))))) + ((SPADLET |m| (|getBasicMode| |t|)) (CONS |m| NIL)) + ((IDENTP (SPADLET |id| (|getUnname| |t|))) + (|putModeSet| |t| (|bottomUpIdentifier| |t| |id|))) + ('T + (|keyedSystemError| 'S2GE0016 + (CONS "bottomUp" (CONS "unknown object form" NIL))))))))) ;computeTypeWithVariablesTarget(p, q) == ; polyVarlist(p) or polyVarlist(q) => @@ -808,15 +894,13 @@ ; NIL (DEFUN |computeTypeWithVariablesTarget| (|p| |q|) - (PROG (|t|) - (RETURN - (COND - ((OR (|polyVarlist| |p|) (|polyVarlist| |q|)) - (SPADLET |t| (|resolveTT| |p| |q|)) - (COND - ((|polyVarlist| |t|) |t|) - ((QUOTE T) NIL))) - ((QUOTE T) NIL))))) + (PROG (|t|) + (RETURN + (COND + ((OR (|polyVarlist| |p|) (|polyVarlist| |q|)) + (SPADLET |t| (|resolveTT| |p| |q|)) + (COND ((|polyVarlist| |t|) |t|) ('T NIL))) + ('T NIL))))) ;bottomUpCompile t == ; $genValue:local := false @@ -825,14 +909,14 @@ ; ms (DEFUN |bottomUpCompile| (|t|) - (PROG (|$genValue| |ms|) - (DECLARE (SPECIAL |$genValue|)) - (RETURN - (PROGN - (SPADLET |$genValue| NIL) - (SPADLET |ms| (|bottomUp| |t|)) - (COMP-TRAN-1 (|objVal| (|getValue| |t|))) - |ms|)))) + (PROG (|$genValue| |ms|) + (DECLARE (SPECIAL |$genValue|)) + (RETURN + (PROGN + (SPADLET |$genValue| NIL) + (SPADLET |ms| (|bottomUp| |t|)) + (COMP-TRAN-1 (|objVal| (|getValue| |t|))) + |ms|)))) ;bottomUpUseSubdomain t == ; $useIntegerSubdomain : local := true @@ -846,22 +930,24 @@ ; ms (DEFUN |bottomUpUseSubdomain| (|t|) - (PROG (|$useIntegerSubdomain| |num| |o| |ms|) - (DECLARE (SPECIAL |$useIntegerSubdomain|)) - (RETURN - (PROGN - (SPADLET |$useIntegerSubdomain| (QUOTE T)) - (SPADLET |ms| (|bottomUp| |t|)) - (COND - ((OR (NEQUAL |$immediateDataSymbol| (|getUnname| |t|)) - (NEQUAL |$Integer| (CAR |ms|))) - |ms|) - ((NULL (INTEGERP (SPADLET |num| (|objValUnwrap| (|getValue| |t|))))) |ms|) - ((QUOTE T) - (SPADLET |o| (|getBasicObject| |num|)) - (|putValue| |t| |o|) - (SPADLET |ms| (CONS (|objMode| |o|) NIL)) - (|putModeSet| |t| |ms|) |ms|)))))) + (PROG (|$useIntegerSubdomain| |num| |o| |ms|) + (DECLARE (SPECIAL |$useIntegerSubdomain| |$Integer| + |$immediateDataSymbol|)) + (RETURN + (PROGN + (SPADLET |$useIntegerSubdomain| 'T) + (SPADLET |ms| (|bottomUp| |t|)) + (COND + ((OR (NEQUAL |$immediateDataSymbol| (|getUnname| |t|)) + (NEQUAL |$Integer| (CAR |ms|))) + |ms|) + ((NULL (INTEGERP + (SPADLET |num| (|objValUnwrap| (|getValue| |t|))))) + |ms|) + ('T (SPADLET |o| (|getBasicObject| |num|)) + (|putValue| |t| |o|) + (SPADLET |ms| (CONS (|objMode| |o|) NIL)) + (|putModeSet| |t| |ms|) |ms|)))))) ;bottomUpPredicate(pred, name) == ; putTarget(pred,$Boolean) @@ -870,27 +956,28 @@ ; ms (DEFUN |bottomUpPredicate| (|pred| |name|) - (PROG (|ms|) - (RETURN - (PROGN - (|putTarget| |pred| |$Boolean|) - (SPADLET |ms| (|bottomUp| |pred|)) - (COND - ((NEQUAL |$Boolean| (CAR |ms|)) - (|throwKeyedMsg| (MAKESTRING "S2IB0001") (CONS |name| NIL))) - ((QUOTE T) |ms|)))))) + (PROG (|ms|) + (DECLARE (SPECIAL |$Boolean|)) + (RETURN + (PROGN + (|putTarget| |pred| |$Boolean|) + (SPADLET |ms| (|bottomUp| |pred|)) + (COND + ((NEQUAL |$Boolean| (CAR |ms|)) + (|throwKeyedMsg| (MAKESTRING "S2IB0001") (CONS |name| NIL))) + ('T |ms|)))))) ;bottomUpCompilePredicate(pred, name) == ; $genValue:local := false ; bottomUpPredicate(pred,name) (DEFUN |bottomUpCompilePredicate| (|pred| |name|) - (PROG (|$genValue|) - (DECLARE (SPECIAL |$genValue|)) - (RETURN - (PROGN - (SPADLET |$genValue| NIL) - (|bottomUpPredicate| |pred| |name|))))) + (PROG (|$genValue|) + (DECLARE (SPECIAL |$genValue|)) + (RETURN + (PROGN + (SPADLET |$genValue| NIL) + (|bottomUpPredicate| |pred| |name|))))) ;bottomUpIdentifier(t,id) == ; m := isType t => bottomUpType(t, m) @@ -923,50 +1010,52 @@ ; bottomUpDefault(t,id,defaultType,getTarget t) (DEFUN |bottomUpIdentifier| (|t| |id|) - (PROG (|m| |defaultType| |u| |tar| |expr| |om| |ISTMP#1| |r|) - (RETURN - (COND - ((SPADLET |m| (|isType| |t|)) (|bottomUpType| |t| |m|)) - ((EQ |id| (QUOTE |noMapVal|)) - (|throwKeyedMsg| (MAKESTRING "S2IB0002") NIL)) - ((EQ |id| (QUOTE |noBranch|)) - (|keyedSystemError| 'S2GE0016 - (CONS "bottomUpIdentifier" (CONS "trying to evaluate noBranch" NIL)))) - ((QUOTE T) - (|transferPropsToNode| |id| |t|) - (SPADLET |defaultType| (CONS (QUOTE |Variable|) (CONS |id| NIL))) - (COND - ((SPADLET |u| (|getValue| |t|)) - (SPADLET |tar| (|getTarget| |t|)) - (SPADLET |expr| (|objVal| |u|)) - (SPADLET |om| (|objMode| |u|)) - (COND - ((AND - (NEQUAL |om| |$EmptyMode|) - (NULL - (AND - (PAIRP |om|) - (EQ (QCAR |om|) (QUOTE |RuleCalled|)) - (PROGN - (SPADLET |ISTMP#1| (QCDR |om|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))))) + (PROG (|m| |defaultType| |u| |tar| |expr| |om| |ISTMP#1| |r|) + (DECLARE (SPECIAL |$genValue| |$EmptyMode|)) + (RETURN + (COND + ((SPADLET |m| (|isType| |t|)) (|bottomUpType| |t| |m|)) + ((EQ |id| '|noMapVal|) + (|throwKeyedMsg| (MAKESTRING "S2IB0002") NIL)) + ((EQ |id| '|noBranch|) + (|keyedSystemError| 'S2GE0016 + (CONS "bottomUpIdentifier" + (CONS "trying to evaluate noBranch" NIL)))) + ('T (|transferPropsToNode| |id| |t|) + (SPADLET |defaultType| (CONS '|Variable| (CONS |id| NIL))) (COND - ((OR |$genValue| (GENSYMP |id|)) - (COND - ((NULL |tar|) (CONS |om| NIL)) - ((SPADLET |r| (|resolveTM| |om| |tar|)) (CONS |r| NIL)) - ((QUOTE T) (CONS |om| NIL)))) - ((QUOTE T) - (|bottomUpDefault| |t| |id| |defaultType| (|getTarget| |t|))))) - ((QUOTE T) - (OR - (|interpRewriteRule| |t| |id| |expr|) - (AND (|isMapExpr| |expr|) (CONS (|objMode| |u|) NIL)) - (|keyedSystemError| 'S2GE0016 - (CONS "bottomUpIdentifier" - (CONS "cannot evaluate identifier" NIL))))))) - ((QUOTE T) - (|bottomUpDefault| |t| |id| |defaultType| (|getTarget| |t|))))))))) + ((SPADLET |u| (|getValue| |t|)) + (SPADLET |tar| (|getTarget| |t|)) + (SPADLET |expr| (|objVal| |u|)) + (SPADLET |om| (|objMode| |u|)) + (COND + ((AND (NEQUAL |om| |$EmptyMode|) + (NULL (AND (PAIRP |om|) + (EQ (QCAR |om|) '|RuleCalled|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |om|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))))) + (COND + ((OR |$genValue| (GENSYMP |id|)) + (COND + ((NULL |tar|) (CONS |om| NIL)) + ((SPADLET |r| (|resolveTM| |om| |tar|)) + (CONS |r| NIL)) + ('T (CONS |om| NIL)))) + ('T + (|bottomUpDefault| |t| |id| |defaultType| + (|getTarget| |t|))))) + ('T + (OR (|interpRewriteRule| |t| |id| |expr|) + (AND (|isMapExpr| |expr|) + (CONS (|objMode| |u|) NIL)) + (|keyedSystemError| 'S2GE0016 + (CONS "bottomUpIdentifier" + (CONS "cannot evaluate identifier" NIL))))))) + ('T + (|bottomUpDefault| |t| |id| |defaultType| + (|getTarget| |t|))))))))) ;bottomUpDefault(t,id,defaultMode,target) == ; if $genValue @@ -974,9 +1063,11 @@ ; else bottomUpDefaultCompile(t,id,defaultMode,target,nil) (DEFUN |bottomUpDefault| (|t| |id| |defaultMode| |target|) - (COND - (|$genValue| (|bottomUpDefaultEval| |t| |id| |defaultMode| |target| NIL)) - ((QUOTE T) (|bottomUpDefaultCompile| |t| |id| |defaultMode| |target| NIL)))) + (DECLARE (SPECIAL |$genValue|)) + (COND + (|$genValue| + (|bottomUpDefaultEval| |t| |id| |defaultMode| |target| NIL)) + ('T (|bottomUpDefaultCompile| |t| |id| |defaultMode| |target| NIL)))) ;bottomUpDefaultEval(t,id,defaultMode,target,isSub) == ; -- try to get value case. @@ -1028,79 +1119,87 @@ ; [target] (DEFUN |bottomUpDefaultEval| (|t| |id| |defaultMode| |target| |isSub|) - (PROG (|m| D |ISTMP#1| |x| |ISTMP#2| |dmode| |val| |tm| |val'|) - (RETURN - (COND - ((SPADLET |m| (|getMode| |t|)) - (COND - ((AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Mapping|))) - (|throwKeyedMsg| (MAKESTRING "S2IB0003") (CONS (|getUnname| |t|) NIL))) - ((QUOTE T) - (COND - ((|isPartialMode| |m|) - (SPADLET |m| - (|resolveTM| (CONS (QUOTE |Variable|) (CONS |id| NIL)) |m|)))) - (COND - ((AND |target| - (NULL |isSub|) - (SPADLET |val| - (|coerceInteractive| - (|objNewWrap| |id| - (CONS (QUOTE |Variable|) (CONS |id| NIL))) |target|))) - (|putValue| |t| |val|) (CONS |target| NIL)) - ((AND (NULL |target|) - (NULL |isSub|) - |m| - (SPADLET |val| - (|coerceInteractive| - (|objNewWrap| |id| - (CONS (QUOTE |Variable|) (CONS |id| NIL))) |m|))) - (|putValue| |t| |val|) (CONS |m| NIL)) - ((QUOTE T) - (|throwKeyedMsg| "S2IB0004" (CONS |id| (CONS |m| NIL)))))))) - ((QUOTE T) - (SPADLET |val| (|objNewWrap| |id| |defaultMode|)) - (COND - ((OR (NULL |target|) (BOOT-EQUAL |defaultMode| |target|)) - (|putValue| |t| |val|) (CONS |defaultMode| NIL)) - ((QUOTE T) - (COND - ((|isPartialMode| |target|) + (PROG (|m| D |ISTMP#1| |x| |ISTMP#2| |dmode| |val| |tm| |val'|) + (DECLARE (SPECIAL |$Integer| |$multivariateDomains| + |$univariateDomains| |$Symbol|)) + (RETURN + (COND + ((SPADLET |m| (|getMode| |t|)) (COND - ((AND (BOOT-EQUAL |defaultMode| |$Symbol|) - (PAIRP |target|) - (PROGN - (SPADLET D (QCAR |target|)) - (SPADLET |ISTMP#1| (QCDR |target|)) - (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)))))) - (COND - ((OR - (AND (|member| D |$univariateDomains|) (BOOT-EQUAL |x| |id|)) - (AND (|member| D |$multivariateDomains|) (|member| |id| |x|))) - (SPADLET |dmode| (CONS D (CONS |x| (CONS |$Integer| NIL)))) - (COND - ((SPADLET |val'| - (|coerceInteractive| - (|objNewWrap| |id| - (CONS (QUOTE |Variable|) (CONS |id| NIL))) |dmode|)) - (PROGN - (SPADLET |defaultMode| |dmode|) - (SPADLET |val| |val'|))))) - ((QUOTE T) NIL)))) - (SPADLET |target| (|resolveTM| |defaultMode| |target|)))) - (COND - ((AND |target| (SPADLET |tm| (|getMinimalVarMode| |id| |target|))) - (SPADLET |target| |tm|))) - (COND - ((OR (NULL |target|) - (NULL (SPADLET |val'| (|coerceInteractive| |val| |target|)))) - (|putValue| |t| |val|) (CONS |defaultMode| NIL)) - ((QUOTE T) (|putValue| |t| |val'|) (CONS |target| NIL)))))))))) + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Mapping|)) + (|throwKeyedMsg| (MAKESTRING "S2IB0003") + (CONS (|getUnname| |t|) NIL))) + ('T + (COND + ((|isPartialMode| |m|) + (SPADLET |m| + (|resolveTM| (CONS '|Variable| (CONS |id| NIL)) + |m|)))) + (COND + ((AND |target| (NULL |isSub|) + (SPADLET |val| + (|coerceInteractive| + (|objNewWrap| |id| + (CONS '|Variable| (CONS |id| NIL))) + |target|))) + (|putValue| |t| |val|) (CONS |target| NIL)) + ((AND (NULL |target|) (NULL |isSub|) |m| + (SPADLET |val| + (|coerceInteractive| + (|objNewWrap| |id| + (CONS '|Variable| (CONS |id| NIL))) + |m|))) + (|putValue| |t| |val|) (CONS |m| NIL)) + ('T + (|throwKeyedMsg| "S2IB0004" (CONS |id| (CONS |m| NIL)))))))) + ('T (SPADLET |val| (|objNewWrap| |id| |defaultMode|)) + (COND + ((OR (NULL |target|) (BOOT-EQUAL |defaultMode| |target|)) + (|putValue| |t| |val|) (CONS |defaultMode| NIL)) + ('T + (COND + ((|isPartialMode| |target|) + (COND + ((AND (BOOT-EQUAL |defaultMode| |$Symbol|) + (PAIRP |target|) + (PROGN + (SPADLET D (QCAR |target|)) + (SPADLET |ISTMP#1| (QCDR |target|)) + (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)))))) + (COND + ((OR (AND (|member| D |$univariateDomains|) + (BOOT-EQUAL |x| |id|)) + (AND (|member| D |$multivariateDomains|) + (|member| |id| |x|))) + (SPADLET |dmode| + (CONS D (CONS |x| (CONS |$Integer| NIL)))) + (COND + ((SPADLET |val'| + (|coerceInteractive| + (|objNewWrap| |id| + (CONS '|Variable| + (CONS |id| NIL))) + |dmode|)) + (PROGN + (SPADLET |defaultMode| |dmode|) + (SPADLET |val| |val'|))))) + ('T NIL)))) + (SPADLET |target| (|resolveTM| |defaultMode| |target|)))) + (COND + ((AND |target| + (SPADLET |tm| (|getMinimalVarMode| |id| |target|))) + (SPADLET |target| |tm|))) + (COND + ((OR (NULL |target|) + (NULL (SPADLET |val'| + (|coerceInteractive| |val| |target|)))) + (|putValue| |t| |val|) (CONS |defaultMode| NIL)) + ('T (|putValue| |t| |val'|) (CONS |target| NIL)))))))))) ;bottomUpDefaultCompile(t,id,defaultMode,target,isSub) == ; tmode := getMode t @@ -1131,47 +1230,51 @@ ; [defaultMode] (DEFUN |bottomUpDefaultCompile| (|t| |id| |defaultMode| |target| |isSub|) - (PROG (|tval| |envMode| |expr| |mdv| |tmode| |obj| |obj'|) - (RETURN - (SEQ - (PROGN - (SPADLET |tmode| (|getMode| |t|)) - (SPADLET |tval| (|getValue| |t|)) - (SPADLET |expr| - (COND - ((|member| |id| |$localVars|) |id|) - ((OR |tmode| |tval|) - (SPADLET |envMode| (OR |tmode| (|objMode| |tval|))) - (COND - ((AND (PAIRP |envMode|) (EQ (QCAR |envMode|) (QUOTE |Variable|))) - (|objVal| |tval|)) - ((BOOT-EQUAL |id| |$immediateDataSymbol|) - (|objVal| |tval|)) - ((QUOTE T) - (CONS - (QUOTE |getValueFromEnvironment|) - (CONS (MKQ |id|) (CONS (MKQ |envMode|) NIL)))))) - ((QUOTE T) (|wrap| |id|)))) - (COND - ((AND |tmode| |tval| (SPADLET |mdv| (|objMode| |tval|))) - (SEQ - (COND - ((|isPartialMode| |tmode|) - (COND - ((NULL (SPADLET |tmode| (|resolveTM| |mdv| |tmode|))) - (EXIT (|keyedMsgCompFailure| (QUOTE S2IB0010) NIL)))))) - (|putValue| |t| (|objNew| |expr| |tmode|)) - (CONS |tmode| NIL))) - ((OR |tmode| (AND |tval| (SPADLET |tmode| (|objMode| |tval|)))) - (|putValue| |t| (|objNew| |expr| |tmode|)) - (CONS |tmode| NIL)) - ((QUOTE T) - (SPADLET |obj| (|objNew| |expr| |defaultMode|)) - (COND - ((AND (|canCoerceFrom| |defaultMode| |target|) - (SPADLET |obj'| (|coerceInteractive| |obj| |target|))) - (|putValue| |t| |obj'|) (CONS |target| NIL)) - ((QUOTE T) (|putValue| |t| |obj|) (CONS |defaultMode| NIL)))))))))) + (declare (ignore |isSub|)) + (PROG (|tval| |envMode| |expr| |mdv| |tmode| |obj| |obj'|) + (DECLARE (SPECIAL |$immediateDataSymbol| |$localVars|)) + (RETURN + (SEQ (PROGN + (SPADLET |tmode| (|getMode| |t|)) + (SPADLET |tval| (|getValue| |t|)) + (SPADLET |expr| + (COND + ((|member| |id| |$localVars|) |id|) + ((OR |tmode| |tval|) + (SPADLET |envMode| + (OR |tmode| (|objMode| |tval|))) + (COND + ((AND (PAIRP |envMode|) + (EQ (QCAR |envMode|) '|Variable|)) + (|objVal| |tval|)) + ((BOOT-EQUAL |id| |$immediateDataSymbol|) + (|objVal| |tval|)) + ('T + (CONS '|getValueFromEnvironment| + (CONS (MKQ |id|) + (CONS (MKQ |envMode|) NIL)))))) + ('T (|wrap| |id|)))) + (COND + ((AND |tmode| |tval| (SPADLET |mdv| (|objMode| |tval|))) + (SEQ (COND + ((|isPartialMode| |tmode|) + (COND + ((NULL (SPADLET |tmode| + (|resolveTM| |mdv| |tmode|))) + (EXIT (|keyedMsgCompFailure| 'S2IB0010 NIL)))))) + (|putValue| |t| (|objNew| |expr| |tmode|)) + (CONS |tmode| NIL))) + ((OR |tmode| + (AND |tval| (SPADLET |tmode| (|objMode| |tval|)))) + (|putValue| |t| (|objNew| |expr| |tmode|)) + (CONS |tmode| NIL)) + ('T (SPADLET |obj| (|objNew| |expr| |defaultMode|)) + (COND + ((AND (|canCoerceFrom| |defaultMode| |target|) + (SPADLET |obj'| + (|coerceInteractive| |obj| |target|))) + (|putValue| |t| |obj'|) (CONS |target| NIL)) + ('T (|putValue| |t| |obj|) (CONS |defaultMode| NIL)))))))))) ;interpRewriteRule(t,id,expr) == ; null get(id,'isInterpreterRule,$e) => NIL @@ -1180,14 +1283,16 @@ ; nil (DEFUN |interpRewriteRule| (|t| |id| |expr|) - (PROG (|ms|) - (RETURN - (COND - ((NULL (|get| |id| (QUOTE |isInterpreterRule|) |$e|)) NIL) - ((AND (SPADLET |ms| (|selectLocalMms| |t| |id| NIL NIL)) - (SPADLET |ms| (|evalForm| |t| |id| NIL |ms|))) - |ms|) - ((QUOTE T) NIL))))) + (declare (ignore |expr|)) + (PROG (|ms|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (COND + ((NULL (|get| |id| '|isInterpreterRule| |$e|)) NIL) + ((AND (SPADLET |ms| (|selectLocalMms| |t| |id| NIL NIL)) + (SPADLET |ms| (|evalForm| |t| |id| NIL |ms|))) + |ms|) + ('T NIL))))) ;bottomUpForm(t,op,opName,argl,argModeSetList) == ; not($inRetract) => @@ -1195,23 +1300,23 @@ ; bottomUpForm2(t,op,opName,argl,argModeSetList) (DEFUN |bottomUpForm| (|t| |op| |opName| |argl| |argModeSetList|) - (COND - ((NULL |$inRetract|) - (|bottomUpForm3| |t| |op| |opName| |argl| |argModeSetList|)) - ((QUOTE T) - (|bottomUpForm2| |t| |op| |opName| |argl| |argModeSetList|)))) + (DECLARE (SPECIAL |$inRetract|)) + (COND + ((NULL |$inRetract|) + (|bottomUpForm3| |t| |op| |opName| |argl| |argModeSetList|)) + ('T (|bottomUpForm2| |t| |op| |opName| |argl| |argModeSetList|)))) ;bottomUpForm3(t,op,opName,argl,argModeSetList) == ; $origArgModeSetList:local := COPY argModeSetList ; bottomUpForm2(t,op,opName,argl,argModeSetList) (DEFUN |bottomUpForm3| (|t| |op| |opName| |argl| |argModeSetList|) - (PROG (|$origArgModeSetList|) - (DECLARE (SPECIAL |$origArgModeSetList|)) - (RETURN - (PROGN - (SPADLET |$origArgModeSetList| (COPY |argModeSetList|)) - (|bottomUpForm2| |t| |op| |opName| |argl| |argModeSetList|))))) + (PROG (|$origArgModeSetList|) + (DECLARE (SPECIAL |$origArgModeSetList|)) + (RETURN + (PROGN + (SPADLET |$origArgModeSetList| (COPY |argModeSetList|)) + (|bottomUpForm2| |t| |op| |opName| |argl| |argModeSetList|))))) ;bottomUpForm2(t,op,opName,argl,argModeSetList) == ; not atom t and EQ(opName,"%%") => bottomUpPercent t @@ -1239,67 +1344,71 @@ ; bottomUpForm0(t,op,opName,argl,argModeSetList) (DEFUN |bottomUpForm2| (|t| |op| |opName| |argl| |argModeSetList|) - (PROG (|opVal| |opMode| |opModeTop| |lookForIt| |ISTMP#1| |m| |ISTMP#2| - |ISTMP#3| |u| |mmS| |mS|) - (RETURN - (COND - ((AND (NULL (ATOM |t|)) (EQ |opName| (QUOTE %%))) (|bottomUpPercent| |t|)) - ((QUOTE T) - (SPADLET |opVal| (|getValue| |op|)) - (SPADLET |lookForIt| + (PROG (|opVal| |opMode| |opModeTop| |lookForIt| |ISTMP#1| |m| + |ISTMP#2| |ISTMP#3| |u| |mmS| |mS|) + (DECLARE (SPECIAL |$genValue|)) + (RETURN (COND - ((|getAtree| |op| (QUOTE |dollar|)) (QUOTE T)) - ((NULL |opVal|) (QUOTE T)) - ((QUOTE T) - (SPADLET |opMode| (|objMode| |opVal|)) - (COND - ((NULL (SPADLET |opModeTop| (IFCAR |opMode|))) (QUOTE T)) - ((|member| |opModeTop| (QUOTE (|Record| |Union|))) NIL) - ((|member| |opModeTop| - (QUOTE (|Variable| |Mapping| |FunctionCalled| - |RuleCalled| |AnonymousFunction|))) - (QUOTE T)) - ((QUOTE T) NIL))))) - (COND - ((AND |$genValue| - (NULL - (AND - (BOOT-EQUAL |opName| (QUOTE =)) - (PAIRP |argModeSetList|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |argModeSetList|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |m| (QCAR |ISTMP#1|)) (QUOTE T)))) - (PROGN - (SPADLET |ISTMP#2| (QCDR |argModeSetList|)) - (AND - (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (EQUAL (QCAR |ISTMP#3|) |m|))))) - (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Union|)))) - (SPADLET |u| - (|bottomUpFormUntaggedUnionRetract| |t| |op| - |opName| |argl| |argModeSetList|))) - |u|) - ((AND |lookForIt| - (SPADLET |u| - (|bottomUpFormTuple| |t| |op| |opName| |argl| |argModeSetList|))) - |u|) - ((AND |lookForIt| - (SPADLET |mmS| (|selectMms| |op| |argl| (|getTarget| |op|))) - (SPADLET |mS| - (|evalForm| |op| - (SPADLET |opName| (|getUnname| |op|)) |argl| |mmS|))) - (|putModeSet| |op| |mS|)) - ((QUOTE T) - (|bottomUpForm0| |t| |op| |opName| |argl| |argModeSetList|)))))))) + ((AND (NULL (ATOM |t|)) (EQ |opName| '%%)) + (|bottomUpPercent| |t|)) + ('T (SPADLET |opVal| (|getValue| |op|)) + (SPADLET |lookForIt| + (COND + ((|getAtree| |op| '|dollar|) 'T) + ((NULL |opVal|) 'T) + ('T (SPADLET |opMode| (|objMode| |opVal|)) + (COND + ((NULL (SPADLET |opModeTop| (IFCAR |opMode|))) + 'T) + ((|member| |opModeTop| '(|Record| |Union|)) NIL) + ((|member| |opModeTop| + '(|Variable| |Mapping| |FunctionCalled| + |RuleCalled| |AnonymousFunction|)) + 'T) + ('T NIL))))) + (COND + ((AND |$genValue| + (NULL (AND (BOOT-EQUAL |opName| '=) + (PAIRP |argModeSetList|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |argModeSetList|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |m| (QCAR |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |argModeSetList|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| + (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (EQUAL (QCAR |ISTMP#3|) |m|))))) + (PAIRP |m|) (EQ (QCAR |m|) '|Union|))) + (SPADLET |u| + (|bottomUpFormUntaggedUnionRetract| |t| |op| + |opName| |argl| |argModeSetList|))) + |u|) + ((AND |lookForIt| + (SPADLET |u| + (|bottomUpFormTuple| |t| |op| |opName| |argl| + |argModeSetList|))) + |u|) + ((AND |lookForIt| + (SPADLET |mmS| + (|selectMms| |op| |argl| (|getTarget| |op|))) + (SPADLET |mS| + (|evalForm| |op| + (SPADLET |opName| (|getUnname| |op|)) + |argl| |mmS|))) + (|putModeSet| |op| |mS|)) + ('T + (|bottomUpForm0| |t| |op| |opName| |argl| |argModeSetList|)))))))) ;bottomUpFormTuple(t, op, opName, args, argModeSetList) == ; getAtree(op,'dollar) => NIL @@ -1318,68 +1427,68 @@ ; bottomUp [op, newArg] (DEFUN |bottomUpFormTuple| (|t| |op| |opName| |args| |argModeSetList|) - (PROG (|singles| |haveTuple| |nargs| |ms| |ISTMP#1| |ISTMP#2| |newArg|) - (RETURN - (SEQ - (COND - ((|getAtree| |op| (QUOTE |dollar|)) NIL) - ((NULL (SPADLET |singles| (|getModemapsFromDatabase| |opName| 1))) NIL) - ((QUOTE T) - (SPADLET |haveTuple| NIL) - (DO ((#0=#:G166755 |singles| (CDR #0#)) (|mm| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |mm| (CAR #0#)) NIL) - (NULL (NULL |haveTuple|))) - NIL) - (SEQ - (EXIT - (COND - ((PROGN - (SPADLET |ISTMP#1| (|getFirstArgTypeFromMm| |mm|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Tuple|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL))))) - (SPADLET |haveTuple| (QUOTE T))) - ((QUOTE T) NIL))))) - (COND - ((NULL |haveTuple|) NIL) - ((QUOTE T) - (SPADLET |nargs| (|#| |args|)) - (COND - ((AND (EQL |nargs| 1) - (BOOT-EQUAL (|getUnname| (CAR |args|)) (QUOTE |Tuple|))) - NIL) - ((AND - (EQL |nargs| 1) - (SPADLET |ms| (|bottomUp| (CAR |args|))) - (OR - (AND - (PAIRP |ms|) - (EQ (QCDR |ms|) NIL) - (PROGN - (SPADLET |ISTMP#1| (QCAR |ms|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Tuple|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) - (AND (PAIRP |ms|) - (EQ (QCDR |ms|) NIL) - (PROGN - (SPADLET |ISTMP#1| (QCAR |ms|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |List|)) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))))) - NIL) - ((QUOTE T) - (SPADLET |newArg| (CONS (|mkAtreeNode| (QUOTE |Tuple|)) |args|)) - (|bottomUp| (CONS |op| (CONS |newArg| NIL))))))))))))) + (declare (ignore |t| |argModeSetList|)) + (PROG (|singles| |haveTuple| |nargs| |ms| |ISTMP#1| |ISTMP#2| |newArg|) + (RETURN + (SEQ (COND + ((|getAtree| |op| '|dollar|) NIL) + ((NULL (SPADLET |singles| + (|getModemapsFromDatabase| |opName| 1))) + NIL) + ('T (SPADLET |haveTuple| NIL) + (DO ((G166755 |singles| (CDR G166755)) (|mm| NIL)) + ((OR (ATOM G166755) + (PROGN (SETQ |mm| (CAR G166755)) NIL) + (NULL (NULL |haveTuple|))) + NIL) + (SEQ (EXIT (COND + ((PROGN + (SPADLET |ISTMP#1| + (|getFirstArgTypeFromMm| |mm|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Tuple|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL))))) + (SPADLET |haveTuple| 'T)) + ('T NIL))))) + (COND + ((NULL |haveTuple|) NIL) + ('T (SPADLET |nargs| (|#| |args|)) + (COND + ((AND (EQL |nargs| 1) + (BOOT-EQUAL (|getUnname| (CAR |args|)) + '|Tuple|)) + NIL) + ((AND (EQL |nargs| 1) + (SPADLET |ms| (|bottomUp| (CAR |args|))) + (OR (AND (PAIRP |ms|) (EQ (QCDR |ms|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |ms|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Tuple|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (AND (PAIRP |ms|) (EQ (QCDR |ms|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |ms|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|List|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))))) + NIL) + ('T + (SPADLET |newArg| + (CONS (|mkAtreeNode| '|Tuple|) |args|)) + (|bottomUp| (CONS |op| (CONS |newArg| NIL))))))))))))) ;removeUnionsAtStart(argl,modeSets) == ; null $genValue => modeSets @@ -1397,40 +1506,37 @@ ; modeSets (DEFUN |removeUnionsAtStart| (|argl| |modeSets|) - (PROG (|v| |m| |val| |val'| |m'|) - (RETURN - (SEQ - (COND - ((NULL |$genValue|) |modeSets|) - ((QUOTE T) - (DO ((#0=#:G166783 |argl| (CDR #0#)) - (|arg| NIL) - (#1=#:G166784 |modeSets| (CDR #1#)) - (|ms| NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ |arg| (CAR #0#)) NIL) - (ATOM #1#) - (PROGN (SETQ |ms| (CAR #1#)) NIL)) - NIL) - (SEQ - (EXIT - (COND - ((NULL (SPADLET |v| (|getValue| |arg|))) NIL) - ((QUOTE T) - (SPADLET |m| (|objMode| |v|)) - (COND - ((NULL (AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Union|)))) NIL) - ((QUOTE T) - (SPADLET |val| (|objVal| |v|)) - (COND - ((NULL (|isWrapped| |val|)) NIL) - ((QUOTE T) - (SPADLET |val'| (|retract| |v|)) - (SPADLET |m'| (|objMode| |val'|)) - (|putValue| |arg| |val'|) - (|putModeSet| |arg| (CONS |m'| NIL)) - (RPLACA |ms| |m'|)))))))))) - |modeSets|)))))) + (PROG (|v| |m| |val| |val'| |m'|) + (DECLARE (SPECIAL |$genValue|)) + (RETURN + (SEQ (COND + ((NULL |$genValue|) |modeSets|) + ('T + (DO ((G166783 |argl| (CDR G166783)) (|arg| NIL) + (G166784 |modeSets| (CDR G166784)) (|ms| NIL)) + ((OR (ATOM G166783) + (PROGN (SETQ |arg| (CAR G166783)) NIL) + (ATOM G166784) + (PROGN (SETQ |ms| (CAR G166784)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (SPADLET |v| (|getValue| |arg|))) + NIL) + ('T (SPADLET |m| (|objMode| |v|)) + (COND + ((NULL (AND (PAIRP |m|) + (EQ (QCAR |m|) '|Union|))) + NIL) + ('T (SPADLET |val| (|objVal| |v|)) + (COND + ((NULL (|isWrapped| |val|)) NIL) + ('T (SPADLET |val'| (|retract| |v|)) + (SPADLET |m'| (|objMode| |val'|)) + (|putValue| |arg| |val'|) + (|putModeSet| |arg| + (CONS |m'| NIL)) + (RPLACA |ms| |m'|)))))))))) + |modeSets|)))))) ;printableArgModeSetList() == ; amsl := nil @@ -1441,22 +1547,26 @@ ; if amsl then amsl := rest amsl ; amsl -(DEFUN |printableArgModeSetList| () - (PROG (|b| |amsl|) - (RETURN - (SEQ - (PROGN - (SPADLET |amsl| NIL) - (DO ((#0=#:G166809 (REVERSE |$origArgModeSetList|) (CDR #0#)) (|a| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |a| (CAR #0#)) NIL)) NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |b| (|prefix2String| (CAR |a|))) - (COND ((ATOM |b|) (SPADLET |b| (CONS |b| NIL)))) - (SPADLET |amsl| (CONS (QUOTE |%l|) (APPEND |b| |amsl|))))))) - (COND (|amsl| (SPADLET |amsl| (CDR |amsl|)))) - |amsl|))))) +(DEFUN |printableArgModeSetList| () + (PROG (|b| |amsl|) + (DECLARE (SPECIAL |$origArgModeSetList|)) + (RETURN + (SEQ (PROGN + (SPADLET |amsl| NIL) + (DO ((G166809 (REVERSE |$origArgModeSetList|) + (CDR G166809)) + (|a| NIL)) + ((OR (ATOM G166809) + (PROGN (SETQ |a| (CAR G166809)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |b| (|prefix2String| (CAR |a|))) + (COND + ((ATOM |b|) (SPADLET |b| (CONS |b| NIL)))) + (SPADLET |amsl| + (CONS '|%l| (APPEND |b| |amsl|))))))) + (COND (|amsl| (SPADLET |amsl| (CDR |amsl|)))) + |amsl|))))) ;bottomUpForm0(t,op,opName,argl,argModeSetList) == ; op0 := op @@ -1524,168 +1634,176 @@ ; throwKeyedMsgSP(msgKey,[opName1, amsl], op0) (DEFUN |bottomUpForm0| (|t| |op| |opName| |argl| |argModeSetList|) - (PROG (|op0| |opName0| |rargs| |rtype| |code| |val| |m| |ISTMP#3| |x| - |object| |ISTMP#1| |ISTMP#2| |var| |u| |amsl| |o| |n| - |opName1| |msgKey|) - (RETURN - (PROGN - (SPADLET |op0| |op|) - (SPADLET |opName0| |opName|) - (COND - ((SPADLET |m| (|isType| |t|)) (|bottomUpType| |t| |m|)) - ((AND (BOOT-EQUAL |opName| (QUOTE |copy|)) - (PAIRP |argModeSetList|) - (EQ (QCDR |argModeSetList|) NIL) - (PROGN - (SPADLET |ISTMP#1| (QCAR |argModeSetList|)) - (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 |Record|)) - (PROGN (SPADLET |rargs| (QCDR |ISTMP#2|)) (QUOTE T))))))) - (SPADLET |rtype| (CONS (QUOTE |Record|) |rargs|)) - (SPADLET |code| - (|optRECORDCOPY| - (CONS - (QUOTE RECORDCOPY) - (CONS (|getArgValue| (CAR |argl|) |rtype|) (CONS (|#| |rargs|) NIL))))) - (COND (|$genValue| (SPADLET |code| (|wrap| (|timedEVALFUN| |code|))))) - (SPADLET |val| (|objNew| |code| |rtype|)) - (|putValue| |t| |val|) (|putModeSet| |t| (CONS |rtype| NIL))) - ((QUOTE T) - (SPADLET |m| (|getModeOrFirstModeSetIfThere| |op|)) - (COND - ((AND (PAIRP |m|) - (EQ (QCAR |m|) (QUOTE |Record|)) - (PAIRP |argModeSetList|) - (EQ (QCDR |argModeSetList|) NIL) - (PROGN - (SPADLET |ISTMP#1| (QCAR |argModeSetList|)) - (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 |Variable|)) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN (SPADLET |x| (QCAR |ISTMP#3|)) (QUOTE T)))))))) - (|member| |x| (|getUnionOrRecordTags| |m|)) - (SPADLET |u| (|bottomUpElt| |t|))) - |u|) - ((AND (PAIRP |m|) - (EQ (QCAR |m|) (QUOTE |Union|)) - (PAIRP |argModeSetList|) - (EQ (QCDR |argModeSetList|) NIL) - (PROGN - (SPADLET |ISTMP#1| (QCAR |argModeSetList|)) - (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 |Variable|)) + (PROG (|op0| |opName0| |rargs| |rtype| |code| |val| |m| |ISTMP#3| |x| + |object| |ISTMP#1| |ISTMP#2| |var| |u| |amsl| |o| |n| + |opName1| |msgKey|) + (DECLARE (SPECIAL |$genValue| |$OutputForm| |$immediateDataSymbol| + |$HTCompanionWindowID|)) + (RETURN + (PROGN + (SPADLET |op0| |op|) + (SPADLET |opName0| |opName|) + (COND + ((SPADLET |m| (|isType| |t|)) (|bottomUpType| |t| |m|)) + ((AND (BOOT-EQUAL |opName| '|copy|) (PAIRP |argModeSetList|) + (EQ (QCDR |argModeSetList|) NIL) (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN (SPADLET |x| (QCAR |ISTMP#3|)) (QUOTE T))))))))) - (COND - ((AND (|member| |x| (|getUnionOrRecordTags| |m|)) - (SPADLET |u| (|bottomUpElt| |t|))) - |u|) - ((NULL |$genValue|) - (SPADLET |amsl| (|printableArgModeSetList|)) - (|throwKeyedMsgSP| (QUOTE S2IB0008) - (CONS (MAKESTRING "the union object") (CONS |amsl| NIL)) |op|)) - ((QUOTE T) - (SPADLET |object| (|retract| (|getValue| |op|))) - (COND - ((BOOT-EQUAL |object| (QUOTE |failed|)) - (|throwKeyedMsgSP| (QUOTE S2IB0008) - (CONS (MAKESTRING "the union object") (CONS |amsl| NIL)) |op|)) - ((QUOTE T) - (|putModeSet| |op| (CONS (|objMode| |object|) NIL)) - (|putValue| |op| |object|) + (SPADLET |ISTMP#1| (QCAR |argModeSetList|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|Record|) + (PROGN + (SPADLET |rargs| (QCDR |ISTMP#2|)) + 'T)))))) + (SPADLET |rtype| (CONS '|Record| |rargs|)) + (SPADLET |code| + (|optRECORDCOPY| + (CONS 'RECORDCOPY + (CONS (|getArgValue| (CAR |argl|) + |rtype|) + (CONS (|#| |rargs|) NIL))))) (COND - ((SPADLET |u| (|bottomUpElt| |t|)) |u|) - ((QUOTE T) - (|bottomUpForm0| |t| |op| |opName| |argl| |argModeSetList|)))))))) - ((AND (NEQUAL |opName| (QUOTE |elt|)) - (NEQUAL |opName| (QUOTE |apply|)) - (EQL (|#| |argl|) 1) - (PROGN - (SPADLET |ISTMP#1| (CAR (CAR |argModeSetList|))) - (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 |var| (QCAR |ISTMP#2|)) (QUOTE T)))))) - (|member| |var| (QUOTE (|first| |last| |rest|))) - (|isEltable| |op| |argl| (|#| |argl|)) - (SPADLET |u| (|bottomUpElt| |t|))) - |u|) - ((AND |$genValue| - (SPADLET |u| - (|bottomUpFormRetract| |t| |op| |opName| |argl| |argModeSetList|))) - |u|) - ((AND (NEQUAL |opName| (QUOTE |elt|)) - (NEQUAL |opName| (QUOTE |apply|)) - (|isEltable| |op| |argl| (|#| |argl|)) - (SPADLET |u| (|bottomUpElt| |t|))) - |u|) - ((QUOTE T) - (COND - ((FIXP |$HTCompanionWindowID|) - (|mkCompanionPage| (QUOTE |operationError|) |t|))) - (SPADLET |amsl| (|printableArgModeSetList|)) - (SPADLET |opName1| - (COND - ((BOOT-EQUAL |opName0| |$immediateDataSymbol|) - (COND - ((SPADLET |o| - (|coerceInteractive| (|getValue| |op0|) |$OutputForm|)) - (|outputTran| (|objValUnwrap| |o|))) - ((QUOTE T) NIL))) - ((QUOTE T) |opName0|))) - (COND - ((NULL |opName1|) - (SPADLET |opName1| - (COND - ((SPADLET |o| (|getValue| |op0|)) (|prefix2String| (|objMode| |o|))) - ((QUOTE T) (MAKESTRING "")))) - (SPADLET |msgKey| - (COND - ((NULL |amsl|) (QUOTE S2IB0013)) - ((QUOTE T) (QUOTE S2IB0012))))) - ((QUOTE T) - (SPADLET |msgKey| - (COND - ((NULL |amsl|) (QUOTE S2IB0011)) - ((SPADLET |n| (|isSharpVarWithNum| |opName1|)) - (SPADLET |opName1| |n|) (QUOTE |S2IB0008g|)) - ((QUOTE T) (QUOTE S2IB0008)))))) - (|sayIntelligentMessageAboutOpAvailability| |opName1| (|#| |argl|)) - (COND - ((NULL |$genValue|) - (|keyedMsgCompFailureSP| |msgKey| - (CONS |opName1| (CONS |amsl| NIL)) |op0|)) - ((QUOTE T) - (|throwKeyedMsgSP| |msgKey| - (CONS |opName1| (CONS |amsl| NIL)) |op0|))))))))))) + (|$genValue| + (SPADLET |code| (|wrap| (|timedEVALFUN| |code|))))) + (SPADLET |val| (|objNew| |code| |rtype|)) + (|putValue| |t| |val|) + (|putModeSet| |t| (CONS |rtype| NIL))) + ('T (SPADLET |m| (|getModeOrFirstModeSetIfThere| |op|)) + (COND + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Record|) + (PAIRP |argModeSetList|) + (EQ (QCDR |argModeSetList|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |argModeSetList|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|Variable|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |x| (QCAR |ISTMP#3|)) + 'T))))))) + (|member| |x| (|getUnionOrRecordTags| |m|)) + (SPADLET |u| (|bottomUpElt| |t|))) + |u|) + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Union|) + (PAIRP |argModeSetList|) + (EQ (QCDR |argModeSetList|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |argModeSetList|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|Variable|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |x| (QCAR |ISTMP#3|)) + 'T)))))))) + (COND + ((AND (|member| |x| (|getUnionOrRecordTags| |m|)) + (SPADLET |u| (|bottomUpElt| |t|))) + |u|) + ((NULL |$genValue|) + (SPADLET |amsl| (|printableArgModeSetList|)) + (|throwKeyedMsgSP| 'S2IB0008 + (CONS (MAKESTRING "the union object") + (CONS |amsl| NIL)) + |op|)) + ('T (SPADLET |object| (|retract| (|getValue| |op|))) + (COND + ((BOOT-EQUAL |object| '|failed|) + (|throwKeyedMsgSP| 'S2IB0008 + (CONS (MAKESTRING "the union object") + (CONS |amsl| NIL)) + |op|)) + ('T + (|putModeSet| |op| (CONS (|objMode| |object|) NIL)) + (|putValue| |op| |object|) + (COND + ((SPADLET |u| (|bottomUpElt| |t|)) |u|) + ('T + (|bottomUpForm0| |t| |op| |opName| |argl| + |argModeSetList|)))))))) + ((AND (NEQUAL |opName| '|elt|) (NEQUAL |opName| '|apply|) + (EQL (|#| |argl|) 1) + (PROGN + (SPADLET |ISTMP#1| (CAR (CAR |argModeSetList|))) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Variable|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |var| (QCAR |ISTMP#2|)) + 'T))))) + (|member| |var| '(|first| |last| |rest|)) + (|isEltable| |op| |argl| (|#| |argl|)) + (SPADLET |u| (|bottomUpElt| |t|))) + |u|) + ((AND |$genValue| + (SPADLET |u| + (|bottomUpFormRetract| |t| |op| |opName| + |argl| |argModeSetList|))) + |u|) + ((AND (NEQUAL |opName| '|elt|) (NEQUAL |opName| '|apply|) + (|isEltable| |op| |argl| (|#| |argl|)) + (SPADLET |u| (|bottomUpElt| |t|))) + |u|) + ('T + (COND + ((FIXP |$HTCompanionWindowID|) + (|mkCompanionPage| '|operationError| |t|))) + (SPADLET |amsl| (|printableArgModeSetList|)) + (SPADLET |opName1| + (COND + ((BOOT-EQUAL |opName0| |$immediateDataSymbol|) + (COND + ((SPADLET |o| + (|coerceInteractive| + (|getValue| |op0|) + |$OutputForm|)) + (|outputTran| (|objValUnwrap| |o|))) + ('T NIL))) + ('T |opName0|))) + (COND + ((NULL |opName1|) + (SPADLET |opName1| + (COND + ((SPADLET |o| (|getValue| |op0|)) + (|prefix2String| (|objMode| |o|))) + ('T (MAKESTRING "")))) + (SPADLET |msgKey| + (COND + ((NULL |amsl|) 'S2IB0013) + ('T 'S2IB0012)))) + ('T + (SPADLET |msgKey| + (COND + ((NULL |amsl|) 'S2IB0011) + ((SPADLET |n| + (|isSharpVarWithNum| |opName1|)) + (SPADLET |opName1| |n|) '|S2IB0008g|) + ('T 'S2IB0008))))) + (|sayIntelligentMessageAboutOpAvailability| |opName1| + (|#| |argl|)) + (COND + ((NULL |$genValue|) + (|keyedMsgCompFailureSP| |msgKey| + (CONS |opName1| (CONS |amsl| NIL)) |op0|)) + ('T + (|throwKeyedMsgSP| |msgKey| + (CONS |opName1| (CONS |amsl| NIL)) |op0|))))))))))) ;sayIntelligentMessageAboutOpAvailability(opName, nArgs) == ; -- see if we can give some decent messages about the availability if @@ -1714,72 +1832,65 @@ ; nil (DEFUN |sayIntelligentMessageAboutOpAvailability| (|opName| |nArgs|) - (PROG (|oo| |nAllExposedMmsWithName| |nAllMmsWithName| - |nAllExposedMmsWithNameAndArgs| |nAllMmsWithNameAndArgs|) - (RETURN - (COND - ((NUMBERP |opName|) NIL) - ((QUOTE T) - (SPADLET |oo| (|object2Identifier| (|opOf| |opName|))) - (COND - ((OR (BOOT-EQUAL |oo| (QUOTE %)) - (BOOT-EQUAL |oo| (QUOTE |Domain|)) - (|domainForm?| |opName|)) - (SPADLET |opName| (QUOTE |elt|)))) - (SPADLET |nAllExposedMmsWithName| - (|#| (|getModemapsFromDatabase| |opName| NIL))) - (SPADLET |nAllMmsWithName| - (|#| (|getAllModemapsFromDatabase| |opName| NIL))) - (COND - ((EQL |nAllMmsWithName| 0) - (|sayKeyedMsg| (QUOTE |S2IB0008a|) (CONS |opName| NIL))) - ((EQL |nAllExposedMmsWithName| 0) - (COND - ((EQL |nAllMmsWithName| 1) - (|sayKeyedMsg| (QUOTE |S2IB0008b|) (CONS |opName| NIL))) - ((QUOTE T) - (|sayKeyedMsg| (QUOTE |S2IB0008c|) - (CONS |opName| (CONS |nAllMmsWithName| NIL)))))) - ((QUOTE T) - (SPADLET |nAllExposedMmsWithNameAndArgs| - (|#| (|getModemapsFromDatabase| |opName| |nArgs|))) - (SPADLET |nAllMmsWithNameAndArgs| - (|#| (|getAllModemapsFromDatabase| |opName| |nArgs|))) - (COND - ((EQL |nAllMmsWithNameAndArgs| 0) - (|sayKeyedMsg| (QUOTE |S2IB0008d|) - (CONS - |opName| - (CONS - |nArgs| - (CONS - |nAllExposedMmsWithName| - (CONS - (SPADDIFFERENCE |nAllMmsWithName| |nAllExposedMmsWithName|) - NIL)))))) - ((EQL |nAllExposedMmsWithNameAndArgs| 0) - (|sayKeyedMsg| (QUOTE |S2IB0008e|) - (CONS - |opName| - (CONS - |nArgs| - (CONS - (SPADDIFFERENCE |nAllMmsWithNameAndArgs| - |nAllExposedMmsWithNameAndArgs|) - NIL))))) - ((QUOTE T) - (|sayKeyedMsg| (QUOTE |S2IB0008f|) - (CONS - |opName| - (CONS - |nArgs| - (CONS - |nAllExposedMmsWithNameAndArgs| - (CONS - (SPADDIFFERENCE |nAllMmsWithNameAndArgs| - |nAllExposedMmsWithNameAndArgs|) - NIL))))))))) - NIL))))) + (PROG (|oo| |nAllExposedMmsWithName| |nAllMmsWithName| + |nAllExposedMmsWithNameAndArgs| |nAllMmsWithNameAndArgs|) + (RETURN + (COND + ((NUMBERP |opName|) NIL) + ('T (SPADLET |oo| (|object2Identifier| (|opOf| |opName|))) + (COND + ((OR (BOOT-EQUAL |oo| '%) (BOOT-EQUAL |oo| '|Domain|) + (|domainForm?| |opName|)) + (SPADLET |opName| '|elt|))) + (SPADLET |nAllExposedMmsWithName| + (|#| (|getModemapsFromDatabase| |opName| NIL))) + (SPADLET |nAllMmsWithName| + (|#| (|getAllModemapsFromDatabase| |opName| NIL))) + (COND + ((EQL |nAllMmsWithName| 0) + (|sayKeyedMsg| '|S2IB0008a| (CONS |opName| NIL))) + ((EQL |nAllExposedMmsWithName| 0) + (COND + ((EQL |nAllMmsWithName| 1) + (|sayKeyedMsg| '|S2IB0008b| (CONS |opName| NIL))) + ('T + (|sayKeyedMsg| '|S2IB0008c| + (CONS |opName| (CONS |nAllMmsWithName| NIL)))))) + ('T + (SPADLET |nAllExposedMmsWithNameAndArgs| + (|#| (|getModemapsFromDatabase| |opName| |nArgs|))) + (SPADLET |nAllMmsWithNameAndArgs| + (|#| (|getAllModemapsFromDatabase| |opName| + |nArgs|))) + (COND + ((EQL |nAllMmsWithNameAndArgs| 0) + (|sayKeyedMsg| '|S2IB0008d| + (CONS |opName| + (CONS |nArgs| + (CONS |nAllExposedMmsWithName| + (CONS + (SPADDIFFERENCE |nAllMmsWithName| + |nAllExposedMmsWithName|) + NIL)))))) + ((EQL |nAllExposedMmsWithNameAndArgs| 0) + (|sayKeyedMsg| '|S2IB0008e| + (CONS |opName| + (CONS |nArgs| + (CONS (SPADDIFFERENCE + |nAllMmsWithNameAndArgs| + |nAllExposedMmsWithNameAndArgs|) + NIL))))) + ('T + (|sayKeyedMsg| '|S2IB0008f| + (CONS |opName| + (CONS |nArgs| + (CONS |nAllExposedMmsWithNameAndArgs| + (CONS + (SPADDIFFERENCE + |nAllMmsWithNameAndArgs| + |nAllExposedMmsWithNameAndArgs|) + NIL))))))))) + NIL))))) ;bottomUpType(t, type) == ; mode := @@ -1792,17 +1903,17 @@ ; putModeSet(t,[mode]) (DEFUN |bottomUpType| (|t| |type|) - (PROG (|mode| |val|) - (RETURN - (PROGN - (SPADLET |mode| - (COND - ((|isPartialMode| |type|) (QUOTE (|Mode|))) - ((|categoryForm?| |type|) (QUOTE (|SubDomain| (|Domain|)))) - ((QUOTE T) (QUOTE (|Domain|))))) - (SPADLET |val| (|objNew| |type| |mode|)) - (|putValue| |t| |val|) - (|putModeSet| |t| (CONS |mode| NIL)))))) + (PROG (|mode| |val|) + (RETURN + (PROGN + (SPADLET |mode| + (COND + ((|isPartialMode| |type|) '(|Mode|)) + ((|categoryForm?| |type|) '(|SubDomain| (|Domain|))) + ('T '(|Domain|)))) + (SPADLET |val| (|objNew| |type| |mode|)) + (|putValue| |t| |val|) + (|putModeSet| |t| (CONS |mode| NIL)))))) ;bottomUpPercent(tree is [op,:argl]) == ; -- handles a call %%(5), which means the output of step 5 @@ -1820,28 +1931,26 @@ ; throwKeyedMsgSP('"S2IB0006",NIL,op) (DEFUN |bottomUpPercent| (|tree|) - (PROG (|op| |argl| |t| |i| |val|) - (RETURN - (PROGN - (SPADLET |op| (CAR |tree|)) - (SPADLET |argl| (CDR |tree|)) - (COND - ((NULL |argl|) - (SPADLET |val| (|fetchOutput| (SPADDIFFERENCE 1))) - (|putValue| |op| |val|) - (|putModeSet| |op| (CONS (|objMode| |val|) NIL))) - ((AND (PAIRP |argl|) - (EQ (QCDR |argl|) NIL) - (PROGN (SPADLET |t| (QCAR |argl|)) (QUOTE T))) - (COND - ((SPADLET |i| (|getArgValue| |t| |$Integer|)) - (SPADLET |val| (|fetchOutput| |i|)) - (|putValue| |op| |val|) - (|putModeSet| |op| (CONS (|objMode| |val|) NIL))) - ((QUOTE T) - (|throwKeyedMsgSP| (MAKESTRING "S2IB0006") NIL |t|)))) - ((QUOTE T) - (|throwKeyedMsgSP| (MAKESTRING "S2IB0006") NIL |op|))))))) + (PROG (|op| |argl| |t| |i| |val|) + (DECLARE (SPECIAL |$Integer|)) + (RETURN + (PROGN + (SPADLET |op| (CAR |tree|)) + (SPADLET |argl| (CDR |tree|)) + (COND + ((NULL |argl|) + (SPADLET |val| (|fetchOutput| (SPADDIFFERENCE 1))) + (|putValue| |op| |val|) + (|putModeSet| |op| (CONS (|objMode| |val|) NIL))) + ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL) + (PROGN (SPADLET |t| (QCAR |argl|)) 'T)) + (COND + ((SPADLET |i| (|getArgValue| |t| |$Integer|)) + (SPADLET |val| (|fetchOutput| |i|)) + (|putValue| |op| |val|) + (|putModeSet| |op| (CONS (|objMode| |val|) NIL))) + ('T (|throwKeyedMsgSP| (MAKESTRING "S2IB0006") NIL |t|)))) + ('T (|throwKeyedMsgSP| (MAKESTRING "S2IB0006") NIL |op|))))))) ;bottomUpFormRetract(t,op,opName,argl,amsl) == ; -- tries to find one argument, which can be pulled back, and calls @@ -1885,63 +1994,66 @@ ; b and bottomUpForm(t,op,opName,a,amsl) (DEFUN |bottomUpFormRetract| (|t| |op| |opName| |argl| |amsl|) - (PROG (|$inRetract| |u| |object| |a| |ms| |typesHad| |b|) - (DECLARE (SPECIAL |$inRetract|)) - (RETURN - (SEQ - (PROGN - (SPADLET |$inRetract| (QUOTE T)) - (COND - ((NULL (|getAllModemapsFromDatabase| (|getUnname| |op|) (|#| |argl|))) - NIL) - ((SPADLET |u| - (|bottomUpFormAnyUnionRetract| |t| |op| |opName| |argl| |amsl|)) - |u|) - ((QUOTE T) - (SPADLET |a| NIL) - (SPADLET |b| NIL) - (SPADLET |ms| NIL) - (DO ((#0=#:G166983 |argl| (CDR #0#)) - (|x| NIL) - (#1=#:G166984 |amsl| (CDR #1#)) - (|m| NIL) - (|i| 1 (QSADD1 |i|))) - ((OR (ATOM #0#) - (PROGN (SETQ |x| (CAR #0#)) NIL) - (ATOM #1#) - (PROGN (SETQ |m| (CAR #1#)) NIL)) - NIL) - (SEQ - (EXIT - (COND - ((AND (EQL |i| 1) (BOOT-EQUAL |opName| (QUOTE |setelt|))) - (SPADLET |a| (CONS |x| |a|)) (SPADLET |ms| (CONS |m| |ms|))) - ((AND (EQL |i| 1) (BOOT-EQUAL |opName| (QUOTE |set!|))) - (SPADLET |a| (CONS |x| |a|)) (SPADLET |ms| (CONS |m| |ms|))) - ((QUOTE T) - (COND - ((AND (PAIRP |m|) (BOOT-EQUAL (CAR |m|) |$EmptyMode|)) - (RETURN NIL))) - (SPADLET |object| (|retract| (|getValue| |x|))) - (SPADLET |a| (CONS |x| |a|)) - (COND - ((EQ |object| (QUOTE |failed|)) - (|putAtree| |x| (QUOTE |retracted|) NIL) - (SPADLET |ms| (CONS |m| |ms|))) - ((QUOTE T) - (SPADLET |b| (QUOTE T)) - (RPLACA |m| (|objMode| |object|)) - (SPADLET |ms| (CONS (COPY-TREE |m|) |ms|)) - (|putAtree| |x| (QUOTE |retracted|) (QUOTE T)) - (|putValue| |x| |object|) - (|putModeSet| |x| (CONS (|objMode| |object|) NIL))))))))) - (SPADLET |a| (NREVERSE |a|)) - (SPADLET |ms| (NREVERSE |ms|)) - (SPADLET |typesHad| (|getAtree| |t| (QUOTE |typesHad|))) - (COND - ((|member| |ms| |typesHad|) (SPADLET |b| NIL)) - ((QUOTE T) (|putAtree| |t| (QUOTE |typesHad|) (CONS |ms| |typesHad|)))) - (AND |b| (|bottomUpForm| |t| |op| |opName| |a| |amsl|))))))))) + (PROG (|$inRetract| |u| |object| |a| |ms| |typesHad| |b|) + (DECLARE (SPECIAL |$inRetract| |$EmptyMode|)) + (RETURN + (SEQ (PROGN + (SPADLET |$inRetract| 'T) + (COND + ((NULL (|getAllModemapsFromDatabase| (|getUnname| |op|) + (|#| |argl|))) + NIL) + ((SPADLET |u| + (|bottomUpFormAnyUnionRetract| |t| |op| + |opName| |argl| |amsl|)) + |u|) + ('T (SPADLET |a| NIL) (SPADLET |b| NIL) + (SPADLET |ms| NIL) + (DO ((G166983 |argl| (CDR G166983)) (|x| NIL) + (G166984 |amsl| (CDR G166984)) (|m| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G166983) + (PROGN (SETQ |x| (CAR G166983)) NIL) + (ATOM G166984) + (PROGN (SETQ |m| (CAR G166984)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (EQL |i| 1) + (BOOT-EQUAL |opName| '|setelt|)) + (SPADLET |a| (CONS |x| |a|)) + (SPADLET |ms| (CONS |m| |ms|))) + ((AND (EQL |i| 1) + (BOOT-EQUAL |opName| '|set!|)) + (SPADLET |a| (CONS |x| |a|)) + (SPADLET |ms| (CONS |m| |ms|))) + ('T + (COND + ((AND (PAIRP |m|) + (BOOT-EQUAL (CAR |m|) |$EmptyMode|)) + (RETURN NIL))) + (SPADLET |object| + (|retract| (|getValue| |x|))) + (SPADLET |a| (CONS |x| |a|)) + (COND + ((EQ |object| '|failed|) + (|putAtree| |x| '|retracted| NIL) + (SPADLET |ms| (CONS |m| |ms|))) + ('T (SPADLET |b| 'T) + (RPLACA |m| (|objMode| |object|)) + (SPADLET |ms| + (CONS (COPY-TREE |m|) |ms|)) + (|putAtree| |x| '|retracted| 'T) + (|putValue| |x| |object|) + (|putModeSet| |x| + (CONS (|objMode| |object|) NIL))))))))) + (SPADLET |a| (NREVERSE |a|)) + (SPADLET |ms| (NREVERSE |ms|)) + (SPADLET |typesHad| (|getAtree| |t| '|typesHad|)) + (COND + ((|member| |ms| |typesHad|) (SPADLET |b| NIL)) + ('T + (|putAtree| |t| '|typesHad| (CONS |ms| |typesHad|)))) + (AND |b| (|bottomUpForm| |t| |op| |opName| |a| |amsl|))))))))) ;retractAtree atr == ; object:= retract getValue atr @@ -1954,19 +2066,16 @@ ; true (DEFUN |retractAtree| (|atr|) - (PROG (|object|) - (RETURN - (PROGN - (SPADLET |object| (|retract| (|getValue| |atr|))) - (COND - ((EQ |object| (QUOTE |failed|)) - (|putAtree| |atr| (QUOTE |retracted|) NIL) - NIL) - ((QUOTE T) - (|putAtree| |atr| (QUOTE |retracted|) (QUOTE T)) - (|putValue| |atr| |object|) - (|putModeSet| |atr| (CONS (|objMode| |object|) NIL)) - (QUOTE T))))))) + (PROG (|object|) + (RETURN + (PROGN + (SPADLET |object| (|retract| (|getValue| |atr|))) + (COND + ((EQ |object| '|failed|) (|putAtree| |atr| '|retracted| NIL) + NIL) + ('T (|putAtree| |atr| '|retracted| 'T) + (|putValue| |atr| |object|) + (|putModeSet| |atr| (CONS (|objMode| |object|) NIL)) 'T)))))) ;bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) == ; -- see if we have a Union @@ -1990,58 +2099,52 @@ ; b and bottomUpForm(t,op,opName,nreverse a,amsl) (DEFUN |bottomUpFormAnyUnionRetract| (|t| |op| |opName| |argl| |amsl|) - (PROG (|ok| |m0| |object| |b| |a|) - (RETURN - (SEQ - (PROGN - (SPADLET |ok| NIL) - (DO ((#0=#:G167032 |amsl| (CDR #0#)) (|m| NIL)) - ((OR (ATOM #0#) (PROGN (SETQ |m| (CAR #0#)) NIL) (NULL (NULL |ok|))) - NIL) - (SEQ - (EXIT - (PROGN - (COND ((ATOM (CAR |m|)) (RETURN NIL))) - (COND - ((BOOT-EQUAL (CAR |m|) |$Any|) - (SPADLET |ok| (QUOTE T))) - ((BOOT-EQUAL (CAR (CAR |m|)) (QUOTE |Union|)) - (SPADLET |ok| (QUOTE T)))))))) - (COND - ((NULL |ok|) NIL) - ((QUOTE T) - (SPADLET |a| NIL) - (SPADLET |b| NIL) - (DO ((#1=#:G167047 |argl| (CDR #1#)) - (|x| NIL) - (#2=#:G167048 |amsl| (CDR #2#)) - (|m| NIL) - (|i| 0 (QSADD1 |i|))) - ((OR (ATOM #1#) - (PROGN (SETQ |x| (CAR #1#)) NIL) - (ATOM #2#) - (PROGN (SETQ |m| (CAR #2#)) NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |m0| (CAR |m|)) - (COND - ((AND - (OR - (BOOT-EQUAL |m0| |$Any|) - (BOOT-EQUAL (CAR |m0|) (QUOTE |Union|))) - (NEQUAL - (QUOTE |failed|) - (SPADLET |object| (|retract| (|getValue| |x|))))) - (SPADLET |b| (QUOTE T)) - (RPLACA |m| (|objMode| |object|)) - (|putModeSet| |x| (CONS (|objMode| |object|) NIL)) - (|putValue| |x| |object|))) - (SPADLET |a| (CONS |x| |a|)))))) - (AND - |b| - (|bottomUpForm| |t| |op| |opName| (NREVERSE |a|) |amsl|))))))))) + (PROG (|ok| |m0| |object| |b| |a|) + (DECLARE (SPECIAL |$Any|)) + (RETURN + (SEQ (PROGN + (SPADLET |ok| NIL) + (DO ((G167032 |amsl| (CDR G167032)) (|m| NIL)) + ((OR (ATOM G167032) + (PROGN (SETQ |m| (CAR G167032)) NIL) + (NULL (NULL |ok|))) + NIL) + (SEQ (EXIT (PROGN + (COND ((ATOM (CAR |m|)) (RETURN NIL))) + (COND + ((BOOT-EQUAL (CAR |m|) |$Any|) + (SPADLET |ok| 'T)) + ((BOOT-EQUAL (CAR (CAR |m|)) '|Union|) + (SPADLET |ok| 'T))))))) + (COND + ((NULL |ok|) NIL) + ('T (SPADLET |a| NIL) (SPADLET |b| NIL) + (DO ((G167047 |argl| (CDR G167047)) (|x| NIL) + (G167048 |amsl| (CDR G167048)) (|m| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G167047) + (PROGN (SETQ |x| (CAR G167047)) NIL) + (ATOM G167048) + (PROGN (SETQ |m| (CAR G167048)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |m0| (CAR |m|)) + (COND + ((AND (OR (BOOT-EQUAL |m0| |$Any|) + (BOOT-EQUAL (CAR |m0|) + '|Union|)) + (NEQUAL '|failed| + (SPADLET |object| + (|retract| (|getValue| |x|))))) + (SPADLET |b| 'T) + (RPLACA |m| (|objMode| |object|)) + (|putModeSet| |x| + (CONS (|objMode| |object|) NIL)) + (|putValue| |x| |object|))) + (SPADLET |a| (CONS |x| |a|)))))) + (AND |b| + (|bottomUpForm| |t| |op| |opName| (NREVERSE |a|) + |amsl|))))))))) ;bottomUpFormUntaggedUnionRetract(t,op,opName,argl,amsl) == ; -- see if we have a Union with no tags, if so retract all such guys @@ -2063,61 +2166,60 @@ ; a := cons(x,a) ; b and bottomUpForm(t,op,opName,nreverse a,amsl) -(DEFUN |bottomUpFormUntaggedUnionRetract| (|t| |op| |opName| |argl| |amsl|) - (PROG (|m| |ok| |m0| |object| |b| |a|) - (RETURN - (SEQ - (PROGN - (SPADLET |ok| NIL) - (DO ((#0=#:G167083 |amsl| (CDR #0#)) (#1=#:G167070 NIL)) - ((OR (ATOM #0#) - (PROGN (SETQ #1# (CAR #0#)) NIL) - (PROGN (PROGN (SPADLET |m| (CAR #1#)) #1#) NIL) - (NULL (NULL |ok|))) - NIL) - (SEQ - (EXIT - (PROGN - (COND ((ATOM |m|) (RETURN NIL))) - (COND - ((AND (PAIRP |m|) - (EQ (QCAR |m|) (QUOTE |Union|)) - (NULL (|getUnionOrRecordTags| |m|))) - (SPADLET |ok| (QUOTE T))) - ((QUOTE T) NIL)))))) - (COND - ((NULL |ok|) NIL) - ((QUOTE T) - (SPADLET |a| NIL) - (SPADLET |b| NIL) - (DO ((#2=#:G167099 |argl| (CDR #2#)) - (|x| NIL) - (#3=#:G167100 |amsl| (CDR #3#)) - (|m| NIL) - (|i| 0 (QSADD1 |i|))) - ((OR (ATOM #2#) - (PROGN (SETQ |x| (CAR #2#)) NIL) - (ATOM #3#) - (PROGN (SETQ |m| (CAR #3#)) NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |m0| (CAR |m|)) - (COND - ((AND (PAIRP |m0|) - (EQ (QCAR |m0|) (QUOTE |Union|)) - (NULL (|getUnionOrRecordTags| |m0|)) - (NEQUAL - (QUOTE |failed|) - (SPADLET |object| (|retract| (|getValue| |x|))))) - (SPADLET |b| (QUOTE T)) - (RPLACA |m| (|objMode| |object|)) - (|putModeSet| |x| (CONS (|objMode| |object|) NIL)) - (|putValue| |x| |object|))) - (SPADLET |a| (CONS |x| |a|)))))) - (AND |b| - (|bottomUpForm| |t| |op| |opName| (NREVERSE |a|) |amsl|))))))))) +(DEFUN |bottomUpFormUntaggedUnionRetract| + (|t| |op| |opName| |argl| |amsl|) + (PROG (|m| |ok| |m0| |object| |b| |a|) + (RETURN + (SEQ (PROGN + (SPADLET |ok| NIL) + (DO ((G167083 |amsl| (CDR G167083)) (G167070 NIL)) + ((OR (ATOM G167083) + (PROGN (SETQ G167070 (CAR G167083)) NIL) + (PROGN + (PROGN + (SPADLET |m| (CAR G167070)) + G167070) + NIL) + (NULL (NULL |ok|))) + NIL) + (SEQ (EXIT (PROGN + (COND ((ATOM |m|) (RETURN NIL))) + (COND + ((AND (PAIRP |m|) + (EQ (QCAR |m|) '|Union|) + (NULL (|getUnionOrRecordTags| |m|))) + (SPADLET |ok| 'T)) + ('T NIL)))))) + (COND + ((NULL |ok|) NIL) + ('T (SPADLET |a| NIL) (SPADLET |b| NIL) + (DO ((G167099 |argl| (CDR G167099)) (|x| NIL) + (G167100 |amsl| (CDR G167100)) (|m| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G167099) + (PROGN (SETQ |x| (CAR G167099)) NIL) + (ATOM G167100) + (PROGN (SETQ |m| (CAR G167100)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |m0| (CAR |m|)) + (COND + ((AND (PAIRP |m0|) + (EQ (QCAR |m0|) '|Union|) + (NULL + (|getUnionOrRecordTags| |m0|)) + (NEQUAL '|failed| + (SPADLET |object| + (|retract| (|getValue| |x|))))) + (SPADLET |b| 'T) + (RPLACA |m| (|objMode| |object|)) + (|putModeSet| |x| + (CONS (|objMode| |object|) NIL)) + (|putValue| |x| |object|))) + (SPADLET |a| (CONS |x| |a|)))))) + (AND |b| + (|bottomUpForm| |t| |op| |opName| (NREVERSE |a|) + |amsl|))))))))) ;bottomUpElt (form:=[op,:argl]) == ; -- this transfers expressions that look like function calls into @@ -2146,86 +2248,89 @@ ; u (DEFUN |bottomUpElt| (|form|) - (PROG (|op| |argl| |ms| |ISTMP#1| |target| |newOps| |newArgs| |u|) - (RETURN - (SEQ - (PROGN - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (SPADLET |ms| (|bottomUp| |op|)) - (COND - ((AND |ms| - (OR - (AND - (PAIRP |ms|) - (EQ (QCDR |ms|) NIL) - (PROGN - (SPADLET |ISTMP#1| (QCAR |ms|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE |Union|))))) - (AND - (PAIRP |ms|) - (EQ (QCDR |ms|) NIL) - (PROGN - (SPADLET |ISTMP#1| (QCAR |ms|)) - (AND - (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE |Record|))))))) - (RPLAC (CDR |form|) (CONS |op| |argl|)) - (RPLAC (CAR |form|) (|mkAtreeNode| (QUOTE |elt|))) - (|bottomUp| |form|)) - ((QUOTE T) - (SPADLET |target| (|getTarget| |form|)) - (SPADLET |newOps| - (CONS - (|mkAtreeNode| (QUOTE |elt|)) - (CONS (|mkAtreeNode| (QUOTE |apply|)) NIL))) - (SPADLET |u| NIL) - (DO ((#0=#:G167149 |newOps| (CDR #0#)) (|newOp| NIL)) - ((OR (NULL (NULL |u|)) - (ATOM #0#) - (PROGN (SETQ |newOp| (CAR #0#)) NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |newArgs| (CONS |op| |argl|)) - (COND - ((|selectMms| |newOp| |newArgs| |target|) - (RPLAC (CDR |form|) |newArgs|) - (RPLAC (CAR |form|) |newOp|) - (SPADLET |u| (|bottomUp| |form|))) - ((QUOTE T) NIL)))))) - (DO () - ((NULL - (AND - (NULL |u|) - (PROG (#1=#:G167164) - (SPADLET #1# (QUOTE T)) - (RETURN - (DO ((#2=#:G167170 NIL (NULL #1#)) - (#3=#:G167171 |newArgs| (CDR #3#)) - (|a| NIL)) - ((OR #2# (ATOM #3#) (PROGN (SETQ |a| (CAR #3#)) NIL)) #1#) - (SEQ (EXIT (SETQ #1# (AND #1# (|retractAtree| |a|)))))))))) - NIL) - (SEQ - (EXIT - (DO ((#4=#:G167184 |newOps| (CDR #4#)) (|newOp| NIL)) - ((OR (NULL (NULL |u|)) - (ATOM #4#) - (PROGN (SETQ |newOp| (CAR #4#)) NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |newArgs| (CONS |op| |argl|)) - (COND - ((|selectMms| |newOp| |newArgs| |target|) - (RPLAC (CDR |form|) |newArgs|) - (RPLAC (CAR |form|) |newOp|) - (SPADLET |u| (|bottomUp| |form|))) - ((QUOTE T) NIL))))))))) - |u|))))))) + (PROG (|op| |argl| |ms| |ISTMP#1| |target| |newOps| |newArgs| |u|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |ms| (|bottomUp| |op|)) + (COND + ((AND |ms| + (OR (AND (PAIRP |ms|) (EQ (QCDR |ms|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |ms|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Union|)))) + (AND (PAIRP |ms|) (EQ (QCDR |ms|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |ms|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Record|)))))) + (RPLAC (CDR |form|) (CONS |op| |argl|)) + (RPLAC (CAR |form|) (|mkAtreeNode| '|elt|)) + (|bottomUp| |form|)) + ('T (SPADLET |target| (|getTarget| |form|)) + (SPADLET |newOps| + (CONS (|mkAtreeNode| '|elt|) + (CONS (|mkAtreeNode| '|apply|) NIL))) + (SPADLET |u| NIL) + (DO ((G167149 |newOps| (CDR G167149)) + (|newOp| NIL)) + ((OR (NULL (NULL |u|)) (ATOM G167149) + (PROGN (SETQ |newOp| (CAR G167149)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |newArgs| (CONS |op| |argl|)) + (COND + ((|selectMms| |newOp| |newArgs| + |target|) + (RPLAC (CDR |form|) |newArgs|) + (RPLAC (CAR |form|) |newOp|) + (SPADLET |u| (|bottomUp| |form|))) + ('T NIL)))))) + (DO () + ((NULL (AND (NULL |u|) + (PROG (G167164) + (SPADLET G167164 'T) + (RETURN + (DO + ((G167170 NIL (NULL G167164)) + (G167171 |newArgs| + (CDR G167171)) + (|a| NIL)) + ((OR G167170 (ATOM G167171) + (PROGN + (SETQ |a| (CAR G167171)) + NIL)) + G167164) + (SEQ + (EXIT + (SETQ G167164 + (AND G167164 + (|retractAtree| |a|)))))))))) + NIL) + (SEQ (EXIT (DO ((G167184 |newOps| (CDR G167184)) + (|newOp| NIL)) + ((OR (NULL (NULL |u|)) + (ATOM G167184) + (PROGN + (SETQ |newOp| (CAR G167184)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |newArgs| + (CONS |op| |argl|)) + (COND + ((|selectMms| |newOp| + |newArgs| |target|) + (RPLAC (CDR |form|) + |newArgs|) + (RPLAC (CAR |form|) |newOp|) + (SPADLET |u| + (|bottomUp| |form|))) + ('T NIL))))))))) + |u|))))))) ;isEltable(op,argl,numArgs) == ; -- determines if the object might possible have an elt function @@ -2249,41 +2354,34 @@ ; true (DEFUN |isEltable| (|op| |argl| |numArgs|) - (PROG (|v| |ISTMP#1| |mapDef| |m| |name| |arg|) - (RETURN - (COND - ((SPADLET |v| (|getValue| |op|)) - (COND - ((ZEROP |numArgs|) - (QUOTE T)) - ((NULL (SPADLET |m| (|objMode| |v|))) - NIL) - ((AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Mapping|))) - NIL) - ((AND - (PROGN - (SPADLET |ISTMP#1| (|objVal| |v|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) - (PROGN (SPADLET |mapDef| (QCDR |ISTMP#1|)) (QUOTE T)))) - (> (|numMapArgs| |mapDef|) 0)) - NIL) - ((QUOTE T) (QUOTE T)))) - ((SPADLET |m| (|getMode| |op|)) - (COND - ((ZEROP |numArgs|) (QUOTE T)) - ((AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Mapping|))) NIL) - ((QUOTE T) (QUOTE T)))) - ((NEQUAL |numArgs| 1) NIL) - ((QUOTE T) - (SPADLET |name| (|getUnname| |op|)) - (COND - ((BOOT-EQUAL |name| (QUOTE SEQ)) NIL) - ((QUOTE T) - (SPADLET |arg| (CAR |argl|)) - (COND - ((NEQUAL (|getUnname| |arg|) (QUOTE |construct|)) NIL) - ((QUOTE T) (QUOTE T)))))))))) + (PROG (|v| |ISTMP#1| |mapDef| |m| |name| |arg|) + (RETURN + (COND + ((SPADLET |v| (|getValue| |op|)) + (COND + ((ZEROP |numArgs|) 'T) + ((NULL (SPADLET |m| (|objMode| |v|))) NIL) + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Mapping|)) NIL) + ((AND (PROGN + (SPADLET |ISTMP#1| (|objVal| |v|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) 'MAP) + (PROGN (SPADLET |mapDef| (QCDR |ISTMP#1|)) 'T))) + (> (|numMapArgs| |mapDef|) 0)) + NIL) + ('T 'T))) + ((SPADLET |m| (|getMode| |op|)) + (COND + ((ZEROP |numArgs|) 'T) + ((AND (PAIRP |m|) (EQ (QCAR |m|) '|Mapping|)) NIL) + ('T 'T))) + ((NEQUAL |numArgs| 1) NIL) + ('T (SPADLET |name| (|getUnname| |op|)) + (COND + ((BOOT-EQUAL |name| 'SEQ) NIL) + ('T (SPADLET |arg| (CAR |argl|)) + (COND + ((NEQUAL (|getUnname| |arg|) '|construct|) NIL) + ('T 'T))))))))) @ \eject