<> <> <<>> <> <> <<>> <> <> <> <> <> <> <> <> <> <> <<>> DIRECTORY Ascii USING [Lower], BasicTime USING [earliestGMT, GMT, Update], Convert, IO, IOUtils, IOUtilsExtras, RefText, Real USING [RealException], RealOps USING [RoundLI], Rope; IOPrintImpl: CEDAR MONITOR IMPORTS Ascii, BasicTime, Convert, IO, IOUtils, RefText, Real, RealOps, Rope EXPORTS IO, IOUtils, IOUtilsExtras = 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; <> <> PutRope: PUBLIC PROC [self: STREAM, r: ROPE] = { WITH r SELECT FROM t: Rope.Text => self.PutBlock[RefText.TrustTextRopeAsText[t]]; ENDCASE => { Put: PROC [char: CHAR] RETURNS [BOOL] = { self.PutChar[char]; RETURN[FALSE] }; [] _ Rope.Map[base: r, action: Put]; }; }; Put: PUBLIC PROC [stream: STREAM, v1, v2, v3: Value] = { scratch: REF TEXT = RefText.ObtainScratch[defaultTextSize]; Put1[stream, v1, scratch]; Put1[stream, v2, scratch]; Put1[stream, v3, scratch]; RefText.ReleaseScratch[scratch]; }; PutR: PUBLIC PROC [v1, v2, v3: Value] RETURNS [ROPE] = { stream: STREAM = IO.ROS[]; scratch: REF TEXT = RefText.ObtainScratch[defaultTextSize]; Put1[stream, v1, scratch]; Put1[stream, v2, scratch]; Put1[stream, v3, scratch]; RefText.ReleaseScratch[scratch]; RETURN[stream.RopeFromROS[]]; }; 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 Put1[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 Put1[stream, l.first, scratch]; ENDLOOP; RefText.ReleaseScratch[scratch]; RETURN[stream.RopeFromROS[]]; }; Put1: PROC [stream: STREAM, v: Value, scratch: REF TEXT] = { scratch.length _ 0; WITH v SELECT FROM null: Value.null => NULL; atom: Value.atom => stream.PutRope[Convert.RopeFromAtom[ from: atom.value, quote: FALSE]]; bool: Value.boolean => stream.PutBlock[RefText.TrustTextRopeAsText[Convert.RopeFromBool[bool.value]]]; char: Value.character => stream.PutChar[char.value]; card: Value.cardinal => stream.PutBlock[Convert.AppendCard[scratch, card.value]]; int: Value.integer => stream.PutBlock[Convert.AppendInt[scratch, int.value]]; real: Value.real => stream.PutBlock[Convert.AppendReal[scratch, real.value]]; refAny: Value.refAny => PrintRef[stream, scratch, refAny.value]; rope: Value.rope => stream.PutRope[rope.value]; text: Value.text => stream.PutBlock[text.value]; time: Value.time => stream.PutBlock[Convert.AppendTime[ to: scratch, from: time.value, start: $years, end: $seconds]]; ENDCASE => ERROR; }; <> 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.PutBlock[scratch]; } 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 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, 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]; }; 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 [stream.RopeFromROS[]]; }; 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 [stream.RopeFromROS[]]; }; <> PFInternal: PROC [ stream: STREAM, format: ROPE, formatPtr: INT, arg: Value, pfProcs: PFProcs] RETURNS [--advancedFormatPtr--INT] = { <> 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]; { <> <> <> <> 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], < IO.atom[atom],>> < IO.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.PutChar[c]; HandleError => { ep: PFErrorProc _ pfProcs.errorProc; IF ep = NIL THEN ep _ PFErrorPrintPounds; ep[error, stream]; GOTO Done; }; } ENDLOOP; EXITS Done => RETURN [formatPtr]; }; PFErrorPrintPounds: PUBLIC PROC [error: IO.ErrorCode, stream: STREAM] = { stream.PutRope["#####"]; }; 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.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.AppendReal[RefText.ObtainScratch[defaultTextSize], v.value]; refAny => { stream: STREAM = IO.ROS[]; stream.Put[val]; rp _ stream.RopeFromROS[]; }; 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 => 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]; }; FlonumRoutine: PROC [stream: STREAM, val: Value, format: Format, char: CHAR] = { <> <> <> <> realValue: REAL; WITH val SELECT FROM cardVal: Value.cardinal => realValue _ cardVal.value; intVal: Value.integer => realValue _ intVal.value; realVal: Value.real => realValue _ realVal.value ENDCASE => ERROR IO.Error[PFTypeMismatch, stream]; PrintText[ Convert.AppendReal[to: RefText.ObtainScratch[defaultTextSize], from: realValue, useE: char = 'e], 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.PutChar['\\]; stream.PutChar[c]; } ELSE { stream.PutChar['\\]; SELECT c FROM '\n => stream.PutChar['n]; '\t => stream.PutChar['t]; '\b => stream.PutChar['b]; '\f => stream.PutChar['f]; '\l => stream.PutChar['l]; ENDCASE => { stream.PutChar['0 + (c - 0C) / 64]; stream.PutChar['0 + (c - 0C) MOD 64 / 8]; stream.PutChar['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 { <> <> <> <> 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 { <> <> <> <> 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]; }; <> PrintText: PROC [ text: REF TEXT, rp: ROPE, format: Format, stream: STREAM, visiblecc: BOOL] = { <> <> MyPut: PROC [c: CHAR] RETURNS [BOOL] = { stream.PutChar[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.PutChar[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.PutChar['^]; stream.PutChar[c + LOOPHOLE['@, CARDINAL]]; } ELSE stream.PutChar[c]; ENDLOOP ELSE { IF text#NIL THEN stream.PutBlock[text] ELSE [] _ Rope.Map[base: rp, action: MyPut]; }; IF ladj THEN THROUGH [1..k] DO stream.PutChar[' ] 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['x] _ FixnumRoutine; }; Create[]; END.