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--% ITERATORS 35 36compReduce(form,m,e) == 37 compReduce1(form,m,e,$formalArgList) 38 39compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == 40 [collectOp,:itl,body]:= collectForm 41 if STRINGP op then op:= INTERN op 42 not MEMQ(collectOp,'(COLLECT COLLECTV COLLECTVEC)) => 43 systemError ["illegal reduction form:",form] 44 $sideEffectsList: local := nil 45 $until: local := nil 46 $initList: local := nil 47 $endTestList: local := nil 48 itl := [([., e] := compIterator(x, e) or return "failed").(0) for x in itl] 49 itl="failed" => return nil 50 acc:= GENSYM() 51 afterFirst:= GENSYM() 52 bodyVal:= GENSYM() 53 [part1, m, e] := comp([":=", bodyVal, body], m, e) or return nil 54 [part2, ., e] := comp([":=", acc, bodyVal], m, e) or return nil 55 [part3, ., e] := comp([":=", acc, parseTran [op, acc, bodyVal]], m, e) 56 or return nil 57 identityCode:= 58 id:= getIdentity(op,e) => u.expr where u() == comp(id,m,e) or return nil 59 ["IdentityError",MKQ op] 60 finalCode:= 61 ["PROGN", 62 ["LET",afterFirst,nil], 63 ["REPEAT",:itl, 64 ["PROGN",part1, 65 ["IF", afterFirst,part3, 66 ["PROGN",part2,["LET",afterFirst,MKQ true]]]]], 67 ["IF",afterFirst,acc,identityCode]] 68 if $until then 69 [untilCode,.,e]:= comp($until,$Boolean,e) 70 finalCode:= substitute(["UNTIL",untilCode],'$until,finalCode) 71 [finalCode,m,e] 72 73$identity_list := [ _ 74 ["+", ["Zero"]], _ 75 ["*", ["One"]], _ 76 ['gcd, ["Zero"]], _ 77 ['lcm, ["One"]], _ 78 ['append, ['construct]], _ 79 ['union, ['construct]], _ 80 ['strconc, '""], _ 81 ['and, 'true], _ 82 ['or, 'false]] 83 84getIdentity(x,e) == 85 av := ASSQ(x, $identity_list) 86 av => av.1 87 nil 88 89compRepeatOrCollect(form,m,e) == 90 fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList 91 ,e) where 92 fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == 93 $until: local := nil 94 [repeatOrCollect,:itl,body]:= form 95 itl':= 96 [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] 97 itl'="failed" => nil 98 targetMode:= first $exitModeStack 99 bodyMode:= 100 repeatOrCollect="COLLECT" => 101 targetMode = '$EmptyMode => '$EmptyMode 102 (u:=modeIsAggregateOf('List,targetMode,e)) => 103 CADR u 104 (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => 105 repeatOrCollect:='COLLECTV 106 CADR u 107 (u:=modeIsAggregateOf('Vector,targetMode,e)) => 108 repeatOrCollect:='COLLECTVEC 109 CADR u 110 stackMessage('"Invalid collect bodytype") 111 return nil 112 -- If we're doing a collect, and the type isn't conformable 113 -- then we've boobed. JHD 26.July.1990 114 $NoValueMode 115 [body',m',e']:= 116 -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or 117 comp(body, bodyMode, e) or return nil 118 if $until then 119 [untilCode,.,e']:= comp($until,$Boolean,e') 120 itl':= substitute(["UNTIL",untilCode],'$until,itl') 121 form':= [repeatOrCollect,:itl',body'] 122 m'':= 123 repeatOrCollect="COLLECT" => 124 (u := modeIsAggregateOf('List, targetMode, e)) => first u 125 ["List",m'] 126 repeatOrCollect="COLLECTV" => 127 (u := modeIsAggregateOf('PrimitiveArray, targetMode, e)) => first u 128 ["PrimitiveArray",m'] 129 repeatOrCollect="COLLECTVEC" => 130 (u := modeIsAggregateOf('Vector, targetMode, e)) => first u 131 ["Vector",m'] 132 m' 133 coerceExit([form',m'',e'],targetMode) 134 135listOrVectorElementMode x == 136 x is [a,b,:.] and member(a,'(PrimitiveArray Vector List)) => b 137 138genLetHelper(op, arg, d, var) == 139 form0 := [["elt", d, op], arg] 140 [":=", var, form0] 141 142compInitGstep(y, ef, sf, mOver, e) == 143 gvar := genSomeVariable() 144 [., ., e] := compMakeDeclaration([":", gvar, mOver], $EmptyMode, e) 145 form := ["SEQ", [":=", gvar, y], 146 genLetHelper("emptyFun", gvar, mOver, ef), 147 genLetHelper("stepFun", gvar, mOver, sf), 148 ["exit", 1, 1]] 149 res := compSeq(form, $Integer, e) 150 res => res 151 nil 152 153compIterator1(it, e) == 154 it is ["IN",x,y] => 155 --these two lines must be in this order, to get "for f in list f" 156 --to give an error message if f is undefined 157 [y',m,e]:= comp(y,$EmptyMode,e) or return nil 158 $formalArgList:= [x,:$formalArgList] 159 ([mOver, mUnder] := modeIsAggregateOf("Generator", m, e)) => 160 if null get(x,"mode",e) then 161 [.,.,e] := compMakeDeclaration([":",x,mUnder],$EmptyMode,e) 162 or return nil 163 e:= put(x, "value", [genSomeVariable(), mUnder, e], e) 164 ef := genSomeVariable() 165 sf := genSomeVariable() 166 [y'', ., .] := compInitGstep(y, ef, sf, mOver, e) or return nil 167 res := ["GSTEP", x, ef, sf, y''] 168 SAY([res, mUnder]) 169 [res, e] 170 [mOver, mUnder] := 171 modeIsAggregateOf("List",m,e) or return 172 stackMessage ["mode: ",m," must be a list of some mode"] 173 if null get(x,"mode",e) then [.,.,e]:= 174 compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil 175 e:= put(x,"value",[genSomeVariable(),mUnder,e],e) 176 [y'',m'',e] := coerce([y',m,e], mOver) or return nil 177 [["IN",x,y''],e] 178 it is ["ON",x,y] => 179 $formalArgList:= [x,:$formalArgList] 180 [y',m,e]:= comp(y,$EmptyMode,e) or return nil 181 [mOver,mUnder]:= 182 modeIsAggregateOf("List",m,e) or return 183 stackMessage ["mode: ",m," must be a list of other modes"] 184 if null get(x,"mode",e) then [.,.,e]:= 185 compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil 186 e:= put(x,"value",[genSomeVariable(),m,e],e) 187 [y'',m'',e] := coerce([y',m,e], mOver) or return nil 188 [["ON",x,y''],e] 189 it is ["STEP",index,start,inc,:optFinal] => 190 $formalArgList:= [index,:$formalArgList] 191 --if all start/inc/end compile as small integers, then loop 192 --is compiled as a small integer loop 193 final':= nil 194 (start' := comp(start, $SingleInteger, e)) and 195 (inc':= comp(inc,$NonNegativeInteger,start'.env)) and 196 (not (optFinal is [final]) or 197 (final' := comp(final, $SingleInteger, inc'.env))) => 198 indexmode:= 199 comp(start,$NonNegativeInteger,e) => 200 $NonNegativeInteger 201 $SingleInteger 202 if null get(index,"mode",e) then [.,.,e]:= 203 compMakeDeclaration([":",index,indexmode],$EmptyMode, 204 (final' => final'.env; inc'.env)) or return nil 205 e:= put(index,"value",[genSomeVariable(),indexmode,e],e) 206 if final' then optFinal:= [final'.expr] 207 [["ISTEP",index,start'.expr,inc'.expr,:optFinal],e] 208 [start,.,e]:= 209 comp(start,$Integer,e) or return 210 stackMessage ["start value of index: ",start," must be an integer"] 211 [inc,.,e]:= 212 comp(inc,$Integer,e) or return 213 stackMessage ["index increment:",inc," must be an integer"] 214 if optFinal is [final] then 215 [final,.,e]:= 216 comp(final,$Integer,e) or return 217 stackMessage ["final value of index: ",final," must be an integer"] 218 optFinal:= [final] 219 indexmode:= 220 comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger 221 $Integer 222 if null get(index,"mode",e) then [.,.,e]:= 223 compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil 224 e:= put(index,"value",[genSomeVariable(),indexmode,e],e) 225 [["STEP",index,start,inc,:optFinal],e] 226 it is ["WHILE",p] => 227 [p',m,e]:= 228 comp(p,$Boolean,e) or return 229 stackMessage ["WHILE operand: ",p," is not Boolean valued"] 230 [["WHILE",p'],e] 231 it is ["UNTIL",p] => ($until:= p; ['$until,e]) 232 it is ["|",x] => 233 u:= 234 comp(x,$Boolean,e) or return 235 stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] 236 [["|",u.expr],u.env] 237 nil 238 239match_segment(i, n) == 240 n is ['SEGMENT,a] => ['STEP,i,a,1] 241 n is ['SEGMENT, a, b] => (b => ['STEP, i, a, 1, b]; ['STEP, i, a, 1]) 242 ['IN, i, n] 243 244compIterator(it, e) == 245 it is ["INBY", i, n, inc] => 246 u := match_segment(i, n) 247 u isnt ['STEP, i, a, 1, :r] => 248 stackAndThrow [" You cannot use", "%b", "by", "%d", 249 "except for an explicitly indexed sequence."] 250 compIterator1(['STEP, i, a, inc, :r], e) 251 it is ["IN", i, n] => 252 compIterator1(match_segment(i, n), e) 253 compIterator1(it, e) 254 255modeIsAggregateOf(ListOrVector,m,e) == 256 m is [ =ListOrVector,R] => [m,R] 257--m = '$EmptyMode => [m,m] I don't think this is correct, breaks POLY + 258 m is ["Union",:l] => 259 mList:= [pair for m' in l | (pair:= modeIsAggregateOf(ListOrVector,m',e))] 260 1=#mList => first mList 261 name:= 262 m is [fn,:.] => fn 263 m="$" => "Rep" 264 m 265 get(name,"value",e) is [[ =ListOrVector,R],:.] => [m,R] 266 267