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
36
37$compBugPrefix :=      '"Bug!"
38$compErrorPrefix :=    '"Error"
39
40--error message facility
41$nopos   := ['noposition]
42$showKeyNum   :=        NIL
43
44-- Miscellaneous nonsense.
45$newcompErrorCount :=           0
46
47-- Items from MSG BOOT I
48$preLength := 11
49$LOGLENGTH := $LINELENGTH - 6
50$specificMsgTags := []
51
52$imPrTagGuys := ['unimple, 'bug, 'debug, 'say, 'warn]
53$toWhereGuys := ['fileOnly, 'screenOnly ]
54$imPrGuys    := ['imPr]
55$repGuys     := ['noRep, 'rep]
56$attrCats    := ['$imPrGuys, '$toWhereGuys, '$repGuys]
57
58
59$ncMsgList := nil
60
61
62--%  Messages for the USERS of the compiler.
63-- The program being compiled has a minor error.
64-- Give a message and continue processing.
65ncSoftError(pos, erMsgKey, erArgL) ==
66  $newcompErrorCount := $newcompErrorCount + 1
67  desiredMsg erMsgKey =>
68    processKeyedError _
69       msgCreate ('error, pos, erMsgKey, erArgL, $compErrorPrefix)
70
71-- The program being compiled is seriously incorrect.
72-- Give message and throw to a recovery point.
73ncHardError(pos, erMsgKey, erArgL) ==
74  $newcompErrorCount := $newcompErrorCount + 1
75  desiredMsg erMsgKey =>
76    erMsg := processKeyedError _
77       msgCreate('error,pos,erMsgKey, erArgL, $compErrorPrefix)
78  ncError()
79
80-- Bug in the compiler: something which shouldn't have happened did.
81ncBug (erMsgKey, erArgL) ==
82  $newcompErrorCount := $newcompErrorCount + 1
83  erMsg := processKeyedError _
84        msgCreate('bug,$nopos, erMsgKey, erArgL,$compBugPrefix)
85  -- The next line is to try to deal with some reported cases of unwanted
86  -- backtraces appearing, MCD.
87  ENABLE_BACKTRACE(nil)
88  BREAK()
89  ncAbort()
90
91--% Lower level functions
92
93--msgObject  tag -- category of msg
94--                    -- attributes as a-list
95--                        'imPr  => dont save for list processing
96--                        toWhere, screen or file
97--                        'norep => only display once in list
98--           pos -- position with possible FROM/TO tag
99--           key -- key for message database
100--          argL -- arguments to be placed in the msg test
101--        prefix -- things like "Error: "
102--          text -- the actual text
103
104msgCreate(tag,posWTag,key,argL,optPre) ==
105    if PAIRP key then tag := 'old
106    msg := [tag,posWTag,key,argL,optPre,NIL]
107    putDatabaseStuff msg
108    initImPr    msg
109    initToWhere msg
110    msg
111
112processKeyedError msg ==
113    getMsgTag? msg = 'old  =>                                 --temp
114        erMsg := getMsgKey msg                                --temp
115        if pre := getMsgPrefix? msg then                      --temp
116          erMsg := ['%b, pre, '%d, :erMsg]                    --temp
117        sayBrightly ['"old msg from ",_
118          CallerName 4,:erMsg]                  --temp
119    msgImPr? msg =>
120      msgOutputter msg
121    $ncMsgList := cons (msg, $ncMsgList)
122
123---------------------------------
124--%getting info from db.
125putDatabaseStuff msg ==
126    [text,attributes] := getMsgInfoFromKey msg
127    if attributes then setMsgUnforcedAttrList(msg,aL)
128    setMsgText(msg,text)
129
130getMsgInfoFromKey msg ==
131    msgText :=
132        msgKey := getMsgKey? msg =>   --temp  oldmsgs use key tostoretext
133           getKeyedMsg msgKey
134        getMsgKey msg                  --temp oldmsgs
135    msgText := segmentKeyedMsg  msgText
136    [msgText,attributes] := removeAttributes msgText
137    msgText := substituteSegmentedMsg(msgText, getMsgArgL msg)
138    [msgText,attributes]
139
140
141-----------------------
142--%character position marking
143
144processChPosesForOneLine msgList ==
145    chPosList := posPointers msgList
146    for msg in msgList repeat
147        if getMsgFTTag? msg then
148            putFTText (msg,chPosList)
149        posLetter := rest ASSOC(poCharPosn getMsgPos msg, chPosList)
150        oldPre := getMsgPrefix msg
151        setMsgPrefix (msg,STRCONC(oldPre,_
152                     make_full_CVEC($preLength - 4 - SIZE oldPre), posLetter))
153    leaderMsg := makeLeaderMsg chPosList
154    NCONC(msgList,LIST leaderMsg)  --a back cons
155
156posPointers msgList ==
157--gets all the char posns for msgs on one line
158--associates them with a uppercase letter
159    pointers  := '"ABCDEFGHIJKLMONPQRS"
160    increment := 0
161    posList:= []
162    ftPosList := []
163    for msg in msgList repeat
164       pos := poCharPosn getMsgPos msg
165       if pos ~= IFCAR posList then
166         posList := [pos,:posList]
167       if getMsgFTTag?(msg) = 'FROMTO then
168         ftPosList := [poCharPosn getMsgPos2 msg,:ftPosList]
169    for toPos in ftPosList repeat
170           posList := insertPos(toPos,posList)
171    for pos in posList repeat
172        posLetterList := [[pos,:pointers.increment],:posLetterList]
173        increment := increment + 1
174    posLetterList
175
176insertPos(newPos,posList) ==
177--inserts a position in the proper place of a position list
178--used for the 2nd pos of a fromto
179    done := false
180    bot  := [0,:posList]
181    top  := []
182    while not done repeat
183        top  := [first bot, :top]
184        bot  := rest bot
185        NULL(bot) =>
186           top := [newPos,:top]
187           done := true
188        pos  := first bot
189        done :=
190          pos < newPos => false
191          pos = newPos => true
192          pos > newPos =>
193            top := [newPos,:top]
194            true
195    for pp in top repeat
196        bot := [pp, :bot]
197    rest bot
198
199putFTText (msg,chPosList) ==
200    tag := getMsgFTTag? msg
201    pos := poCharPosn getMsgPos msg
202    charMarker := rest ASSOC(pos, chPosList)
203    tag = 'FROM =>
204        markingText := ['"(from ",charMarker,'" and on) "]
205        setMsgText(msg,[:markingText,:getMsgText msg])
206    tag = 'TO =>
207        markingText := ['"(up to ",charMarker,'") "]
208        setMsgText(msg,[:markingText,:getMsgText msg])
209    tag = 'FROMTO =>
210       pos2 := poCharPosn getMsgPos2 msg
211       charMarker2 := rest ASSOC(pos2, chPosList)
212       markingText := ['"(from ",charMarker,'" up to ",_
213           charMarker2,'") "]
214       setMsgText(msg,[:markingText,:getMsgText msg])
215
216rep (c,n)  ==
217    n > 0 =>
218      make_full_CVEC(n, c)
219    '""
220
221--called from parameter list of nc message functions
222From   pos == ['FROM,   pos]
223To     pos == ['TO,     pos]
224FromTo (pos1,pos2) == ['FROMTO, pos1, pos2]
225
226------------------------
227--%processing error lists
228processMsgList (erMsgList,lineList) ==
229    $outputList :local := []--grows in queueUp errors
230    $noRepList :local := []--grows in queueUp errors
231    erMsgList  := erMsgSort erMsgList
232    for line in lineList repeat
233        msgLine := makeMsgFromLine line
234        $outputList := [msgLine,:$outputList]
235        globalNumOfLine := poGlobalLinePosn getMsgPos msgLine
236        erMsgList :=
237             queueUpErrors(globalNumOfLine,erMsgList)
238    $outputList := append(erMsgList,$outputList)  --the nopos's
239    listOutputter reverse $outputList
240
241erMsgSort erMsgList ==
242    [msgWPos,msgWOPos] := erMsgSep erMsgList
243    msgWPos  := listSort(function erMsgCompare, msgWPos)
244    msgWOPos := reverse msgWOPos
245    [:msgWPos,:msgWOPos]
246
247erMsgCompare(ob1,ob2)==
248    pos1 :=  getMsgPos ob1
249    pos2 :=  getMsgPos ob2
250    compareposns(pos2,pos1)
251
252erMsgSep erMsgList ==
253    msgWPos  := []
254    msgWOPos := []
255    for msg in erMsgList repeat
256        if poNopos? getMsgPos msg then
257          msgWOPos := [msg,:msgWOPos]
258        else
259          msgWPos  := [msg,:msgWPos]
260    [msgWPos,msgWOPos]
261
262getLinePos line  == first line
263getLineText line == rest line
264
265queueUpErrors(globalNumOfLine,msgList)==
266    thisPosMsgs  := []
267    notThisLineMsgs := []
268    for msg in msgList _
269      while thisPosIsLess(getMsgPos msg,globalNumOfLine) repeat
270    --these are msgs that refer to positions from earlier compilations
271        if not redundant (msg,notThisPosMsgs) then
272           notThisPosMsgs := [msg,:notThisPosMsgs]
273        msgList := rest msgList
274    for msg in msgList _
275      while thisPosIsEqual(getMsgPos msg,globalNumOfLine) repeat
276       if not redundant (msg,thisPosMsgs) then
277           thisPosMsgs := [msg,:thisPosMsgs]
278       msgList := rest msgList
279    if thisPosMsgs then
280        thisPosMsgs := processChPosesForOneLine  thisPosMsgs
281        $outputList := NCONC(thisPosMsgs,$outputList)
282    if notThisPosMsgs then
283        $outputList := NCONC(notThisPosMsgs,$outputList)
284    msgList
285
286redundant(msg,thisPosMsgs) ==
287    found := NIL
288    if msgNoRep? msg then
289        for item in $noRepList repeat
290            sameMsg?(msg,item) => return (found := true)
291        $noRepList := [msg,$noRepList]
292    found or MEMBER(msg,thisPosMsgs)
293
294sameMsg? (msg1,msg2) ==
295    (getMsgKey   msg1 = getMsgKey  msg2) and _
296    (getMsgArgL  msg1 = getMsgArgL msg2)
297
298
299thisPosIsLess(pos,num) ==
300    poNopos? pos => NIL
301    poGlobalLinePosn pos < num
302
303thisPosIsEqual(pos,num) ==
304    poNopos? pos => NIL
305    poGlobalLinePosn pos = num
306
307--%outputting stuff
308
309listOutputter outputList ==
310    for msg in outputList repeat
311        msgOutputter msg
312
313msgOutputter msg  ==
314    st := getStFromMsg msg
315    shouldFlow := not (leader? msg or line? msg)
316    if toScreen? msg then
317       if shouldFlow then
318          st := flowSegmentedMsg(st,$LINELENGTH,0)
319       sayBrightly st
320    if toFile? msg then
321       if shouldFlow then
322          st := flowSegmentedMsg(st,$LOGLENGTH,0)
323       alreadyOpened := alreadyOpened? msg
324
325toScreen? msg ==  getMsgToWhere msg ~= 'fileOnly
326
327toFile? msg   ==
328     getMsgToWhere msg ~= 'screenOnly
329
330alreadyOpened? msg ==
331       not msgImPr? msg
332
333getStFromMsg msg ==
334    $optKeyBlanks : local := '""  --set in setOptKeyBlanks()
335    setOptKeyBlanks()
336    preStL := getPreStL getMsgPrefix? msg
337    getMsgTag  msg = 'line =>
338          [$optKeyBlanks, '"%x1" , :preStL,_
339           getMsgText msg]
340    posStL := getPosStL msg
341    optKey :=
342        $showKeyNum =>
343            msgKey := getMsgKey? msg => PNAME msgKey
344            '"no key  "
345        '""
346    st :=[posStL,getMsgLitSym msg,_
347          optKey,:preStL,_
348          tabbing msg,:getMsgText msg]
349
350tabbing msg ==
351    chPos := 2
352    if getMsgPrefix? msg then
353      chPos := chPos + $preLength - 1
354    if $showKeyNum then chPos := chPos + 8
355    ["%t",:chPos]
356
357setOptKeyBlanks() ==
358    $optKeyBlanks :=
359        $showKeyNum => '"%x8"
360        '""
361
362getPosStL msg ==
363    not showMsgPos? msg => '""
364    msgPos := getMsgPos msg
365    howMuch :=
366        msgImPr? msg =>
367            decideHowMuch (msgPos,$lastPos)
368        listDecideHowMuch (msgPos,$lastPos)
369    $lastPos := msgPos
370    fullPrintedPos := ppos msgPos
371    printedFileName :=  ['"%x2",'"[",:remLine fullPrintedPos,'"]" ]
372    printedLineNum  :=  ['"%x2",'"[",:remFile fullPrintedPos,'"]" ]
373    printedOrigin   :=  ['"%x2",'"[",:fullPrintedPos,'"]" ]
374    howMuch  = 'ORG  => [$optKeyBlanks,:printedOrigin, '%l]
375    howMuch  = 'LINE => [$optKeyBlanks,:printedLineNum, '%l]
376    howMuch  = 'FILE => [$optKeyBlanks,:printedFileName, '%l]
377    howMuch  = 'ALL  => [$optKeyBlanks,:printedFileName, '%l,_
378                         $optKeyBlanks,:printedLineNum,  '%l]
379    '""
380
381showMsgPos? msg ==
382    $erMsgToss or (not msgImPr? msg and not msgLeader? msg)
383
384remFile positionList ==
385        IFCDR IFCDR positionList
386
387remLine positionList ==
388        [IFCAR positionList]
389
390decideHowMuch(pos,oldPos) ==
391--when printing a msg, we wish not to show pos info that was
392--shown for a previous msg with identical pos info.
393--org prints out the word noposition or console
394    ((poNopos? pos) and (poNopos? oldPos)) or _
395      ((poPosImmediate? pos) and (poPosImmediate? oldPos))  => 'NONE
396    (poNopos? pos) or (poPosImmediate? pos) => 'ORG
397    (poNopos? oldPos) or (poPosImmediate? oldPos) => 'ALL
398    poFileName oldPos ~= poFileName pos => 'ALL
399    poLinePosn oldPos ~= poLinePosn pos => 'LINE
400    'NONE
401
402listDecideHowMuch(pos,oldPos) ==
403    ((poNopos? pos) and (poNopos? oldPos)) or _
404      ((poPosImmediate? pos) and (poPosImmediate? oldPos))  => 'NONE
405    (poNopos? pos)     => 'ORG
406    (poNopos? oldPos)  => 'NONE
407    poGlobalLinePosn pos < poGlobalLinePosn oldPos =>
408        poPosImmediate? pos => 'ORG
409        'LINE
410    --(poNopos? pos) or (poPosImmediate? pos) => 'ORG
411    'NONE
412
413getPreStL optPre ==
414    null optPre => [make_full_CVEC 2]
415    spses :=
416      (extraPlaces := ($preLength - (SIZE optPre) - 3)) > 0 =>
417        make_full_CVEC extraPlaces
418      '""
419    ['%b, optPre,spses,'":", '%d]
420
421-------------------
422--%   a-list stuff
423desiredMsg (erMsgKey,:optCatFlag) ==
424    isKeyQualityP(erMsgKey,'show)   => true
425    isKeyQualityP(erMsgKey,'stifle) => false
426    not null optCatFlag  => first optCatFlag
427    true
428
429isKeyQualityP (key,qual)  ==
430    --returns pair if found, else NIL
431    found := false
432    while not found and (qualPair := ASSOC(key,$specificMsgTags)) repeat
433        if rest qualPair = qual then found := true
434    qualPair
435
436-----------------------------
437--% these functions handle the attributes
438
439initImPr msg  ==
440    $erMsgToss or MEMQ (getMsgTag msg,$imPrTagGuys) =>
441        setMsgUnforcedAttr (msg,'$imPrGuys,'imPr)
442
443initToWhere msg  ==
444    MEMBER ('trace,getMsgCatAttr (msg,'catless)) =>
445          setMsgUnforcedAttr (msg,'$toWhereGuys,'screenOnly)
446
447msgImPr? msg ==
448    (getMsgCatAttr (msg,'$imPrGuys) = 'imPr)
449
450msgNoRep? msg ==
451    (getMsgCatAttr (msg,'$repGuys) = 'noRep)
452
453msgLeader? msg ==
454    getMsgTag msg = 'leader
455
456getMsgToWhere msg ==
457    getMsgCatAttr (msg,'$toWhereGuys)
458
459getMsgCatAttr  (msg,cat) ==
460    IFCDR ASSQ(cat, ncAlist msg)
461
462setMsgUnforcedAttrList (msg,aL) ==
463    for attr in aL repeat
464        setMsgUnforcedAttr(msg,whichCat attr,attr)
465
466setMsgUnforcedAttr(msg,cat,attr) ==
467    cat = 'catless => setMsgCatlessAttr(msg,attr)
468    not ASSQ(cat, ncAlist msg) => ncPutQ(msg,cat,attr)
469
470setMsgCatlessAttr(msg,attr) ==
471    ncPutQ(msg,catless,CONS (attr, IFCDR ASSQ(catless, ncAlist msg)))
472
473whichCat attr ==
474    found := 'catless
475    for cat in $attrCats repeat
476        if ListMember? (attr,EVAL cat) then
477          found := cat
478          return found
479    found
480
481--------------------------------------
482--% these functions directly interact with the message object
483
484makeLeaderMsg chPosList ==
485    st := make_full_CVEC($preLength - 3)
486    oldPos := -1
487    for [posNum,:posLetter] in reverse chPosList repeat
488        st := STRCONC(st, _
489            rep(char ".", (posNum - oldPos - 1)),posLetter)
490        oldPos := posNum
491    ['leader,$nopos,'nokey,NIL,NIL,[st]]
492
493makeMsgFromLine line ==
494    posOfLine  := getLinePos line
495    textOfLine := getLineText line
496    globalNumOfLine := poGlobalLinePosn posOfLine
497    localNumOfLine  :=
498        i := poLinePosn posOfLine
499        stNum := STRINGIMAGE i
500        STRCONC(rep(char " ", ($preLength - 7 - SIZE stNum)),_
501         stNum)
502    ['line,posOfLine,NIL,NIL, STRCONC('"Line", localNumOfLine),_
503        textOfLine]
504
505getMsgTag msg == ncTag msg
506
507getMsgTag? msg ==
508   IFCAR MEMBER (getMsgTag msg,_
509       ['line,'old,'error,'warn,'bug,'unimple,'remark,'stat,'say,'debug])
510
511leader? msg == getMsgTag msg = 'leader
512line?   msg == getMsgTag msg = 'line
513
514getMsgPosTagOb msg == msg.1
515
516getMsgPos msg ==
517    getMsgFTTag? msg => CADR getMsgPosTagOb msg
518    getMsgPosTagOb msg
519
520getMsgPos2 msg ==
521    getMsgFTTag? msg => CADDR getMsgPosTagOb msg
522    ncBug('"not a from to",[])
523
524getMsgFTTag? msg == IFCAR MEMBER (IFCAR getMsgPosTagOb msg,_
525                      ['FROM,'TO,'FROMTO])
526
527getMsgKey msg == msg.2
528
529getMsgKey? msg == IDENTP (val := getMsgKey msg) => val
530
531getMsgArgL msg == msg.3
532
533getMsgPrefix? msg ==
534    (pre := msg.4) = 'noPre => NIL
535    pre
536
537getMsgPrefix  msg == msg.4
538
539
540getMsgLitSym msg ==
541    getMsgKey? msg => '" "
542    '"*"
543
544getMsgText msg == msg.5
545
546setMsgPrefix (msg,val) == msg.4 := val
547
548setMsgText (msg,val) == msg.5 := val
549