diff options
Diffstat (limited to 'src/interp/msg.boot.pamphlet')
| -rw-r--r-- | src/interp/msg.boot.pamphlet | 577 |
1 files changed, 577 insertions, 0 deletions
diff --git a/src/interp/msg.boot.pamphlet b/src/interp/msg.boot.pamphlet new file mode 100644 index 00000000..ac311779 --- /dev/null +++ b/src/interp/msg.boot.pamphlet @@ -0,0 +1,577 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/msg.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} + +\tableofcontents +\eject + +\section{License} + +<<license>>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- 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. + +@ +<<*>>= +<<license>> + +)package "BOOT" + +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) + -- The next line is to try to deal with some reported cases of unwanted + -- backtraces appearing, MCD. + ENABLE_-BACKTRACE(nil) + 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 := CDR 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 := CDR 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 := CDR 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, '"%x1" , :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 + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} |