diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index 152ada1..d3ed19b 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -2098,6 +2098,7 @@ It is controlled with the {\tt )se me any} command. \end{chunk} \defun{printTypeAndTimeNormal}{printTypeAndTimeNormal} +\calls{printTypeAndTimeNormal}{retract} \calls{printTypeAndTimeNormal}{qcar} \calls{printTypeAndTimeNormal}{retract} \calls{printTypeAndTimeNormal}{objNewWrap} @@ -25009,6 +25010,26 @@ recurrence specially compile recurrence relations on \end{chunk} +\defun{insertAlist}{insertAlist} +\calls{insertAlist}{rplac} +\calls{insertAlist}{?order} +\begin{chunk}{defun insertAlist} +(defun |insertAlist| (a b z) + (labels ( + (fn (a b z) + (cond + ((null (cdr z)) (rplac (cdr z) (list (cons a b)))) + ((equal a (elt (elt z 1) 0)) (rplac (cdr (elt z 1)) b)) + ((?order (elt (elt z 1) 0) a) (rplac (cdr z) (cons (cons a b) (cdr z)))) + (t (fn a b (cdr z)))))) + (cond + ((null z) (list (cons a b))) + ((equal a (elt (elt z 0) 0)) (rplac (cdar z) b) z) + ((?order (elt (elt z 0) 0) a) (cons (cons a b) z)) + (t (fn a b z) z)))) + +\end{chunk} + \defunsec{describeSetFunctionsCache}{Describe the set functions cache} \calls{describeSetFunctionsCache}{sayBrightly} \begin{chunk}{defun describeSetFunctionsCache} @@ -38013,6 +38034,118 @@ but the Axiom semantics are not the same. Because Axiom was originally written in Maclisp, then VMLisp, and then Common Lisp some of these old semantics survive. +;spad2BootCoerce(x,source,target) == +; -- x : source and we wish to coerce to target +; -- used in spad code for Any +; null isValidType source => throwKeyedMsg("S2IE0004",[source]) +; null isValidType target => throwKeyedMsg("S2IE0004",[target]) +; x' := coerceInteractive(objNewWrap(x,source),target) => +; objValUnwrap(x') +; throwKeyedMsgCannotCoerceWithValue(wrap x,source,target) + +\section{AlgebraicFunction} +\defun{retract}{retract} +\calls{retract}{objMode} +\calls{retract}{objVal} +\calls{retract}{isWrapped} +\calls{retract}{qcar} +\calls{retract}{retract1} +\calls{retract}{objNew} +\refsdollar{retract}{EmptyMode} +\begin{chunk}{defun retract} +(defun |retract| (object) + (labels ( + (retract1 (object) + (let (type val typep tmp1 underDomain objectp) + (declare (special |$SingleInteger| |$Integer| |$NonNegativeInteger| + |$PositiveInteger|)) + (setq type (|objMode| object)) + (cond + ((stringp type) '|failed|) + (t + (setq val (|objVal| object)) + (cond + ((equal type |$PositiveInteger|) (|objNew| val |$NonNegativeInteger|)) + ((equal type |$NonNegativeInteger|) (|objNew| val |$Integer|)) + ((and (equal type |$Integer|) (typep (|unwrap| val) 'fixnum)) + (|objNew| val |$SingleInteger|)) + (t + (cond + ((or (eql 1 (|#| type)) + (and (consp type) (eq (qcar type) '|Union|)) + (and (consp type) (eq (qcar type) '|FunctionCalled|) + (and (consp (qcdr type)) (eq (qcddr type) nil))) + (and (consp type) (eq (qcar type) '|OrderedVariableList|) + (and (consp (qcdr type)) (eq (qcddr type) nil))) + (and (consp type) (eq (qcar type) '|Variable|) + (and (consp (qcdr type)) (eq (qcddr type) nil)))) + (if (setq objectp (|retract2Specialization| object)) + objectp + '|failed|)) + ((null (setq underDomain (|underDomainOf| type))) + '|failed|) + ; try to retract the "coefficients", e.g. P RN -> P I or M RN -> M I + (t + (setq objectp (|retractUnderDomain| object type underDomain)) + (cond + ((nequal objectp '|failed|) objectp) + ; see if we can use the retract functions + ((setq objectp (|coerceRetract| object underDomain)) objectp) + ; see if we have a special case here + ((setq objectp (|retract2Specialization| object)) objectp) + (t '|failed|))))))))))) + (let (type val ans) + (declare (special |$EmptyMode|)) + (setq type (|objMode| object)) + (cond + ((stringp type) '|failed|) + ((equal type |$EmptyMode|) '|failed|) + (t + (setq val (|objVal| object)) + (cond + ((and (null (|isWrapped| val)) + (null (and (consp val) (eq (qcar val) 'map)))) + '|failed|) + (t + (cond + ((eq (setq ans (retract1 (|objNew| val type))) '|failed|) + ans) + (t + (|objNew| (|objVal| ans) (|eqType| (|objMode| ans)))))))))))) + +\end{chunk} + +\section{Any} +\defun{spad2BootCoerce}{spad2BootCoerce} +\begin{chunk}{defun spad2BootCoerce} +(defun |spad2BootCoerce| (x source target) + (let (xp) + (cond + ((null (|isValidType| source)) (|throwKeyedMsg| 'S2IE0004 (list source))) + ((null (|isValidType| target)) (|throwKeyedMsg| 'S2IE0004 (list target))) + ((setq xp (|coerceInteractive| (|objNewWrap| x source) target)) + (|objValUnwrap| xp)) + (t + (|throwKeyedMsgCannotCoerceWithValue| (|wrap| x) source target))))) + +\end{chunk} + +\section{ParametricLinearEquations} +\defun{algCoerceInteractive}{algCoerceInteractive} +\begin{chunk}{defun algCoerceInteractive} +(defun |algCoerceInteractive| (p source target) + (let (|$useConvertForCoercions| u) + (declare (special |$useConvertForCoercions|)) + (setq |$useConvertForCoercions| t) + (setq source (|devaluate| source)) + (setq target (|devaluate| target)) + (setq u (|coerceInteractive| (|objNewWrap| p source) target)) + (if u + (|objValUnwrap| u) + (|error| (list "can't convert" p "of mode" source "to mode" target))))) + +\end{chunk} + \section{NumberFormats} \defun{ncParseFromString}{ncParseFromString} \begin{chunk}{defun ncParseFromString} @@ -40562,6 +40695,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun addNewInterpreterFrame} \getchunk{defun addoperations} \getchunk{defun addTraceItem} +\getchunk{defun algCoerceInteractive} \getchunk{defun allConstructors} \getchunk{defun allOperations} \getchunk{defun alqlGetOrigin} @@ -40801,6 +40935,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun initImPr} \getchunk{defun initroot} \getchunk{defun initToWhere} +\getchunk{defun insertAlist} \getchunk{defun insertpile} \getchunk{defun InterpExecuteSpadSystemCommand} \getchunk{defun interpFunctionDepAlists} @@ -41416,6 +41551,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun restart} \getchunk{defun restart0} \getchunk{defun restoreHistory} +\getchunk{defun retract} \getchunk{defun /rf} \getchunk{defun /rq} \getchunk{defun rread} @@ -41538,6 +41674,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun spadTrace,g} \getchunk{defun spadTrace,isTraceable} \getchunk{defun spadUntrace} +\getchunk{defun spad2BootCoerce} \getchunk{defun specialChar} \getchunk{defun spleI} \getchunk{defun spleI1} diff --git a/changelog b/changelog index 7ad6aba..54eb2f3 100644 --- a/changelog +++ b/changelog @@ -1,4 +1,10 @@ -20110923 tpd src/axiom-website/patches.html 20110924.01.tpd.patch +20110926 tpd src/axiom-website/patches.html 20110926.01.tpd.patch +20110926 tpd src/interp/i-resolv.lisp treeshake interpreter +20110926 tpd src/interp/i-coerfn.lisp treeshake interpreter +20110926 tpd src/interp/i-coerce.lisp treeshake interpreter +20110926 tpd src/interp/clammed.lisp treeshake interpreter +20110926 tpd books/bookvol5 treeshake interpreter +20110924 tpd src/axiom-website/patches.html 20110924.01.tpd.patch 20110924 tpd src/input/unittest2.input fixup broken tests 20110924 tpd src/input/unittest1.input fixup broken tests 20110924 tpd src/input/setcmd.input fixup broken tests diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index a0e1ca2..205598e 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3632,5 +3632,7 @@ src/interp/Makefile remove nci.lisp
books/bookvol5 remove ncParseAndInterpretString
20110924.01.tpd.patch books/bookvol5 merge nocompil.lisp
+20110926.01.tpd.patch +books/bookvol5 treeshake interpreter
diff --git a/src/interp/clammed.lisp.pamphlet b/src/interp/clammed.lisp.pamphlet index 4978ba6..5528abc 100644 --- a/src/interp/clammed.lisp.pamphlet +++ b/src/interp/clammed.lisp.pamphlet @@ -727,7 +727,7 @@ (|ofCategory| D '(|Field|))) NIL) ((BOOT-EQUAL |t| '(|Complex| (|AlgebraicNumber|))) NIL) - ('T (SPADLET |t| (|equiType| |t|)) + ('T (SEQ (COND ((SPADLET |vl| (|isPolynomialMode| |t|)) (PROGN diff --git a/src/interp/i-coerce.lisp.pamphlet b/src/interp/i-coerce.lisp.pamphlet index 1b82823..8867944 100644 --- a/src/interp/i-coerce.lisp.pamphlet +++ b/src/interp/i-coerce.lisp.pamphlet @@ -40,63 +40,6 @@ The special routines that do the coercions typically involve a "2" \begin{chunk}{*} (IN-PACKAGE "BOOT" ) -;--% Algebraic coercions using interactive code -;algCoerceInteractive(p,source,target) == -; -- now called in some groebner code -; $useConvertForCoercions : local := true -; source := devaluate source -; target := devaluate target -; u := coerceInteractive(objNewWrap(p,source),target) -; u => objValUnwrap(u) -; error ['"can't convert",p,'"of mode",source,'"to mode",target] - -(DEFUN |algCoerceInteractive| (|p| |source| |target|) - (PROG (|$useConvertForCoercions| |u|) - (DECLARE (SPECIAL |$useConvertForCoercions|)) - (RETURN - (PROGN - (SPADLET |$useConvertForCoercions| 'T) - (SPADLET |source| (|devaluate| |source|)) - (SPADLET |target| (|devaluate| |target|)) - (SPADLET |u| - (|coerceInteractive| (|objNewWrap| |p| |source|) - |target|)) - (COND - (|u| (|objValUnwrap| |u|)) - ('T - (|error| (CONS "can't convert" - (CONS |p| - (CONS "of mode" - (CONS |source| - (CONS "to mode" - (CONS |target| NIL))))))))))))) - - -;spad2BootCoerce(x,source,target) == -; -- x : source and we wish to coerce to target -; -- used in spad code for Any -; null isValidType source => throwKeyedMsg("S2IE0004",[source]) -; null isValidType target => throwKeyedMsg("S2IE0004",[target]) -; x' := coerceInteractive(objNewWrap(x,source),target) => -; objValUnwrap(x') -; throwKeyedMsgCannotCoerceWithValue(wrap x,source,target) - -(DEFUN |spad2BootCoerce| (|x| |source| |target|) - (PROG (|x'|) - (RETURN - (COND - ((NULL (|isValidType| |source|)) - (|throwKeyedMsg| 'S2IE0004 (CONS |source| NIL))) - ((NULL (|isValidType| |target|)) - (|throwKeyedMsg| 'S2IE0004 (CONS |target| NIL))) - ((SPADLET |x'| - (|coerceInteractive| (|objNewWrap| |x| |source|) - |target|)) - (|objValUnwrap| |x'|)) - ('T - (|throwKeyedMsgCannotCoerceWithValue| (|wrap| |x|) |source| - |target|)))))) - ;--% Functions for Coercion or Else We'll Get Rough ;coerceOrFail(triple,t,mapName) == ; -- some code generated for this is in coerceInt0 @@ -163,136 +106,6 @@ The special routines that do the coercions typically involve a "2" (|objValUnwrap| |result|))))) ;--% Retraction functions -;retract object == -; type := objMode object -; STRINGP type => 'failed -; type = $EmptyMode => 'failed -; val := objVal object -; not isWrapped val and val isnt ['MAP,:.] => 'failed -; type' := equiType(type) -; (ans := retract1 objNew(val,equiType(type))) = 'failed => ans -; objNew(objVal ans,eqType objMode ans) - -(DEFUN |retract| (|object|) - (PROG (|type| |val| |type'| |ans|) - (DECLARE (SPECIAL |$EmptyMode|)) - (RETURN - (PROGN - (SPADLET |type| (|objMode| |object|)) - (COND - ((STRINGP |type|) '|failed|) - ((BOOT-EQUAL |type| |$EmptyMode|) '|failed|) - ('T (SPADLET |val| (|objVal| |object|)) - (COND - ((AND (NULL (|isWrapped| |val|)) - (NULL (AND (CONSP |val|) (EQ (QCAR |val|) 'MAP)))) - '|failed|) - ('T (SPADLET |type'| (|equiType| |type|)) - (COND - ((BOOT-EQUAL - (SPADLET |ans| - (|retract1| - (|objNew| |val| (|equiType| |type|)))) - '|failed|) - |ans|) - ('T - (|objNew| (|objVal| |ans|) - (|eqType| (|objMode| |ans|))))))))))))) - -;retract1 object == -; -- this function is the new version of the old "pullback" -; -- it first tries to change the datatype of an object to that of -; -- largest contained type. Examples: P RN -> RN, RN -> I -; -- This is mostly for cases such as constant polynomials or -; -- quotients with 1 in the denominator. -; type := objMode object -; STRINGP type => 'failed -; val := objVal object -; type = $PositiveInteger => objNew(val,$NonNegativeInteger) -; type = $NonNegativeInteger => objNew(val,$Integer) -; type = $Integer and SINTP unwrap val => objNew(val, $SingleInteger) -; type' := equiType(type) -; if not EQ(type,type') then object := objNew(val,type') -; (1 = #type') or (type' is ['Union,:.]) or -; (type' is ['FunctionCalled,.]) -; or (type' is ['OrderedVariableList,.]) or (type is ['Variable,.]) => -; (object' := retract2Specialization(object)) => object' -; 'failed -; null (underDomain := underDomainOf type') => 'failed -; -- try to retract the "coefficients" -; -- think of P RN -> P I or M RN -> M I -; object' := retractUnderDomain(object,type,underDomain) -; object' ^= 'failed => object' -; -- see if we can use the retract functions -; (object' := coerceRetract(object,underDomain)) => object' -; -- see if we have a special case here -; (object' := retract2Specialization(object)) => object' -; 'failed - -(DEFUN |retract1| (|object|) - (PROG (|type| |val| |type'| |ISTMP#1| |underDomain| |object'|) - (DECLARE (SPECIAL |$SingleInteger| |$Integer| |$NonNegativeInteger| - |$PositiveInteger|)) - (RETURN - (PROGN - (SPADLET |type| (|objMode| |object|)) - (COND - ((STRINGP |type|) '|failed|) - ('T (SPADLET |val| (|objVal| |object|)) - (COND - ((BOOT-EQUAL |type| |$PositiveInteger|) - (|objNew| |val| |$NonNegativeInteger|)) - ((BOOT-EQUAL |type| |$NonNegativeInteger|) - (|objNew| |val| |$Integer|)) - ((AND (BOOT-EQUAL |type| |$Integer|) - (typep (|unwrap| |val|) 'fixnum)) - (|objNew| |val| |$SingleInteger|)) - ('T (SPADLET |type'| (|equiType| |type|)) - (COND - ((NULL (EQ |type| |type'|)) - (SPADLET |object| (|objNew| |val| |type'|)))) - (COND - ((OR (EQL 1 (|#| |type'|)) - (AND (CONSP |type'|) (EQ (QCAR |type'|) '|Union|)) - (AND (CONSP |type'|) - (EQ (QCAR |type'|) '|FunctionCalled|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |type'|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL)))) - (AND (CONSP |type'|) - (EQ (QCAR |type'|) '|OrderedVariableList|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |type'|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL)))) - (AND (CONSP |type|) (EQ (QCAR |type|) '|Variable|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |type|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL))))) - (COND - ((SPADLET |object'| - (|retract2Specialization| |object|)) - |object'|) - ('T '|failed|))) - ((NULL (SPADLET |underDomain| - (|underDomainOf| |type'|))) - '|failed|) - ('T - (SPADLET |object'| - (|retractUnderDomain| |object| |type| - |underDomain|)) - (COND - ((NEQUAL |object'| '|failed|) |object'|) - ((SPADLET |object'| - (|coerceRetract| |object| |underDomain|)) - |object'|) - ((SPADLET |object'| - (|retract2Specialization| |object|)) - |object'|) - ('T '|failed|)))))))))))) - ;retractUnderDomain(object,type,underDomain) == ; null (ud := underDomainOf underDomain) => 'failed ; [c,:args] := deconstructT type @@ -604,7 +417,7 @@ The special routines that do the coercions typically involve a "2" (SPADLET |m| (|resolveTypeListAny| |tl|)) D) NIL) - ((BOOT-EQUAL D (|equiType| |m|)) NIL) + ((BOOT-EQUAL D |m|) NIL) ('T (SPADLET |vl'| NIL) (DO ((G166358 |vl| (CDR G166358)) (|e| NIL) @@ -704,7 +517,7 @@ The special routines that do the coercions typically involve a "2" (SPADLET |val'| (|retract| (|objNew| |val| |rep|))) (DO () ((NULL (AND (NEQUAL |val'| '|failed|) - (NEQUAL (|equiType| (|objMode| |val'|)) + (NEQUAL (|objMode| |val'|) |k|))) NIL) (SEQ (EXIT (SPADLET |val'| (|retract| |val'|))))) @@ -1370,8 +1183,8 @@ Interpreter Coercion Query Functions (COND ((BOOT-EQUAL |t2| |$OutputForm|) (SPADLET |s1| |t1|) (SPADLET |s2| |t2|)) - ('T (SPADLET |s1| (|equiType| |t1|)) - (SPADLET |s2| (|equiType| |t2|)))) + ('T (SPADLET |s1| |t1|) + (SPADLET |s2| |t2|))) (COND ((NULL (|isValidType| |t2|)) NIL) ((NULL (|isLegitimateMode| |t2| NIL NIL)) NIL) @@ -2472,8 +2285,8 @@ Interpreter Coercion Query Functions (COND ((BOOT-EQUAL |t2| |$OutputForm|) (SPADLET |s1| |t1|) (SPADLET |s2| |t2|)) - ('T (SPADLET |s1| (|equiType| |t1|)) - (SPADLET |s2| (|equiType| |t2|)) + ('T (SPADLET |s1| |t1|) + (SPADLET |s2| |t2|) (COND ((BOOT-EQUAL |s1| |s2|) (RETURN (|objNew| |val| |t2|)))))) (COND diff --git a/src/interp/i-coerfn.lisp.pamphlet b/src/interp/i-coerfn.lisp.pamphlet index 0682435..1fb1e8a 100755 --- a/src/interp/i-coerfn.lisp.pamphlet +++ b/src/interp/i-coerfn.lisp.pamphlet @@ -5515,32 +5515,6 @@ all these coercion functions have the following result: ('T (|coercionFailure|)))) ('T (|coercionFailure|))))))) -;insertAlist(a,b,l) == -; null l => [[a,:b]] -; a = l.0.0 => (RPLAC(CDAR l,b);l) -; _?ORDER(l.0.0,a) => [[a,:b],:l] -; (fn(a,b,l);l) where fn(a,b,l) == -; null rest l => RPLAC(rest l,[[a,:b]]) -; a = l.1.0 => RPLAC(rest l.1,b) -; _?ORDER(l.1.0,a) => RPLAC(rest l,[[a,:b],:rest l]) -; fn(a,b,rest l) - -(DEFUN |insertAlist,fn| (|a| |b| |l|) - (SEQ (IF (NULL (CDR |l|)) - (EXIT (RPLAC (CDR |l|) (CONS (CONS |a| |b|) NIL)))) - (IF (BOOT-EQUAL |a| (ELT (ELT |l| 1) 0)) - (EXIT (RPLAC (CDR (ELT |l| 1)) |b|))) - (IF (?ORDER (ELT (ELT |l| 1) 0) |a|) - (EXIT (RPLAC (CDR |l|) (CONS (CONS |a| |b|) (CDR |l|))))) - (EXIT (|insertAlist,fn| |a| |b| (CDR |l|))))) - -(DEFUN |insertAlist| (|a| |b| |l|) - (COND - ((NULL |l|) (CONS (CONS |a| |b|) NIL)) - ((BOOT-EQUAL |a| (ELT (ELT |l| 0) 0)) (RPLAC (CDAR |l|) |b|) |l|) - ((?ORDER (ELT (ELT |l| 0) 0) |a|) (CONS (CONS |a| |b|) |l|)) - ('T (|insertAlist,fn| |a| |b| |l|) |l|))) - ;--% Union ;Un2E(x,source,target) == ; ['Union,:branches] := source diff --git a/src/interp/i-resolv.lisp.pamphlet b/src/interp/i-resolv.lisp.pamphlet index 441a101..77d0cd4 100644 --- a/src/interp/i-resolv.lisp.pamphlet +++ b/src/interp/i-resolv.lisp.pamphlet @@ -2460,15 +2460,6 @@ this symmetric resolution is done the following way: (DEFUN |eqType| (|t|) |t|) -;equiType(t) == -; -- looks for an equivalent but expanded type -; -- eg, equiType RN == QF I -; -- the new algebra orginization no longer uses these sorts of types -;-- termRW(t,$TypeEqui) -; t - -(DEFUN |equiType| (|t|) |t|) - ;getUnderModeOf d == ; not CONSP d => NIL ;-- n := LASSOC(first d,$underDomainAlist) => d.n ----> $underDomainAlist NOW always NIL