package Fmt; /* Code in this package is used for formatted text output of various types of values. This is done via "ioProc" procs, which provide handlers to the parser, which it will then call as values are parsed which are to be output. The code here, on those callouts, generates calls to appropriate internal routines to perform the needed formatting. Thus, there are procs in this package that are called at compile time, as well as procs that are called at run time. This is indicated in the header comment. */ use ../BI; use ../Basic; use ../Char; use ../String; use ../CharBuffer; use ../Names; use ../Types; use ../Package; use ../Proc; use ../Exec; use ../IeeeFloat; /* These two are exported so that references to them can be compiled into code which uses Fmt entry points. */ export CharBuffer/OBuf_t FmtDefaultOBuf; // buffer for standard output export CharBuffer/OBuf_t FmtTempOBuf; // buffer for FmtS /* * EndingMode - this enumerates the various special end-of-work things that * we need to do, based on the actual routine the user called. */ enum EndingMode_t { em_nothing, // nothing special to do em_line, // FmtL - append newline em_buffer, // FmtB - copy to other buffer em_string, // FmtS - create a string from result }; /* This type holds the various pieces of the format parameters as they are delivered by the callouts from the parser. This type is exported, but not public, so that other ioProcs can use Fmt's services. */ export record FmtCookie_t { Package/PContext_t fc_pctx; Exec/Exec_t fc_bufExec; // user-provided buffer, if any Exec/Exec_t fc_mainExec; // value to be formatted string fc_format; // format string (or nil)*/ Exec/Exec_t fc_widthExec; // field width (or nil) Exec/Exec_t fc_precisionExec; // precision (or nil) EndingMode_t fc_endingMode; // what to do at end of sequence }; /******************************** Utilities **********************************/ /* Since this Fmt code is executed at compile time to produce the I/O calls needed, it needs the ability to emit error messages if it encounters difficulties with the operations requested by callers. So, these two standard-form error emitters are used. compile-time */ proc emitError(Package/PContext_t pctx; uint errorCode)void: Package/EmitError(pctx, "Fmt", false, errorCode, nil, 0, nil, 0); corp; proc emitErrorName(Package/PContext_t pctx; uint errorCode1; string name; uint errorCode2)void: Package/EmitError(pctx, "Fmt", false, errorCode1, name, 0, nil, errorCode2); corp; /* * useExists - the code we are generating is being produced in the context of * the package containing the proc we are producing code for. If that * package does not have a "use" for CharBuffer/Char/String, then we * cannot reference procs from those packages, and must use alternates * here that simply call those procs (which we can do since we do have * "use"s for those packages). This routine checks the current context * for the wanted "use", returning true if its found, else false. */ proc useExists(Package/PContext_t pctx; Package/Package_t pk)bool: Package/FindDirectUse(pctx.pctx_containingPackage, pk) corp; /* * closeCall - close off a call that is being done. Return the Exec_t for * the call. * * compile-time */ proc closeCall(@ Exec/TempCall_t tcal; Exec/Exec_t par1, par2, par3, par4, par5)Exec/Exec_t: if par1 ~= nil then Exec/CallAppend(tcal, par1); fi; if par2 ~= nil then Exec/CallAppend(tcal, par2); fi; if par3 ~= nil then Exec/CallAppend(tcal, par3); fi; if par4 ~= nil then Exec/CallAppend(tcal, par4); fi; if par5 ~= nil then Exec/CallAppend(tcal, par5); fi; Exec/Call_t cl; Exec/CallNew(tcal, @cl) corp; /* * finishCall - do the last part of adding a call to the current code. * * compile-time */ proc finishCall(@ Exec/TempCall_t tcal; Exec/Exec_t par1, par2, par3, par4, par5)void: Package/PContext_t pctx := tcal@.tcal_pctx; Exec/Exec_t ex := closeCall(tcal, par1, par2, par3, par4, par5); Exec/SequenceAppend(pctx, ex); corp; /* * addCall - add a call to a named routine (in this Fmt package) to the * calling code sequence. 0 - 5 parameters are also passed - all are * passed in here as Exec/Exec_t's. Note that if any are nil, then no * parameter is passed to the called routine - if a nil parameter is * needed then an explicit Exec/NilNew() should be passed in. * * compile-time */ proc addCall(Package/PContext_t pctx; string name; Exec/Exec_t par1, par2, par3, par4, par5)void: Package/NameReference_t nr := Package/CreateReference(pctx, ., name); Exec/Exec_t fmtRef := Exec/PackageNameRefNew(pctx, nr); Exec/TempCall_t tcal; Exec/CallStart(@tcal, pctx, fmtRef); finishCall(@tcal, par1, par2, par3, par4, par5); corp; /* * callCharBuffer - utility routine to create a call to a CharBuffer proc, * passing either FmtDefaultOBuf or FmtTempOBuf to it. The call is * appended as usual. * * compile-time */ proc callCharBuffer(Package/PContext_t pctx; string name; Exec/Exec_t par1, par2)void: Package/NameReference_t nr := Package/CreateReference(pctx, CharBuffer, name); Exec/TempCall_t tcal; Exec/CallStart(@tcal, pctx, Exec/PackageNameRefNew(pctx, nr)); finishCall(@tcal, par1, par2, nil, nil, nil); corp; /* * useCharBuffer - generate a call to a CharBuffer routine to do the needed * work. Doing this is essentially optimizing out extra run-time work. * * compile-time */ proc useCharBuffer(string name; FmtCookie_t fc)void: callCharBuffer(fc.fc_pctx, "O" + name, fc.fc_bufExec, fc.fc_mainExec); corp; /* * addCall01 - this variant of addCall takes care of whether or not a * bufExec has been provided. The convention used by the code in this * package is that a formatting routine whose name ends in "1" accepts * a user-provided OBuf_t. One whose name ends in "0" uses the default * OBuf_t (FmtDefaultOBuf). * * compile-time */ proc addCall01(string name; FmtCookie_t fc; Exec/Exec_t par1, par2, par3, par4)void: if fc.fc_bufExec ~= nil then addCall(fc.fc_pctx, name + "1", fc.fc_bufExec, par1, par2, par3, par4); else addCall(fc.fc_pctx, name + "0", par1, par2, par3, par4, nil); fi; corp; /* * addCustomCall - in this variant we have a direct reference to the proc * to be called. For now, we only support one variant of such a proc, * which has 5 parameters - the CharBuffer/OBuf_t to output to, the value * to be displayed, the format string (which can be nil), the width and * the precision. If either or both of the latter two are not given by the * user, they will be 0. This is used when we find a provided "fmt" * routine in the exports of a type. * * compile-time */ proc addCustomCall(Proc/Proc_t pr; FmtCookie_t fc)void: Package/PContext_t pctx := fc.fc_pctx; Package/NameReference_t nr; Exec/Exec_t procEx; /* There is a limitation here that is required by CreateReference: the proc must be exported from its package, local to the current package, or private to the current subpackage. As a consequence, if you are exporting a type from a package, and you want a "fmt" routine for the type, then you must export the "fmt" proc as well, so that this call can work in other packages. Note that "FmtCreate", below, creates the proc as Package/nl_export for this reason. */ nr := Package/CreateReference(pctx, pr.pr_containingPackage, pr.pr_name); procEx := Exec/PackageNameRefNew(pctx, nr); Exec/TempCall_t tcal; Exec/CallStart(@tcal, pctx, procEx); Exec/Exec_t bufExec := if fc.fc_bufExec ~= nil then fc.fc_bufExec else nr := Package/CreateReference(pctx, ., "FmtDefaultOBuf"); Exec/PackageNameRefNew(pctx, nr) fi; Exec/Exec_t fmtExec := if fc.fc_format ~== nil then Exec/StringConstantNew(fc.fc_format) else Exec/NilNew() fi; Exec/Exec_t widthExec := if fc.fc_widthExec ~= nil then fc.fc_widthExec else Exec/UintConstantNew(nil, 0) fi; Exec/Exec_t precisionExec := if fc.fc_precisionExec ~= nil then fc.fc_precisionExec else Exec/UintConstantNew(nil, 0) fi; finishCall(@tcal, bufExec, fc.fc_mainExec, fmtExec, widthExec, precisionExec); corp; /* * doDirect - generate a call that is either to a single-parameter fmt routine * in this package, or directly to a CharBuffer routine, depending on * whether a bufExec was provided or not. * * compile-time */ proc doDirect(string name; FmtCookie_t fc)void: if fc.fc_bufExec ~= nil and useExists(fc.fc_pctx, CharBuffer) then useCharBuffer(name, fc); else addCall01("fmt" + name, fc, fc.fc_mainExec, nil, nil, nil); fi; corp; /************************* Miscellaneous output ******************************/ /* Note: all of these output routines are exported. This is not because we expect other code to be calling them, however. It is because they need to be exported unqualified if they are to be usable from any client code. See Package/CreateReference. */ /* * fmtError{01}, fmtVoid{01}, fmtNil{01} and fmtPoly{01} are used for the * corresponding types. Under normal circumstances, these are not needed, * but it is always possible for user-level code to do this. * * run-time */ export proc fmtError0()void: CharBuffer/OString(FmtDefaultOBuf, ""); corp; export proc fmtError1(CharBuffer/OBuf_t ob)void: CharBuffer/OString(ob, ""); corp; export proc fmtVoid0()void: CharBuffer/OString(FmtDefaultOBuf, ""); corp; export proc fmtVoid1(CharBuffer/OBuf_t ob)void: CharBuffer/OString(ob, ""); corp; export proc fmtNil0()void: CharBuffer/OString(FmtDefaultOBuf, ""); corp; export proc fmtNil1(CharBuffer/OBuf_t ob)void: CharBuffer/OString(ob, ""); corp; export proc fmtPoly0()void: CharBuffer/OString(FmtDefaultOBuf, ""); corp; export proc fmtPoly1(CharBuffer/OBuf_t ob)void: CharBuffer/OString(ob, ""); corp; /* * fmtArray{01}, fmtStruct{01}, fmtUnion{01} - these are used if we encounter * the corresponding kind of type. This can happen either at the top * level, or within the nesting possible with FmtCreate. * * run-time */ export proc fmtArray0()void: CharBuffer/OString(FmtDefaultOBuf, ""); corp; export proc fmtArray1(CharBuffer/OBuf_t ob)void: CharBuffer/OString(ob, ""); corp; export proc fmtStruct0()void: CharBuffer/OString(FmtDefaultOBuf, ""); corp; export proc fmtStruct1(CharBuffer/OBuf_t ob)void: CharBuffer/OString(ob, ""); corp; export proc fmtUnion0()void: CharBuffer/OString(FmtDefaultOBuf, ""); corp; export proc fmtUnion1(CharBuffer/OBuf_t ob)void: CharBuffer/OString(ob, ""); corp; /******************************* Numeric output ******************************/ /* * decodeFormat - given a caller-supplied format string and a valid format * code, see if the format properly matches that code and the modifiers * allowed with it. Return 'true' if so, and return the values of the * updated code and resulting modifiers. Otherwise return 'false'. * * This routine is used for uint, sint and float format codes. * * compile-time and run-time */ proc decodeFormat(string format; char code; bool capOk, zeroOk, plusOk; @ char resCode; @ bool resCap, resZero, resPlus)bool: resCode@ := ' '; resCap@ := false; resZero@ := false; resPlus@ := false; if format == nil then return true; fi; uint len := getBound(format); if len = 0 then return true; fi; char ch0 := format[0], ch0l := Char/ToLower(ch0); if ch0 = code then resCode@ := ch0; elif capOk and ch0l = code then resCap@ := true; resCode@ := ch0l; else return false; fi; if len = 1 then return true; fi; if len > 3 then return false; fi; for uint i from 1 upto len - 1 do char ch := format[i]; if zeroOk and ch = '0' then resZero@ := true; elif plusOk and ch = 'p' then resPlus@ := true; else return false; fi; od; true corp; /* * getBase - given a format code, return the base to use. * * run-time */ proc getBase(char code)uint: case code incase 'd': 10 incase 'x': 16 incase 'o': 8 incase 'b': 2 default: 10 esac corp; /* When formatting a signed 64 bit integer in binary, we can need upto 64 + 2 + 1 characters. For convenience we want to use CharBuffer/BUF_SIZE, for our buffer size. Make sure it is large enough. */ uint MAX_WIDTH = 67; [if CharBuffer/BUF_SIZE >= MAX_WIDTH then 1 else 0 fi] char Unused; /* * fmtDigits - insert the digits of the value into the passed Buf_t, using * the passed base. Used for uint and sint output. Return the number of * characters put into the higher-indexed end of the Buf_t. * * run-time */ proc fmtDigits(uint n, base; @ CharBuffer/Buf_t buf)uint: uint pos := CharBuffer/BUF_SIZE, len := 0; while uint digit := n % base; char ch; if digit > 9 then ch := digit - 10 + 'a'; else ch := digit + '0'; fi; pos := pos - 1; buf@[pos] := ch; len := len + 1; n := n / base; n ~= 0 do od; len corp; /* * fmtIntCommon - common code for much of the work of formatting uint and * sint values. * * run-time */ proc fmtIntCommon(CharBuffer/OBuf_t ob; uint n; char code; uint width; bool pfx, zero, plus, isNeg)void: if code = ' ' then code := 'd'; fi; uint base := getBase(code); if width > CharBuffer/BUF_SIZE then width := CharBuffer/BUF_SIZE; fi; CharBuffer/Buf_t buf; uint len := fmtDigits(n, base, @buf); uint pos := CharBuffer/BUF_SIZE - len; if pfx then if not zero then pos := pos - 1; buf[pos] := code; pos := pos - 1; buf[pos] := '0'; fi; len := len + 2; fi; if isNeg then if not zero then pos := pos - 1; buf[pos] := '-'; fi; len := len + 1; fi; while len < width do pos := pos - 1; buf[pos] := if zero then '0' else ' ' fi; len := len + 1; od; if zero then if pfx then pos := pos - 1; buf[pos] := code; pos := pos - 1; buf[pos] := '0'; fi; if isNeg then pos := pos - 1; buf[pos] := '-'; fi; fi; CharBuffer/OBufR(ob, @buf, pos); corp; /* * getUintFormat - verify a format string for use with uints, and return * the chosen code and its modifiers. * * compile-time and run-time */ proc getUintFormat(string format; @ char code; @ bool pfx, zero, plus)bool: decodeFormat(format, 'd', true, true, false, code, pfx, zero, plus) or decodeFormat(format, 'x', true, true, false, code, pfx, zero, plus) or decodeFormat(format, 'o', true, true, false, code, pfx, zero, plus) or decodeFormat(format, 'b', true, true, false, code, pfx, zero, plus) corp; /* * fmtUint1 - the actual guts of formatting a uint for output. * * run-time */ export proc fmtUint1(CharBuffer/OBuf_t ob; uint n; string format; uint width)void: if format == nil then format := "d"; fi; char code; bool pfx, zero, plus; eval getUintFormat(format, @code, @pfx, @zero, @plus); fmtIntCommon(ob, n, code, width, pfx, zero, plus, false); corp; /* * fmtUint00, etc. - forms. We compile in calls to these for simpler * formatting. Providing these stubs means that the generated code is not * bulked out with constants. * * run-time */ export proc fmtUint0(uint n; string format; uint width)void: fmtUint1(FmtDefaultOBuf, n, format, width); corp; export proc fmtUint00(uint n)void: CharBuffer/OUint(FmtDefaultOBuf, n); corp; export proc fmtUint01(CharBuffer/OBuf_t ob; uint n)void: CharBuffer/OUint(ob, n); corp; export proc fmtUint10(uint n; string format)void: fmtUint1(FmtDefaultOBuf, n, format, 0); corp; export proc fmtUint11(CharBuffer/OBuf_t ob; uint n; string format)void: fmtUint1(ob, n, format, 0); corp; export proc fmtUint20(uint n, width)void: fmtUint1(FmtDefaultOBuf, n, "d", width); corp; export proc fmtUint21(CharBuffer/OBuf_t ob; uint n, width)void: fmtUint1(ob, n, "d", width); corp; /* * getSintFormat - verify a format string for use with sints, and return * the chosen code and its modifiers. * * compile-time and run-time */ proc getSintFormat(string format; @ char code; @ bool pfx, zero, plus)bool: decodeFormat(format, 'd', true, true, true, code, pfx, zero, plus) or decodeFormat(format, 'x', true, true, true, code, pfx, zero, plus) or decodeFormat(format, 'o', true, true, true, code, pfx, zero, plus) or decodeFormat(format, 'b', true, true, true, code, pfx, zero, plus) corp; /* * fmtSint1 - the actual guts of formatting a sint for output. * * run-time */ proc fmtSint1(CharBuffer/OBuf_t ob; sint n; string format; uint width)void: if format == nil then format := "d"; fi; char code; bool pfx, zero, plus; eval getSintFormat(format, @code, @pfx, @zero, @plus); bool isNeg := false; if n < 0 then isNeg := true; n := -n; fi; fmtIntCommon(ob, toUint(n), code, width, pfx, zero, plus, isNeg); corp; export proc fmtSint0(sint n; string format; uint width)void: fmtSint1(FmtDefaultOBuf, n, format, width); corp; export proc fmtSint00(sint n)void: CharBuffer/OSint(FmtDefaultOBuf, n); corp; export proc fmtSint01(CharBuffer/OBuf_t ob; sint n)void: CharBuffer/OSint(ob, n); corp; export proc fmtSint10(sint n; string format)void: fmtSint1(FmtDefaultOBuf, n, format, 0); corp; export proc fmtSint11(CharBuffer/OBuf_t ob; sint n; string format)void: fmtSint1(ob, n, format, 0); corp; export proc fmtSint20(sint n; uint width)void: fmtSint1(FmtDefaultOBuf, n, "d", width); corp; export proc fmtSint21(CharBuffer/OBuf_t ob; sint n; uint width)void: fmtSint1(ob, n, "d", width); corp; /* * doUintOrSint - generate the appropriate uint or sint formatting call, * based on the presence of a specified format and/or width. * * compile-time */ proc doUintOrSint(string name; FmtCookie_t fc)void: if fc.fc_format == nil then if fc.fc_widthExec = nil then if fc.fc_bufExec ~= nil and useExists(fc.fc_pctx, CharBuffer) then /* This is in some sense a silly optimization to do. But, if someone ends up sending a billion uints or sints through FmtB with default parameters, they may appreciate the increased efficiency. */ useCharBuffer(name, fc); return; fi; name := "fmt" + name + "0"; else name := "fmt" + name + "2"; fi; elif fc.fc_widthExec = nil then name := "fmt" + name + "1"; else name := "fmt" + name; fi; Exec/Exec_t fmtExec := if fc.fc_format == nil then nil else Exec/StringConstantNew(fc.fc_format) fi; addCall01(name, fc, fc.fc_mainExec, fmtExec, fc.fc_widthExec, nil); corp; /********************* char, string and bool output **************************/ /* * pad - local utility to add spaces to the output. * * run-time */ proc pad(CharBuffer/OBuf_t ob; uint count)void: for uint i from 1 upto count do CharBuffer/OChar(ob, ' '); od; corp; /* * addLCR - generate a call to an output routine whose name is composed * from the type name and the format string. Also used for enums. * * "extra" is only used for enums - it is nil otherwise, and so * will be ignored by "addCall". * * compile-time */ proc addLCR(string name; FmtCookie_t fc; Exec/Exec_t extra)void: name := "fmt" + name; string format := fc.fc_format; if format == nil then format := "r"; fi; if format = "l" then name := name + "Left"; elif format = "c" then name := name + "Center"; else /* format = "r" */ name := name + "Right"; fi; addCall01(name, fc, fc.fc_mainExec, fc.fc_widthExec, extra, nil); corp; /* * fmtChar0 - simple output of a char. * * run-time */ export proc fmtChar0(char ch)void: CharBuffer/OChar(FmtDefaultOBuf, ch); corp; export proc fmtChar1(CharBuffer/OBuf_t ob; char ch)void: CharBuffer/OChar(ob, ch); corp; /* * fmtCharLeft{01} - left-justify a single char value. Also for bool. * * run-time */ export proc fmtCharLeft1(CharBuffer/OBuf_t ob; char ch; uint width)void: CharBuffer/OChar(ob, ch); if width > 1 then pad(ob, width - 1); fi; corp; export proc fmtCharLeft0(char ch; uint width)void: fmtCharLeft1(FmtDefaultOBuf, ch, width); corp; /* * fmtCharCenter{01} - center a single char in its field. Also for bool. * * run-time */ export proc fmtCharCenter1(CharBuffer/OBuf_t ob; char ch; uint width)void: if width > 1 then uint half := (width - 1) / 2; pad(ob, half); if width % 2 = 0 then CharBuffer/OChar(ob, ' '); fi; CharBuffer/OChar(ob, ch); pad(ob, half); else CharBuffer/OChar(ob, ch); fi; corp; export proc fmtCharCenter0(char ch; uint width)void: fmtCharCenter1(FmtDefaultOBuf, ch, width); corp; /* * fmtCharRight{01} - right-justify a single char value. Also for bool. * * run-time */ export proc fmtCharRight1(CharBuffer/OBuf_t ob; char ch; uint width)void: if width > 1 then pad(ob, width - 1); fi; CharBuffer/OChar(ob, ch); corp; export proc fmtCharRight0(char ch; uint width)void: fmtCharRight1(FmtDefaultOBuf, ch, width); corp; /* * fmtCharF - use Char/Fmt to output a character to the default output, * using 'f' format. */ export proc fmtCharF0(char ch)void: Char/Fmt(FmtDefaultOBuf, ch); corp; export proc fmtCharF1(CharBuffer/OBuf_t ob; char ch)void: Char/Fmt(ob, ch); corp; /* * fmtString0 - simple output of a string. * * run-time */ export proc fmtString0(string s)void: CharBuffer/OString(FmtDefaultOBuf, s); corp; export proc fmtString1(CharBuffer/OBuf_t ob; string s)void: CharBuffer/OString(ob, s); corp; /* * fmtStringLeft{01} - left-justify a string in a given width. * * run-time */ export proc fmtStringLeft1(CharBuffer/OBuf_t ob; string s; uint width)void: uint len := getBound(s); if width ~= 0 and len > width then for uint i from 0 upto len - 1 do CharBuffer/OChar(ob, s[i]); od; else CharBuffer/OString(ob, s); fi; if width > len then pad(ob, width - len); fi; corp; export proc fmtStringLeft0(string s; uint width)void: fmtStringLeft1(FmtDefaultOBuf, s, width); corp; /* * fmtStringCenter{01} - center a string in a given width. * * run-time */ export proc fmtStringCenter1(CharBuffer/OBuf_t ob; string s; uint width)void: uint len := getBound(s); if width ~= 0 and len > width then for uint i from 0 upto len - 1 do CharBuffer/OChar(ob, s[i]); od; else if width > len then width := width - len; uint half := width / 2; pad(ob, half); if width % 2 ~= 0 then CharBuffer/OChar(ob, ' '); fi; CharBuffer/OString(ob, s); pad(ob, half); else CharBuffer/OString(ob, s); fi; fi; corp; export proc fmtStringCenter0(string s; uint width)void: fmtStringCenter1(FmtDefaultOBuf, s, width); corp; /* * fmtStringRight{01} - right-justify a string in a given with. * * run-time */ export proc fmtStringRight1(CharBuffer/OBuf_t ob; string s; uint width)void: uint len := getBound(s); if width ~= 0 and len > width then for uint i from 0 upto len - 1 do CharBuffer/OChar(ob, s[i]); od; else if width > len then pad(ob, width - len); fi; CharBuffer/OString(ob, s); fi; corp; export proc fmtStringRight0(string s; uint width)void: fmtStringRight1(FmtDefaultOBuf, s, width); corp; /* * fmtStringF{01} - use String/Fmt to output a string to the default output, * using 'f' format. */ export proc fmtStringF0(string s)void: String/Fmt(FmtDefaultOBuf, s); corp; export proc fmtStringF1(CharBuffer/OBuf_t ob; string s)void: String/Fmt(ob, s); corp; /* * doCharString - generate code to output a char or string value, based on the * format string and width specifier. * * compile-time */ proc doCharString(bool isString; FmtCookie_t fc)void: Package/PContext_t pctx := fc.fc_pctx; string typeName := if isString then "String" else "Char" fi; if fc.fc_format ~== nil and fc.fc_format = "f" then if fc.fc_bufExec ~= nil and useExists(pctx, if isString then String else Char fi) then Package/NameReference_t nr; if isString then nr := Package/CreateReference(pctx, String, "Fmt"); else nr := Package/CreateReference(pctx, Char, "Fmt"); fi; Exec/TempCall_t tcal; Exec/CallStart(@tcal, pctx, Exec/PackageNameRefNew(pctx, nr)); finishCall(@tcal, fc.fc_bufExec, fc.fc_mainExec, nil, nil, nil); else addCall01("fmt" + typeName + "F", fc, fc.fc_mainExec, nil, nil, nil); fi; elif fc.fc_widthExec = nil then /* There is no width, so, the format doesn't matter. */ doDirect(typeName, fc); elif fc.fc_format == nil then /* We have a width but no format. Use right justification. */ addCall01("fmt" + typeName + "Right", fc, fc.fc_mainExec, fc.fc_widthExec, nil, nil); elif Exec/IsUintConstantExpr(fc.fc_widthExec) then uint width; eval Exec/GetUintConstantExpr(pctx, fc.fc_widthExec, @width); if width < 2 then doDirect(typeName, fc); else addLCR(typeName, fc, nil); fi; else addLCR(typeName, fc, nil); fi; corp; /* * fmtBool{01} - straight output of a bool value, with no field width. * * run-time */ export proc fmtBool0(bool f)void: CharBuffer/OChar(FmtDefaultOBuf, if f then 'T' else 'F' fi); corp; export proc fmtBool1(CharBuffer/OBuf_t ob; bool f)void: CharBuffer/OChar(ob, if f then 'T' else 'F' fi); corp; /* * fmtBoolLeft{01} - left-justify a bool within a given width. * * run-time */ export proc fmtBoolLeft0(bool b; uint width)void: fmtCharLeft1(FmtDefaultOBuf, if b then 'T' else 'F' fi, width); corp; export proc fmtBoolLeft1(CharBuffer/OBuf_t ob; bool b; uint width)void: fmtCharLeft1(ob, if b then 'T' else 'F' fi, width); corp; /* * fmtBoolCenter{01} - center a bool value within a given width. * * run-time */ export proc fmtBoolCenter0(bool b; uint width)void: fmtCharCenter1(FmtDefaultOBuf, if b then 'T' else 'F' fi, width); corp; export proc fmtBoolCenter1(CharBuffer/OBuf_t ob; bool b; uint width)void: fmtCharCenter1(ob, if b then 'T' else 'F' fi, width); corp; /* * fmtBoolRight{01} - right-justify a bool within a given width. * * run-time */ export proc fmtBoolRight0(bool b; uint width)void: fmtCharRight1(FmtDefaultOBuf, if b then 'T' else 'F' fi, width); corp; export proc fmtBoolRight1(CharBuffer/OBuf_t ob; bool b; uint width)void: fmtCharRight1(ob, if b then 'T' else 'F' fi, width); corp; /* * doBool - generate code to output a bool value, based on the format string * and width specifier. * * compile-time */ proc doBool(FmtCookie_t fc)void: string name; if fc.fc_widthExec = nil then /* If there is no width, then the format doesn't matter. */ addCall01("fmtBool", fc, fc.fc_mainExec, nil, nil, nil); elif fc.fc_format == nil then /* Default to right justified. */ addCall01("fmtBoolRight", fc, fc.fc_mainExec, fc.fc_widthExec, nil, nil); elif Exec/IsUintConstantExpr(fc.fc_widthExec) then uint width; eval Exec/GetUintConstantExpr(fc.fc_pctx, fc.fc_widthExec, @width); if width < 2 then /* The format won't matter. */ addCall01("fmtBool", fc, fc.fc_mainExec, nil, nil, nil); else addLCR("Bool", fc, nil); fi; else addLCR("Bool", fc, nil); fi; corp; /************************* floating point output *****************************/ /* * getFloatFormat - verify a format string for use with floats, and return * the chosen code and its modifiers. * * compile-time and run-time */ proc getFloatFormat(string format; @ char code; @ bool cap, zero, plus)bool: decodeFormat(format, 'e', true, true, false, code, cap, zero, plus) or decodeFormat(format, 'f', false, true, true, code, cap, zero, plus) or decodeFormat(format, 'g', true, true, true, code, cap, zero, plus) or decodeFormat(format, 'x', true, true, false, code, cap, zero, plus) corp; uint MAX_DIGITS = 20; /* max 64 bit uint in decimal */ uint DEFAULT_DIGITS = 7; /* a "reasonable" number of digits */ /* S0.{d}eSddd */ uint E_OVERHEAD = 8, E_MIN = E_OVERHEAD + 1; /* * getDigits - decode the mantissa into a char buffer. Return the number of * decimal digits produced. Note that this routine can return 0. Note also * that the significant digits are in the higher-indexed portion of the * char buffer. * * compile-time and run-time */ proc getDigits(@ [MAX_DIGITS] char digits; uint mant)uint: uint pos := MAX_DIGITS; while mant ~= 0 do pos := pos - 1; digits@[pos] := mant % 10 + '0'; mant := mant / 10; od; MAX_DIGITS - pos corp; /* * fmtInfNaN - utility for dealing with Inf and NaN. * * run-time */ proc fmtInfNaN(CharBuffer/OBuf_t ob; uint width; bool isNeg, doCap, doPlus; string name)void: uint needed := if isNeg or doPlus then 6 else 5 fi; if width ~= 0 and width < needed then while width ~= 0 do CharBuffer/OChar(ob, '*'); width := width - 1; od; else if width ~= 0 then pad(ob, width - needed); fi; if isNeg then CharBuffer/OChar(ob, '-'); elif doPlus then CharBuffer/OChar(ob, '+'); fi; CharBuffer/OString(ob, if doCap then "0F" else "0f" fi); CharBuffer/OString(ob, name); fi; corp; /* * trimZeroes - utility to trim unwanted trailing 0's from a floating point * representation. * * compile-time and run-time */ proc trimZeroes(@ [MAX_DIGITS] char digits; uint digCount, beforeDot, afterDot)uint: if digCount > afterDot then /* We may not be starting with as many digits as are wanted, so we may not be able to trim at all. */ uint pos := MAX_DIGITS - digCount + beforeDot + afterDot - 1; while afterDot > 0 and digits@[pos] = '0' do afterDot := afterDot - 1; pos := pos - 1; od; fi; afterDot corp; /* * checkFloatF - check to see if the floating point number whose description is * passed in can be properly output using the given 'f' or 'g' format, * width and precision. If it can, then return 'true' and the chosen * counts of digits before the '.' and digits after the '.' If not, then * return 'false'. * * compile-time and run-time */ enum CheckMode_t { cm_gCheck, /* check for appropriateness of 'f' in 'g' mode */ cm_fCheck, /* check for do-ability in forced 'f' mode */ cm_ctError /* check for non-fit of forced 'f' at compile time */ }; proc checkFloatF(CheckMode_t cm; @ [MAX_DIGITS] char digits; bool doPlus, isNeg; sint decExp; uint digCount, width, precision; @ uint resBefore, resAfter)bool: uint extra, beforeDot, afterDot, space, zeroes; /* 'extra' includes the '.' and any needed '-'. */ if doPlus or isNeg then extra := 2; else extra := 1; fi; /* Compute the number of digits needed before and after the '.'. */ if decExp >= 0 then beforeDot := digCount + toUint(decExp); afterDot := 0; else afterDot := toUint(-decExp); if digCount <= afterDot then beforeDot := 0; else beforeDot := digCount - afterDot; fi; fi; if width ~= 0 then /* A width was specified, and possibly a precision. We need room for at least the '.' and possibly a sign. */ if width < extra then if cm = cm_ctError then return false; fi; width := extra; fi; if precision >= width - extra then /* Huh? What do you want? */ if cm = cm_ctError then return false; fi; precision := width - extra; fi; if precision ~= 0 then space := width - extra - precision; if space >= beforeDot then /* The value fits in the user specified format. */ resBefore@ := space; resAfter@ := precision; return true; fi; fi; /* Note, it is possible that beforeDot + afterDot > digCount. */ if beforeDot + afterDot + extra <= width then /* It all fits in the user's specified space. If we have more room than needed, put spaces before the value. */ resBefore@ := width - extra - afterDot; resAfter@ := afterDot; return true; fi; /* Not all digits can be displayed. Is it reasonable to discard some at the low end? */ if width - extra >= beforeDot then /* Value fits with no digits after the '.'. But, we should show however many digits after the '.' as will fit. */ if beforeDot ~= 0 then /* At least some digits before '.' - go with it. We don't use trimZeroes here since we were supposed to show more digits than we are, so showing zeroes is likely useful. */ resBefore@ := beforeDot; resAfter@ := width - extra - beforeDot; return true; fi; /* Force a '0' before the '.'. */ space := width - extra - 1; if cm = cm_fCheck then /* -decExp > digCount, else we could not have beforeDot = 0. */ zeroes := toUint(-decExp) - digCount; if zeroes + digCount > space and digCount + E_OVERHEAD <= width then /* The entire value does not fit in the space available for 'f' format, but it does fit in the space available for 'e' format. So, use 'e' format. This particular test will only catch quite small values. */ return false; fi; if zeroes > space and width > E_OVERHEAD then /* The leading '0's after the '.' will not fit in the available space, but there is space for at least 1 digit in 'e' format. So, use 'e' format. */ return false; fi; fi; uint trimmed := afterDot - space; /* digits we have to trim */ if trimmed + 1 <= digCount then /* This is actually "trimmed <= digCount - 1", but we are avoiding possible uint underflow. Basically, there would be at least 1 valid digit displayed. */ resBefore@ := 1; resAfter@ := space; return true; fi; /* We would end up displaying "0" in 'f' format. If we don't have enough width to do a decent 'e' format, then go with the "0". */ if width < E_MIN then resBefore@ := space; resAfter@ := 1; return true; fi; fi; else /* No width specified, and so no precision specified. If the digits before and after the '.' are "reasonable", then we will use 'f' format. */ if beforeDot ~= 0 then if beforeDot <= DEFAULT_DIGITS then resBefore@ := beforeDot; if digCount + extra <= 10 then /* The entire value fits "reasonably". Do it. */ if digCount >= beforeDot then /* No need to insert any zeros before the '.'. */ resAfter@ := trimZeroes(digits, digCount, beforeDot, digCount - beforeDot); else resAfter@ := 0; fi; else /* Else, chop off some digits after the '.'. */ resAfter@ := trimZeroes(digits, digCount, beforeDot, 10 - extra - beforeDot); fi; return true; fi; else zeroes := toUint(-decExp) - digCount; if zeroes < DEFAULT_DIGITS then /* Less than DEFAULT_DIGITS '0's after '.' before digits. */ resBefore@ := 1; /* add '0' before the '.' */ space := zeroes + digCount; /* Restrict output to DEFAULT_DIGITS digits after '.'. */ if space <= DEFAULT_DIGITS then resAfter@ := trimZeroes(digits, digCount, 1, space); else /* Doing the trimZeroes call here doesn't work properly, but I didn't track down exactly why - I think perhaps the trimming starts in a bad place. */ resAfter@ := DEFAULT_DIGITS; fi; return true; fi; fi; fi; false corp; /* * fmtFloatF - the floating point value will be output in 'f' format. We are * given the chosen valid counts of digits before and after the '.'. * Do the final formatting work and output the value. * * run-time */ proc fmtFloatF(CharBuffer/OBuf_t ob; bool doZero, doPlus, isNeg; sint decExp; uint mant, chosenBefore, chosenAfter)void: [MAX_DIGITS] char digits; uint digCount := getDigits(@digits, mant); CharBuffer/Buf_t buf; uint beforeDot, afterDot; /* The beforeDot and afterDot values computed here are saying how many characters are needed to print the entire set of digits, some of which might be before the '.', and some of which might be after the '.'. The values will include any padding '0' digits that might be needed between real digits and the '.'. */ if decExp >= 0 then beforeDot := digCount + toUint(decExp); afterDot := 0; else afterDot := toUint(-decExp); if digCount <= afterDot then beforeDot := 0; else beforeDot := digCount - afterDot; fi; fi; /* Do any needed rounding of the value, if some available digits after the '.' will not be shown. */ bool first := true; while mant ~= 0 and afterDot > chosenAfter do if first then mant := mant + 5; first := false; fi; mant := mant / 10; uint newDigCount := getDigits(@digits, mant); if newDigCount ~= digCount then /* Rounding the value in this case reduced the number of digits in it. There are rare cases where it won't, e.g. (99997 + 5) / 10 = 10000. In that case, we will need one more rounding step. */ afterDot := afterDot - 1; digCount := newDigCount; fi; decExp := decExp + 1; od; uint pos := CharBuffer/BUF_SIZE, digitsPos := MAX_DIGITS, trailingZeros; if decExp < 0 then if toUint(-decExp) >= chosenAfter then trailingZeros := 0; else trailingZeros := chosenAfter - toUint(-decExp); fi; else trailingZeros := chosenAfter; fi; while trailingZeros ~= 0 do pos := pos - 1; buf[pos] := '0'; trailingZeros := trailingZeros - 1; chosenAfter := chosenAfter - 1; od; while chosenAfter ~= 0 do pos := pos - 1; if decExp >= 0 then buf[pos] := '0'; else if digCount ~= 0 then digitsPos := digitsPos - 1; buf[pos] := digits[digitsPos]; digCount := digCount - 1; else buf[pos] := '0'; fi; decExp := decExp + 1; fi; chosenAfter := chosenAfter - 1; od; pos := pos - 1; buf[pos] := '.'; if decExp <= 0 and beforeDot = 0 and chosenBefore ~= 0 then /* Force a '0' before the '.'. */ pos := pos - 1; buf[pos] := '0'; chosenBefore := chosenBefore - 1; fi; while decExp > 0 do pos := pos - 1; buf[pos] := '0'; decExp := decExp - 1; chosenBefore := chosenBefore - 1; beforeDot := beforeDot - 1; od; while beforeDot ~= 0 do pos := pos - 1; digitsPos := digitsPos - 1; buf[pos] := digits[digitsPos]; beforeDot := beforeDot - 1; chosenBefore := chosenBefore - 1; od; if doZero then while chosenBefore ~= 0 do pos := pos - 1; buf[pos] := '0'; chosenBefore := chosenBefore - 1; od; fi; if isNeg then pos := pos - 1; buf[pos] := '-'; elif doPlus then pos := pos - 1; buf[pos] := '+'; fi; if not doZero then while chosenBefore ~= 0 do pos := pos - 1; buf[pos] := ' '; chosenBefore := chosenBefore - 1; od; fi; CharBuffer/OBufR(ob, @buf, pos); corp; /* * fmtFloatE - format the floating point number in 'e' format. * * run-time */ proc fmtFloatE(CharBuffer/OBuf_t ob; bool doCap, doZero, isNeg; sint decExp; uint mant, width, precision)void: [MAX_DIGITS] char digits; uint digCount := getDigits(@digits, mant), digitsPos := MAX_DIGITS; CharBuffer/Buf_t buf; uint pos := CharBuffer/BUF_SIZE, useWidth; if width = 0 then /* Go with upto DEFAULT_DIGITS digits. */ useWidth := if digCount > DEFAULT_DIGITS then DEFAULT_DIGITS else digCount fi; else if width < E_MIN then /* Not enough space to display the value. Display '*'s. */ while width ~= 0 do CharBuffer/OChar(ob, '*'); width := width - 1; od; return; fi; useWidth := width - E_OVERHEAD; fi; if precision = 0 or precision > useWidth then precision := useWidth; fi; /* Round the mantissa to "precision" digits. */ bool first := true; while mant ~= 0 and digCount > precision do if first then mant := mant + 5; first := false; fi; mant := mant / 10; digCount := getDigits(@digits, mant); decExp := decExp + 1; od; /* Trim trailing zeroes. */ if mant ~= 0 and mant % 10 = 0 then while mant ~= 0 and mant % 10 = 0 do mant := mant / 10; decExp := decExp + 1; od; digCount := getDigits(@digits, mant); if width = 0 and digCount < precision then /* Set useWidth and precision based on any trimming. */ precision := digCount; useWidth := digCount; fi; fi; /* Put the exponent, sign and 'e' into "buf". */ decExp := decExp + fromUint(sint, digCount); uint decExpU; bool expNeg; if decExp < 0 then expNeg := true; decExpU := toUint(-decExp); else expNeg := false; decExpU := toUint(decExp); fi; for uint i from 0 upto 2 do pos := pos - 1; buf[pos] := decExpU % 10 + '0'; decExpU := decExpU / 10; od; pos := pos - 1; buf[pos] := if expNeg then '-' else '+' fi; pos := pos - 1; buf[pos] := if doCap then 'E' else 'e' fi; /* Put the fractional digits into "buf". */ while precision ~= 0 do pos := pos - 1; if precision > digCount then buf[pos] := '0'; else digitsPos := digitsPos - 1; buf[pos] := digits[digitsPos]; digCount := digCount - 1; fi; precision := precision - 1; useWidth := useWidth - 1; od; /* Put in the '.' leading '0' and sign into "buf" along with either leading '0's or leading space. */ pos := pos - 1; buf[pos] := '.'; pos := pos - 1; buf[pos] := '0'; if doZero then while useWidth ~= 0 do pos := pos - 1; buf[pos] := '0'; useWidth := useWidth - 1; od; fi; pos := pos - 1; buf[pos] := if isNeg then '-' else '+' fi; if not doZero then while useWidth ~= 0 do pos := pos - 1; buf[pos] := ' '; useWidth := useWidth - 1; od; fi; /* Dump "buf" to the OBuf_t. */ CharBuffer/OBufR(ob, @buf, pos); corp; /* * fmtFloat1 - format a floating point number according to the passed * format string, width and precision. Because of the way the width * and precision values are parsed, you will never get a non-zero * precision with a zero width. * * mostly run-time */ export proc fmtFloat1(CharBuffer/OBuf_t ob; float f; string format; uint width, precision)void: uint HEX_DIGITS = 16, HEX_SIZE = HEX_DIGITS + 3; /* 0fx */ if width > MAX_WIDTH then width := MAX_WIDTH; fi; char code; bool doCap, doZero, doPlus; eval getFloatFormat(format, @code, @doCap, @doZero, @doPlus); if code = ' ' then code := 'g'; fi; if code = 'x' then if width ~= 0 and width < HEX_SIZE then while width ~= 0 do CharBuffer/OChar(ob, '*'); width := width - 1; od; else if doZero then CharBuffer/OString(ob, if doCap then "0FX" else "0fx" fi); fmtUint1(ob, toUint(f), "x0", if width > HEX_SIZE then width - 3 else 0 fi); else if width > HEX_SIZE then width := width - HEX_SIZE; while width ~= 0 do CharBuffer/OChar(ob, ' '); width := width - 1; od; fi; CharBuffer/OString(ob, if doCap then "0FX" else "0fx" fi); fmtUint1(ob, toUint(f), "x0", HEX_DIGITS); fi; fi; return; fi; /* Testing for < 0.0 doesn't work for Inf and NaN. */ bool isNeg := IeeeFloat/IsNeg(f); if IeeeFloat/IsInf(f) then fmtInfNaN(ob, width, isNeg, doCap, doPlus, "Inf"); return; elif IeeeFloat/IsNaN(f) then fmtInfNaN(ob, width, isNeg, doCap, doPlus, "NaN"); return; fi; sint decExp; uint mant; eval IeeeFloat/ToDecimal(f, @isNeg, @decExp, @mant); [MAX_DIGITS] char digits; uint digCount := getDigits(@digits, mant); if code = 'f' then uint chosenBefore, chosenAfter; if checkFloatF(cm_fCheck, @digits, doPlus, isNeg, decExp, digCount, width, precision, @chosenBefore, @chosenAfter) then fmtFloatF(ob, doZero, doPlus, isNeg, decExp, mant, chosenBefore, chosenAfter); return; fi; precision := 0; elif code = 'g' then uint chosenBefore, chosenAfter; if checkFloatF(cm_gCheck, @digits, doPlus, isNeg, decExp, digCount, width, precision, @chosenBefore, @chosenAfter) then fmtFloatF(ob, doZero, doPlus, isNeg, decExp, mant, chosenBefore, chosenAfter); return; fi; precision := 0; fi; fmtFloatE(ob, doCap, doZero, isNeg, decExp, mant, width, precision); corp; /* * fmtFloat0, etc. - short forms. * * run-time */ export proc fmtFloat0(float f; string format; uint width, precision)void: fmtFloat1(FmtDefaultOBuf, f, format, width, precision); corp; export proc fmtFloat00(float f)void: fmtFloat1(FmtDefaultOBuf, f, "g", 0, 0); corp; export proc fmtFloat01(CharBuffer/OBuf_t ob; float f)void: fmtFloat1(ob, f, "g", 0, 0); corp; export proc fmtFloat10(float f; string format)void: fmtFloat1(FmtDefaultOBuf, f, format, 0, 0); corp; export proc fmtFloat11(CharBuffer/OBuf_t ob; float f; string format)void: fmtFloat1(ob, f, format, 0, 0); corp; export proc fmtFloat20(float f; uint width)void: fmtFloat1(FmtDefaultOBuf, f, "g", width, 0); corp; export proc fmtFloat21(CharBuffer/OBuf_t ob; float f; uint width)void: fmtFloat1(ob, f, "g", width, 0); corp; export proc fmtFloat30(float f; string format; uint width)void: fmtFloat1(FmtDefaultOBuf, f, format, width, 0); corp; export proc fmtFloat31(CharBuffer/OBuf_t ob; float f; string format; uint width)void: fmtFloat1(ob, f, format, width, 0); corp; export proc fmtFloat40(float f; uint width, precision)void: fmtFloat1(FmtDefaultOBuf, f, "g", width, precision); corp; export proc fmtFloat41(CharBuffer/OBuf_t ob; float f; uint width, precision)void: fmtFloat1(ob, f, "g", width, precision); corp; /* * doFloat - generate a call to a floating point formatting routine. * * compile-time */ proc doFloat(FmtCookie_t fc)void: Package/PContext_t pctx := fc.fc_pctx; /* What I was mainly doing here with the "allAreConstant" testing was to be able to produce the two error messages at compile time, whenever I could. However, as soon as the infrastructure is in place to do that, then turning the float to a string at compile time is only a few more lines of code. Doing this for float values makes some sense, since the run time cost of formatting a float is relatively large. With the other types, the cost is low, and the string constants may end up being larger than the call to the formatting routine. */ string format := fc.fc_format; Exec/Exec_t mainExec := fc.fc_mainExec, widthExec := fc.fc_widthExec, precisionExec := fc.fc_precisionExec; bool allAreConstant := Exec/IsFloatConstantExpr(mainExec); uint width := 0, precision := 0; if allAreConstant and widthExec ~= nil then if Exec/IsUintConstantExpr(widthExec) then eval Exec/GetUintConstantExpr(pctx, widthExec, @width); else allAreConstant := false; fi; fi; if allAreConstant and precisionExec ~= nil then if Exec/IsUintConstantExpr(precisionExec) then eval Exec/GetUintConstantExpr(pctx, precisionExec, @precision); else allAreConstant := false; fi; fi; if allAreConstant then char code := 'g'; bool doCap := false, doZero := false, doPlus := false; if format ~== nil then eval getFloatFormat(format, @code, @doCap, @doZero, @doPlus); fi; float f; eval Exec/GetFloatConstantExpr(mainExec, @f); if code ~= 'e' then bool isNeg; sint decExp; uint mant; if IeeeFloat/ToDecimal(f, @isNeg, @decExp, @mant) then [MAX_DIGITS] char digits; uint digCount := getDigits(@digits, mant); uint chosenBefore, chosenAfter; if not checkFloatF(cm_ctError, @digits, doPlus, isNeg, decExp, digCount, width, precision, @chosenBefore, @chosenAfter) then if code = 'f' then /* Value does not fit in specified \"f\" format */ emitError(pctx, 21); elif width ~= 0 and width < E_MIN then /* Width is too small for \"e\" format */ emitError(pctx, 20); fi; fi; fi; fi; CharBuffer/OBuf_t ob := CharBuffer/OCreate(); fmtFloat1(ob, f, format, width, precision); string s := CharBuffer/OToString(ob); fc.fc_mainExec := Exec/StringConstantNew(s); fc.fc_widthExec := nil; fc.fc_precisionExec := nil; doDirect("String", fc); else if format == nil then if widthExec = nil then addCall01("fmtFloat0", fc, mainExec, nil, nil, nil); elif precisionExec = nil then addCall01("fmtFloat2", fc, mainExec, widthExec, nil, nil); else addCall01("fmtFloat4", fc, mainExec, widthExec, precisionExec, nil); fi; else Exec/Exec_t fmtExec := Exec/StringConstantNew(format); if widthExec = nil then addCall01("fmtFloat1", fc, mainExec, fmtExec, nil, nil); elif precisionExec = nil then addCall01("fmtFloat3", fc, mainExec, fmtExec, widthExec, nil); else addCall01("fmtFloat", fc, mainExec, fmtExec, widthExec, precisionExec); fi; fi; fi; corp; /******************************** non-basic types ****************************/ /* * fmtPtr - output formatting for pointers (and '@'s). * * run-time */ export proc fmtPtr1(CharBuffer/OBuf_t ob; uint p)void: if p = 0x0 then CharBuffer/OString(ob, ""); else CharBuffer/OString(ob, "0x"); CharBuffer/Buf_t buf; uint len := fmtDigits(p, 16, @buf); CharBuffer/OBufR(ob, @buf, CharBuffer/BUF_SIZE - len); fi; corp; /* * fmtPtrW - output format a pointer within a field width. * * run-time */ export proc fmtPtrW1(CharBuffer/OBuf_t ob; uint p, width)void: if p = 0x0 then if width > 5 then pad(ob, width - 5); fi; CharBuffer/OString(ob, ""); else if width > CharBuffer/BUF_SIZE then width := CharBuffer/BUF_SIZE; fi; CharBuffer/Buf_t buf; uint len := fmtDigits(p, 16, @buf); uint pos := CharBuffer/BUF_SIZE - len; len := len + 2; /* Account for the leading 0x */ while len < width do pos := pos - 1; buf[pos] := '0'; len := len + 1; od; pos := pos - 1; buf[pos] := 'x'; pos := pos - 1; buf[pos] := '0'; CharBuffer/OBufR(ob, @buf, pos); fi; corp; /* * fmtPtr0 and fmtPtr1 - stubs with no Buf_t parameter. */ export proc fmtPtr0(uint p)void: fmtPtr1(FmtDefaultOBuf, p); corp; export proc fmtPtrW0(uint p, width)void: fmtPtrW1(FmtDefaultOBuf, p, width); corp; /* * doPointer - generate the appropriate code for some kind of pointer * reference - pointer, '@' or 'any'. * * compile-time */ proc doPointer(FmtCookie_t fc)void: Exec/Exec_t mainExec := fc.fc_mainExec; if mainExec.ex_kind ~= Exec/exk_toUint then /* Could already have one - see "fmtDoField", below. */ mainExec := Exec/ToUintNew(fc.fc_pctx, mainExec); fi; if fc.fc_widthExec ~= nil then addCall01("fmtPtrW", fc, mainExec, fc.fc_widthExec, nil, nil); else addCall01("fmtPtr", fc, mainExec, nil, nil, nil); fi; corp; /* * fmtEnum{01} - output of an enum value with no field width. * * run-time */ export proc fmtEnum1(CharBuffer/OBuf_t ob; uint n; Types/Type_t t)void: CharBuffer/OString(ob, Types/EnumToString(n, t)); corp; export proc fmtEnum0(uint n; Types/Type_t t)void: CharBuffer/OString(FmtDefaultOBuf, Types/EnumToString(n, t)); corp; /* * fmtEnumLeft{01} - output an enum left-justified in a field. * * run-time */ export proc fmtEnumLeft1(CharBuffer/OBuf_t ob; uint n; uint width; Types/Type_t t)void: fmtStringLeft1(ob, Types/EnumToString(n, t), width); corp; export proc fmtEnumLeft0(uint n; uint width; Types/Type_t t)void: fmtStringLeft1(FmtDefaultOBuf, Types/EnumToString(n, t), width); corp; /* * fmtEnumCenter{01} - output an enum centered in a field. * * run-time */ export proc fmtEnumCenter1(CharBuffer/OBuf_t ob; uint n; uint width; Types/Type_t t)void: fmtStringCenter1(ob, Types/EnumToString(n, t), width); corp; export proc fmtEnumCenter0(uint n; uint width; Types/Type_t t)void: fmtStringCenter1(FmtDefaultOBuf, Types/EnumToString(n, t), width); corp; /* * fmtEnumRight{01} - output an enum right-justified in a field. * * run-time */ export proc fmtEnumRight1(CharBuffer/OBuf_t ob; uint n; uint width; Types/Type_t t)void: fmtStringRight1(ob, Types/EnumToString(n, t), width); corp; export proc fmtEnumRight0(uint n; uint width; Types/Type_t t)void: fmtStringRight1(FmtDefaultOBuf, Types/EnumToString(n, t), width); corp; /* * fmtRecord{01} - output of a record selector value with no field width. * * run-time */ export proc fmtRecord1(CharBuffer/OBuf_t ob; uint n; Types/Type_t t)void: CharBuffer/OString(ob, Types/VariantToString(n, t)); corp; export proc fmtRecord0(uint n; Types/Type_t t)void: CharBuffer/OString(FmtDefaultOBuf, Types/VariantToString(n, t)); corp; /* * fmtRecordLeft{01} - output a record selector left-justified in a field. * * run-time */ export proc fmtRecordLeft1(CharBuffer/OBuf_t ob; uint n; uint width; Types/Type_t t)void: fmtStringLeft1(ob, Types/VariantToString(n, t), width); corp; export proc fmtRecordLeft0(uint n; uint width; Types/Type_t t)void: fmtStringLeft1(FmtDefaultOBuf, Types/VariantToString(n, t), width); corp; /* * fmtRecordCenter{01} - output a record selector centered in a field. * * run-time */ export proc fmtRecordCenter1(CharBuffer/OBuf_t ob; uint n; uint width; Types/Type_t t)void: fmtStringCenter1(ob, Types/VariantToString(n, t), width); corp; export proc fmtRecordCenter0(uint n; uint width; Types/Type_t t)void: fmtStringCenter1(FmtDefaultOBuf, Types/VariantToString(n, t), width); corp; /* * fmtRecordRight{01} - output a record selector right-justified in a field. * * run-time */ export proc fmtRecordRight1(CharBuffer/OBuf_t ob; uint n; uint width; Types/Type_t t)void: fmtStringRight1(ob, Types/VariantToString(n, t), width); corp; export proc fmtRecordRight0(uint n; uint width; Types/Type_t t)void: fmtStringRight1(FmtDefaultOBuf, Types/VariantToString(n, t), width); corp; /* * fmtOneof{01} - output of a oneof value with no field width. * * run-time */ export proc fmtOneof1(CharBuffer/OBuf_t ob; uint n; Types/Type_t t)void: CharBuffer/OString(ob, Types/OneofToString(n, t)); corp; export proc fmtOneof0(uint n; Types/Type_t t)void: CharBuffer/OString(FmtDefaultOBuf, Types/OneofToString(n, t)); corp; /* * fmtOneofLeft{01} - output a oneof left-justified in a field. * * run-time */ export proc fmtOneofLeft1(CharBuffer/OBuf_t ob; uint n; uint width; Types/Type_t t)void: fmtStringLeft1(ob, Types/OneofToString(n, t), width); corp; export proc fmtOneofLeft0(uint n; uint width; Types/Type_t t)void: fmtStringLeft1(FmtDefaultOBuf, Types/OneofToString(n, t), width); corp; /* * fmtOneofCenter{01} - output a oneof centered in a field. * * run-time */ export proc fmtOneofCenter1(CharBuffer/OBuf_t ob; uint n; uint width; Types/Type_t t)void: fmtStringCenter1(ob, Types/OneofToString(n, t), width); corp; export proc fmtOneofCenter0(uint n; uint width; Types/Type_t t)void: fmtStringCenter1(FmtDefaultOBuf, Types/OneofToString(n, t), width); corp; /* * fmtOneofRight{01} - output a oneof right-justified in a field. * * run-time */ export proc fmtOneofRight1(CharBuffer/OBuf_t ob; uint n; uint width; Types/Type_t t)void: fmtStringRight1(ob, Types/OneofToString(n, t), width); corp; export proc fmtOneofRight0(uint n; uint width; Types/Type_t t)void: fmtStringRight1(FmtDefaultOBuf, Types/OneofToString(n, t), width); corp; /* * doEnumish - generate calls to format an enum, oneof or record selector * value. * * compile-time */ proc doEnumish(FmtCookie_t fc; string tag)void: Exec/Exec_t mainExec := fc.fc_mainExec, typeExec := Exec/TypeNew(fc.fc_pctx, mainExec.ex_type); mainExec := Exec/ToUintNew(fc.fc_pctx, mainExec); if fc.fc_widthExec ~= nil then fc.fc_mainExec := mainExec; addLCR(tag, fc, typeExec); else addCall01("fmt" + tag, fc, mainExec, typeExec, nil, nil); fi; corp; /* * showBitsValue - recursive helper for fmtBits1. We are passed the value * of the entire bits value, the bits type to show, and the bit offset * within the Basic/BYTES_PER_WORD sized value that the fields of this * bits type begin at. This routine is recursive. * * run-time */ proc showBitsValue(CharBuffer/OBuf_t ob; uint n; Types/Type_t t; uint bitOffset)void: t := Types/SkipExec(t); Types/Type_t tCopy := t; string name := ""; case tCopy.t_kind incase Types/tk_named: Types/NamedDesc_t nd := tCopy.t_named; name := nd.nd_name; t := Types/SkipExec(nd.nd_subType); default: esac; case t.t_kind incase Types/tk_bits: uint byteSize := t.t_byteSize; CharBuffer/OString(ob, name); CharBuffer/OChar(ob, '('); [] ro Types/BitsField_t fldVec := t.t_bits.bd_fldVec; uint count := getBound(fldVec); for uint i from 1 upto count do bool addComma := i ~= count; Types/BitsField_t bf := fldVec[i - 1]; uint shift := Basic/BYTES_PER_WORD * Basic/BITS_PER_BYTE - bf.bf_bitWidth - bf.bf_bitOffset - bitOffset; uint n2 := (n >> shift) & ((1 << bf.bf_bitWidth) - 1); case bf.bf_kind incase Types/bfk_named: Types/Type_t t2 := bf.bf_named.nbf_type; Types/Type_t tSkipped := Types/SkipNameAndExec(t2); case tSkipped.t_kind incase Types/tk_basic: case tSkipped.t_basic.bd_code incase Types/btc_bool: CharBuffer/OChar(ob, if n2 ~= 0 then 'T' else 'F' fi); incase Types/btc_char: Char/Fmt(ob, n2 + '\0'); incase Types/btc_uint: CharBuffer/OUint(ob, n2); default: esac; incase Types/tk_bits: showBitsValue(ob, n, t2, bf.bf_bitOffset + bitOffset); incase Types/tk_oneof: fmtOneof1(ob, n2, t2); default: esac; incase Types/bfk_fixed: uint n3; eval Exec/GetUintConstantExpr(nil, bf.bf_fixed, @n3); if n2 ~= n3 then /* The actual value at run-time is not the same as the value that the bits type says should be there. Complain, showing both values. */ CharBuffer/OString(ob, "<>"); else addComma := false; fi; esac; if addComma then CharBuffer/OString(ob, ", "); fi; od; CharBuffer/OChar(ob, ')'); default: esac; corp; /* * fmtBits{01} - output a bits value. * * run-time */ export proc fmtBits1(CharBuffer/OBuf_t ob; uint n; Types/Type_t t)void: /* The value we get will be at the upper end of a value whose size is 1, 2, 4 or 8 bytes, and is the minimum of those that will hold all of the needed bits. */ showBitsValue(ob, n, t, (Basic/BYTES_PER_WORD - t.t_byteSize) * Basic/BITS_PER_BYTE); corp; export proc fmtBits0(uint n; Types/Type_t t)void: fmtBits1(FmtDefaultOBuf, n, t); corp; /* * doBits - generate calls to format a bits value. * * compile-time */ proc doBits(FmtCookie_t fc)void: Exec/Exec_t mainExec := fc.fc_mainExec, typeExec := Exec/TypeNew(fc.fc_pctx, mainExec.ex_type); addCall01("fmtBits", fc, Exec/ToUintNew(fc.fc_pctx, mainExec), typeExec, nil, nil); corp; /******************************** main interfaces ****************************/ /* * flush - flush the default output buffer. * * run-time */ export proc flush()void: CharBuffer/OFlush(FmtDefaultOBuf); corp; /* * oToString - provide our wrapper for CharBuffer/OToString in case the * context we are producing code for does not have a "use" for CharBuffer. * * run-time */ export proc oToString(CharBuffer/OBuf_t ob)string: CharBuffer/OToString(ob) corp; /* * FmtPhaseHandler - this is the phaseHandler that we register with the Exec * code. It receives the various callouts driven by the parser. This * routine is exported to code that wishes to use Fmt services. For * example, see Debug. * * compile-time */ export proc FmtPhaseHandler(FmtCookie_t fc; Exec/Exec_t ex; Exec/IoPhase_t iop)bool: Package/PContext_t pctx := fc.fc_pctx; bool hasError := false; case iop incase Exec/iop_main: fc.fc_mainExec := ex; incase Exec/iop_width: Types/Type_t t := Types/SkipNameAndExec(fc.fc_mainExec.ex_type); case t.t_kind incase Types/tk_basic: case t.t_basic.bd_code incase Types/btc_char: incase Types/btc_string: if fc.fc_format ~== nil and fc.fc_format = "f" then /* Cannot have width with "f" 'char' or 'string' format */ emitError(pctx, 29); hasError := true; fi; incase Types/btc_float: if fc.fc_format ~== nil and getBound(fc.fc_format) > 0 and Exec/IsUintConstantExpr(ex) then uint width; eval Exec/GetUintConstantExpr(pctx, ex, @width); char code := Char/ToLower(fc.fc_format[0]); if code = 'e' then if width < E_MIN then /* Width is too small for "e" format */ emitError(pctx, 20); hasError := true; fi; elif code = 'f' then if width < 2 then /* Width is too small for "f" format */ emitError(pctx, 22); hasError := true; fi; fi; fi; default: esac; default: esac; fc.fc_widthExec := ex; incase Exec/iop_precision: Types/Type_t t := Types/SkipNameAndExec(fc.fc_mainExec.ex_type); case t.t_kind incase Types/tk_basic: if t.t_basic.bd_code = Types/btc_float then if fc.fc_format ~== nil and getBound(fc.fc_format) > 0 and Char/ToLower(fc.fc_format[0]) = 'x' then /* Cannot have precision with "x" 'float' format */ emitError(pctx, 23); hasError := true; fi; else /* Only 'float' basic type can have a precision */ emitError(pctx, 1); hasError := true; ex := nil; fi; incase Types/tk_named: /* Do nothing - just accept it. */ ; incase Types/tk_ref: incase Types/tk_pointer: incase Types/tk_enum: incase Types/tk_array: incase Types/tk_matrix: incase Types/tk_struct: incase Types/tk_record: incase Types/tk_recordSelector: incase Types/tk_union: incase Types/tk_bits: incase Types/tk_oneof: incase Types/tk_proc: incase Types/tk_exec: incase Types/tk_genericParam: incase Types/tk_interface: incase Types/tk_capsule: /* Cannot have precision with this kind of type */ emitError(pctx, 4); hasError := true; ex := nil; esac; fc.fc_precisionExec := ex; incase Exec/iop_done: Types/Type_t t := Types/SkipExec(fc.fc_mainExec.ex_type); case t.t_kind incase Types/tk_named: Names/Info_t inf := Types/ExportFind(t, "fmt"); if inf ~= nil then case inf.inf_kind incase Names/infk_proc: /* This type has a custom formatting routine. Use it. */ addCustomCall(inf.inf_proc, fc); return false; default: esac; fi; default: esac; t := Types/SkipNameAndExec(fc.fc_mainExec.ex_type); case t.t_kind incase Types/tk_basic: case t.t_basic.bd_code incase Types/btc_error: addCall01("fmtError", fc, nil, nil, nil, nil); incase Types/btc_void: addCall01("fmtVoid", fc, nil, nil, nil, nil); incase Types/btc_nil: addCall01("fmtNil", fc, nil, nil, nil, nil); incase Types/btc_poly: addCall01("fmtPoly", fc, nil, nil, nil, nil); incase Types/btc_arbptr: doPointer(fc); incase Types/btc_bool: doBool(fc); incase Types/btc_char: doCharString(false, fc); incase Types/btc_uint: /* "p" is a special case used by "fmtDoField", below. */ if fc.fc_format ~== nil and fc.fc_format = "p" then doPointer(fc); else doUintOrSint("Uint", fc); fi; incase Types/btc_sint: doUintOrSint("Sint", fc); incase Types/btc_float: doFloat(fc); incase Types/btc_string: doCharString(true, fc); incase Types/btc_any: doPointer(fc); incase Types/btc_bits8: incase Types/btc_bits16: incase Types/btc_bits32: incase Types/btc_bits64: BI/Abort("Unexpected basic type in phaseHandler/iop_done"); esac; incase Types/tk_ref: Types/Type_t t2 := Types/SkipExec(t.t_ref.pd_subType); case t2.t_kind incase Types/tk_named: Names/Info_t inf := Types/ExportFind(t2, "fmt"); if inf ~= nil then case inf.inf_kind incase Names/infk_proc: /* Use a custom formatting routine for the ref-ed type. */ addCustomCall(inf.inf_proc, fc); return false; default: esac; fi; default: esac; doPointer(fc); incase Types/tk_pointer: incase Types/tk_matrix: incase Types/tk_record: incase Types/tk_interface: incase Types/tk_capsule: doPointer(fc); incase Types/tk_recordSelector: doEnumish(fc, "Record"); incase Types/tk_enum: doEnumish(fc, "Enum"); incase Types/tk_bits: doBits(fc); incase Types/tk_oneof: doEnumish(fc, "Oneof"); incase Types/tk_proc: /* The actual parameter is of a proc type, so it is a proc expression or a proc name itself. An explicit proc will end up having used "Proc/FmtProc". We just print the value in hex. %%%% print byteCode addr. */ doPointer(fc); incase Types/tk_array: addCall01("fmtArray", fc, nil, nil, nil, nil); incase Types/tk_struct: addCall01("fmtStruct", fc, nil, nil, nil, nil); incase Types/tk_union: addCall01("fmtUnion", fc, nil, nil, nil, nil); incase Types/tk_named: incase Types/tk_exec: incase Types/tk_genericParam: /* Unexpected type kind for Fmt parameter */ emitError(pctx, 11); hasError := true; esac; /* Clear out the FmtCookie_t - it is used for all of the cycles for a given Fmt call. */ fc.fc_mainExec := nil; fc.fc_format := nil; fc.fc_widthExec := nil; fc.fc_precisionExec := nil; /* Don't clear fc_bufExec or fc_endingMode - they must stay until the iop_complete, and then the FmtCookie_t is freed anyway. */ incase Exec/iop_complete: case fc.fc_endingMode incase em_nothing: addCall(pctx, "flush", nil, nil, nil, nil, nil); incase em_line: fc.fc_mainExec := Exec/CharConstantNew('\n'); doDirect("Char", fc); addCall(pctx, "flush", nil, nil, nil, nil, nil); incase em_buffer: /* We don't flush a user-provided OBuf_t. */ ; incase em_string: /* FmtS has set fc.fc_bufExec to be an Exec_t that references the local variable it has put FmtTempOBuf into. */ if useExists(pctx, CharBuffer) then callCharBuffer(pctx, "OToString", fc.fc_bufExec, nil); else addCall(pctx, "oToString", fc.fc_bufExec, nil, nil, nil, nil); fi; esac; esac; hasError corp; /* * FmtFormatHandler - this interface is called via the Exec code to provide any * user-specified format string. The provided format codes are checked * here, so that error indicators for them can come out at the proper * place relative to the source being parsed. This routine is exported to * other code which wants to use Fmt's facilities for output formatting. * * compile-time */ export proc FmtFormatHandler(FmtCookie_t fc; string format)bool: Package/PContext_t pctx := fc.fc_pctx; bool hasError := false; char code; bool cap, zero, plus; Types/Type_t t := Types/SkipNameAndExec(fc.fc_mainExec.ex_type); case t.t_kind incase Types/tk_basic: case t.t_basic.bd_code incase Types/btc_error: incase Types/btc_void: incase Types/btc_nil: incase Types/btc_poly: /* Cannot have format code with this kind of type */ emitError(pctx, 14); hasError := true; incase Types/btc_arbptr: /* Cannot have format code with pointer, matrix, record, bits or proc type */ emitError(pctx, 24); hasError := true; incase Types/btc_bool: if format ~= "l" and format ~= "c" and format ~= "r" then /* Unknown format code "X" for 'bool' value */ emitErrorName(pctx, 15, format, 16); hasError := true; format := "l"; fi; incase Types/btc_char: if format ~= "l" and format ~= "c" and format ~= "r" and format ~= "f" then /* Unknown format code "X" for 'char' value */ emitErrorName(pctx, 9, format, 10); hasError := true; format := "l"; fi; incase Types/btc_uint: /* "p" is a special case, generated by "fmtDoField", below. */ if not getUintFormat(format, @code, @cap, @zero, @plus) and format ~= "p" then /* Unknown format code "X" for 'uint' value */ emitErrorName(pctx, 2, format, 3); hasError := true; format := "d"; fi; incase Types/btc_sint: if not getSintFormat(format, @code, @cap, @zero, @plus) then /* Unknown format code "X" for 'sint' value */ emitErrorName(pctx, 5, format, 6); hasError := true; format := "d"; fi; incase Types/btc_float: if not getFloatFormat(format, @code, @cap, @zero, @plus) then /* Unknown format code "X" for 'float' value */ emitErrorName(pctx, 7, format, 8); hasError := true; format := "g"; fi; incase Types/btc_string: if format ~= "l" and format ~= "c" and format ~= "r" and format ~= "f" then /* Unknown format code "X" for 'string' value */ emitErrorName(pctx, 12, format, 13); hasError := true; format := "l"; fi; incase Types/btc_any: /* Cannot have format code with 'any' */ emitError(pctx, 19); hasError := true; format := nil; incase Types/btc_bits8: incase Types/btc_bits16: incase Types/btc_bits32: incase Types/btc_bits64: BI/Abort("Unexpected basic type in formatHandler"); esac; incase Types/tk_enum: if format ~= "l" and format ~= "c" and format ~= "r" then /* Unknown format code "X" for enum value */ emitErrorName(pctx, 17, format, 18); hasError := true; format := "l"; fi; incase Types/tk_oneof: if format ~= "l" and format ~= "c" and format ~= "r" then /* Unknown format code "X" for 'oneof' value */ emitErrorName(pctx, 25, format, 26); hasError := true; format := "l"; fi; incase Types/tk_recordSelector: if format ~= "l" and format ~= "c" and format ~= "r" then /* Unknown format code "X" for record selector value */ emitErrorName(pctx, 27, format, 28); hasError := true; format := "l"; fi; incase Types/tk_ref: bool hasCustom := false; Types/Type_t t2 := Types/SkipExec(t.t_ref.pd_subType); case t2.t_kind incase Types/tk_named: Names/Info_t inf := Types/ExportFind(t2, "fmt"); if inf ~= nil then case inf.inf_kind incase Names/infk_proc: hasCustom := true; default: esac; fi; default: esac; if not hasCustom then /* Cannot have format code with pointer, matrix, record, bits or proc type */ emitError(pctx, 24); hasError := true; fi; incase Types/tk_pointer: incase Types/tk_matrix: incase Types/tk_record: incase Types/tk_bits: incase Types/tk_proc: /* Cannot have format code with pointer, matrix, record, bits or proc type */ emitError(pctx, 24); hasError := true; incase Types/tk_named: incase Types/tk_array: incase Types/tk_struct: incase Types/tk_union: incase Types/tk_exec: incase Types/tk_genericParam: incase Types/tk_interface: incase Types/tk_capsule: /* Cannot have format code with this kind of type */ emitError(pctx, 14); hasError := true; esac; fc.fc_format := format; hasError corp; /* Interaction with the parser and the Exec code requires that we implement Exec/ActiveIoCall_t. We use our FmtCookie_t as a capsule field. */ capsule FmtActiveIoCall_t implements Exec/ActiveIoCall_t { fields { FmtCookie_t faiocl_fc; }; procs Exec/ActiveIoCall_t { proc PhaseHandler(FmtActiveIoCall_t faiocl; Exec/Exec_t ex; Exec/IoPhase_t iop)bool: FmtPhaseHandler(faiocl.faiocl_fc, ex, iop) corp; proc FormatHandler(FmtActiveIoCall_t faiocl; string format)bool: FmtFormatHandler(faiocl.faiocl_fc, format) corp; }; }; /* * fmtSetupTemp - setup our FmtTempOBuf if it has not already been setup. * Return the value. * * run-time */ export proc fmtSetupTemp()CharBuffer/OBuf_t: if FmtTempOBuf = nil then FmtTempOBuf := CharBuffer/OCreate(); fi; FmtTempOBuf corp; /* * createCookie - create and return a new FmtCookie_t, with the given initial * values. * * compile-time */ proc createCookie(Package/PContext_t pctx; Exec/Exec_t bufExec; EndingMode_t em)FmtCookie_t: FmtCookie_t(pctx, bufExec, nil, nil, nil, nil, em) corp; /* * Cookie - exported routine to create a new FmtCookie_t for external code * that wishes to use Fmt's services. * * Note: since Fmt generates calls to its own internal routines, any * ultimate user of code which uses Fmt's services must "use" Fmt. * * compile-time, exported */ export proc Cookie(Package/PContext_t pctx)FmtCookie_t: createCookie(pctx, nil, em_nothing) corp; /* * fmtCommon - common code for Fmt, FmtB and FmtS. Create the FormatCookie_t * that tracks this call, and interface with Exec code to receive * callouts as the parser handles ioProc arguments. * * compile-time */ proc fmtCommon(Package/PContext_t pctx; Exec/Exec_t bufExec; EndingMode_t em)void: FmtCookie_t fc := createCookie(pctx, bufExec, em); Exec/ProvideIoHandler(pctx, FmtActiveIoCall_t(fc)); corp; /* * Fmt - format arguments to the default output. An internal CharBuffer/OBuf_t * is used to buffer the output, and that is flushed at the end of the * call. * * compile-time, ioProc, exported */ export proc ioProc Fmt(Package/PContext_t pctx)void: fmtCommon(pctx, nil, em_nothing); corp; /* * FmtL - format arguments to the default output, just like Fmt. However, * arrange to add a newline at the end of the output. * * compile-time, ioProc, exported */ export proc ioProc FmtL(Package/PContext_t pctx)void: fmtCommon(pctx, nil, em_line); corp; /* * FmtB - format arguments to a provided CharBuffer/OBuf_t. We do not flush * the OBuf_t - that is under control of the caller. * * compile-time, ioProc, exported */ export proc ioProc FmtB(Package/PContext_t pctx; Exec/Exec_t bufExec)void: if Types/SkipExec(bufExec.ex_type) ~= CharBuffer/OBuf_t then /* First parameter to "FmtB" must be "CharBuffer/Buf_t" */ emitError(pctx, 30); fi; Exec/Exec_t newBuf := bufExec; case bufExec.ex_kind incase Exec/exk_procParam: incase Exec/exk_localVarRef: /* Do nothing - just use the reference directly. */ ; default: /* Make a local copy and use that. */ newBuf := Exec/CreateLocalCopy(pctx, bufExec); esac; fmtCommon(pctx, newBuf, em_buffer); corp; /* * FmtS - format arguments into a temporary buffer, and return a string * containing all of the result. * * compile-time, ioProc, exported */ export proc ioProc FmtS(Package/PContext_t pctx)string: /* Also generate a call to fmtSetupTemp to create FmtTempOBuf (if it has not been previously created) and return FmtTempOBuf. We then use that, copied to a local variable, during this FmtS call. */ Package/NameReference_t nr := Package/CreateReference(pctx, ., "fmtSetupTemp"); Exec/TempCall_t tcal; Exec/CallStart(@tcal, pctx, Exec/PackageNameRefNew(pctx, nr)); Exec/Exec_t ex := closeCall(@tcal, nil, nil, nil, nil, nil); ex := Exec/CreateLocalCopy(pctx, ex); fmtCommon(pctx, ex, em_string); nil corp; /* * Provide a package initialization routine to setup FmtDefaultOBuf and * FmtTempOBuf. * * run-time */ proc __PackageInit__()void: FmtDefaultOBuf := CharBuffer/OCreateStdout(100); FmtTempOBuf := nil; corp; /* * fmtStartCall - helper for FmtCreate that starts a call to "FmtB". Return * the Exec/TempIoCall_t. * * compile-time (run-time of FmtCreate) */ proc fmtStartCall(Package/PContext_t pctx; Exec/Exec_t bufEx)Exec/TempIoCall_t: Package/NameReference_t nr := Package/CreateReference(pctx, ., "FmtB"); Exec/TempCall_t tcal; Exec/CallStart(@tcal, pctx, Exec/PackageNameRefNew(pctx, nr)); Exec/CallAppend(@tcal, bufEx); Exec/Call_t cl; eval Exec/CallNew(@tcal, @cl); Exec/IoCallStart(pctx, cl) corp; /* * fmtAddChar - helper for FmtCreate that adds a character output to the * FmtB call being built up. * * compile-time (run-time of FmtCreate) */ proc fmtAddChar(Exec/TempIoCall_t tioc; char ch)void: Exec/IoCallPhase(tioc, Exec/CharConstantNew(ch), Exec/iop_main); Exec/IoCallPhase(tioc, nil, Exec/iop_done); corp; /* * fmtAddString - helper for FmtCreate that adds a string output to the * FmtB call being built up. * * compile-time (run-time of FmtCreate) */ proc fmtAddString(Exec/TempIoCall_t tioc; string s)void: Exec/IoCallPhase(tioc, Exec/StringConstantNew(s), Exec/iop_main); Exec/IoCallPhase(tioc, nil, Exec/iop_done); corp; /* Forward-declare fmtDoField so that fmtDoArray can call it. */ proc fmtDoField(Exec/TempIoCall_t tioc; Exec/Exec_t bufEx, fldEx; Types/Type_t flType; @ string pendingStr)Exec/TempIoCall_t; /* * fmtDoArray - helper for fmtDoField that handles array fields. We generate * a 'for' loop to iterate over the array elements. Note that we * arbitrarily limit the number of array elements that we will show. * * compile-time (run-time of FmtCreate) */ proc fmtDoArray(Exec/TempIoCall_t tioc; Exec/Exec_t bufEx, fldEx; Types/ArrayDesc_t ad; @ string pendingStr)Exec/TempIoCall_t: Package/PContext_t pctx := tioc.tioc_pctx; Exec/EContext_t ectx := pctx.pctx_ectx; uint dimCount := getBound(ad.ad_dims); if dimCount ~= 1 then /* Don't try to handle multi-dimensional arrays. */ pendingStr@ := pendingStr@ + "[...]"; return tioc; fi; uint count := ad.ad_dims[0].dd_value; if count = 0 then /* 0-sized array - presumeably from a compilation error. */ pendingStr@ := pendingStr@ + "[]"; return tioc; fi; if pendingStr@ ~= "" then fmtAddString(tioc, pendingStr@ + "["); /* pendingStr is unconditionally assigned below */ else fmtAddChar(tioc, '['); fi; bool truncated := false; Types/Type_t elType := ad.ad_elementType, tSkipped := Types/SkipNameAndExec(elType); case tSkipped.t_kind incase Types/tk_struct: incase Types/tk_array: /* Pick magic value 5 out of the air. */ if count > 5 then count := 5; truncated := true; fi; incase Types/tk_basic: incase Types/tk_named: incase Types/tk_ref: incase Types/tk_pointer: incase Types/tk_enum: incase Types/tk_genericParam: incase Types/tk_matrix: incase Types/tk_bits: incase Types/tk_oneof: incase Types/tk_proc: incase Types/tk_exec: incase Types/tk_record: incase Types/tk_recordSelector: incase Types/tk_union: incase Types/tk_interface: incase Types/tk_capsule: /* Another magic value. */ if count > 10 then count := 10; truncated := true; fi; esac; /* Since we need a 'for' loop to iterate over the elements, we must end the outstanding "FmtB" call that our caller has open. */ Exec/Exec_t ex := Exec/IoCallDone(tioc); Exec/SequenceAppend(pctx, ex); /* Create a scope to hold the 'for' loop and its variable. */ Exec/ScopeStart(pctx); /* Create the 'for' loop to display the array elements. This includes a scope for the statements of the 'for' body. */ Exec/TempFor_t tf; Exec/ForStart(@tf, pctx); Exec/ForVariable(@tf, Types/Uint, Exec/CreateNewName(pctx.pctx_ectx)); Exec/ForInit(@tf, Exec/UintConstantNew(nil, 0)); Exec/ForLimit(@tf, Exec/UintConstantNew(nil, count - 1)); Exec/ScopeStart(pctx); /* Inside the 'for' loop, we want to conditionally insert ", ". */ Exec/Exec_t forVarEx := Exec/LocalVariableRefNew(tf.tf_variable); Exec/TempBinary_t tbin; Exec/BinaryStart(@tbin, pctx, forVarEx, Exec/bo_notEqual); ex := Exec/BinaryNew(@tbin, Exec/UintConstantNew(nil, 0)); Exec/TempIf_t tif; Exec/IfFirstCondition(@tif, pctx, ex); /* Create and use a "FmtB" call for ", " inside the 'if'. */ tioc := fmtStartCall(pctx, bufEx); fmtAddString(tioc, ", "); ex := Exec/IoCallDone(tioc); Exec/IfFirst(@tif, ex); ex := Exec/IfNew(@tif); Exec/SequenceAppend(pctx, ex); /* Create a "FmtB" call for the array element inside the 'for' loop. */ tioc := fmtStartCall(pctx, bufEx); /* Index the array with the 'for' variable. */ Exec/TempIndexing_t tix; Exec/IndexingStart(@tix, pctx, fldEx); Exec/IndexingAppend(@tix, forVarEx); ex := Exec/IndexingNew(@tix); /* Recursively use fmtDoField to format the array element. We do that call because we do not want the default formatting that "FmtB" does. */ string pendingStrInner := ""; tioc := fmtDoField(tioc, bufEx, ex, elType, @pendingStrInner); if pendingStrInner ~= "" then fmtAddString(tioc, pendingStrInner); fi; /* Close off the "FmtB" call inside the 'for' loop. */ ex := Exec/IoCallDone(tioc); Exec/SequenceAppend(pctx, ex); /* Close off the inner scope, the 'for' loop and the outer scope. */ ex := Exec/ScopeNew(pctx); ex := Exec/ForNew(@tf, ex); Exec/SequenceAppend(pctx, ex); ex := Exec/ScopeNew(pctx); Exec/SequenceAppend(pctx, ex); /* Now start a new "FmtB" call so that we leave things as our caller expects them. We have stuff here that we need output as well. */ tioc := fmtStartCall(pctx, bufEx); if truncated then pendingStr@ := "...]"; else pendingStr@ := "]"; fi; tioc corp; /* * fmtDoField - helper for FmtCreate that handles the output of one field * of the struct/record. * * compile-time (run-time of FmtCreate) */ proc fmtDoField(Exec/TempIoCall_t tioc; Exec/Exec_t bufEx, fldEx; Types/Type_t flType; @ string pendingStr)Exec/TempIoCall_t: string format := nil; Types/Type_t tSkipped := Types/SkipNameAndExec(flType); case tSkipped.t_kind incase Types/tk_basic: Types/BasicDesc_t bd := tSkipped.t_basic; case bd.bd_code incase Types/btc_char: incase Types/btc_string: /* Want enclosing quotes, and escaping. */ format := "f"; default: esac; incase Types/tk_named: incase Types/tk_ref: incase Types/tk_pointer: incase Types/tk_enum: incase Types/tk_genericParam: incase Types/tk_matrix: incase Types/tk_recordSelector: incase Types/tk_bits: incase Types/tk_oneof: incase Types/tk_proc: incase Types/tk_exec: ; incase Types/tk_record: incase Types/tk_interface: incase Types/tk_capsule: /* Just show address in hex. */ fldEx := Exec/ToUintNew(tioc.tioc_pctx, fldEx); format := "p"; incase Types/tk_struct: /* If the struct has its own custom formatting routine, then en-'@' the struct for use with that routine. Otherwise use default formatting, which just outputs "". It would be possible to re-use parts of FmtCreate and fmtDoField to allow proper formatting of the struct, but I choose not to do that, in order that default output not be too lengthy. If detailed output for a struct is desired within a larger entity, then the user can simply call FmtAdd to create a custom routine for the struct type. */ if Types/ExportFind(Types/SkipExec(flType), "fmt") ~= nil then fldEx := Exec/EnrefNew(tioc.tioc_pctx, fldEx); fi; incase Types/tk_array: /* This call is why we need to return a possibly-updated "tioc" value - a new one can be created inside "fmtDoArray". */ return fmtDoArray(tioc, bufEx, fldEx, tSkipped.t_array, pendingStr); incase Types/tk_union: pendingStr@ := pendingStr@ + ""; return tioc; esac; if pendingStr@ ~= "" then fmtAddString(tioc, pendingStr@); pendingStr@ := ""; fi; /* Note that these calls will end up in the main "FmtPhaseHandler" and "FmtFormatHandler" routines above, which will add code appropriate to the type of the field. This is happening because we are in the middle of building a call to "FmtB" (see fmtStartCall), which is an ioProc. "FmtB" runs at compile-time, which is now, since we are doing compiler- like things here. */ Exec/IoCallPhase(tioc, fldEx, Exec/iop_main); if format ~== nil then Exec/IoCallFormat(tioc, format); fi; Exec/IoCallPhase(tioc, nil, Exec/iop_done); tioc corp; /* * FmtCreate - this routine creates a "fmt" proc for a record, struct or * capsule type. The type must be presented as a named type. If a record * field is encountered, it is not handled by Fmt, but instead is directly * output in hex. This prevents recursion, and avoids problems with trying * to call the formatting routine we are currently producing. The created * proc is returned. Note that this routine can return nil if the type * passed is not one that it will build a formatting proc for. "procName" * is the desired name for the new proc, and typically starts with "Fmt". * If 'nil' is passed, a name will be created. * * normally compile-time, exported */ export proc FmtCreate(Package/PContext_t pctx; Types/Type_t t; string procName)Proc/Proc_t: case t.t_kind incase Types/tk_named: Types/NamedDesc_t nd := t.t_named; Types/Type_t t2 := nd.nd_subType; [] ro Types/Field_t fldVec; Types/Type_t mainType; bool isStruct; case t2.t_kind incase Types/tk_struct: fldVec := t2.t_struct.sd_fldVec; mainType := Types/RefNew(pctx, t, Types/NO_STORAGE_FLAGS); isStruct := true; incase Types/tk_record: fldVec := t2.t_record.rd_fldVec; mainType := t; isStruct := false; incase Types/tk_capsule: fldVec := t2.t_capsule.cap_fldVec; mainType := t; isStruct := false; default: return nil; esac; /* Start creation of the proc - first the proc header. */ if procName == nil then procName := "fmt" + nd.nd_name + Package/CreateNewName(pctx); fi; Proc/TempDefineProc_t tdp; Proc/DefineProcStart(@tdp, pctx, procName, Package/nl_export, Proc/pt_regular); pctx := tdp.tdp_pctx; /* I name the formal parameter "ob", to be consistent with it being an OBuf_t, but use "buf" for variables within this set of procs, since "ob" could be misinterpreted as "object". */ Types/StorageFlags_t sf := Types/NO_STORAGE_FLAGS; // %%%%%%% Proc/FormalList_t bufFl := Proc/AddFormal(@tdp, "ob", CharBuffer/OBuf_t, sf); Proc/FormalList_t valFl := Proc/AddFormal(@tdp, "val", mainType, sf); eval Proc/AddFormal(@tdp, "fmt", Types/String, sf); eval Proc/AddFormal(@tdp, "width", Types/Uint, sf); eval Proc/AddFormal(@tdp, "precision", Types/Uint, sf); Proc/DefineProcMiddle(@tdp, Types/Void); /* Header complete, now on to the proc body, which uses FmtB to output the individual field values, perhaps in conjunction with a 'for' loop for array fields. */ Exec/ScopeStart(pctx); Exec/Exec_t bufEx := Exec/ProcFormalRefNew(pctx, bufFl); Exec/Exec_t valEx := Exec/ProcFormalRefNew(pctx, valFl); if isStruct then valEx := Exec/DerefNew(pctx, valEx); fi; string pendingStr := nd.nd_name + "("; Exec/TempIoCall_t tioc := fmtStartCall(pctx, bufEx); if fldVec ~= nil then bool firstField := true; for uint i from 0 upto getBound(fldVec) - 1 do Types/Field_t fld := fldVec[i]; if not firstField then pendingStr := pendingStr + ", "; fi; Exec/Exec_t fldEx := Exec/FieldRefNew(pctx, valEx, fld.fld_name); tioc := fmtDoField(tioc, bufEx, fldEx, fld.fld_type, @pendingStr); firstField := false; od; fi; if pendingStr ~= "" then fmtAddString(tioc, pendingStr + ")"); else fmtAddChar(tioc, ')'); fi; Exec/Exec_t ex := Exec/IoCallDone(tioc); Exec/SequenceAppend(pctx, ex); ex := Exec/ScopeNew(pctx); /* Proc body created - attach it to the proc, and return the proc. */ Proc/DefineProcEnd(@tdp, ex) default: nil esac corp; /* * FmtAdd - create a "fmt" routine for the passed named type, and add that * new routine as the "fmt" export on that type. The routine will be * created with name "name" (or a created name if "name" is nil), and * added to the export table of the active package, so that code generated * by Fmt calls can reference it. * * compile-time, exported */ export proc compileTime FmtAdd(Package/PContext_t pctx; Types/Type_t t; string name)void: Proc/Proc_t pr := FmtCreate(pctx, t, name); if pr ~= nil then Types/DoExportAdd(pctx, t, "fmt", Names/Info_t.infk_proc(pr)); fi; corp;