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
33)package "BOOT"
34
35-- Yet Another Parser Transformation File
36-- These functions are used by for SPAD code
37
38postTransform y ==
39  $insidePostCategoryIfTrue : local := nil
40  x:= y
41  u:= postTran x
42  if u is ["@Tuple", :l, [":", y, t]] and (and/[IDENTP x for x in l]) then
43      u := [":", ['LISTOF, :l, y], t]
44  postTransformCheck u
45  u
46
47displayPreCompilationErrors() ==
48  n:= #($postStack:= REMDUP NREVERSE $postStack)
49  n=0 => nil
50  errors:=
51    1<n => '"errors"
52    '"error"
53  heading:=
54        $topOp ~= '$topOp => ['"   ",$topOp,'" has"]
55        ['"   You have"]
56  sayBrightly [:heading, '%b, n, '%d, '"precompilation ", errors, '":"]
57  if 1<n then
58    (for x in $postStack for i in 1.. repeat sayMath ['"   ",i,'"_) ",:x])
59    else sayMath ['"    ",:first $postStack]
60  TERPRI()
61
62postTran x ==
63  atom x =>
64    postAtom x
65  op := first x
66  IDENTP(op) and (f := GET(op, 'postTran)) => FUNCALL(f, x)
67  op is ['Sel, a, b] =>
68    u:= postTran [b,:rest x]
69    [postTran op,:rest u]
70  postForm x
71
72postTranList x == [postTran y for y in x]
73
74postBigFloat x ==
75  [.,mant, expon] := x
76  postTran [["Sel", '(Float), 'float], [",", [",", mant, expon], 10]]
77
78postAdd ['add,a,:b] ==
79  null b => postCapsule a
80  ['add,postTran a,postCapsule first b]
81
82checkWarning msg == postError concat('"Parsing error: ",msg)
83
84checkWarningIndentation() ==
85  checkWarning ['"Apparent indentation error following",:bright "add"]
86
87postCapsule x ==
88  x isnt [op,:.] => checkWarningIndentation()
89  op = ";" => ['CAPSULE,:postBlockItemList postFlatten(x,";")]
90  op = "if" or INTEGERP op or op = "==" => ['CAPSULE, postBlockItem x]
91  checkWarningIndentation()
92
93postQUOTE x == x
94
95postConstruct u ==
96  u is ['construct,b] =>
97    a:= (b is [",",:.] => comma2Tuple b; b)
98    a is ['SEGMENT,p,q] => ['construct,postTranSegment(p,q)]
99    a is ["@Tuple", :l] =>
100      or/[x is [":",y] for x in l] => postMakeCons l
101      or/[x is ['SEGMENT,:.] for x in l] => tuple2List l
102      ['construct,:postTranList l]
103    ['construct,postTran a]
104  u
105
106postError msg ==
107  xmsg:=
108    BOUNDP("$defOp") => [$defOp, '": " , :msg]
109    msg
110  $postStack:= [xmsg,:$postStack]
111  nil
112
113postMakeCons l ==
114  null l => nil
115  l is [[":",a],:l'] =>
116    l' => ['append,postTran a,postMakeCons l']
117    postTran a
118  ['cons,postTran first l,postMakeCons rest l]
119
120postAtom x ==
121  x=0 => '(Zero)
122  x=1 => '(One)
123  EQ(x,'T) => 'T_$ -- rename T in spad code to T$
124  IDENTP x and GETDATABASE(x,'NILADIC) => LIST x
125  x
126
127postBlockItemList l == [postBlockItem x for x in l]
128
129postBlockItem x ==
130  x:= postTran x
131  x is ["@Tuple", :l, [":", y, t]] and (and/[IDENTP x for x in l]) =>
132    [":",['LISTOF,:l,y],t]
133  x
134
135postCategory (u is ['CATEGORY,:l]) ==
136  --RDJ: ugh_ please -- someone take away need for PROGN as soon as possible
137  null l => u
138  op :=
139    $insidePostCategoryIfTrue = true => 'PROGN
140    'CATEGORY
141  [op,:[fn x for x in l]] where fn x ==
142    $insidePostCategoryIfTrue: local := true
143    postTran x
144
145postComma u == postTuple comma2Tuple u
146
147comma2Tuple u == ["@Tuple", :postFlatten(u, ",")]
148
149postDef [defOp,lhs,rhs] ==
150--+
151  lhs is ["macro",name] => postMDef ["==>",name,rhs]
152
153  recordHeaderDocumentation nil
154  if $maxSignatureLineNumber ~= 0 then
155    $docList := [['constructor,:$headerDocumentation],:$docList]
156    $maxSignatureLineNumber := 0
157    --reset this for next constructor; see recordDocumentation
158  lhs:= postTran lhs
159  [form,targetType]:=
160    lhs is [":",:.] => rest lhs
161    [lhs,nil]
162  if atom form then form := [form]
163  newLhs:= [(x is [":",a,.] => a; x) for x in form]
164  argTypeList:=
165    [(x is [":",.,t] => t; nil) for x in rest form]
166  typeList:= [targetType,:argTypeList]
167  specialCaseForm := [nil for x in form]
168  trhs :=
169      rhs is ["=>", a, b] => ['IF,postTran a, postTran b, 'noBranch]
170      postTran rhs
171  ['DEF, newLhs, typeList, specialCaseForm, trhs]
172
173postMDef(t) ==
174  [.,lhs,rhs] := t
175  lhs := postTran lhs
176  [form,targetType]:=
177    lhs is [":",:.] => rest lhs
178    [lhs,nil]
179  form:=
180    atom form => LIST form
181    form
182  newLhs:= [(x is [":",a,:.] => a; x) for x in form]
183  typeList:= [targetType,:[(x is [":",.,t] => t; nil) for x in rest form]]
184  ['MDEF,newLhs,typeList,[nil for x in form],postTran rhs]
185
186postExit ["=>",a,b] == ['IF,postTran a,['exit,postTran b],'noBranch]
187
188
189postFlatten(x,op) ==
190  x is [ =op,a,b] => [:postFlatten(a,op),:postFlatten(b,op)]
191  LIST x
192
193postForm (u is [op,:argl]) ==
194  x:=
195    atom op =>
196      argl':= postTranList argl
197      [op,:argl']
198    u:= postTranList u
199    if u is [["@Tuple", :.], :.] then
200      postError ['"  ",:bright u,
201        '"is illegal because tuples cannot be applied!",'%l,
202          '"   Did you misuse infix dot?"]
203    u
204  x is [., ["@Tuple", :y]] => [first x, :y]
205  x
206
207postIf t ==
208  t isnt ["if",:l] => t
209  ['IF, :[(null(x := postTran x) => 'noBranch; x)
210    for x in l]]
211
212postJoin ['Join,a,:l] ==
213  a:= postTran a
214  l:= postTranList l
215  if l is [b] and b is [name, :.] and MEMQ(name, ["ATTRIBUTE", "SIGNATURE"])
216  then l := LIST(['CATEGORY, b])
217  al:=
218    a is ["@Tuple", :c] => c
219    LIST a
220  ['Join,:al,:l]
221
222postMapping u  ==
223  u isnt ["->",source,target] => u
224  ['Mapping,postTran target,:unTuple postTran source]
225
226postRepeat ['REPEAT,:m,x] == ['REPEAT,:postIteratorList m,postTran x]
227
228postSEGMENT ['SEGMENT,a,b] ==
229  key:= [a,'"..",:(b => [b]; nil)]
230  postError ['"   Improper placement of segment",:bright key]
231
232postCollect [constructOp,:m,x] ==
233  x is [['Sel, D, 'construct], :y] =>
234    postCollect [['Sel, D, 'COLLECT], :m, ['construct, :y]]
235  itl:= postIteratorList m
236  x:= (x is ['construct,r] => r; x)  --added 84/8/31
237  y:= postTran x
238  finish(constructOp,itl,y) where
239    finish(op,itl,y) ==
240      y is [":",a] => ['REDUCE,'append,0,[op,:itl,a]]
241      y is ["@Tuple", :l] =>
242        newBody:=
243          or/[x is [":",y] for x in l] => postMakeCons l
244          or/[x is ['SEGMENT,:.] for x in l] => tuple2List l
245          ['construct,:postTranList l]
246        ['REDUCE,'append,0,[op,:itl,newBody]]
247      [op,:itl,y]
248
249postIteratorList x ==
250  x is [p,:l] =>
251    (p:= postTran p) is ['IN,y,u] =>
252      u is ["|",a,b] => [['IN,y,postInSeq a],["|",b],:postIteratorList l]
253      [['IN,y,postInSeq u],:postIteratorList l]
254    p is  ['INBY, y, u, v] =>
255      u is ["|",a,b] =>
256          [['INBY, y, postInSeq a, v], ["|",b], :postIteratorList l]
257      [['INBY, y, u, v], :postIteratorList l]
258    [p,:postIteratorList l]
259  x
260
261postin arg ==
262  arg isnt ["in",i,seq] => systemErrorHere '"postin"
263  ["in",postTran i, postInSeq seq]
264
265postIn arg ==
266  arg isnt ['IN,i,seq] => systemErrorHere '"postIn"
267  ['IN,postTran i,postInSeq seq]
268
269postInSeq seq ==
270  seq is ['SEGMENT,p,q] => postTranSegment(p,q)
271  seq is ["@Tuple", :l] => tuple2List l
272  postTran seq
273
274postTranSegment(p,q) == ['SEGMENT,postTran p,(q => postTran q; nil)]
275
276tuple2List l ==
277  l is [a,:l'] =>
278    u:= tuple2List l'
279    null u => ['construct,postTran a]
280    ["cons", postTran a, u]
281  nil
282
283postReduce ['Reduce,op,expr] ==
284  expr is ['COLLECT, :.] =>
285    ['REDUCE,op,0,postTran expr]
286  postReduce ['Reduce,op,['COLLECT,['IN,g:= GENSYM(),expr],
287    ['construct,  g]]]
288
289postFlattenLeft(x,op) ==--
290  x is [ =op,a,b] => [:postFlattenLeft(a,op),b]
291  [x]
292
293postSemiColon u ==
294    [:l, x] := postFlattenLeft(u, ";")
295    ['SEQ, :postBlockItemList l, ["exit", postTran x]]
296
297postSignature1(op, sig) ==
298    sig1 := postType sig
299    op := postAtom (STRINGP op => INTERN op; op)
300    sig is ["->",:.] =>
301        ["SIGNATURE",op,:removeSuperfluousMapping killColons sig1]
302    ["SIGNATURE", op, killColons sig1, "constant"]
303
304postSignature ['Signature, op, sig, doc] ==
305    res1 := postSignature1(op, sig)
306    if res1 then record_on_docList(rest res1, doc)
307    res1
308
309killColons x ==
310  atom x => x
311  x is ['Record,:.] => x
312  x is ['Union,:.] => x
313  x is [":",.,y] => killColons y
314  [killColons first x,:killColons rest x]
315
316postSlash ['_/,a,b] ==
317  STRINGP a => postTran ['Reduce,INTERN a,b]
318  ['_/,postTran a,postTran b]
319
320removeSuperfluousMapping sig1 ==
321  --get rid of this asap
322  sig1 is [x,:y] and x is ['Mapping,:.] => [rest x,:y]
323  sig1
324
325postType typ ==
326  typ is ["->",source,target] =>
327    source="constant" => [LIST postTran target,"constant"]
328    LIST ['Mapping,postTran target,:unTuple postTran source]
329  typ is ["->",target] => LIST ['Mapping,postTran target]
330  LIST postTran typ
331
332postTuple u ==
333  u is ["@Tuple"] => u
334  u is ["@Tuple", :l, a] => (["@Tuple", :postTranList rest u])
335
336postWhere ["where",a,b] ==
337    ["where", postTran a, postTran b]
338
339postWith ["with",a] ==
340  $insidePostCategoryIfTrue: local := true
341  a:= postTran a
342  a is [op, :.] and MEMQ(op, ["ATTRIBUTE", "SIGNATURE", "IF"]) =>
343      ['CATEGORY, a]
344  a is ['PROGN,:b] => ['CATEGORY,:b]
345  a
346
347-- should set $topOp
348postTransformCheck x ==
349  $defOp: local:= nil
350  postcheck x
351
352postcheck x ==
353  atom x => nil
354  x is ['DEF,form,[target,:.],:.] =>
355    setDefOp form
356    nil
357  x is ['QUOTE,:.] => nil
358  postcheck first x
359  postcheck rest x
360
361setDefOp f ==
362  if f is [":",g,:.] then f := g
363  f := (atom f => f; first f)
364  if $topOp then $defOp:= f else $topOp:= f
365
366unTuple x ==
367  x is ["@Tuple", :y] => y
368  LIST x
369