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