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