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--=======================================================
35--             Lookup From Interpreter
36--=======================================================
37
38NRTevalDomain form ==
39  form is ['SETELT,:.] =>
40      BREAK()
41      eval form
42  evalDomain form
43
44compiledLookupCheck(op,sig,dollar) ==
45  fn := compiledLookup(op,sig,dollar)
46
47  fn = nil =>
48    keyedSystemError("S2NR0001",[op,formatSignature sig,dollar.0])
49  fn
50
51--=======================================================
52--                 Lookup From Compiled Code
53--=======================================================
54
55NRTreplaceLocalTypes(t,dom) ==
56   atom t =>
57     not INTEGERP t => t
58     t:= dom.t
59     if PAIRP t then t:= NRTevalDomain t
60     t.0
61   MEMQ(first t, '(Mapping Union Record _:)) =>
62      [first t, :[NRTreplaceLocalTypes(x, dom) for x in rest t]]
63   t
64
65substDomainArgs(domain,object) ==
66    form := devaluate domain
67    SUBLISLIS([form,:rest form],["$$",:$FormalMapVariableList],object)
68
69--=======================================================
70--       Lookup Function in Slot 1 (via SPADCALL)
71--=======================================================
72lookupInTable(op,sig,dollar,[domain,table]) ==
73  success := false
74  someMatch := false
75  while not success for [sig1, :code] in QLASSQ(op, table) repeat
76    success :=
77      null compareSig(sig,sig1,dollar.0,domain) => false
78      loc := code
79      loc = 0 => BREAK()
80      slot := domain.loc
81      lookupDisplay(op,sig,domain,'" !! found in NEW table!!")
82      slot
83  success
84
85--=======================================================
86--                       Predicates
87--=======================================================
88
89compareSig(sig,tableSig,dollar,domain) ==
90  not (#sig = #tableSig) => false
91  null (target := first sig)
92   or lazyCompareSigEqual(target,first tableSig,dollar,domain) =>
93     and/[lazyCompareSigEqual(s,t,dollar,domain)
94              for s in rest sig for t in rest tableSig]
95
96lazyCompareSigEqual(s,tslot,dollar,domain) ==
97  tslot = '$ => s = tslot
98  INTEGERP tslot and PAIRP(lazyt:=domain.tslot) and PAIRP s =>
99      lazyt is [.,.,.,[.,item,.]] and
100        item is [., [functorName, :.]] and functorName = first s =>
101          compareSigEqual(s,(NRTevalDomain lazyt).0,dollar,domain)
102      nil
103  compareSigEqual(s,NRTreplaceLocalTypes(tslot,domain),dollar,domain)
104
105
106compareSigEqual(s,t,dollar,domain) ==
107  EQUAL(s,t) => true
108  ATOM t =>
109    u :=
110      EQ(t,'$) => dollar
111      isSharpVar t =>
112        VECP domain => ELT(rest domain.0,POSN1(t,$FormalMapVariableList))
113        ELT(rest domain,POSN1(t,$FormalMapVariableList))
114      STRINGP t and IDENTP s => (s := PNAME s; t)
115      nil
116    s = '$ => compareSigEqual(dollar,u,dollar,domain)
117    u => compareSigEqual(s,u,dollar,domain)
118    EQUAL(s,u)
119  EQ(s,'$) => compareSigEqual(dollar,t,dollar,domain)
120  ATOM s => nil
121  #s ~= #t => nil
122  match := true
123  for u in s for v in t repeat
124    not compareSigEqual(u,v,dollar,domain) => return(match:=false)
125  match
126
127-----------------------Compiler for Interpreter---------------------------------
128
129NRT_opt_call(u, opName, sigTail,dcVector) ==
130    dc := devaluate(dcVector)
131    -- sayBrightly(["NRT_opt_call ", u, opName, sigTail, dc])
132    not MEMQ(IFCAR dc, $optimizableConstructorNames) => nil
133    NULL(name := BPINAME(first u))  => nil
134    fn := GETL(name, 'SPADreplace) =>
135        n := #dcVector
136        flag := true
137        k := -1
138        for i in 0..(n - 1) while flag repeat
139            if dcVector.i = u then
140                k := i
141                flag := false
142        k >= 0 => ["ELT", dc, k]
143        nil
144    nil
145
146NRTcompileEvalForm(opName,sigTail,dcVector) ==
147  u := NRTcompiledLookup(opName,sigTail,dcVector)
148  not ($insideCompileBodyIfTrue = true) => MKQ u
149  res1 := NRT_opt_call(u, opName, sigTail, dcVector) => res1
150  k := NRTgetMinivectorIndex(u,opName,sigTail,dcVector)
151  ['ELT,"$$$",k]  --$$$ denotes minivector
152
153NRTtypeHack t ==
154  ATOM t => t
155  first t = '_# => # CADR t
156  [first t, :[NRTtypeHack tt for tt in rest t]]
157
158NRTgetMinivectorIndex(u,op,sig,domVector) ==
159  s := # $minivector
160  k := or/[k for k in 0..(s-1)
161        for x in $minivector | EQ(x,u)] => k
162  $minivector := [:$minivector,u]
163  s
164
165is_op_slot(slot, dom, k, minivector_name, int_vec, bool_vec) ==
166    dom = minivector_name => EQ(slot, $minivector.k)
167    dom = ["Integer"] => EQ(slot, int_vec.k)
168    dom = ["Boolean"] => EQ(slot, bool_vec.k)
169    nil
170
171NRTisRecurrenceRelation(op,body,minivectorName) ==
172  -- returns [body p1 p2 ... pk] for a k-term recurrence relation
173  -- where the n-th term is computed using the (n-1)st,...,(n-k)th
174  -- whose values are initially computed using the expressions
175  -- p1,...,pk respectively; body has #2,#3,... in place of
176  -- f(k-1),f(k-2),...
177
178  body isnt ['COND,:pcl] => false
179  -- body should have a conditional expression which
180  -- gives k boundary values, one general term plus possibly an
181  -- "out of domain" condition
182--pcl is [:.,[ ''T,:mess]] and not (CONTAINED('throwMessage,mess) or
183--  CONTAINED('throwKeyedMsg,mess)) => NIL
184  pcl := [x for x in pcl | not (x is [''T,:mess] and
185    (CONTAINED('throwMessage,mess) or
186      CONTAINED('throwKeyedMsg,mess)))]
187  integer := EVAL $Integer
188  iequalSlot := compiledLookupCheck("=", '((Boolean) $ $), integer)
189  lt_slot := compiledLookupCheck("<", '((Boolean) $ $), integer)
190  le_slot := compiledLookupCheck("<=", '((Boolean) $ $), integer)
191  gt_slot := compiledLookupCheck(">", '((Boolean) $ $), integer)
192  ge_slot := compiledLookupCheck(">=", '((Boolean) $ $), integer)
193  bf := '(Boolean)
194  bf_vec := EVAL bf
195  notpSlot := compiledLookupCheck("not", '((Boolean)(Boolean)), bf_vec)
196  for [p,c] in pcl repeat
197    p is ['SPADCALL, sharpVar, n1, ['ELT, dom, slot]] and
198      is_op_slot(iequalSlot, dom, slot, minivectorName, integer, bf_vec) =>
199        initList:= [[n1,:c],:initList]
200        sharpList := insert(sharpVar,sharpList)
201        n:=n1
202    miscList:= [[p,c],:miscList]
203  miscList isnt [[generalPred,generalTerm]] or sharpList isnt [sharpArg] =>
204      return false
205    --first general term starts at n
206
207  --Must have at least one special value; insist that they be consecutive
208  null initList => false
209  specialValues:= MSORT ASSOCLEFT initList
210  or/[null INTEGERP n for n in specialValues] => false
211  minIndex:= "MIN"/specialValues
212  not (and/[i=x for i in minIndex..(minIndex+n-1) for x in specialValues]) =>
213    sayKeyedMsg("S2IX0005",
214      ["append"/[['" ",sv]  for sv in specialValues]])
215    return nil
216
217  --Determine the order k of the recurrence and index n of first general term
218  k:= #specialValues
219  n:= k+minIndex
220  --Check general predicate
221  predOk :=
222    generalPred is '(QUOTE T) => true
223    generalPred is ['SPADCALL, m1, m2, ['ELT, dom, slot]] =>
224        m2 = sharpArg and is_op_slot(lt_slot, dom, slot,
225                            minivectorName, integer, bf_vec) => m1 + 1
226        m2 = sharpArg and is_op_slot(le_slot, dom, slot,
227                            minivectorName, integer, bf_vec) => m1
228        m1 = sharpArg and is_op_slot(gt_slot, dom, slot,
229                            minivectorName, integer, bf_vec) => m2 + 1
230        m1 = sharpArg and is_op_slot(ge_slot, dom, slot,
231                            minivectorName, integer, bf_vec) => m2
232    generalPred is ['SPADCALL, ['SPADCALL, =sharpArg, m,
233      ['ELT, dom1, slot1]], ['ELT, dom2, slot2]] and
234        is_op_slot(notSlot, dom2, slot2, minivectorName, integer, bf_vec)
235          and is_op_slot(lt_slot, dom1, slot1,
236                         minivectorName, integer, bf_vec) => m
237    generalPred is ['NOT, ['SPADCALL, =sharpArg, m,
238       ['ELT, dom, slot]]] and
239          is_op_slot(lt_slot, dom, slot, minivectorName, integer, bf_vec) => m
240    return nil
241  INTEGERP predOk and predOk ~= n =>
242    sayKeyedMsg("S2IX0006",[n,m])
243    return nil
244
245  --Check general term for references to just the k previous values
246  diffCell := compiledLookupCheck("-", '($ $ $), integer)
247  --Check general term for references to just the k previous values
248  sharpPosition := PARSE_-INTEGER SUBSTRING(sharpArg,1,nil)
249  al:= mkDiffAssoc(op, generalTerm, k, sharpPosition, sharpArg,
250                   diffCell, minivectorName, integer, bf_vec)
251  null al => false
252  '$failed in al => false
253  body:= generalTerm
254  for [a,:b] in al repeat
255    body:= substitute(b,a,body)
256  result:= [body,sharpArg,n-1,:NREVERSE [LASSOC(i,initList) or
257      systemErrorHere('"NRTisRecurrenceRelation")
258        for i in minIndex..(n-1)]]
259
260mkDiffAssoc(op, body, k, sharpPosition, sharpArg, diffCell,
261            vecname, int_vec, bool_vec) ==
262  -- returns alist which should not have any entries = $failed
263  -- form substitution list of the form:
264  -- ( ((f (,DIFFERENCE #1 1)) . #2) ((f (,DIFFERENCE #1 2)) . #3) ...)
265  --   but also checking that all difference values lie in 1..k
266  atom body => nil
267  body is ['COND,:pl] =>
268    "union"/[mkDiffAssoc(op, c, k, sharpPosition, sharpArg, diffCell,
269                         vecname, int_vec, bool_vec) for [p, c] in pl]
270  body is [fn,:argl] =>
271    (fn = op) and argl.(sharpPosition-1) is
272      ['SPADCALL, =sharpArg, n, ['ELT, dom, slot]] and
273        is_op_slot(diffCell, dom, slot, vecname, int_vec, bool_vec) =>
274          NUMBERP n and n > 0 and n <= k =>
275              [[body, :$TriangleVariableList.n]]
276          ['$failed]
277    "union"/[mkDiffAssoc(op, x, k, sharpPosition, sharpArg, diffCell,
278                         vecname, int_vec, bool_vec) for x in argl]
279  systemErrorHere '"mkDiffAssoc"
280