-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2008, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical ALgorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. import sys_-macros import astr namespace BOOT $erLocMsgDatabaseName := pathname '(co_-eng msgs a) $erGlbMsgDatabaseName := pathname '(co_-eng msgs i) $newcompErrorCount := 0 $imPrTagGuys == ['unimple, 'bug, 'debug, 'say, 'warn] $toWhereGuys == ['fileOnly, 'screenOnly ] $imPrGuys == ['imPr] $repGuys == ['noRep, 'rep] $attrCats == ['$imPrGuys, '$toWhereGuys, '$repGuys] $LINELENGTH := 80 $preLength := 11 $LOGLENGTH := $LINELENGTH - 6 $specificMsgTags := [] $showKeyNum := NIL $compErrorPrefix := '"Error" $compBugPrefix := '"Bug!" $ncMsgList := [] --% ListMember?(ob, l) == MEMBER(ob, l, KEYWORD::TEST, function EQUAL) --% Messages for the USERS of the compiler. -- The program being compiled has a minor error. -- Give a message and continue processing. ncSoftError(pos, erMsgKey, erArgL,:optAttr) == $newcompErrorCount := $newcompErrorCount + 1 desiredMsg erMsgKey => processKeyedError _ msgCreate ('error, pos, erMsgKey, erArgL, $compErrorPrefix,optAttr) -- The program being compiled is seriously incorrect. -- Give message and throw to a recovery point. ncHardError(pos, erMsgKey, erArgL,:optAttr) == $newcompErrorCount := $newcompErrorCount + 1 desiredMsg erMsgKey => erMsg := processKeyedError _ msgCreate('error,pos,erMsgKey, erArgL, $compErrorPrefix,optAttr) ncError() -- Bug in the compiler: something which shouldn't have happened did. ncBug (erMsgKey, erArgL,:optAttr) == $newcompErrorCount := $newcompErrorCount + 1 erMsg := processKeyedError _ msgCreate('bug,$nopos, erMsgKey, erArgL,$compBugPrefix,optAttr) BREAK() ncAbort() --% Lower level functions --msgObject tag -- catagory of msg -- -- attributes as a-list -- 'imPr => dont save for list processing -- toWhere, screen or file -- 'norep => only display once in list -- pos -- position with possible FROM/TO tag -- key -- key for message database -- argL -- arguments to be placed in the msg test -- prefix -- things like "Error: " -- text -- the actual text msgCreate(tag,posWTag,key,argL,optPre,:optAttr) == if PAIRP key then tag := 'old msg := [tag,posWTag,key,argL,optPre,NIL] if CAR optAttr then setMsgForcedAttrList(msg,car optAttr) putDatabaseStuff msg initImPr msg initToWhere msg msg processKeyedError msg == getMsgTag? msg = 'old => --temp erMsg := getMsgKey msg --temp if pre := getMsgPrefix? msg then --temp erMsg := ['%b, pre, '%d, :erMsg] --temp sayBrightly ['"old msg from ",_ CallerName 4,:erMsg] --temp msgImPr? msg => msgOutputter msg $ncMsgList := cons (msg, $ncMsgList) --------------------------------- --%getting info from db. putDatabaseStuff msg == [text,attributes] := getMsgInfoFromKey msg if attributes then setMsgUnforcedAttrList(msg,attributes) setMsgText(msg,text) getMsgInfoFromKey msg == $msgDatabaseName : local := [] msgText := msgKey := getMsgKey? msg => --temp oldmsgs use key tostoretext dbL := [$erLocMsgDatabaseName,$erGlbMsgDatabaseName] getErFromDbL (msgKey,dbL) getMsgKey msg --temp oldmsgs msgText := segmentKeyedMsg msgText [msgText,attributes] := removeAttributes msgText msgText := substituteSegmentedMsg(msgText, getMsgArgL msg) [msgText,attributes] getErFromDbL (erMsgKey,dbL) == erMsg := NIL while null erMsg repeat dbName := CAR dbL dbL := CDR dbL $msgDatabaseName := dbName lastName := null dbL -- fileFound := '"co_-eng.msgs" fileFound := '"s2_-us.msgs" if fileFound or lastName then erMsg := fetchKeyedMsg(erMsgKey,not lastName) erMsg ----------------------- --%character position marking processChPosesForOneLine msgList == chPosList := posPointers msgList for msg in msgList repeat if getMsgFTTag? msg then putFTText (msg,chPosList) posLetter := rest assoc(poCharPosn getMsgPos msg,chPosList) oldPre := getMsgPrefix msg setMsgPrefix (msg,STRCONC(oldPre,_ MAKE_-FULL_-CVEC ($preLength - 4 - SIZE oldPre),posLetter) ) leaderMsg := makeLeaderMsg chPosList NCONC(msgList,LIST leaderMsg) --a back cons posPointers msgList == --gets all the char posns for msgs on one line --associates them with a uppercase letter pointers := '"ABCDEFGHIJKLMONPQRS" increment := 0 posList:= [] ftPosList := [] for msg in msgList repeat pos := poCharPosn getMsgPos msg if pos ^= IFCAR posList then posList := [pos,:posList] if getMsgFTTag? msg = 'FROMTO then ftPosList := [poCharPosn getMsgPos2 msg,:ftPosList] for toPos in ftPosList repeat posList := insertPos(toPos,posList) for pos in posList repeat posLetterList := [[pos,:pointers.increment],:posLetterList] increment := increment + 1 posLetterList insertPos(newPos,posList) == --insersts a position in the proper place of a positon list --used for the 2nd pos of a fromto done := false bot := [0,:posList] top := [] while not done repeat top := [CAR bot,:top] bot := CDR bot pos := CAR bot done := pos < newPos => false pos = newPos => true pos > newPos => top := [newPos,:top] true [CDR reverse top,:bot] putFTText (msg,chPosList) == tag := getMsgFTTag? msg pos := poCharPosn getMsgPos msg charMarker := rest assoc(pos,chPosList) tag = 'FROM => markingText := ['"(from ",charMarker,'" and on) "] setMsgText(msg,[:markingText,:getMsgText msg]) tag = 'TO => markingText := ['"(up to ",charMarker,'") "] setMsgText(msg,[:markingText,:getMsgText msg]) tag = 'FROMTO => pos2 := poCharPosn getMsgPos2 msg charMarker2 := rest assoc(pos2,chPosList) markingText := ['"(from ",charMarker,'" up to ",_ charMarker2,'") "] setMsgText(msg,[:markingText,:getMsgText msg]) rep (c,n) == n > 0 => MAKE_-FULL_-CVEC(n, c) '"" --called from parameter list of nc message functions From pos == ['FROM, pos] To pos == ['TO, pos] FromTo (pos1,pos2) == ['FROMTO, pos1, pos2] ------------------------ --%processing error lists processMsgList (erMsgList,lineList) == $outputList :local := []--grows in queueUp errors $noRepList :local := []--grows in queueUp errors erMsgList := erMsgSort erMsgList for line in lineList repeat msgLine := makeMsgFromLine line $outputList := [msgLine,:$outputList] globalNumOfLine := poGlobalLinePosn getMsgPos msgLine erMsgList := queueUpErrors(globalNumOfLine,erMsgList) $outputList := append(erMsgList,$outputList) --the nopos's st := '"---------SOURCE-TEXT-&-ERRORS------------------------" listOutputter reverse $outputList erMsgSort erMsgList == [msgWPos,msgWOPos] := erMsgSep erMsgList msgWPos := listSort(function erMsgCompare, msgWPos) msgWOPos := reverse msgWOPos [:msgWPos,:msgWOPos] erMsgCompare(ob1,ob2)== pos1 := getMsgPos ob1 pos2 := getMsgPos ob2 compareposns(pos2,pos1) erMsgSep erMsgList == msgWPos := [] msgWOPos := [] for msg in erMsgList repeat if poNopos? getMsgPos msg then msgWOPos := [msg,:msgWOPos] else msgWPos := [msg,:msgWPos] [msgWPos,msgWOPos] getLinePos line == CAR line getLineText line == CDR line queueUpErrors(globalNumOfLine,msgList)== thisPosMsgs := [] notThisLineMsgs := [] for msg in msgList _ while thisPosIsLess(getMsgPos msg,globalNumOfLine) repeat --these are msgs that refer to positions from earlier compilations if not redundant (msg,notThisPosMsgs) then notThisPosMsgs := [msg,:notThisPosMsgs] msgList := rest msgList for msg in msgList _ while thisPosIsEqual(getMsgPos msg,globalNumOfLine) repeat if not redundant (msg,thisPosMsgs) then thisPosMsgs := [msg,:thisPosMsgs] msgList := rest msgList if thisPosMsgs then thisPosMsgs := processChPosesForOneLine thisPosMsgs $outputList := NCONC(thisPosMsgs,$outputList) if notThisPosMsgs then $outputList := NCONC(notThisPosMsgs,$outputList) msgList redundant(msg,thisPosMsgs) == found := NIL if msgNoRep? msg then for item in $noRepList repeat sameMsg?(msg,item) => return (found := true) $noRepList := [msg,$noRepList] found or member(msg,thisPosMsgs) sameMsg? (msg1,msg2) == (getMsgKey msg1 = getMsgKey msg2) and _ (getMsgArgL msg1 = getMsgArgL msg2) thisPosIsLess(pos,num) == poNopos? pos => NIL poGlobalLinePosn pos < num thisPosIsEqual(pos,num) == poNopos? pos => NIL poGlobalLinePosn pos = num --%outputting stuff listOutputter outputList == for msg in outputList repeat msgOutputter msg msgOutputter msg == st := getStFromMsg msg shouldFlow := not (leader? msg or line? msg) if toScreen? msg then if shouldFlow then st := flowSegmentedMsg(st,$LINELENGTH,0) sayBrightly st if toFile? msg then if shouldFlow then st := flowSegmentedMsg(st,$LOGLENGTH,0) alreadyOpened := alreadyOpened? msg toScreen? msg == getMsgToWhere msg ^= 'fileOnly toFile? msg == PAIRP $fn and _ getMsgToWhere msg ^= 'screenOnly alreadyOpened? msg == not msgImPr? msg getStFromMsg msg == $optKeyBlanks : local := '"" --set in setOptKeyBlanks() setOptKeyBlanks() preStL := getPreStL getMsgPrefix? msg getMsgTag msg = 'line => [$optKeyBlanks, '"%1" , :preStL,_ getMsgText msg] posStL := getPosStL msg optKey := $showKeyNum => msgKey := getMsgKey? msg => PNAME msgKey '"no key " '"" st :=[posStL,getMsgLitSym msg,_ optKey,:preStL,_ tabbing msg,:getMsgText msg] tabbing msg == chPos := 2 if getMsgPrefix? msg then chPos := chPos + $preLength - 1 if $showKeyNum then chPos := chPos + 8 ["%t",:chPos] setOptKeyBlanks() == $optKeyBlanks := $showKeyNum => '"%x8" '"" getPosStL msg == not showMsgPos? msg => '"" msgPos := getMsgPos msg howMuch := msgImPr? msg => decideHowMuch (msgPos,$lastPos) listDecideHowMuch (msgPos,$lastPos) $lastPos := msgPos fullPrintedPos := ppos msgPos printedFileName := ['"%x2",'"[",:remLine fullPrintedPos,'"]" ] printedLineNum := ['"%x2",'"[",:remFile fullPrintedPos,'"]" ] printedOrigin := ['"%x2",'"[",:fullPrintedPos,'"]" ] howMuch = 'ORG => [$optKeyBlanks,:printedOrigin, '%l] howMuch = 'LINE => [$optKeyBlanks,:printedLineNum, '%l] howMuch = 'FILE => [$optKeyBlanks,:printedFileName, '%l] howMuch = 'ALL => [$optKeyBlanks,:printedFileName, '%l,_ $optKeyBlanks,:printedLineNum, '%l] '"" showMsgPos? msg == $erMsgToss or (not msgImPr? msg and not msgLeader? msg) remFile positionList == IFCDR IFCDR positionList remLine positionList == [IFCAR positionList] decideHowMuch(pos,oldPos) == --when printing a msg, we wish not to show pos infor that was --shown for a previous msg with identical pos info. --org prints out the word noposition or console ((poNopos? pos) and (poNopos? oldPos)) or _ ((poPosImmediate? pos) and (poPosImmediate? oldPos)) => 'NONE (poNopos? pos) or (poPosImmediate? pos) => 'ORG (poNopos? oldPos) or (poPosImmediate? oldPos) => 'ALL poFileName oldPos ^= poFileName pos => 'ALL poLinePosn oldPos ^= poLinePosn pos => 'LINE 'NONE listDecideHowMuch(pos,oldPos) == ((poNopos? pos) and (poNopos? oldPos)) or _ ((poPosImmediate? pos) and (poPosImmediate? oldPos)) => 'NONE (poNopos? pos) => 'ORG (poNopos? oldPos) => 'NONE poGlobalLinePosn pos < poGlobalLinePosn oldPos => poPosImmediate? pos => 'ORG 'LINE --(poNopos? pos) or (poPosImmediate? pos) => 'ORG 'NONE getPreStL optPre == null optPre => [MAKE_-FULL_-CVEC 2] spses := (extraPlaces := ($preLength - (SIZE optPre) - 3)) > 0 => MAKE_-FULL_-CVEC extraPlaces '"" ['%b, optPre,spses,'":", '%d] ------------------- --% a-list stuff desiredMsg (erMsgKey,:optCatFlag) == isKeyQualityP(erMsgKey,'show) => true isKeyQualityP(erMsgKey,'stifle) => false not null optCatFlag => CAR optCatFlag true isKeyQualityP (key,qual) == --returns pair if found, else NIL found := false while not found and (qualPair := assoc(key,$specificMsgTags)) repeat if CDR qualPair = qual then found := true qualPair ----------------------------- --% these functions handle the attributes initImPr msg == $erMsgToss or MEMQ (getMsgTag msg,$imPrTagGuys) => setMsgUnforcedAttr (msg,'$imPrGuys,'imPr) initToWhere msg == member ('trace,getMsgCatAttr (msg,'catless)) => setMsgUnforcedAttr (msg,'$toWhereGuys,'screenOnly) msgImPr? msg == (getMsgCatAttr (msg,'$imPrGuys) = 'imPr) msgNoRep? msg == (getMsgCatAttr (msg,'$repGuys) = 'noRep) msgLeader? msg == getMsgTag msg = 'leader getMsgToWhere msg == getMsgCatAttr (msg,'$toWhereGuys) getMsgCatAttr (msg,cat) == IFCDR QASSQ(cat, ncAlist msg) setMsgForcedAttrList (msg,aL) == for attr in aL repeat setMsgForcedAttr(msg,whichCat attr,attr) setMsgUnforcedAttrList (msg,aL) == for attr in aL repeat setMsgUnforcedAttr(msg,whichCat attr,attr) setMsgForcedAttr(msg,cat,attr) == cat = 'catless => setMsgCatlessAttr(msg,attr) ncPutQ(msg,cat,attr) setMsgUnforcedAttr(msg,cat,attr) == cat = 'catless => setMsgCatlessAttr(msg,attr) not QASSQ(cat, ncAlist msg) => ncPutQ(msg,cat,attr) setMsgCatlessAttr(msg,attr) == ncPutQ(msg,'catless,CONS (attr, IFCDR QASSQ("catless", ncAlist msg))) whichCat attr == found := 'catless for cat in $attrCats repeat if ListMember? (attr,EVAL cat) then found := cat return found found -------------------------------------- --% these functions directly interact with the message object makeLeaderMsg chPosList == st := MAKE_-FULL_-CVEC ($preLength- 3) oldPos := -1 for [posNum,:posLetter] in reverse chPosList repeat st := STRCONC(st, _ rep(char ".", (posNum - oldPos - 1)),posLetter) oldPos := posNum ['leader,$nopos,'nokey,NIL,NIL,[st]] makeMsgFromLine line == posOfLine := getLinePos line textOfLine := getLineText line globalNumOfLine := poGlobalLinePosn posOfLine localNumOfLine := i := poLinePosn posOfLine stNum := STRINGIMAGE i STRCONC(rep(char " ", ($preLength - 7 - SIZE stNum)),_ stNum) ['line,posOfLine,NIL,NIL, STRCONC('"Line", localNumOfLine),_ textOfLine] getMsgTag msg == ncTag msg getMsgTag? msg == IFCAR member (getMsgTag msg,_ ['line,'old,'error,'warn,'bug,'unimple,'remark,'stat,'say,'debug]) leader? msg == getMsgTag msg = 'leader line? msg == getMsgTag msg = 'line getMsgPosTagOb msg == msg.1 getMsgPos msg == getMsgFTTag? msg => CADR getMsgPosTagOb msg getMsgPosTagOb msg getMsgPos2 msg == getMsgFTTag? msg => CADDR getMsgPosTagOb msg ncBug('"not a from to",[]) getMsgFTTag? msg == IFCAR member (IFCAR getMsgPosTagOb msg,_ ['FROM,'TO,'FROMTO]) getMsgKey msg == msg.2 getMsgKey? msg == IDENTP (val := getMsgKey msg) => val getMsgArgL msg == msg.3 getMsgPrefix? msg == (pre := msg.4) = 'noPre => NIL pre getMsgPrefix msg == msg.4 getMsgLitSym msg == getMsgKey? msg => '" " '"*" getMsgText msg == msg.5 setMsgPrefix (msg,val) == msg.4 := val setMsgText (msg,val) == msg.5 := val