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--% Formatting functions for various compiler data objects. 36-- These are used as [%origin o, %id n] for %1f %2f... style arguments 37-- in a keyed message. 38-- SMW, SG June 88 39 40%id a == [FUNCTION IDENTITY, a] 41 42-- Union(FileName,"strings","console") 43%origin x == 44 [function porigin, x] 45 46porigin x == x 47 48ppos p == 49 pfNoPosition? p => ['"no position"] 50 pfImmediate? p => ['"console"] 51 cpos := pfCharPosn p 52 lpos := pfLinePosn p 53 org := porigin pfFileName p 54 [org,'" ",'"line",'" ",lpos] 55 56--keyStuff ::= keynumber | [ one or more keySeqs ] 57--keySeq ::= keynumber optargList optdbn 58--optARgL ::= [ 0 or more arguments ] | nothing at all 59--optDbn ::= ['dbN , databaseName ] | nothing at all 60 61-- Includer 62 63incStringStream s== 64 incRenumber incLude(0,incRgen s,0,['"strings"] ,[Top]) 65 66incFile fn== 67 incRenumber incLude(0,incRgen OPEN fn,0,[fn],[Top]) 68 69incStream(st, fn) == 70 incRenumber incLude(0,incRgen st,0,[fn],[Top]) 71 72incFileInput fn == incRgen MAKE_INSTREAM(fn) 73 74incLine(eb, str, gno, lno, ufo) == 75 ln := lnCreate(eb,str,gno,lno,ufo) 76 CONS(CONS(ln,1), str) 77 78incPos f == first f 79 80incRenumberItem(f, i) == 81 l := CAAR f 82 lnSetGlobalNum(l, i) 83 f 84 85incRenumberLine(xl, gno) == 86 l := incRenumberItem(xl.0, gno) 87 incHandleMessage xl 88 l 89 90incRenumber ssx == incZip (function incRenumberLine, ssx, incIgen 0) 91 92incPrefix?(prefix, start, whole) == 93 #prefix > #whole-start => false 94 good:=true 95 for i in 0..#prefix-1 for j in start.. while good repeat 96 good:= prefix.i = whole.j 97 good 98 99incCommand?(s) == #s > 1 and s.0 = char ")" and not (s.1 = char " ") 100 101incCommands := 102 ['"say" , _ 103 '"include", _ 104 '"fin" , _ 105 '"assert" , _ 106 '"if" , _ 107 '"elseif" , _ 108 '"else" , _ 109 '"endif" ] 110 111incClassify(s) == 112 not incCommand? s => [false,0, '""] 113 i := 1; n := #s 114 while i < n and s.i = char " " repeat i := i + 1 115 i >= n => [true,0,'"other"] 116 eb := (i = 1 => 0; i) 117 bad:=true 118 for p in incCommands while bad repeat 119 incPrefix?(p, i, s) => 120 bad:=false 121 p1 :=p 122 if bad then [true,0,'"other"] else [true,eb,p1] 123 124incCommandTail(s, info) == 125 start := (info.1 = 0 => 1; info.1) 126 incDrop(start+#info.2+1, s) 127 128incDrop(n, b) == 129 n >= #b => "" 130 SUBSTRING(b,n,nil) 131 132 133inclFname(s, info) == incFileName incCommandTail(s, info) 134 135incBiteOff x == 136 n:=STRPOSL('" ",x,0,true)-- first nonspace 137 if null n 138 then false -- all spaces 139 else 140 n1:=STRPOSL ('" ",x,n,nil) 141 if null n1 -- all nonspaces 142 then [SUBSTRING(x,n,nil),'""] 143 else [SUBSTRING(x,n,n1-n),SUBSTRING(x,n1,nil)] 144 145incTrunc (n,x)== 146 if #x>n 147 then SUBSTRING(x,0,n) 148 else x 149 150incFileName x == first incBiteOff x 151 152fileNameStrings fn==[PNAME(fn.0),PNAME(fn.1),PNAME(fn.2)] 153 154ifCond(s, info) == 155 word := INTERN DROPTRAILINGBLANKS(incCommandTail(s, info)) 156 member(word, $inclAssertions) 157 158assertCond(s, info) == 159 word := INTERN DROPTRAILINGBLANKS(incCommandTail(s, info)) 160 if not member(word, $inclAssertions) then 161 $inclAssertions := [word, :$inclAssertions] 162 163 164incActive?(fn,ufos)==MEMBER(fn,ufos) 165 166Top := 01 167IfSkipToEnd := 10 168IfKeepPart := 11 169IfSkipPart := 12 170ElseifSkipToEnd:= 20 171ElseifKeepPart := 21 172ElseifSkipPart := 22 173ElseSkipToEnd := 30 174ElseKeepPart := 31 175Continuation := 41 176 177Top? (st) == QUOTIENT(st,10) = 0 178If? (st) == QUOTIENT(st,10) = 1 179Elseif? (st) == QUOTIENT(st,10) = 2 180Else? (st) == QUOTIENT(st,10) = 3 181SkipEnd? (st) == REMAINDER(st,10) = 0 182KeepPart?(st) == REMAINDER(st,10) = 1 183SkipPart?(st) == REMAINDER(st,10) = 2 184Skipping?(st) == not KeepPart? st 185 186 --% Message Handling 187incHandleMessage(xl) == 188 xl.1.1 = "none" => 189 0 190 xl.1.1 = "error" => 191 inclHandleError(incPos xl.0, xl.1.0) 192 xl.1.1 = "warning" => 193 inclHandleWarning(incPos xl.0, xl.1.0) 194 xl.1.1 = "say" => 195 inclHandleSay(incPos xl.0, xl.1.0) 196 inclHandleBug(incPos xl.0, xl.1.0) 197 198xlOK(eb, str, lno, ufo) == 199 [incLine(eb, str, -1, lno, ufo), [NIL, "none"]] 200 201xlOK1(eb, str,str1, lno, ufo) == 202 [incLine1(eb, str,str1, -1, lno, ufo), [NIL, "none"]] 203 204incLine1(eb, str,str1, gno, lno, ufo) == 205 ln := lnCreate(eb,str,gno,lno,ufo) 206 CONS(CONS(ln,1), str1) 207xlSkip(eb, str, lno, ufo) == 208 str := CONCAT('"-- Omitting:", str) 209 [incLine(eb, str, -1, lno, ufo), [NIL, "none"]] 210 211xlMsg(eb, str, lno, ufo, mess) == 212 [incLine(eb, str, -1, lno, ufo), mess] 213 214xlPrematureEOF(eb, str, lno, ufos) == 215 xlMsg(eb, str, lno,ufos.0, 216 [inclmsgPrematureEOF(ufos.0),"error"]) 217 218xlPrematureFin(eb, str, lno, ufos) == 219 xlMsg(eb, str, lno,ufos.0, 220 [inclmsgPrematureFin(ufos.0),"error"]) 221 222xlFileCycle(eb, str, lno, ufos, fn) == 223 xlMsg(eb, str, lno,ufos.0, 224 [inclmsgFileCycle(ufos,fn),"error"]) 225 226xlNoFile(eb, str, lno, ufos) == 227 xlMsg(eb, str, lno,ufos.0, 228 [inclmsgNoFile(), "error"]) 229 230xlCannotRead(eb, str, lno, ufos, fn) == 231 xlMsg(eb, str, lno,ufos.0, 232 [inclmsgCannotRead(fn), "error"]) 233 234xlSkippingFin(eb, str, lno, ufos) == 235 xlMsg(eb, str, lno,ufos.0, 236 [inclmsgFinSkipped(),"warning"]) 237 238xlIfBug(eb, str, lno, ufos) == 239 xlMsg(eb, str, lno,ufos.0, 240 [inclmsgIfBug(), "bug"]) 241 242xlCmdBug(eb, str, lno, ufos) == 243 xlMsg(eb, str, lno,ufos.0, 244 [inclmsgCmdBug(), "bug"]) 245 246xlSay(eb, str, lno, ufos, x) == 247 xlMsg(eb, str, lno,ufos.0, 248 [inclmsgSay(x), "say"]) 249 250xlIfSyntax(eb, str, lno,ufos,info,sts) == 251 st := sts.0 252 found := info.2 253 context := 254 Top? st => "not in an )if...)endif" 255 Else? st => "after an )else" 256 "but can't figure out where" 257 xlMsg(eb, str, lno, ufos.0, 258 [inclmsgIfSyntax(ufos.0,found,context), "error"]) 259 260 --% This is it 261 262incLude(eb, ss, ln, ufos, states) == 263 Delay(function incLude1,[eb, ss, ln, ufos, states]) 264 265Rest s ==> incLude(eb, rest ss, lno, ufos, states) 266 267incLude1 (:z) == 268 [eb, ss, ln, ufos, states]:=z 269 lno := ln+1 270 state := states.0 271 272 StreamNull ss => 273 not Top? state => 274 cons(xlPrematureEOF(eb, 275 '")--premature end", lno,ufos), StreamNil) 276 StreamNil 277 278 str := EXPAND_TABS(first(ss)) 279 has_cont := 280 (nn := #str) < 1 => false 281 str.(nn - 1) = char('"__") 282 283 state = Continuation => 284 rs := 285 has_cont => Rest(s) 286 incLude(eb, rest ss, lno, ufos, rest(states)) 287 Skipping?(states.1) => cons(xlSkip(eb,str,lno,ufos.0), rs) 288 cons(xlOK(eb, str, lno, ufos.0), rs) 289 290 info := incClassify str 291 292 not info.0 => 293 rs := 294 has_cont => incLude(eb, rest ss, lno, ufos, 295 cons(Continuation, states)) 296 Rest(s) 297 Skipping? state => cons(xlSkip(eb,str,lno,ufos.0), rs) 298 cons(xlOK(eb, str, lno, ufos.0), rs) 299 300 info.2 = '"other" => 301 Skipping? state => cons(xlSkip(eb,str,lno,ufos.0), Rest s) 302 cons(xlOK1(eb, str,CONCAT('")command",str), lno, ufos.0), 303 Rest s) 304 305 info.2 = '"say" => 306 Skipping? state => cons(xlSkip(eb,str,lno,ufos.0), Rest s) 307 str := incCommandTail(str, info) 308 cons(xlSay(eb, str, lno, ufos, str), 309 cons(xlOK(eb,str,lno,ufos.0), Rest s)) 310 311 info.2 = '"include" => 312 Skipping? state => 313 cons(xlSkip(eb,str,lno,ufos.0), Rest s) 314 fn1 := inclFname(str, info) 315 not fn1 => 316 cons(xlNoFile(eb, str, lno, ufos), Rest s) 317 not PROBE_-FILE fn1 => 318 cons(xlCannotRead(eb, str, lno,ufos,fn1),Rest s) 319 incActive?(fn1,ufos) => 320 cons(xlFileCycle (eb, str, lno,ufos,fn1),Rest s) 321 Includee := 322 incLude(eb+info.1,incFileInput fn1,0, 323 cons(fn1,ufos), cons(Top,states)) 324 cons( 325 xlOK(eb,str,lno,ufos.0), 326 incAppend(Includee, Rest s)) 327 328 info.2 = '"fin" => 329 Skipping? state => 330 cons(xlSkippingFin(eb, str, lno,ufos), Rest s) 331 not Top? state => 332 cons(xlPrematureFin(eb, str, lno,ufos), StreamNil) 333 cons(xlOK(eb,str,lno,ufos.0), StreamNil) 334 335 info.2 = '"assert" => 336 Skipping? state => 337 cons(xlSkippingFin(eb, str, lno,ufos), Rest s) 338 assertCond(str, info) 339 cons(xlOK(eb,str,lno,ufos.0), incAppend(Includee, Rest s)) 340 341 info.2 = '"if" => 342 s1 := 343 Skipping? state => IfSkipToEnd 344 if ifCond(str,info) then IfKeepPart else IfSkipPart 345 cons(xlOK(eb,str,lno,ufos.0), 346 incLude(eb, rest ss, lno, ufos, cons(s1, states))) 347 info.2 = '"elseif" => 348 not If? state and not Elseif? state => 349 cons(xlIfSyntax(eb, str,lno,ufos,info,states), 350 StreamNil) 351 352 if SkipEnd? state or KeepPart? state or SkipPart? state 353 then 354 s1:=if SkipPart? state 355 then 356 pred := ifCond(str,info) 357 if pred 358 then ElseifKeepPart 359 else ElseifSkipPart 360 else ElseifSkipToEnd 361 cons(xlOK(eb,str,lno,ufos.0), 362 incLude(eb, rest ss, lno, ufos, cons(s1, rest states))) 363 else 364 cons(xlIfBug(eb, str, lno,ufos), StreamNil) 365 366 info.2 = '"else" => 367 not If? state and not Elseif? state => 368 cons(xlIfSyntax(eb, str,lno,ufos,info,states), 369 StreamNil) 370 if SkipEnd? state or KeepPart? state or SkipPart? state 371 then 372 s1 :=if SkipPart? state 373 then ElseKeepPart 374 else ElseSkipToEnd 375 cons(xlOK(eb,str,lno,ufos.0), 376 incLude(eb, rest ss, lno, ufos, cons(s1, rest states))) 377 else 378 cons(xlIfBug(eb, str, lno,ufos), StreamNil) 379 380 info.2 = '"endif" => 381 Top? state => 382 cons(xlIfSyntax(eb, str,lno,ufos,info,states), 383 StreamNil) 384 cons(xlOK(eb,str,lno,ufos.0), 385 incLude(eb, rest ss, lno, ufos, rest states)) 386 387 cons(xlCmdBug(eb, str, lno,ufos), StreamNil) 388 389--% Message handling for the source includer 390-- SMW June 88 391 392inclHandleError(pos, [key, args]) == 393 ncSoftError(pos, key, args) 394inclHandleWarning(pos, [key, args]) == 395 ncSoftError(pos, key,args) 396inclHandleBug(pos, [key, args]) == 397 ncBug(key, args) 398inclHandleSay(pos, [key, args]) == 399 ncSoftError(pos, key, args) 400 401inclmsgSay str == 402 ['S2CI0001, [%id str]] 403inclmsgPrematureEOF ufo == 404 ['S2CI0002, [%origin ufo]] 405inclmsgPrematureFin ufo == 406 ['S2CI0003, [%origin ufo]] 407inclmsgFileCycle(ufos,fn) == 408 flist := [porigin n for n in reverse ufos] 409 f1 := porigin fn 410 cycle := [:[:[n,'"==>"] for n in flist], f1] 411 ['S2CI0004, [%id cycle, %id f1]] 412inclmsgFinSkipped() == 413 ['S2CI0008, []] 414inclmsgIfSyntax(ufo,found,context) == 415 found := CONCAT('")", found) 416 ['S2CI0009, [%id found, %id context, %origin ufo]] 417inclmsgNoFile() == 418 ['S2CI0010, []] 419inclmsgCannotRead fn == 420 ['S2CI0011, [fn]] 421inclmsgIfBug() == 422 ['S2CB0002, []] 423inclmsgCmdBug() == 424 ['S2CB0003, []] 425