1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2-- All rights reserved. 3-- 4-- Redistribution and use in source and binary forms, with or without 5-- modification, are permitted provided that the following conditions are 6-- met: 7-- 8-- - Redistributions of source code must retain the above copyright 9-- notice, this list of conditions and the following disclaimer. 10-- 11-- - Redistributions in binary form must reproduce the above copyright 12-- notice, this list of conditions and the following disclaimer in 13-- the documentation and/or other materials provided with the 14-- distribution. 15-- 16-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17-- names of its contributors may be used to endorse or promote products 18-- derived from this software without specific prior written permission. 19-- 20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32)package "BOOT" 33 34--% Functions on $clamList 35 36-- These files are read in by the system so that they can be cached 37-- properly. Otherwise, must read in compiled versions and then 38-- recompile these, resulting in wasted BPI space. 39 40canCoerceFrom(mr,m) == 41 -- bind flag for recording/reporting instantiations 42 -- (see recordInstantiation) 43 $insideCanCoerceFrom: local := [mr,m] 44 canCoerceFrom0(mr,m) 45 46canCoerce(t1, t2) == 47 val := canCoerce1(t1, t2) => val 48 t1 is ['Variable, :.] => 49 newMode := getMinimalVarMode(t1, nil) 50 canCoerce1(t1, newMode) and canCoerce1(newMode, t2) 51 nil 52 53isValidType form == 54 -- returns true IFF form is a type whose arguments satisfy the 55 -- predicate of the type constructor 56 -- Note that some forms are said to be invalid because they would 57 -- cause problems with the interpreter. Thus things like P P I 58 -- are not valid. 59 STRINGP form => true 60 IDENTP form => false 61 form in '((Mode) (Type) (Category)) => true 62 form is ['Record,:selectors] => 63 and/[isValidType type for [:.,type] in selectors] 64 form is ['Enumeration,:args] => 65 null (and/[IDENTP x for x in args]) => false 66 ((# args) = (# REMDUP args)) => true 67 false 68 form is ['Mapping,:mapargs] => 69 null mapargs => NIL 70 and/[isValidType type for type in mapargs] 71 form is ['Union,:args] => 72 -- check for a tagged union 73 args and first args is [":",:.] => 74 and/[isValidType type for [:.,type] in args] 75 null (and/[isValidType arg for arg in args]) => NIL 76 ((# args) = (# REMDUP args)) => true 77 sayKeyedMsg("S2IR0005",[form]) 78 NIL 79 80 badDoubles := CONS($QuotientField, '(Complex Polynomial Expression)) 81 form is [T1, [T2, :.]] and T1 = T2 and member(T1, badDoubles) => NIL 82 83 form is [=$QuotientField,D] and not isPartialMode(D) and 84 ofCategory(D,'(Field)) => NIL 85 form is ['UnivariatePolynomial, x, ['UnivariatePolynomial, y, .]] and x=y => 86 NIL 87 form = '(Complex (AlgebraicNumber)) => NIL 88 form is ['Expression, ['Kernel, . ]] => NIL 89 form is [op,:argl] => 90 null constructor? op => nil 91 cosig := GETDATABASE(op, 'COSIG) 92 cosig and null rest cosig => -- niladic constructor 93 null argl => true 94 false 95 null (sig := getConstructorSignature form) => nil 96 [.,:cl] := sig 97 -- following line is needed to deal with mutable domains 98 if # cl ~= # argl and GENSYMP last argl then argl:= DROP(-1,argl) 99 # cl ~= # argl => nil 100 cl:= replaceSharps(cl,form) 101 and/[isValid for x in argl for c in cl] where isValid == 102 categoryForm?(c) => 103 evalCategory(x,MSUBSTQ(x,'_$,c)) and isValidType x 104 not (GETDATABASE(opOf x, 'CONSTRUCTORKIND) = 'domain) 105 106selectMms1(op,tar,args1,args2,$Coerce) == 107 selectMms2(op,tar,args1,args2,$Coerce) 108 109coerceConvertMmSelection(funName,m1,m2) == 110 -- calls selectMms with $Coerce=NIL and tests for required 111 -- target type. funName is either 'coerce or 'convert. 112 $declaredMode : local:= NIL 113 $reportBottomUpFlag : local:= NIL 114 l := selectMms1(funName,m2,[m1],[m1],NIL) 115 -- mmS := [[sig,[targ,arg],:pred] for x in l | x is [sig,[.,arg],:pred] and 116 mmS := [x for x in l | x is [sig,:.] and hasCorrectTarget(m2,sig) and 117 sig is [dc,targ,oarg] and isEqualOrSubDomain(m1,oarg)] 118 mmS and first mmS 119 120resolveTT(t1,t2) == 121 -- resolves two types 122 -- this symmetric resolve looks for a type t to which both t1 and t2 123 -- can be coerced 124 -- if resolveTT fails, the result will be NIL 125 startTimingProcess 'resolve 126 null (t := resolveTT1(t1,t2)) => 127 stopTimingProcess 'resolve 128 nil 129 isValidType (t) => 130 stopTimingProcess 'resolve 131 t 132 stopTimingProcess 'resolve 133 nil 134 135isLegitimateMode(t,hasPolyMode,polyVarList) == 136 -- returns true IFF t is a valid type. i.e. if t has no repeated 137 -- variables, or two levels of Polynomial 138 null t => true -- a terminating condition with underDomainOf 139 t = $EmptyMode => true 140 STRINGP t => true 141 ATOM t => false 142 143 badDoubles := CONS($QuotientField, '(Complex Polynomial Expression)) 144 t is [T1, [T2, :.]] and T1 = T2 and member(T1, badDoubles) => NIL 145 146 t is [=$QuotientField,D] and not isPartialMode(D) and 147 ofCategory(D,'(Field)) => NIL 148 t = '(Complex (AlgebraicNumber)) => NIL 149 150 vl := isPolynomialMode t => 151 if vl~='all then 152 var:= or/[(x in polyVarList => x;nil) for x in vl] => return false 153 listOfDuplicates vl => return false 154 polyVarList:= union(vl,polyVarList) 155 hasPolyMode => false 156 con := first t 157 poly? := (con = 'Polynomial or con = 'Expression) 158 isLegitimateMode(underDomainOf t,poly?,polyVarList) 159 160 constructor? first t => 161 isLegitimateMode(underDomainOf t,hasPolyMode,polyVarList) => t 162 t is ['Mapping,:ml] => 163 null ml => NIL 164 -- first arg is target, which can be Void 165 null isLegitimateMode(first ml,nil,nil) => NIL 166 for m in rest ml repeat 167 m = $Void => 168 return NIL 169 null isLegitimateMode(m,nil,nil) => return NIL 170 true 171 t is ['Union,:ml] => 172 -- check for tagged union 173 ml and first ml is [":",:.] => isLegitimateRecordOrTaggedUnion ml 174 null (and/[isLegitimateMode(m,nil,nil) for m in ml]) => NIL 175 ((# ml) = (# REMDUP ml)) => true 176 NIL 177 t is ['Record,:r] => isLegitimateRecordOrTaggedUnion r 178 t is ['Enumeration,:r] => 179 null (and/[IDENTP x for x in r]) => false 180 ((# r) = (# REMDUP r)) => true 181 false 182 false 183 184underDomainOf t == 185 t = $RationalNumber => $Integer 186 not PAIRP t => NIL 187 d := deconstructT t 188 1 = #d => NIL 189 u := getUnderModeOf(t) => u 190 last d 191 192findRetractMms(st, tt) == findRetractMms1(st, tt) 193 194getConstantFromDomain(form,domainForm) == 195 getConstantFromDomain1(form,domainForm) 196 197interpLookup(funName, sig, dc) == 198 dcVector:= evalDomain dc 199 NRTcompiledLookup(funName, sig, dcVector) 200