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