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