<<>> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <<>> 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; <> <> 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: 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] ~ { <> i2: DINT ~ (-1) - i; c3: DCARD ~ i2; RETURN [c3+1]}; <> 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: 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: 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: PROC [stream: STREAM, format: ROPE, formatPtr: INT, arg: Value, pfProcs: PFProcs] RETURNS [--advancedFormatPtr--INT] = { <> 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 { <> 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 { <> <> <> <> <> 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]], < time[pi^],>> <> 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.>> <> <> <> <> <<= -1 if there was no number present>> <<= LAST[INTEGER] if the number overflows>> <> <> <<= -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]; }; <> StringRoutine: PROC [stream: STREAM, val: Value, format: Format, char: CHAR] = TRUSTED { <> <> <> < for ctrl-char.>> <> 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 { <> 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 { <> <> <> <> <> 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] = { <> <> <> <> WITH val SELECT FROM ropeVal: Value.rope => { <> 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]; <> 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] = { <> <> <> <> PutEscape: PROC [c: CHAR] RETURNS [BOOL] = { <> 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] = { <> <> <> <> 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] = { <> <> <> <> 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]; }; <> 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, '!]; }; <> 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]; }; <> PrintText: PROC [text: REF TEXT, rp: ROPE, format: Format, stream: STREAM, visiblecc: BOOL] = { <> <> 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]; }; <> 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.