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