diff options
Diffstat (limited to 'src/interp/msgdb.boot.pamphlet')
-rw-r--r-- | src/interp/msgdb.boot.pamphlet | 1076 |
1 files changed, 1076 insertions, 0 deletions
diff --git a/src/interp/msgdb.boot.pamphlet b/src/interp/msgdb.boot.pamphlet new file mode 100644 index 00000000..29920edf --- /dev/null +++ b/src/interp/msgdb.boot.pamphlet @@ -0,0 +1,1076 @@ +\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} +<<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>> + +--% 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) == + BUMPCOMPERRORCOUNT() + 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) + BUMPCOMPERRORCOUNT() + 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} |