IOPrintImpl.mesa
Copyright © 1984, 1985 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
TO DO:
Implement AppendReal here, eliminating ConvertReal and IeeeIOB.
IOPrintImpl:
CEDAR
MONITOR
IMPORTS Ascii, BasicTime, Convert, IO, IOUtils, RefText, Real, RealOps, Rope
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.
Put
PutRope:
PUBLIC
PROC [self:
STREAM, r:
ROPE] = {
len: INT ← Rope.InlineLength[r];
WITH r
SELECT
FROM
t: Rope.Text => self.streamProcs.putBlock[self, RefText.TrustTextRopeAsText[t], 0, len];
ENDCASE => {
scratch: REF TEXT = RefText.ObtainScratch[defaultTextSize];
pos: INT ← 0;
WHILE len > 0
DO
moved: NAT ← scratch.length ← 0;
moved ← Rope.AppendChars[scratch, r, pos, len];
self.streamProcs.putBlock[self, scratch, 0, moved];
len ← len - moved;
pos ← pos + moved;
ENDLOOP;
RefText.ReleaseScratch[scratch];
};
};
PutText:
PUBLIC
PROC [self:
STREAM, t:
REF
READONLY
TEXT] = {
IF t # NIL THEN self.streamProcs.putBlock[self, t, 0, t.length];
};
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 =>
PutRope[stream, Convert.RopeFromAtom[from: atom.value, quote: FALSE]];
bool: Value.boolean =>
PutRope[stream, Convert.RopeFromBool[bool.value]];
char: Value.character =>
stream.streamProcs.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};
real: Value.real => {
scratch ← Convert.AppendG[scratch, real.value]; GO TO putBlock};
refAny: Value.refAny =>
PrintRef[stream, scratch, refAny.value];
rope: Value.rope =>
PutRope[stream, rope.value];
text: Value.text =>
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];
};
};
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 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, v4, v5: 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];
IF v4.type#null THEN fp ← PFInternal[stream, format, fp, v4, pfProcs];
IF v5.type#null THEN fp ← PFInternal[stream, format, fp, v5, 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, v4, v5: Value]
RETURNS [
ROPE] = {
stream: STREAM = IO.ROS[];
PutF[stream, format, v1, v2, v3, v4, v5];
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;
GetNextFromFormat:
PROC[] =
INLINE {
c ← format.InlineFetch[formatPtr]; formatPtr ← formatPtr.SUCC;
};
formatSize: INT ← format.InlineLength[];
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 {
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];
{
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!
val: Value =
WITH arg
SELECT
FROM
ref: Value.refAny =>
WITH ref.value
SELECT
FROM
refBool: REF READONLY BOOL => IO.bool[refBool^],
refChar: REF READONLY CHAR => IO.char[refChar^],
refCard: REF READONLY CARDINAL => IO.card[refCard^],
refLongCard: REF READONLY LONG CARDINAL => IO.card[refLongCard^],
refInteger: REF READONLY INTEGER => IO.int[refInteger^],
refInt: REF READONLY INT => IO.int[refInt^],
refNat: REF READONLY NAT => IO.int[refNat^],
refReal: REF READONLY REAL => IO.real[refReal^],
refText: REF READONLY TEXT => IO.text[refText],
atom: ATOM => IO.atom[atom],
rope: ROPE => IO.rope[rope],
Not possible now because of Compiler bug?
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 < Length[form])
leadingZero = TRUE iff there is a '0 at form[start] (and start < Length[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.Length[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] = {
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.ObtainScratch[defaultTextSize];
r[0] ← v.value;
r.length ← 1;
};
cardinal => r ← Convert.AppendCard[RefText.ObtainScratch[defaultTextSize], v.value];
integer => r ← Convert.AppendInt[RefText.ObtainScratch[defaultTextSize], v.value];
real => r ← Convert.AppendG[RefText.ObtainScratch[defaultTextSize], v.value];
refAny => {
stream: STREAM = IO.ROS[];
stream.Put[val];
rp ← IO.RopeFromROS[stream];
};
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 => Convert.AppendCard[RefText.ObtainScratch[defaultTextSize], IF v.value THEN 1 ELSE 0, base, FALSE],
cardinal => Convert.AppendCard[RefText.ObtainScratch[defaultTextSize], v.value, base, FALSE],
integer => Convert.AppendInt[RefText.ObtainScratch[defaultTextSize], v.value, base, FALSE],
real => Convert.AppendInt[RefText.ObtainScratch[defaultTextSize], RealOps.RoundLI[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 out 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];
ENDCASE => ERROR IO.Error[PFTypeMismatch, stream];
TimeIntervalRoutine:
PROC [stream:
STREAM, val: Value, format: Format, char:
CHAR] =
TRUSTED {
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).
et, hours1, minutes, seconds: LONG CARDINAL;
li: INT;
r: REF TEXT;
han: STREAM;
WITH v: val
SELECT
FROM
cardinal => et ← v.value;
integer => et ← LOOPHOLE[v.value];
real =>
TRUSTED {
li ← RealOps.RoundLI[v.value ! Real.RealException =>
ERROR IO.Error[PFUnprintableValue, stream]];
IF li < 0 THEN ERROR IO.Error[PFUnprintableValue, stream];
et ← li;
};
ENDCASE => ERROR IO.Error[PFTypeMismatch, stream];
seconds ← et MOD 60;
et ← et/60;
minutes ← et MOD 60;
et ← et/60;
hours1 ← et MOD 100;
et ← et/100;
r ← RefText.ObtainScratch[defaultTextSize];
han ← IO.TOS[r];
IO.PutF[han, "%g%02g:%02g:%02g",
IF et # 0 THEN IO.int[et] ELSE IO.rope[NIL],
IO.card[hours1],
IO.card[minutes],
IO.card[seconds]];
r ← han.TextFromTOS[];
han.Close[];
PrintText[r, NIL, format, stream, FALSE];
};
TimeRoutine:
PROC [stream:
STREAM, val: Value, format: Format, char:
CHAR] =
TRUSTED {
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;
li: INT;
WITH v: val
SELECT
FROM
integer => t ← BasicTime.Update[base: BasicTime.earliestGMT, period: v.value];
cardinal => t ← BasicTime.Update[base: BasicTime.earliestGMT, period: v.value];
real => {
li ← RealOps.RoundLI[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];
};
time => t ← v.value;
ENDCASE => ERROR IO.Error[PFTypeMismatch, stream];
PrintText[
Convert.AppendTime[
to: RefText.ObtainScratch[defaultTextSize], from: t, start: $years, end: $seconds],
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] RETURNS [BOOL] = { stream.streamProcs.putChar[stream, c]; RETURN[FALSE] };
ladj, fill0: BOOL ← FALSE;
w, k, tlength: CARDINAL; -- w is field width, k is # chars to fill
c: CHAR;
formatPtr: INT ← format.first;
GetNextFromFormat:
PROC[] =
INLINE {
c ← format.form.InlineFetch[formatPtr]; formatPtr ← formatPtr.SUCC };
IF text#NIL THEN tlength ← text.length ELSE tlength ← rp.InlineLength[];
GetNextFromFormat[];
SELECT c
FROM
'0 => { fill0 ← TRUE; 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
stream.streamProcs.putChar[stream, IF fill0 THEN '0 ELSE ' ];
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 {
stream.streamProcs.putChar[stream, '^];
stream.streamProcs.putChar[stream, c + LOOPHOLE['@, CARDINAL]]; }
ELSE stream.streamProcs.putChar[stream, c];
ENDLOOP
ELSE {
IF text#
NIL
THEN stream.streamProcs.putBlock[stream, text, 0, text.length]
ELSE [] ← Rope.Map[base: rp, action: MyPut];
};
IF ladj THEN THROUGH [1..k] DO stream.streamProcs.putChar[stream, ' ] 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['x] ← FixnumRoutine;
};