\documentclass{article} \usepackage{axiom} \title{\File{src/interp/msgdb.boot} Pamphlet} \author{The Axiom Team} \begin{document} \maketitle \begin{abstract} \end{abstract} \eject \tableofcontents \eject \begin{verbatim} Description of Messages Axiom messages are read from a flat file database and returned as one long string. They are preceded in the database by a key and this is how they are referenced from code. For example, one key is S2IL0001 which means: S2 Scratchpad II designation I from the interpreter L originally from LISPLIB BOOT 0001 a sequence number Each message may contain formatting codes and and parameter codes. The formatting codes are: %b turn on bright printing %ceoff turn off centering %ceon turn on centering %d turn off bright printing %f user defined printing %i start indentation of 3 more spaces %l start a new line %m math-print an expression %rjoff turn off right justification (actually ragged left) %rjon turn on right justification (actually ragged left) %s pretty-print as an S-expression %u unindent 3 spaces %x# insert # spaces The parameter codes look like %1, %2b, %3p, %4m, %5bp, %6s where the digit is the parameter number ans the letters following indicate additional formatting. You can indicate as many additional formatting qualifiers as you like, to the degree they make sense. The "p" code means to call prefix2String on the parameter, a standard way of printing abbreviated types. The "P" operator maps prefix2String over its arguments. The "o" operation formats the argument as an operation name. "b" means to print that parameter in a bold (bright) font. "c" means to center that parameter on a new line. "f" means that the parameter is a list [fn, :args] and that "fn" is to be called on "args" to get the text. "r" means to right justify (ragged left) the argument. Look in the file with the name defined in $defaultMsgDatabaseName above for examples. \end{verbatim} \section{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. @ <<*>>= <> --% Message Database Code and Message Utility Functions SETANDFILEQ($msgDatabase,NIL) SETANDFILEQ($cacheMessages,'T) -- for debugging purposes SETANDFILEQ($msgAlist,NIL) SETANDFILEQ($msgDatabaseName,NIL) SETANDFILEQ($testingErrorPrefix, '"Daly Bug") SETANDFILEQ($texFormatting, false) --% Accessing the Database string2Words l == i := 0 [w while wordFrom(l,i) is [w,i]] wordFrom(l,i) == maxIndex := MAXINDEX l k := or/[j for j in i..maxIndex | l.j ^= char ('_ ) ] or return nil buf := '"" while k < maxIndex and (c := l.k) ^= char ('_ ) repeat ch := c = char '__ => l.(k := 1+k) --this may exceed bounds c buf := STRCONC(buf,ch) k := k + 1 if k = maxIndex and (c := l.k) ^= char ('_ ) then buf := STRCONC(buf,c) [buf,k+1] getKeyedMsg key == fetchKeyedMsg(key,false) --% Formatting and Printing Keyed Messages segmentKeyedMsg(msg) == string2Words msg segmentedMsgPreprocess x == ATOM x => x [head,:tail] := x center := rightJust := NIL if head in '(%ceon "%ceon") then center := true if head in '(%rjon "%rjon") then rightJust := true center or rightJust => -- start collecting terms y := NIL ok := true while tail and ok repeat [t,:tail] := tail t in '(%ceoff "%ceoff" %rjoff "%rjoff") => ok := NIL y := CONS(segmentedMsgPreprocess t,y) head1 := [(center => '"%ce"; '"%rj"),:NREVERSE y] NULL tail => [head1] [head1,:segmentedMsgPreprocess tail] head1 := segmentedMsgPreprocess head tail1 := segmentedMsgPreprocess tail EQ(head,head1) and EQ(tail,tail1) => x [head1,:tail1] removeAttributes msg == --takes a segmented message and returns it with the attributes --separted. first msg ^= '"%atbeg" => [msg,NIL] attList := [] until item = '"%atend" repeat msg := rest msg item := first msg attList := [INTERN item,:attList] msg := rest msg attList := rest attList [msg,attList] substituteSegmentedMsg(msg,args) == -- this does substitution of the parameters l := NIL nargs := #args for x in segmentedMsgPreprocess msg repeat -- x is a list PAIRP x => l := cons(substituteSegmentedMsg(x,args),l) c := x.0 n := STRINGLENGTH x -- x is a special case (n > 2) and (c = "%") and (x.1 = "k") => l := NCONC(NREVERSE pkey SUBSTRING(x,2,NIL),l) -- ?name gets replaced by '"Push PF10" or '"Type >b (enter)" (x.0 = char "?") and n > 1 and (v := pushOrTypeFuture(INTERN x,nil)) => l := NCONC(NREVERSE v,l) -- x requires parameter substitution (x.0 = char "%") and (n > 1) and (DIGITP x.1) => a := DIG2FIX x.1 arg := a <= nargs => args.(a-1) '"???" -- now pull out qualifiers q := NIL for i in 2..(n-1) repeat q := cons(x.i,q) -- Note 'f processing must come first. if MEMQ(char 'f,q) then arg := PAIRP arg => APPLY(first arg, rest arg) arg if MEMQ(char 'm,q) then arg := [['"%m",:arg]] if MEMQ(char 's,q) then arg := [['"%s",:arg]] if MEMQ(char 'p,q) then $texFormatting => arg := prefix2StringAsTeX arg arg := prefix2String arg if MEMQ(char 'P,q) then $texFormatting => arg := [prefix2StringAsTeX x for x in arg] arg := [prefix2String x for x in arg] if MEMQ(char 'o, q) and $texFormatting then arg := operationLink(arg) if MEMQ(char 'c,q) then arg := [['"%ce",:arg]] if MEMQ(char 'r,q) then arg := [['"%rj",:arg]] if MEMQ(char 'l,q) then l := cons('"%l",l) if MEMQ(char 'b,q) then l := cons('"%b",l) --we splice in arguments that are lists --if y is not specified, then the adding of blanks is --stifled after the first item in the list until the --end of the list. (using %n and %y) l := PAIRP(arg) => MEMQ(char 'y,q) or (CAR arg = '"%y") or ((LENGTH arg) = 1) => APPEND(REVERSE arg, l) head := first arg tail := rest arg ['"%y",:APPEND(REVERSE tail, ['"%n",head,:l ]) ] cons(arg,l) if MEMQ(char 'b,q) then l := cons('"%d",l) for ch in '(_. _, _! _: _; _?) repeat if MEMQ(char ch,q) then l := cons(ch,l) --x is a plain word l := cons(x,l) addBlanks NREVERSE l addBlanks msg == -- adds proper blanks null PAIRP msg => msg null msg => msg LENGTH msg = 1 => msg blanksOff := false x := first msg if x = '"%n" then blanksOff := true msg1 := [] else msg1 := LIST x blank := '" " for y in rest msg repeat y in '("%n" %n) => blanksOff := true y in '("%y" %y) => blanksOff := false if noBlankAfterP x or noBlankBeforeP y or blanksOff then msg1 := [y,:msg1] else msg1 := [y,blank,:msg1] x := y NREVERSE msg1 SETANDFILEQ($msgdbPrims,'( %b %d %l %i %u %U %n %x %ce %rj "%U" "%b" "%d" "%l" "%i" "%u" "%U" "%n" "%x" "%ce" "%rj")) SETANDFILEQ($msgdbPunct,'(_. _, _! _: _; _? _] _) "." "," "!" ":" ";" "?" "]" ")" )) SETANDFILEQ($msgdbNoBlanksBeforeGroup,['" ", " ", '"%", "%",_ :$msgdbPrims, :$msgdbPunct]) SETANDFILEQ($msgdbListPrims,'(%m %s %ce %rj "%m" "%s" "%ce" "%rj")) noBlankBeforeP word== INTP word => false word in $msgdbNoBlanksBeforeGroup => true if CVECP word and SIZE word > 1 then word.0 = char '% and word.1 = char 'x => return true word.0 = char " " => return true (PAIRP word) and (CAR word in $msgdbListPrims) => true false $msgdbPunct := '(_[ _( "[" "(" ) SETANDFILEQ($msgdbNoBlanksAfterGroup,['" ", " ",'"%" ,"%",_ :$msgdbPrims,:$msgdbPunct]) noBlankAfterP word== INTP word => false word in $msgdbNoBlanksAfterGroup => true if CVECP word and (s := SIZE word) > 1 then word.0 = char '% and word.1 = char 'x => return true word.(s-1) = char " " => return true (PAIRP word) and (CAR word in $msgdbListPrims) => true false cleanUpSegmentedMsg msg == -- removes any junk like double blanks -- takes a reversed msg and puts it in the correct order null PAIRP msg => msg blanks := ['" "," "] haveBlank := NIL prims := '(%b %d %l %i %u %m %ce %rj _ "%b" "%d" "%l" "%i" "%m" "%u" "%ce" "%rj") msg1 := NIL for x in msg repeat if haveBlank and ((x in blanks) or (x in prims)) then msg1 := CDR msg1 msg1 := cons(x,msg1) haveBlank := (x in blanks => true; NIL) msg1 operationLink name == FORMAT(nil, '"\lispLink{\verb!(|oSearch| _"~a_")!}{~a}", name, escapeSpecialChars STRINGIMAGE name) ---------------------------------------- sayPatternMsg(msg,args) == msg := segmentKeyedMsg msg msg := substituteSegmentedMsg(msg,args) sayMSG flowSegmentedMsg(msg,$LINELENGTH,3) throwPatternMsg(key,args) == sayMSG '" " if $testingSystem then sayMSG $testingErrorPrefix sayPatternMsg(key,args) spadThrow() sayKeyedMsgAsTeX(key, args) == $texFormatting: fluid := true sayKeyedMsgLocal(key, args) sayKeyedMsg(key,args) == $texFormatting: fluid := false sayKeyedMsgLocal(key, args) sayKeyedMsgLocal(key, args) == msg := segmentKeyedMsg getKeyedMsg key msg := substituteSegmentedMsg(msg,args) if $displayMsgNumber then msg := ['"%b",key,":",'"%d",:msg] msg' := flowSegmentedMsg(msg,$LINELENGTH,$MARGIN) if $printMsgsToFile then sayMSG2File msg' sayMSG msg' throwKeyedErrorMsg(kind,key,args) == BUMPERRORCOUNT kind sayMSG '" " if $testingSystem then sayMSG $testingErrorPrefix sayKeyedMsg(key,args) spadThrow() throwKeyedMsgSP(key,args,atree) == if atree and (sp := getSrcPos(atree)) then sayMSG '" " srcPosDisplay(sp) throwKeyedMsg(key,args) throwKeyedMsg(key,args) == $saturn => saturnThrowKeyedMsg(key, args) throwKeyedMsg1(key, args) saturnThrowKeyedMsg(key,args) == _*STANDARD_-OUTPUT_* : fluid := $texOutputStream last := pushSatOutput("line") sayString '"\bgroup\color{red}\begin{list}\item{} " sayKeyedMsgAsTeX(key,args) sayString '"\end{list}\egroup" popSatOutput(last) spadThrow() throwKeyedMsg1(key,args) == _*STANDARD_-OUTPUT_* : fluid := $texOutputStream sayMSG '" " if $testingSystem then sayMSG $testingErrorPrefix sayKeyedMsg(key,args) spadThrow() throwListOfKeyedMsgs(descKey,descArgs,l) == -- idea is that descKey and descArgs are the message describing -- what the list is about and l is a list of [key,args] messages -- the messages in the list are numbered and should have a %1 as -- the first token in the message text. sayMSG '" " if $testingSystem then sayMSG $testingErrorPrefix sayKeyedMsg(descKey,descArgs) sayMSG '" " for [key,args] in l for i in 1.. repeat n := STRCONC(object2String i,'".") sayKeyedMsg(key,[n,:args]) spadThrow() -- breakKeyedMsg is like throwKeyedMsg except that the user is given -- a chance to play around in a break loop if $BreakMode is not 'nobreak breakKeyedMsg(key,args) == BUMPERRORCOUNT "semantic" sayKeyedMsg(key,args) handleLispBreakLoop($BreakMode) keyedSystemError(key,args) == $saturn => saturnKeyedSystemError(key, args) keyedSystemError1(key, args) saturnKeyedSystemError(key, args) == _*STANDARD_-OUTPUT_* : fluid := $texOutputStream sayString '"\bgroup\color{red}" sayString '"\begin{verbatim}" sayKeyedMsg("S2GE0000",NIL) BUMPERRORCOUNT "semantic" sayKeyedMsgAsTeX(key,args) sayString '"\end{verbatim}" sayString '"\egroup" handleLispBreakLoop($BreakMode) keyedSystemError1(key,args) == sayKeyedMsg("S2GE0000",NIL) breakKeyedMsg(key,args) -- these 2 functions control the mode of saturn output. -- having the stream writing functions control this would -- be better (eg. sayText, sayCommands) pushSatOutput(arg) == $saturnMode = arg => arg was := $saturnMode arg = "verb" => $saturnMode := "verb" sayString '"\begin{verbatim}" was arg = "line" => $saturnMode := "line" sayString '"\end{verbatim}" was sayString FORMAT(nil, '"What is: ~a", $saturnMode) $saturnMode popSatOutput(newmode) == newmode = $saturnMode => nil newmode = "verb" => $saturnMode := "verb" sayString '"\begin{verbatim}" newmode = "line" => $saturnMode := "line" sayString '"\end{verbatim}" sayString FORMAT(nil, '"What is: ~a", $saturnMode) $saturnMode systemErrorHere functionName == keyedSystemError("S2GE0017",[functionName]) isKeyedMsgInDb(key,dbName) == $msgDatabaseName : fluid := pathname dbName fetchKeyedMsg(key,true) getKeyedMsgInDb(key,dbName) == $msgDatabaseName : fluid := pathname dbName fetchKeyedMsg(key,false) sayKeyedMsgFromDb(key,args,dbName) == $msgDatabaseName : fluid := pathname dbName msg := segmentKeyedMsg getKeyedMsg key msg := substituteSegmentedMsg(msg,args) if $displayMsgNumber then msg := ['"%b",key,":",'%d,:msg] --sayMSG flowSegmentedMsg(msg,$LINELENGTH,3) u := flowSegmentedMsg(msg,$LINELENGTH,3) sayBrightly u returnStLFromKey(key,argL,:optDbN) == savedDbN := $msgDatabaseName if IFCAR optDbN then $msgDatabaseName := pathname CAR optDbN text := fetchKeyedMsg(key, false) $msgDatabaseName := savedDbN text := segmentKeyedMsg text text := substituteSegmentedMsg(text,argL) throwKeyedMsgFromDb(key,args,dbName) == sayMSG '" " if $testingSystem then sayMSG $testingErrorPrefix sayKeyedMsgFromDb(key,args,dbName) spadThrow() queryUserKeyedMsg(key,args) == -- display message and return reply conStream := DEFIOSTREAM ('((DEVICE . CONSOLE) (MODE . INPUT)),120,0) sayKeyedMsg(key,args) ans := READ_-LINE conStream SHUT conStream ans flowSegmentedMsg(msg, len, offset) == -- tries to break a sayBrightly-type input msg into multiple -- lines, with offset and given length. -- msgs that are entirely centered or right justified are not flowed msg is [[ce,:.]] and ce in '(%ce "%ce" %rj "%rj") => msg -- if we are formatting latex, then we assume -- that nothing needs to be done $texFormatting => msg -- msgs that are entirely centered are not flowed msg is [[ce,:.]] and ListMember?(ce,'(%ce "%ce")) => msg potentialMarg := 0 actualMarg := 0 off := (offset <= 0 => '""; fillerSpaces(offset,'" ")) off1:= (offset <= 1 => '""; fillerSpaces(offset-1,'" ")) firstLine := true PAIRP msg => lnl := offset if msg is [a,:.] and a in '(%b %d _ "%b" "%d" " ") then nl := [off1] lnl := lnl - 1 else nl := [off] for f in msg repeat f in '("%l" %l) => actualMarg := potentialMarg if lnl = 99999 then nl := ['%l,:nl] lnl := 99999 PAIRP(f) and CAR(f) in '("%m" %m '%ce "%ce" %rj "%rj") => actualMarg := potentialMarg nl := [f,'%l,:nl] lnl := 199999 f in '("%i" %i ) => potentialMarg := potentialMarg + 3 nl := [f,:nl] PAIRP(f) and CAR(f) in '("%t" %t) => potentialMarg := potentialMarg + CDR f nl := [f,:nl] sbl := sayBrightlyLength f tot := lnl + offset + sbl + actualMarg if firstLine then firstLine := false offset := offset + offset off1 := STRCONC(off, off1) off := STRCONC(off, off) if (tot <= len) or (sbl = 1 and tot = len) then nl := [f,:nl] lnl := lnl + sbl else f in '(%b %d _ "%b" "%d" " ") => nl := [f,off1,'%l,:nl] actualMarg := potentialMarg lnl := -1 + offset + sbl nl := [f,off,'%l,:nl] lnl := offset + sbl concat nreverse nl concat('%l,off,msg) --% Other handy things keyedMsgCompFailure(key,args) == -- Called when compilation fails in such a way that interpret-code -- mode might be of some use. not $useCoerceOrCroak => THROW('coerceOrCroaker, 'croaked) if not($Coerce) and $reportInterpOnly then sayKeyedMsg(key,args) sayKeyedMsg("S2IB0009",NIL) null $compilingMap => THROW('loopCompiler,'tryInterpOnly) THROW('mapCompiler,'tryInterpOnly) keyedMsgCompFailureSP(key,args,atree) == -- Called when compilation fails in such a way that interpret-code -- mode might be of some use. not $useCoerceOrCroak => THROW('coerceOrCroaker, 'croaked) if not($Coerce) and $reportInterpOnly then if atree and (sp := getSrcPos(atree)) then sayMSG '" " srcPosDisplay(sp) sayKeyedMsg(key,args) sayKeyedMsg("S2IB0009",NIL) null $compilingMap => THROW('loopCompiler,'tryInterpOnly) THROW('mapCompiler,'tryInterpOnly) throwKeyedMsgCannotCoerceWithValue(val,t1,t2) == null (val' := coerceInteractive(mkObj(val,t1),$OutputForm)) => throwKeyedMsg("S2IC0002",[t1,t2]) val' := objValUnwrap(val') throwKeyedMsg("S2IC0003",[t1,t2,val']) --% Some Standard Message Printing Functions bright x == ['"%b",:(PAIRP(x) and NULL CDR LASTNODE x => x; [x]),'"%d"] --bright x == ['%b,:(ATOM x => [x]; x),'%d] mkMessage msg == msg and (PAIRP msg) and ((first msg) in '(%l "%l")) and ((last msg) in '(%l "%l")) => concat msg concat('%l,msg,'%l) sayMessage msg == sayMSG mkMessage msg sayNewLine(:margin) == -- Note: this function should *always* be used by sayBrightly and -- friends rather than TERPRI -- see bindSayBrightly TERPRI() if margin is [n] then BLANKS n nil sayString x == -- Note: this function should *always* be used by sayBrightly and -- friends rather than PRINTEXP -- see bindSayBrightly PRINTEXP x spadStartUpMsgs() == -- messages displayed when the system starts up $LINELENGTH < 60 => NIL bar := fillerSpaces($LINELENGTH,specialChar 'hbar) sayKeyedMsg("S2GL0001",[_*BUILD_-VERSION_*, _*YEARWEEK_*]) sayMSG bar sayKeyedMsg("S2GL0018C",NIL) sayKeyedMsg("S2GL0018D",NIL) sayKeyedMsg("S2GL0003B",[$opSysName]) sayMSG bar -- sayMSG bar -- sayMSG '" *" -- sayMSG '" ***** ** ** *** ****** ** * *" -- sayMSG '" * * * * * * * ** ** ** **" -- sayMSG '" * * * * * * ** *** **" -- sayMSG '" ****** * * * * * * *" -- sayMSG '" * * * * * * * * * *" -- sayMSG '" * * * * * * * * * *" -- sayMSG '" * * * * * * * * * *" -- sayMSG '" ***** * ** ** *** **** ** *** ***" -- sayMSG '" *" -- sayMSG '" Issue )copyright for copyright notices." -- sayKeyedMsg("S2GL0018A",NIL) -- sayKeyedMsg("S2GL0018B",NIL) -- sayKeyedMsg("S2GL0003C",NIL) -- sayKeyedMsg("S2GL0003A",NIL) -- if not $printTimeIfTrue then sayKeyedMsg("S2GL0004",NIL) -- if not $printTypeIfTrue then sayKeyedMsg("S2GL0005",NIL) -- if not $displaySetValue then sayKeyedMsg("S2GL0007",NIL) -- if not $HiFiAccess then sayKeyedMsg("S2GL0008",NIL) -- sayMSG bar -- version() $msgAlist := NIL -- these msgs need not be saved sayMSG " " HELP() == sayKeyedMsg("S2GL0019",NIL) version() == _*YEARWEEK_* --% Some Advanced Formatting Functions brightPrint x == $MARG : local := 0 for y in x repeat brightPrint0 y NIL brightPrint0 x == $texFormatting => brightPrint0AsTeX x if IDENTP x then x := PNAME x -- if the first character is a backslash and the second is a percent sign, -- don't try to give the token any special interpretation. Just print -- it without the backslash. STRINGP x and STRINGLENGTH x > 1 and x.0 = char "\" and x.1 = char "%" => sayString SUBSTRING(x,1,NIL) x = '"%l" => sayNewLine() for i in 1..$MARG repeat sayString '" " x = '"%i" => $MARG := $MARG + 3 x = '"%u" => $MARG := $MARG - 3 if $MARG < 0 then $MARG := 0 x = '"%U" => $MARG := 0 x = '"%" => sayString '" " x = '"%%" => sayString '"%" x = '"%b" => NULL IS_-CONSOLE CUROUTSTREAM => sayString '" " NULL $highlightAllowed => sayString '" " sayString $highlightFontOn k := blankIndicator x => BLANKS k x = '"%d" => NULL IS_-CONSOLE CUROUTSTREAM => sayString '" " NULL $highlightAllowed => sayString '" " sayString $highlightFontOff STRINGP x => sayString x brightPrintHighlight x brightPrint0AsTeX x == x = '"%l" => sayString('"\\") for i in 1..$MARG repeat sayString '"\ " x = '"%i" => $MARG := $MARG + 3 x = '"%u" => $MARG := $MARG - 3 if $MARG < 0 then $MARG := 0 x = '"%U" => $MARG := 0 x = '"%" => sayString '"\ " x = '"%%" => sayString '"%" x = '"%b" => sayString '" {\tt " k := blankIndicator x => for i in 1..k repeat sayString '"\ " x = '"%d" => sayString '"} " x = '"_"$_"" => sayString('"_"\verb!$!_"") x = '"$" => sayString('"\verb!$!") STRINGP x => sayString x brightPrintHighlight x blankIndicator x == if IDENTP x then x := PNAME x null STRINGP x or MAXINDEX x < 1 => nil x.0 = '% and x.1 = 'x => MAXINDEX x > 1 => PARSE_-INTEGER SUBSTRING(x,2,nil) 1 nil brightPrint1 x == if x in '(%l "%l") then sayNewLine() else if STRINGP x then sayString x else brightPrintHighlight x NIL brightPrintHighlight x == $texFormatting => brightPrintHighlightAsTeX x IDENTP x => pn := PNAME x sayString pn -- following line helps find certain bugs that slip through -- also see sayBrightlyLength1 VECP x => sayString '"UNPRINTABLE" ATOM x => sayString object2String x [key,:rst] := x if IDENTP key then key:=PNAME key key = '"%m" => mathprint rst key in '("%p" "%s") => PRETTYPRIN0 rst key = '"%ce" => brightPrintCenter rst key = '"%rj" => brightPrintRightJustify rst key = '"%t" => $MARG := $MARG + tabber rst sayString '"(" brightPrint1 key if EQ(key,'TAGGEDreturn) then rst:=[CAR rst,CADR rst,CADDR rst, '"environment (omitted)"] for y in rst repeat sayString '" " brightPrint1 y if rst and (la := LASTATOM rst) then sayString '" . " brightPrint1 la sayString '")" brightPrintHighlightAsTeX x == IDENTP x => pn := PNAME x sayString pn ATOM x => sayString object2String x VECP x => sayString '"UNPRINTABLE" [key,:rst] := x key = '"%m" => mathprint rst key = '"%m" => rst key = '"%s" => sayString '"\verb__" PRETTYPRIN0 rst sayString '"__" key = '"%ce" => brightPrintCenter rst key = '"%t" => $MARG := $MARG + tabber rst -- unhandled junk (print verbatim(ish) sayString '"(" brightPrint1 key if EQ(key,'TAGGEDreturn) then rst:=[CAR rst,CADR rst,CADDR rst, '"environment (omitted)"] for y in rst repeat sayString '" " brightPrint1 y if rst and (la := LASTATOM rst) then sayString '" . " brightPrint1 la sayString '")" tabber num == maxTab := 50 num > maxTab => maxTab num brightPrintCenter x == $texFormatting => brightPrintCenterAsTeX x -- centers rst within $LINELENGTH, checking for %l's ATOM x => x := object2String x wid := STRINGLENGTH x if wid < $LINELENGTH then f := DIVIDE($LINELENGTH - wid,2) x := LIST(fillerSpaces(f.0,'" "),x) for y in x repeat brightPrint0 y NIL y := NIL ok := true while x and ok repeat if CAR(x) in '(%l "%l") then ok := NIL else y := cons(CAR x, y) x := CDR x y := NREVERSE y wid := sayBrightlyLength y if wid < $LINELENGTH then f := DIVIDE($LINELENGTH - wid,2) y := CONS(fillerSpaces(f.0,'" "),y) for z in y repeat brightPrint0 z if x then sayNewLine() brightPrintCenter x NIL brightPrintCenterAsTeX x == ATOM x => sayString '"\centerline{" sayString x sayString '"}" lst := x while lst repeat words := nil while lst and not CAR(lst) = "%l" repeat words := [CAR lst,: words] lst := CDR lst if lst then lst := cdr lst sayString '"\centerline{" words := nreverse words for zz in words repeat brightPrint0 zz sayString '"}" nil brightPrintRightJustify x == -- right justifies rst within $LINELENGTH, checking for %l's ATOM x => x := object2String x wid := STRINGLENGTH x wid < $LINELENGTH => x := LIST(fillerSpaces($LINELENGTH-wid,'" "),x) for y in x repeat brightPrint0 y NIL brightPrint0 x NIL y := NIL ok := true while x and ok repeat if CAR(x) in '(%l "%l") then ok := NIL else y := cons(CAR x, y) x := CDR x y := NREVERSE y wid := sayBrightlyLength y if wid < $LINELENGTH then y := CONS(fillerSpaces($LINELENGTH-wid,'" "),y) for z in y repeat brightPrint0 z if x then sayNewLine() brightPrintRightJustify x NIL -- some hooks for older functions --------------------> NEW DEFINITION (see macros.lisp.pamphlet) BRIGHTPRINT x == brightPrint x --------------------> NEW DEFINITION (see macros.lisp.pamphlet) BRIGHTPRINT_-0 x == brightPrint0 x --% Message Formatting Utilities sayBrightlyLength l == null l => 0 atom l => sayBrightlyLength1 l sayBrightlyLength1 first l + sayBrightlyLength rest l sayBrightlyLength1 x == member(x,'("%b" "%d" %b %d)) => NULL $highlightAllowed => 1 1 member(x,'("%l" %l)) => 0 STRINGP x and STRINGLENGTH x > 2 and x.0 = '"%" and x.1 = '"x" => INTERN x.3 STRINGP x => STRINGLENGTH x IDENTP x => STRINGLENGTH PNAME x -- following line helps find certain bugs that slip through -- also see brightPrintHighlight VECP x => STRINGLENGTH '"UNPRINTABLE" ATOM x => STRINGLENGTH STRINGIMAGE x 2 + sayBrightlyLength x sayAsManyPerLineAsPossible l == -- it is assumed that l is a list of strings l := [atom2String a for a in l] m := 1 + "MAX"/[SIZE(a) for a in l] -- w will be the field width in which we will display the elements m > $LINELENGTH => for a in l repeat sayMSG a NIL w := MIN(m + 3,$LINELENGTH) -- p is the number of elements per line p := QUOTIENT($LINELENGTH,w) n := # l str := '"" for i in 0..(n-1) repeat [c,:l] := l str := STRCONC(str,c,fillerSpaces(w - #c,'" ")) REMAINDER(i+1,p) = 0 => (sayMSG str ; str := '"" ) if str ^= '"" then sayMSG str NIL say2PerLine l == say2PerLineWidth(l,$LINELENGTH / 2) say2PerLineWidth(l,n) == [short,long] := say2Split(l,nil,nil,n) say2PerLineThatFit short for x in long repeat sayLongOperation x sayBrightly '"" say2Split(l,short,long,width) == l is [x,:l'] => sayWidth x < width => say2Split(l',[x,:short],long,width) say2Split(l',short,[x,:long],width) [nreverse short,nreverse long] sayLongOperation x == sayWidth x > $LINELENGTH and (splitListOn(x,"if") is [front,back]) => sayBrightly front BLANKS (6 + # PNAME front.1) sayBrightly back sayBrightly x splitListOn(x,key) == key in x => while first x ^= key repeat y:= [first x,:y] x:= rest x [nreverse y,x] nil say2PerLineThatFit l == while l repeat sayBrightlyNT first l sayBrightlyNT fillerSpaces((($LINELENGTH/2)-sayDisplayWidth first l),'" ") (l:= rest l) => sayBrightlyNT first l l:= rest l sayBrightly '"" sayBrightly '"" sayDisplayStringWidth x == null x => 0 sayDisplayWidth x sayDisplayWidth x == PAIRP x => +/[fn y for y in x] where fn y == y in '(%b %d "%b" "%d") or y=$quadSymbol => 1 k := blankIndicator y => k sayDisplayWidth y x = "%%" or x = '"%%" => 1 # atom2String x sayWidth x == atom x => # atom2String x +/[fn y for y in x] where fn y == sayWidth y pp2Cols(al) == while al repeat [[abb,:name],:al]:= al ppPair(abb,name) if canFit2ndEntry(name,al) then [[abb,:name],:al]:= al TAB ($LINELENGTH / 2) ppPair(abb,name) sayNewLine() nil ppPair(abb,name) == sayBrightlyNT [:bright abb,fillerSpaces(8-entryWidth abb," "),name] canFit2ndEntry(name,al) == wid := ($LINELENGTH/2) - 10 null al => nil entryWidth name > wid => nil entryWidth CDAR al > wid => nil 'T entryWidth x == # atom2String x center80 text == centerNoHighlight(text,$LINELENGTH,'" ") centerAndHighlight(text,:argList) == width := IFCAR argList or $LINELENGTH fillchar := IFCAR IFCDR argList or '" " wid := entryWidth text + 2 wid >= width - 2 => sayBrightly ['%b,text,'%d] f := DIVIDE(width - wid - 2,2) fill1 := '"" for i in 1..(f.0) repeat fill1 := STRCONC(fillchar,fill1) if f.1 = 0 then fill2 := fill1 else fill2 := STRCONC(fillchar,fill1) sayBrightly [fill1,'%b,text,'%d,fill2] nil centerNoHighlight(text,:argList) == sayBrightly center(text,argList) center(text,argList) == width := IFCAR argList or $LINELENGTH fillchar := IFCAR IFCDR argList or '" " if (u:= splitSayBrightlyArgument text) then [text,:moreLines]:= u wid := sayBrightlyLength text wid >= width - 2 => sayBrightly text f := DIVIDE(width - wid - 2,2) fill1 := '"" for i in 1..(f.0) repeat fill1 := STRCONC(fillchar,fill1) if f.1 = 0 then fill2 := fill1 else fill2 := STRCONC(fillchar,fill1) concat(fill1,text,fill2) splitSayBrightly u == width:= 0 while u and (width:= width + sayWidth first u) < $LINELENGTH repeat segment:= [first u,:segment] u := rest u null u => NREVERSE segment segment => [:NREVERSE segment,"%l",:splitSayBrightly(u)] u splitSayBrightlyArgument u == atom u => nil while splitListSayBrightly u is [head,:u] repeat result:= [head,:result] result => [:NREVERSE result,u] [u] splitListSayBrightly u == for x in tails u repeat y := rest x null y => nil first y = '%l => RPLACD(x,nil) ans:= [u,:rest y] ans --======================================================================= -- Utility Functions --======================================================================= $htSpecialChars := ['"_#", '"[", '"]", '"%", '"{", '"}", '"_\", '"$", '"&", '"^", '"__", '"_~"] $htCharAlist := '( ("$" . "\%") ("[]" . "\[\]") ("{}" . "\{\}") ("\\" . "\\\\") ("\/" . "\\/" ) ("/\" . "/\\" ) ) escapeSpecialChars s == u := LASSOC(s,$htCharAlist) => u member(s, $htSpecialChars) => STRCONC('"_\", s) null $saturn => s ALPHA_-CHAR_-P (s.0) => s not (or/[dbSpecialDisplayOpChar? s.i for i in 0..MAXINDEX s]) => s buf := '"" for i in 0..MAXINDEX s repeat buf := dbSpecialDisplayOpChar?(s.i) => STRCONC(buf,'"\verb!",s.i,'"!") STRCONC(buf,s.i) buf dbSpecialDisplayOpChar? c == (c = char '_~) @ \eject \begin{thebibliography}{99} \bibitem{1} nothing \end{thebibliography} \end{document}