IOPrintImpl.mesa
Copyright Ó 1984, 1985, 1986, 1987, 1991 by Xerox Corporation. All rights reserved.
Schmidt on 31-Aug-81 21:39:19
Stewart on 20-Jan-82 19:15:39
Teitelman on January 21, 1983 5:31 pm
Andrew Birrell on June 22, 1983 9:44 am
Paul Rovner on May 26, 1983 3:56 pm
Levin on August 8, 1983 6:09 pm
MBrown on January 16, 1984 3:06 pm PST
Swinehart, June 25, 1984 1:34:33 pm PDT
Russ Atkinson (RRA) February 19, 1985 7:13:57 pm PST
Carl Hauser, May 11, 1988 3:49:46 pm PDT
Michael Plass, January 23, 1992 4:11 pm PST
Doug Wyatt, May 20, 1992 3:55 pm PDT
Willie-s, September 2, 1992 6:19 pm PDT
Last tweaked by Mike Spreitzer September 17, 1992 9:57 pm PDT
DIRECTORY
Ascii USING [Lower],
BasicTime USING [earliestGMT, GMT, UnpackedPeriod, UnpackPeriod, Update],
Convert USING [AppendCard, AppendDCard, AppendDReal, AppendE, AppendF, AppendG, AppendInt, AppendTime, AppendTimeRFC822, Base, RopeFromAtom, RopeFromBool],
DReal USING [Round],
IO USING [Close, Error, ErrorCode, Flush, int, InlinePutChar, PutChar, PutRope, PutText, RopeFromROS, ROS, STREAM, TextFromTOS, TOS, Value],
IOUtils USING [Format, LookupData, PFCodeProc, PFErrorProc, PrintRefAnyProc, StoreData],
Real USING [MaxSinglePrecision, RealException, Round],
RefText USING [AppendChar, AppendTextRope, ObtainScratch, ReleaseScratch, TrustTextAsRope, TrustTextRopeAsText],
Rope USING [Fetch, Map, Size, SkipTo, ROPE],
RuntimeError USING [BoundsFault];
IOPrintImpl: CEDAR MONITOR
IMPORTS Ascii, BasicTime, Convert, DReal, IO, IOUtils, RefText, Real, Rope, RuntimeError
EXPORTS IO, IOUtils
= BEGIN
ROPE: TYPE = Rope.ROPE;
STREAM: TYPE = IO.STREAM;
Value: TYPE = IO.Value;
Format: TYPE = IOUtils.Format;
PFCodeProc: TYPE = IOUtils.PFCodeProc;
PFErrorProc: TYPE = IOUtils.PFErrorProc;
defaultTextSize: NAT ¬ 64;
RRA: It is better to quickly acquire and release buffers of constant size, even when the need is not constant, since this reduces fragmentation. We believe that this size should be OK for nearly all applications. It is a variable to encourage experimentation.
Value constructors
dint: PUBLIC PROC [v: DINT] RETURNS [Value] = {RETURN[[dint[NEW[DINT¬v]]]]};
dcard: PUBLIC PROC [v: DCARD] RETURNS [Value] = {RETURN[[dcard[NEW[DCARD¬v]]]]};
dreal: PUBLIC PROC [v: DREAL] RETURNS [Value] = {RETURN[[dreal[NEW[DREAL¬v]]]]};
Put
Put: PUBLIC PROC [stream: STREAM, v1, v2, v3: Value] = {
scratch: REF TEXT = RefText.ObtainScratch[defaultTextSize];
InnerPut1[stream, v1, scratch];
InnerPut1[stream, v2, scratch];
InnerPut1[stream, v3, scratch];
RefText.ReleaseScratch[scratch];
};
Put1: PUBLIC PROC [stream: STREAM, value: Value] = {
scratch: REF TEXT = RefText.ObtainScratch[defaultTextSize];
InnerPut1[stream, value, scratch];
RefText.ReleaseScratch[scratch];
};
PutR1: PUBLIC PROC [value: Value] RETURNS [ROPE] = {
stream: STREAM = IO.ROS[];
scratch: REF TEXT = RefText.ObtainScratch[defaultTextSize];
InnerPut1[stream, value, scratch];
RefText.ReleaseScratch[scratch];
RETURN[IO.RopeFromROS[stream]];
};
PutR: PUBLIC PROC [v1, v2, v3: Value] RETURNS [ROPE] = {
stream: STREAM = IO.ROS[];
scratch: REF TEXT = RefText.ObtainScratch[defaultTextSize];
InnerPut1[stream, v1, scratch];
InnerPut1[stream, v2, scratch];
InnerPut1[stream, v3, scratch];
RefText.ReleaseScratch[scratch];
RETURN[IO.RopeFromROS[stream]];
};
PutL: PUBLIC PROC [stream: STREAM, list: LIST OF Value] = {
scratch: REF TEXT = RefText.ObtainScratch[defaultTextSize];
FOR l: LIST OF READONLY Value ¬ list, l.rest UNTIL l = NIL DO
InnerPut1[stream, l.first, scratch];
ENDLOOP;
RefText.ReleaseScratch[scratch];
};
PutLR: PUBLIC PROC [list: LIST OF Value] RETURNS [ROPE] = {
stream: STREAM = IO.ROS[];
scratch: REF TEXT = RefText.ObtainScratch[defaultTextSize];
FOR l: LIST OF READONLY Value ¬ list, l.rest UNTIL l = NIL DO
InnerPut1[stream, l.first, scratch];
ENDLOOP;
RefText.ReleaseScratch[scratch];
RETURN[IO.RopeFromROS[stream]];
};
InnerPut1: PROC [stream: STREAM, v: Value, scratch: REF TEXT] = {
scratch.length ¬ 0;
{
WITH v SELECT FROM
null: Value.null => NULL;
atom: Value.atom =>
IO.PutRope[stream, Convert.RopeFromAtom[from: atom.value, quote: FALSE]];
bool: Value.boolean =>
IO.PutRope[stream, Convert.RopeFromBool[bool.value]];
char: Value.character =>
IO.PutChar[stream, char.value];
card: Value.cardinal => {
scratch ¬ Convert.AppendCard[scratch, card.value]; GO TO putBlock};
int: Value.integer => {
scratch ¬ Convert.AppendInt[scratch, int.value]; GO TO putBlock};
dint: Value.dint => {
IF dint.value­ >= 0 THEN scratch ¬ Convert.AppendDCard[scratch, dint.value­]
ELSE{
ENABLE RuntimeError.BoundsFault => IO.Error[PFUnprintableValue, stream];
dc: DCARD ~ NegateDIntToDCard[dint.value­];
scratch ¬ RefText.AppendChar[scratch, '-];
scratch ¬ Convert.AppendDCard[scratch, dc];
};
GO TO putBlock
};
dcard: Value.dcard => {
scratch ¬ Convert.AppendDCard[scratch, dcard.value­]; GO TO putBlock};
real: Value.real => {
scratch ¬ Convert.AppendG[scratch, real.value]; GO TO putBlock};
refAny: Value.refAny =>
PrintRef[stream, scratch, refAny.value];
rope: Value.rope =>
IO.PutRope[stream, rope.value];
text: Value.text =>
IO.PutText[stream, text.value];
time: Value.time => {
scratch ¬ Convert.AppendTime[to: scratch, from: time.value, start: $years, end: $seconds];
GO TO putBlock;
};
ENDCASE => ERROR;
EXITS putBlock => stream.streamProcs.putBlock[stream, scratch, 0, scratch.length];
};
};
NegateDIntToDCard: PROC [i: DINT--that's negative--] RETURNS [DCARD] ~ {
<<This code avoids overflow, assuming the valid DINT values are [-(2^k) .. (2^k)-1], for some k.>>
i2: DINT ~ (-1) - i;
c3: DCARD ~ i2;
RETURN [c3+1]};
PrintRefAny
globalPrintRefAny: IOUtils.PrintRefAnyProc ¬ NIL;
RegisterPrintRefAny: PUBLIC ENTRY PROC [printRefAnyProc: IOUtils.PrintRefAnyProc] = {
globalPrintRefAny ¬ printRefAnyProc;
};
GetPrintRefAny: ENTRY PROC [] RETURNS [IOUtils.PrintRefAnyProc] = {
RETURN [globalPrintRefAny]
};
PrintRef: PROC [stream: STREAM, scratch: REF TEXT, ref: REF READONLY ANY] = {
printRefAnyProc: IOUtils.PrintRefAnyProc = GetPrintRefAny[];
IF printRefAnyProc = NIL THEN {
scratch ¬ RefText.AppendTextRope[scratch, "[REF: "];
scratch ¬ Convert.AppendCard[
to: scratch, from: LOOPHOLE[ref, LONG CARDINAL], base: 8, showRadix: TRUE];
scratch ¬ RefText.AppendChar[scratch, ']];
stream.streamProcs.putBlock[stream, scratch, 0, scratch.length];
}
ELSE {
printRefAnyProc[stream, ref, 4, 32, FALSE];
}
};
PFProcs
PFProcs: TYPE = REF PFProcsRecord;
PFProcsRecord: PUBLIC TYPE = RECORD [
procArray: ARRAY CHAR ['a..'z] OF PFCodeProc ¬ ALL[NIL],
errorProc: PFErrorProc ¬ NIL
];
globalPFProcs: PFProcs ¬ NIL;
GetDefaultPFProcs: ENTRY PROC [] RETURNS [PFProcs] = INLINE {
RETURN [globalPFProcs];
};
GetPFProcs: PROC [stream: STREAM] RETURNS [pfProcs: PFProcs] = INLINE {
pfProcs ¬ NARROW[IOUtils.LookupData[stream, $SetPFCode]];
IF pfProcs = NIL THEN pfProcs ¬ GetDefaultPFProcs[];
};
SetDefaultPFCodeProc: PUBLIC ENTRY PROC [char: CHAR, codeProc: PFCodeProc] RETURNS [previous: PFCodeProc] = {
char ¬ Ascii.Lower[char];
IF char NOT IN ['a..'z] THEN RETURN WITH ERROR IO.Error[PFInvalidCode, NIL];
previous ¬ globalPFProcs.procArray[char];
globalPFProcs.procArray[char] ¬ codeProc;
};
SetDefaultPFErrorProc: PUBLIC ENTRY PROC [errorProc: PFErrorProc] RETURNS [previous: PFErrorProc] = {
previous ¬ globalPFProcs.errorProc;
globalPFProcs.errorProc ¬ errorProc;
};
CopyPFProcs: PUBLIC PROC [stream: STREAM] RETURNS [new: PFProcs] = {
pfProcs: PFProcs ¬
IF stream = NIL THEN NIL ELSE NARROW[IOUtils.LookupData[stream, $SetPFCode]];
IF pfProcs = NIL THEN pfProcs ¬ GetDefaultPFProcs[];
RETURN [NEW[PFProcsRecord ¬ pfProcs­]];
};
SetPFProcs: PUBLIC PROC [stream: STREAM, pfProcs: PFProcs] RETURNS [previous: PFProcs] = {
previous ¬ NARROW[IOUtils.LookupData[stream, $SetPFCode]];
IOUtils.StoreData[stream, $SetPFCode, pfProcs];
};
SetPFCodeProc: PUBLIC PROC [pfProcs: PFProcs, char: CHAR, codeProc: PFCodeProc] RETURNS [previous: PFCodeProc] = {
IF pfProcs = NIL THEN ERROR IO.Error[PFInvalidPFProcs, NIL];
char ¬ Ascii.Lower[char];
IF char NOT IN ['a..'z] THEN ERROR IO.Error[PFInvalidCode, NIL];
previous ¬ pfProcs.procArray[char];
pfProcs.procArray[char] ¬ codeProc;
};
SetPFErrorProc: PUBLIC PROC [pfProcs: PFProcs, errorProc: PFErrorProc] RETURNS [previous: PFErrorProc] = {
IF pfProcs = NIL THEN ERROR IO.Error[PFInvalidPFProcs, NIL];
previous ¬ pfProcs.errorProc;
pfProcs.errorProc ¬ errorProc;
};
PutF, PutFR, PutFL, PutFLR
PutF: PUBLIC PROC [stream: STREAM, format: ROPE, v1, v2, v3: Value] = {
pfProcs: PFProcs = GetPFProcs[stream];
fp: INT ¬ 0;
IF v1.type#null THEN fp ¬ PFInternal[stream, format, fp, v1, pfProcs];
IF v2.type#null THEN fp ¬ PFInternal[stream, format, fp, v2, pfProcs];
IF v3.type#null THEN fp ¬ PFInternal[stream, format, fp, v3, pfProcs];
[] ¬ PFInternal[stream, format, fp, [null[]], pfProcs];
};
PutF1: PUBLIC PROC [stream: STREAM, format: ROPE, value: Value] = {
pfProcs: PFProcs = GetPFProcs[stream];
fp: INT ¬ 0;
IF value.type#null THEN fp ¬ PFInternal[stream, format, fp, value, pfProcs];
[] ¬ PFInternal[stream, format, fp, [null[]], pfProcs];
};
PutFR: PUBLIC PROC [format: ROPE, v1, v2, v3: Value] RETURNS [ROPE] = {
stream: STREAM = IO.ROS[];
PutF[stream, format, v1, v2, v3];
RETURN [IO.RopeFromROS[stream]];
};
PutFR1: PUBLIC PROC [format: ROPE, value: Value] RETURNS [ROPE] = {
stream: STREAM = IO.ROS[];
pfProcs: PFProcs = GetPFProcs[stream];
fp: INT ¬ 0;
IF value.type#null THEN fp ¬ PFInternal[stream, format, fp, value, pfProcs];
[] ¬ PFInternal[stream, format, fp, [null[]], pfProcs];
RETURN [IO.RopeFromROS[stream]];
};
PutFL: PUBLIC PROC [stream: STREAM, format: ROPE, list: LIST OF Value] = {
pfProcs: PFProcs = GetPFProcs[stream];
fp: INT ¬ 0;
FOR l: LIST OF READONLY Value ¬ list, l.rest UNTIL l = NIL DO
fp ¬ PFInternal[stream, format, fp, l.first, pfProcs];
ENDLOOP;
[] ¬ PFInternal[stream, format, fp, [null[]], pfProcs];
};
PutFLR: PUBLIC PROC [format: ROPE, list: LIST OF Value] RETURNS [ROPE] = {
stream: STREAM = IO.ROS[];
PutFL[stream, format, list];
RETURN [IO.RopeFromROS[stream]];
};
PFInternal (scan format and print one Value)
PFInternal: PROC [stream: STREAM, format: ROPE, formatPtr: INT, arg: Value, pfProcs: PFProcs] RETURNS [--advancedFormatPtr--INT] = {
Scans format, starting at formatPtr, until reaching end or reaching a conversion specification (e.g., "%05d"). If format is a null rope, treats it as if it were the rope "%g", and as if formatPtr = 0. If conversion specification is found and arg is not null, prints it; if conversion specification is not found and arg is null, ok; otherwise error. Returns index of first byte of format not scanned.
error: IO.ErrorCode ¬ $Null;
c: CHAR ¬ 0C;
GetNextFromFormat: PROC[] = INLINE {
c ¬ format.Fetch[formatPtr]; formatPtr ¬ formatPtr.SUCC;
};
formatSize: INT ¬ format.Size[];
IF formatSize = 0 THEN {
IF arg.type = null THEN GOTO Done
ELSE {
format ¬ "%g"; formatSize ¬ 2; formatPtr ¬ 0 }
};
DO { -- EXITS PutC, HandleError
IF formatPtr < formatSize THEN {
accelerator - output consecutive vanilla characters all at once
end: INT ~ Rope.SkipTo[format, formatPtr, "%"];
IF end > formatPtr THEN {
IO.PutRope[stream, format, formatPtr, end-formatPtr];
formatPtr ¬ end;
};
}; -- end accelerator
IF formatPtr >= formatSize THEN {
IF arg.type = null THEN GOTO Done
ELSE { --ran out of format while looking for '%
error ¬ PFFormatSyntaxError; GOTO HandleError
}
};
GetNextFromFormat[];
IF c # '% THEN GOTO PutC;
{
savedFormatPointer: INT = formatPtr;
DO {
IF formatPtr >= formatSize THEN { --ran out of format while looking for code
error ¬ PFFormatSyntaxError; GOTO HandleError
};
GetNextFromFormat[];
IF c IN ['a..'z] OR c IN ['A..'Z] THEN GOTO FoundCode;
IF c = '% THEN GOTO FoundPercent;
EXITS
FoundCode => EXIT;
FoundPercent => { --found '% while looking for code
IF formatPtr = savedFormatPointer.SUCC THEN GOTO PutC;
error ¬ PFFormatSyntaxError; GOTO HandleError
};
} ENDLOOP;
IF arg.type = null THEN { --no Value corresponding to '% in format
error ¬ PFFormatSyntaxError; GOTO HandleError
};
c ¬ Ascii.Lower[c];
TRUSTED {
c is a conversion code; conversion string is the stuff between % and c.
Now either print arg or generate error.
If arg has type refAny, narrow it to a more specific type if possible.
Can't update of arg in checked code, even though arg is local!
This block is trusted because of the interface says REF READONLY ANY, and we need to loophole this into a REF ANY for the discrimination to work (for ROPE and ATOM, in particular).August 6, 1991 12:02:10 pm PDT
val: Value = WITH arg SELECT FROM
ref: Value.refAny =>
WITH LOOPHOLE[ref.value, REF] SELECT FROM
refBool: REF BOOL => [boolean[refBool­]],
refChar: REF CHAR => [character[refChar­]],
refCard: REF CARD => [cardinal[refCard­]],
refInt: REF INT => [integer[refInt­]],
refNat: REF NAT => [integer[refNat­]],
refReal: REF REAL => [real[refReal­]],
refDReal: REF DREAL => [dreal[refDReal]],
refDInt: REF DINT => [dint[refDInt]],
refDCard: REF DCARD => [dcard[refDCard]],
refText: REF TEXT => [text[refText]],
atom: ATOM => [atom[atom]],
rope: ROPE => [rope[rope]],
pi: REF READONLY BasicTime.GMT => time[pi^],
Not possible now because GMT is opaque
ENDCASE => arg
ENDCASE => arg;
p: PFCodeProc ¬ pfProcs.procArray[c];
IF p = NIL THEN {
error ¬ PFCantBindConversionProc; GOTO HandleError
};
p[stream, val, [format, savedFormatPointer], c ! IO.Error =>
IF ec IN [PFCantBindConversionProc .. PFUnprintableValue] THEN {
error ¬ ec; GOTO HandleError }];
GOTO Done;
}
}
EXITS
PutC => stream.streamProcs.putChar[stream, c];
HandleError => {
ep: PFErrorProc ¬ pfProcs.errorProc;
IF ep = NIL THEN ep ¬ PFErrorPrintPounds;
ep[error, stream];
GOTO Done;
};
} ENDLOOP;
EXITS
Done => RETURN [formatPtr];
};
ParseFormat: PROC [form: ROPE, start: INT] RETURNS [leadingMinus: BOOL ¬ FALSE, leadingZero: BOOL ¬ FALSE, fieldWidth: INTEGER ¬ -1, numDigits: INTEGER ¬ -1] = {
... parses a standard format specification.
leadingMinus = TRUE iff there is a '- at form[start] (and start < Size[form])
leadingZero = TRUE iff there is a '0 at form[start] (and start < Size[form])
fieldWidth is an optional leading number in the format specification
IN [0..LAST[INTEGER]) if there was a number
= -1 if there was no number present
= LAST[INTEGER] if the number overflows
numDigits is an optional number following a '. in the specification
IN [0..LAST[INTEGER]) if there was such a number
= -1 if there was no such number
= LAST[INTEGER] if said number overflows
len: INT ¬ Rope.Size[form];
IF start < len THEN
SELECT Rope.Fetch[form, start] FROM
'0 => {leadingZero ¬ TRUE; start ¬ start + 1};
'- => {leadingMinus ¬ TRUE; start ¬ start + 1};
ENDCASE;
WHILE start < len DO
c: CHAR ¬ Rope.Fetch[form, start];
SELECT c FROM
IN ['0..'9] => {
digit: [0..9] ¬ (c-'0);
IF fieldWidth < 0 THEN fieldWidth ¬ 0;
IF fieldWidth >= (LAST[INTEGER] - digit)/10 THEN {
fieldWidth ¬ LAST[INTEGER]; RETURN};
fieldWidth ¬ fieldWidth*10 + digit;
};
ENDCASE => EXIT;
start ¬ start + 1;
ENDLOOP;
IF start < len AND Rope.Fetch[form, start] = '. THEN {
start ¬ start + 1;
WHILE start < len DO
c: CHAR ¬ Rope.Fetch[form, start];
SELECT c FROM
IN ['0..'9] => {
digit: [0..9] ¬ (c-'0);
IF numDigits < 0 THEN numDigits ¬ 0;
IF numDigits >= (LAST[INTEGER] - digit)/10 THEN {
numDigits ¬ LAST[INTEGER]; RETURN};
numDigits ¬ numDigits*10 + digit;
};
ENDCASE => RETURN;
start ¬ start + 1;
ENDLOOP;
};
};
PFErrorPrintPounds: PUBLIC PROC [error: IO.ErrorCode, stream: STREAM] = {
IO.PutRope[stream, "#####"];
};
PFErrorNoop: PUBLIC PROC [error: IO.ErrorCode, stream: STREAM] = {
};
PFErrorError: PUBLIC PROC [error: IO.ErrorCode, stream: STREAM] = {
ERROR IO.Error[error, stream];
};
PFCodeProcs
StringRoutine: PROC [stream: STREAM, val: Value, format: Format, char: CHAR] = TRUSTED {
TRUSTED because of WITH v: val SELECT ... compiler problem
Value: any
Format: standard
char: 'h: causes ^<char> for ctrl-char.
Converts fixnums to decimal, flonums to F-format decimal. Converts bools to "TRUE" | "FALSE". Converts date to standard format. Prints resulting string.
r: REF TEXT ¬ NIL;
rp: ROPE ¬ NIL;
WITH v: val SELECT FROM
atom => rp ¬ Convert.RopeFromAtom[from: v.value, quote: FALSE];
boolean => rp ¬ Convert.RopeFromBool[v.value];
character => r ¬ RefText.AppendChar[RefText.ObtainScratch[defaultTextSize], v.value];
cardinal => r ¬ Convert.AppendCard[RefText.ObtainScratch[defaultTextSize], v.value];
dcard => r ¬ Convert.AppendDCard[RefText.ObtainScratch[defaultTextSize], v.value­];
integer => r ¬ Convert.AppendInt[RefText.ObtainScratch[defaultTextSize], v.value];
dint => {
r ¬ RefText.ObtainScratch[defaultTextSize];
IF v.value­ >= 0 THEN r ¬ Convert.AppendDCard[r, v.value­]
ELSE {
ABS[DINT] does not do the right thing - no ABS is applied
ENABLE RuntimeError.BoundsFault => IO.Error[PFUnprintableValue, stream];
dc: DCARD ~ NegateDIntToDCard[v.value­];
r ¬ RefText.AppendChar[r, '-];
r ¬ Convert.AppendDCard[r, dc];
};
};
real => r ¬ Convert.AppendG[RefText.ObtainScratch[defaultTextSize], v.value];
dreal => r ¬ Convert.AppendDReal[RefText.ObtainScratch[defaultTextSize], v.value­];
refAny => { strm: STREAM = IO.ROS[]; Put1[strm, val]; rp ¬ IO.RopeFromROS[strm] };
rope => rp ¬ v.value;
text => rp ¬ RefText.TrustTextAsRope[v.value];
time => r ¬ Convert.AppendTime[to: RefText.ObtainScratch[defaultTextSize], from: v.value, start: $years, end: $seconds];
ENDCASE => ERROR;
PrintText[r, rp, format, stream, IF char = 'h THEN TRUE ELSE FALSE];
};
FixnumRoutine: PROC [stream: STREAM, val: Value, format: Format, char: CHAR] = TRUSTED {
TRUSTED because of WITH v: val SELECT ... compiler problem
Value: bool, char, card, int, real
Format: standard
char: 'b: forces base 8; 'x: forces base 16
Converts numbers to decimal unless other base specified by char. Converts bools to 1 | 0. Converts char to numeric code. Rounds real to nearest INT. Prints resulting string.
base: Convert.Base ¬ SELECT char FROM 'b => 8, 'x => 16, ENDCASE => 10;
r: REF TEXT;
WITH v: val SELECT FROM
boolean => r ¬ Convert.AppendCard[RefText.ObtainScratch[defaultTextSize], IF v.value THEN 1 ELSE 0, base, FALSE];
cardinal => r ¬ Convert.AppendCard[RefText.ObtainScratch[defaultTextSize], v.value, base, FALSE];
character => r ¬ Convert.AppendCard[RefText.ObtainScratch[defaultTextSize], v.value.ORD, base, FALSE];
dcard => r ¬ Convert.AppendDCard[RefText.ObtainScratch[defaultTextSize], v.value­, base, FALSE];
dint => {
r ¬ RefText.ObtainScratch[defaultTextSize];
IF v.value­ >= 0 THEN r ¬ Convert.AppendDCard[r, v.value­, base, FALSE]
ELSE {
ENABLE RuntimeError.BoundsFault => IO.Error[PFUnprintableValue, stream];
dc: DCARD ~ NegateDIntToDCard[v.value­];
r ¬ RefText.AppendChar[r, '-];
r ¬ Convert.AppendDCard[r, dc, base, FALSE];
};
};
dreal => r ¬ Convert.AppendDCard[RefText.ObtainScratch[defaultTextSize], LOOPHOLE[DReal.Round[v.value­ !
Real.RealException => ERROR IO.Error[PFUnprintableValue, stream]], DCARD], base, FALSE];
integer => r ¬ Convert.AppendInt[RefText.ObtainScratch[defaultTextSize], v.value, base, FALSE];
real => r ¬ Convert.AppendInt[RefText.ObtainScratch[defaultTextSize], DReal.Round[v.value !
Real.RealException => ERROR IO.Error[PFUnprintableValue, stream]], base, FALSE];
ENDCASE => ERROR IO.Error[PFTypeMismatch, stream];
PrintText[r, NIL, format, stream, FALSE];
};
LooksRoutine: PROC [stream: STREAM, val: Value, format: Format, char: CHAR] = {
Value: rope
Format: ignored
char: ignored
Noop here; for Viewer streams, performs font changes
WITH val SELECT FROM
ropeVal: Value.rope => {
RRA: I changed this to pass through the info to the backing stream. This is to allow layered streams to pass along formatting commands without having to have cloned PFProcs, provided that the layered streams stuff the under layer in the backingStream field. We stop whenever we get to a proper PFProc for the backing stream, under the assumption that it is no longer our problem after that.
back: STREAM ¬ stream.backingStream;
WHILE back # NIL DO
WITH IOUtils.LookupData[back, $SetPFCode] SELECT FROM
pfProcs: PFProcs => {
pp: PFCodeProc = pfProcs.procArray[char];
IF pp # NIL THEN {
IO.Flush[stream];
Must flush stream to synch with setting looks
pp[back, val, format, char];
RETURN;
};
};
ENDCASE;
back ¬ back.backingStream;
ENDLOOP;
};
ENDCASE => ERROR IO.Error[PFTypeMismatch, stream];
};
RopeLiteralRoutine: PROC [stream: STREAM, val: Value, format: Format, char: CHAR] = {
Value: rope
Format: ignored
char: ignored
Prints rope with \-notation for control codes, \, and "
PutEscape: PROC [c: CHAR] RETURNS [BOOL] = {
Print c to stream with \-notation
IF c IN [40C .. 177C] THEN {
IF c = '\\ OR c = '\" THEN stream.streamProcs.putChar[stream, '\\];
stream.streamProcs.putChar[stream, c];
}
ELSE {
stream.streamProcs.putChar[stream, '\\];
SELECT c FROM
'\n => stream.streamProcs.putChar[stream, 'n];
'\t => stream.streamProcs.putChar[stream, 't];
'\b => stream.streamProcs.putChar[stream, 'b];
'\f => stream.streamProcs.putChar[stream, 'f];
'\l => stream.streamProcs.putChar[stream, 'l];
ENDCASE => {
stream.streamProcs.putChar[stream, '0 + (c - 0C) / 64];
stream.streamProcs.putChar[stream, '0 + (c - 0C) MOD 64 / 8];
stream.streamProcs.putChar[stream, '0 + (c - 0C) MOD 8]
} ;
};
RETURN [FALSE];
};
WITH val SELECT FROM
ropeVal: Value.rope => [] ¬ Rope.Map[base: ropeVal.value, action: PutEscape];
charVal: Value.character => [] ¬ PutEscape[charVal.value];
ENDCASE => ERROR IO.Error[PFTypeMismatch, stream];
};
TimeIntervalRoutine: PROC [stream: STREAM, val: Value, format: Format, char: CHAR] = {
Value: card, int, real
Format: standard
char: ignored
Rounds real to nearest INT. Prints number as hh:mm:ss (hh may be more than two digits, but not fewer).
seconds: INT;
period: BasicTime.UnpackedPeriod;
r: REF TEXT;
han: STREAM;
WITH val SELECT FROM
v: Value.cardinal => {
IF v.value>CARD[INT.LAST] THEN ERROR IO.Error[PFUnprintableValue, stream];
seconds ¬ v.value;
};
v: Value.integer => seconds ¬ v.value;
v: Value.real => seconds ¬ Real.Round[v.value !
Real.RealException => ERROR IO.Error[PFUnprintableValue, stream]
];
ENDCASE => ERROR IO.Error[PFTypeMismatch, stream];
period ¬ BasicTime.UnpackPeriod[seconds];
r ¬ RefText.ObtainScratch[defaultTextSize];
han ¬ IO.TOS[r];
IF period.negative THEN IO.PutChar[han, '-];
PutF[han, "%02g:%02g:%02g", IO.int[period.hours], IO.int[period.minutes], IO.int[period.seconds]];
r ¬ han.TextFromTOS[];
han.Close[];
PrintText[r, NIL, format, stream, FALSE];
};
TimeRoutine: PROC [stream: STREAM, val: Value, format: Format, char: CHAR] = {
Value: int, card, real, time
Format: standard
char: ignored
Prints a date using AppendTime. Interprets int, card, and real as seconds since "beginning of time"
t: BasicTime.GMT;
text: REF TEXT ¬ NIL;
WITH val SELECT FROM
v: Value.integer => t ¬ BasicTime.Update[base: BasicTime.earliestGMT, period: v.value];
v: Value.cardinal => t ¬ BasicTime.Update[base: BasicTime.earliestGMT, period: v.value];
v: Value.real => {
li: INT ¬ Real.Round[v.value ! Real.RealException =>
ERROR IO.Error[PFUnprintableValue, stream] ];
IF li < 0 THEN ERROR IO.Error[PFUnprintableValue, stream];
t ¬ BasicTime.Update[base: BasicTime.earliestGMT, period: li];
};
v: Value.time => t ¬ v.value;
ENDCASE => ERROR IO.Error[PFTypeMismatch, stream];
text ¬ RefText.ObtainScratch[defaultTextSize];
SELECT char FROM
'u => text ¬ Convert.AppendTimeRFC822[to: text, from: t, includeSeconds: TRUE];
ENDCASE => text ¬ Convert.AppendTime[to: text, from: t, start: $years, end: $seconds];
PrintText[text, NIL, format, stream, FALSE];
};
Real Formatting
FlonumRoutine: IOUtils.PFCodeProc = {
[stream: STREAM, val: IO.Value, format: IOUtils.Format, char: CHAR]
leadingMinus: BOOL ¬ FALSE;
leadingZero: BOOL ¬ FALSE;
fieldWidth: INT ¬ -1;
numDigits: INT ¬ -1;
[leadingMinus, leadingZero, fieldWidth, numDigits] ¬ ParseFormat[format.form, format.first];
SELECT numDigits FROM
< 0 => numDigits ¬ 2;
> Real.MaxSinglePrecision => numDigits ¬ Real.MaxSinglePrecision;
ENDCASE;
WITH val SELECT FROM
r: real IO.Value => {
proc: PROC [REF TEXT, REAL, [0..Real.MaxSinglePrecision]] RETURNS [REF TEXT] ¬
SELECT char FROM
'e => Convert.AppendE, 'f => Convert.AppendF,
ENDCASE => ERROR;
scratch: REF TEXT ¬ RefText.ObtainScratch[defaultTextSize];
buffer: REF TEXT ¬ proc[scratch, r.value, numDigits];
rLen: NAT ¬ buffer.length;
diff: INTEGER ¬ fieldWidth - rLen;
IF diff > 0 AND NOT leadingMinus THEN PutChars[stream, diff, ' ];
IO.PutText[stream, buffer];
IF diff > 0 AND leadingMinus THEN PutChars[stream, diff, ' ];
RefText.ReleaseScratch[scratch];
};
ENDCASE => PutChars[stream, fieldWidth, '!];
};
Utility routines
PutChars: PROC [st: STREAM, chars: NAT, char: CHAR] = {
THROUGH [0..chars) DO IO.PutChar[st, char]; ENDLOOP;
};
AppendChars: PROC [text: REF TEXT, chars: NAT, char: CHAR] RETURNS [REF TEXT] = {
THROUGH [0..chars) DO text ¬ RefText.AppendChar[text, char]; ENDLOOP;
RETURN [text];
};
Field justification and filling
PrintText: PROC [text: REF TEXT, rp: ROPE, format: Format, stream: STREAM, visiblecc: BOOL] = {
Prints text or rp to stream, while enforcing simple format specifications: field width, left or right justification, zero-filling. Format has syntax [0|-|][num.num]. Used by conversion routines that first buffer full output in text, then format it here. Our policy is to print all of text, even if the format specifies a smaller width.
If text is non-NIL, releases to scratch pool after call.
MyPut: PROC [c: CHAR] = { IO.InlinePutChar[stream, c] };
fillChar: CHAR ¬ ' ;
ladj: BOOL ¬ FALSE;
w, k, tlength: CARDINAL; -- w is field width, k is # chars to fill
c: CHAR ¬ 0C;
formatPtr: INT ¬ format.first;
GetNextFromFormat: PROC[] = INLINE {
c ¬ format.form.Fetch[formatPtr];
formatPtr ¬ formatPtr.SUCC;
};
IF text#NIL THEN tlength ¬ text.length ELSE tlength ¬ rp.Size[];
GetNextFromFormat[];
SELECT Ascii.Lower[c] FROM
'0 => { fillChar ¬ '0; GetNextFromFormat[] };
'- => { ladj ¬ TRUE; GetNextFromFormat[] };
ENDCASE;
w ¬ 0;
DO
SELECT c FROM
IN ['0 .. '9] => { w ¬ w*10 + (c - '0); GetNextFromFormat[] };
ENDCASE => EXIT;
ENDLOOP;
SELECT Ascii.Lower[c] FROM
'., IN ['a .. 'z] => NULL;
ENDCASE => IO.Error[PFFormatSyntaxError, stream];
IF w < tlength THEN { w ¬ tlength; k ¬ 0} ELSE { k ¬ w - tlength };
IF NOT ladj THEN THROUGH [1..k] DO
MyPut[fillChar];
ENDLOOP;
IF visiblecc
THEN {
FOR j: NAT IN [0..tlength) DO
c ¬ IF text#NIL THEN text[j] ELSE rp.Fetch[j];
IF c < 40C
THEN {
MyPut['^];
MyPut[c + LOOPHOLE['@, CARDINAL]]
}
ELSE MyPut[c];
ENDLOOP
}
ELSE {
IF text#NIL
THEN IO.PutText[stream, text]
ELSE IO.PutRope[stream, rp];
};
IF ladj THEN THROUGH [1..k] DO MyPut[' ] ENDLOOP;
IF text#NIL THEN RefText.ReleaseScratch[text];
};
Initialization
Create: ENTRY PROC [] = {
globalPFProcs ¬ NEW[PFProcsRecord ¬ []];
globalPFProcs.errorProc ¬ PFErrorPrintPounds;
globalPFProcs.procArray['a] ¬ StringRoutine;
globalPFProcs.procArray['b] ¬ FixnumRoutine;
globalPFProcs.procArray['c] ¬ StringRoutine;
globalPFProcs.procArray['d] ¬ FixnumRoutine;
globalPFProcs.procArray['e] ¬ FlonumRoutine;
globalPFProcs.procArray['f] ¬ FlonumRoutine;
globalPFProcs.procArray['g] ¬ StringRoutine;
globalPFProcs.procArray['h] ¬ StringRoutine;
globalPFProcs.procArray['l] ¬ LooksRoutine;
globalPFProcs.procArray['q] ¬ RopeLiteralRoutine;
globalPFProcs.procArray['r] ¬ TimeIntervalRoutine;
globalPFProcs.procArray['s] ¬ StringRoutine;
globalPFProcs.procArray['t] ¬ TimeRoutine;
globalPFProcs.procArray['u] ¬ TimeRoutine;
globalPFProcs.procArray['x] ¬ FixnumRoutine;
};
Create[];
END.