Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/benchmarks/todo/format/format.sml
ViewVC logotype

Annotation of /sml/trunk/benchmarks/todo/format/format.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 193 - (view) (download)

1 : monnier 193 (* format.sml
2 :     *
3 :     * COPYRIGHT (c) 1992 by AT&T Bell Laboratories. See COPYRIGHT file for details.
4 :     *
5 :     * AUTHOR: John Reppy
6 :     * AT&T Bell Laboratories
7 :     * Murray Hill, NJ 07974
8 :     * jhr@research.att.com
9 :     *
10 :     * TODO
11 :     * - field widths in scan
12 :     *)
13 :    
14 :     structure Format (*: FORMAT*) =
15 :     struct
16 :    
17 :     structure SC = StringCvt
18 :     structure M = Makestring
19 :    
20 :     datatype fmt_item
21 :     = INT of int
22 :     | BOOL of bool
23 :     | STR of string
24 :     | REAL of real
25 :     | LEFT of (int * fmt_item) (* left justify in field of given width *)
26 :     | RIGHT of (int * fmt_item) (* right justify in field of given width *)
27 :    
28 :     exception BadFormat
29 :     exception BadArgList
30 :     exception BadInput of fmt_item list
31 :    
32 :     (* return the index of the next non-whitespace charater in s *)
33 :     fun eatWS (s, i) = let
34 :     fun f j = if CType.isSpace(s, j) then f(j+1) else j
35 :     in
36 :     (f i) handle _ => String.size s
37 :     end
38 :    
39 :     local
40 :     fun pad padChars = let
41 :     fun mkP (i, l) = if (i <= 0)
42 :     then l
43 :     else if (i <= 20)
44 :     then (substring(padChars, 0, i) :: l)
45 :     else mkP (i-20, padChars :: l)
46 :     in
47 :     mkP
48 :     end
49 :     val mkPad = pad " "
50 :     val mkZeroPad = pad "00000000000000000000"
51 :     in
52 :     fun padLeft (str, pad) = implode (mkPad (pad - (String.size str), [str]))
53 :     fun padRight (str, pad) = implode (str :: mkPad (pad - (String.size str), []))
54 :     fun zeroLPad (str, pad) = implode (mkZeroPad (pad - (String.size str), [str]))
55 :     fun zeroRPad (str, pad) = implode (str :: mkZeroPad (pad - (String.size str), []))
56 :     end
57 :    
58 :     (* int to string conversions (for positive integers only) *)
59 :     datatype posint = PosInt of int | MaxInt
60 :     local
61 :     fun mkDigit i : string =
62 :     System.Unsafe.cast(System.Unsafe.ordof("0123456789abcdef", i))
63 :     in
64 :     fun intToOctal MaxInt = "10000000000"
65 :     | intToOctal (PosInt i) = let
66 :     fun f (i, l) = if (i < 8)
67 :     then implode((mkDigit i) :: l)
68 :     else f(Bits.rshift(i, 3), mkDigit(Bits.andb(i, 0x7)) :: l)
69 :     in
70 :     f (i, [])
71 :     end
72 :     fun intToStr MaxInt = "1073741824"
73 :     | intToStr (PosInt i) = M.intToStr i
74 :     fun intToHex MaxInt = "40000000"
75 :     | intToHex (PosInt i) = let
76 :     fun f (i, l) = if (i < 16)
77 :     then implode((mkDigit i) :: l)
78 :     else f(Bits.rshift(i, 4), mkDigit(Bits.andb(i, 0xf)) :: l)
79 :     in
80 :     f (i, [])
81 :     end
82 :     fun intToHeX i = CType.toUpper(intToHex i)
83 :     end
84 :    
85 :     (* precompiled format specifiers *)
86 :     datatype sign
87 :     = DfltSign (* default: put a sign on negative numbers *)
88 :     | AlwaysSign (* "+" always has sign (+ or -) *)
89 :     | BlankSign (* " " put a blank in the sign field for positive numbers *)
90 :     datatype neg_sign
91 :     = MinusSign (* default: use "-" for negative numbers *)
92 :     | TildeSign (* "~" use "~" for negative numbers *)
93 :     type field_flags = {
94 :     sign : sign,
95 :     neg_char : neg_sign,
96 :     zero_pad : bool,
97 :     base : bool,
98 :     ljust : bool
99 :     }
100 :    
101 :     datatype field_wid = NoPad | Wid of int
102 :    
103 :     datatype real_format
104 :     = F_Format (* "%f" *)
105 :     | E_Format of bool (* "%e" or "%E" *)
106 :     | G_Format of bool (* "%g" or "%G" *)
107 :    
108 :     datatype field_type
109 :     = OctalField
110 :     | IntField
111 :     | HexField
112 :     | CapHexField
113 :     | CharField
114 :     | BoolField
115 :     | StrField
116 :     | RealField of {prec : int, format : real_format}
117 :    
118 :     datatype fmt_spec
119 :     = Raw of string
120 :     | CharSet of (string * int) -> bool
121 :     | Field of (field_flags * field_wid * field_type)
122 :    
123 :     (* character sets *)
124 :     abstype charset = CS of ByteArray.bytearray
125 :     with
126 :     fun mkCharSet () = CS(ByteArray.array(256, 0))
127 :     fun addChar (CS ba, c) = ByteArray.update(ba, c, 1)
128 :     fun addRange (CS ba, c1, c2) = let
129 :     fun add i = if (i <= c2)
130 :     then (ByteArray.update(ba, i, 1); add(i+1))
131 :     else ()
132 :     in
133 :     if (c1 <= c2) then (add c1) else raise BadFormat
134 :     end
135 :     fun inSet (CS ba) = fn arg => (ByteArray.sub(ba, ordof arg) = 1)
136 :     fun notInSet (CS ba) = fn arg => (ByteArray.sub(ba, ordof arg) = 0)
137 :     end
138 :    
139 :     (* scan a field specification. Assume that fmtStr[i-1] = "%", and
140 :     * that fmtStr[i] <> "%".
141 :     *)
142 :     fun scanFieldSpec (fmtStr, i) = let
143 :     val (i, flags) = let
144 :     fun doFlags (i, flags) = (case (ordof(fmtStr, i), flags)
145 :     of ((* " " *) 32, {sign=AlwaysSign, ...}) => raise BadFormat
146 :     | ((* " " *) 32, {neg_char, zero_pad, base, ljust, ...}) =>
147 :     doFlags (i+1, {
148 :     sign = BlankSign, neg_char = neg_char,
149 :     zero_pad = zero_pad, base = base, ljust = ljust
150 :     })
151 :     | ((* "+" *) 43, {sign=BlankSign, ...}) => raise BadFormat
152 :     | ((* "+" *) 43, {neg_char, zero_pad, base, ljust, ...}) =>
153 :     doFlags (i+1, {
154 :     sign = AlwaysSign, neg_char = neg_char,
155 :     zero_pad = zero_pad, base = base, ljust = ljust
156 :     })
157 :     | ((* "~" *) 126, {sign, zero_pad, base, ljust, ...}) =>
158 :     doFlags (i+1, {
159 :     sign = sign, neg_char = TildeSign,
160 :     zero_pad = zero_pad, base = base, ljust = ljust
161 :     })
162 :     | ((* "-" *) 45, {sign, neg_char, zero_pad, base, ...}) =>
163 :     doFlags (i+1, {
164 :     sign = sign, neg_char = neg_char,
165 :     zero_pad = zero_pad, base = base, ljust = true
166 :     })
167 :     | ((* "#" *) 35, {sign, neg_char, zero_pad, ljust, ...}) =>
168 :     doFlags (i+1, {
169 :     sign = sign, neg_char = neg_char,
170 :     zero_pad = zero_pad, base = true, ljust = ljust
171 :     })
172 :     | ((* "0" *) 48, {sign, neg_char, base, ljust, ...}) =>
173 :     (i+1, {
174 :     sign = sign, neg_char = neg_char,
175 :     zero_pad = true, base = base, ljust = ljust
176 :     })
177 :     | _ => (i, flags)
178 :     (* end case *))
179 :     in
180 :     doFlags (i, {
181 :     sign = DfltSign, neg_char = MinusSign,
182 :     zero_pad = false, base = false, ljust = false
183 :     })
184 :     end
185 :     val (wid, i) = if (CType.isDigit(fmtStr, i))
186 :     then let val (n, i) = SC.strToInt(fmtStr, i, 10) in (Wid n, i) end
187 :     else (NoPad, i)
188 :     val (ty, i) = (case (ordof (fmtStr, i))
189 :     of (* "d" *) 100 => (IntField, i+1)
190 :     | (* "X" *) 88 => (CapHexField, i+1)
191 :     | (* "x" *) 120 => (HexField, i+1)
192 :     | (* "o" *) 111 => (OctalField, i+1)
193 :     | (* "c" *) 99 => (CharField, i+1)
194 :     | (* "s" *) 115 => (StrField, i+1)
195 :     | (* "b" *) 98 => (BoolField, i+1)
196 :     | (* "." *) 46 => let
197 :     val (n, i) = SC.strToInt(fmtStr, i+1, 10)
198 :     val format = (case (ordof (fmtStr, i))
199 :     of (* "E" *) 69 => E_Format true
200 :     | (* "e" *) 101 => E_Format false
201 :     | (* "f" *) 102 => F_Format
202 :     | (* "G" *) 71 => G_Format true
203 :     | (* "g" *) 103 => G_Format false
204 :     | _ => raise BadFormat
205 :     (* end case *))
206 :     in
207 :     (RealField{prec = n, format = format}, i+1)
208 :     end
209 :     | (* "E" *) 69 => (RealField{prec=6, format=E_Format true}, i+1)
210 :     | (* "e" *) 101 => (RealField{prec=6, format=E_Format false}, i+1)
211 :     | (* "f" *) 102 => (RealField{prec=6, format=F_Format}, i+1)
212 :     | (* "G" *) 71 => (RealField{prec=6, format=G_Format true}, i+1)
213 :     | (* "g" *) 103 => (RealField{prec=6, format=G_Format false}, i+1)
214 :     | _ => raise BadFormat
215 :     (* end case *))
216 :     in
217 :     (Field(flags, wid, ty), i)
218 :     end (* scanFieldSpec *)
219 :    
220 :     fun scanField (fmtStr, i) = if (ordof(fmtStr, i) = (* "%" *) 37)
221 :     then (Raw "%", i+1)
222 :     else scanFieldSpec(fmtStr, i)
223 :    
224 :     fun scanCharSet (fmtStr, i) = let
225 :     val cset = mkCharSet()
226 :     val (isNot, i) = if (ordof(fmtStr, i) = (* "^" *) 94)
227 :     then (true, i+1)
228 :     else (false, i)
229 :     fun scan (nextChar, j) = (case (ordof(fmtStr, j))
230 :     of (* "-" *) 45 => let
231 :     val c = ordof(fmtStr, j+1)
232 :     in
233 :     if (c = (* "]" *) 93)
234 :     then (
235 :     addChar(cset, nextChar);
236 :     addChar(cset, (* "-" *) 45);
237 :     j+2)
238 :     else (
239 :     addRange(cset, nextChar, c);
240 :     scanNext(j+2))
241 :     end
242 :     | (* "]" *) 93 => (addChar(cset, nextChar); j+1)
243 :     | c => (addChar(cset, nextChar); scan(c, j+1))
244 :     (* end case *))
245 :     and scanNext j = (case (ordof(fmtStr, j))
246 :     of (* "-" *) 45 => raise BadFormat
247 :     | (* "]" *) 93 => j+1
248 :     | c => scan(c, j+1)
249 :     (* end case *))
250 :     val j = scan (ordof(fmtStr, i), i+1)
251 :     in
252 :     if isNot then (j, CharSet(notInSet cset)) else (j, CharSet(inSet cset))
253 :     end
254 :    
255 :     fun compileFormat isScan str = (let
256 :     val len = String.size str
257 :     fun mkStr (i, j, l) =
258 :     if (i = j) then l else (Raw(substring(str, i, (j - i))) :: l)
259 :     fun scan (i, j, l) = if (j < len)
260 :     then (case (ordof (str, j))
261 :     of (* "%" *) 37 => let val (f, j') = scanField(str, j+1)
262 :     in
263 :     scan (j', j', f :: mkStr(i, j, l))
264 :     end
265 :     | (* "[" *) 91 => if isScan
266 :     then let val (j', cs) = scanCharSet(str, j+1)
267 :     in
268 :     scan (j', j', cs :: mkStr(i, j, l))
269 :     end
270 :     else scan (i, j+1, l)
271 :     | c => if ((CType.isSpaceOrd c) andalso isScan)
272 :     then let val j' = eatWS(str, j+1)
273 :     in
274 :     scan (j', j', mkStr(i, j, l))
275 :     end
276 :     else scan (i, j+1, l)
277 :     (* end case *))
278 :     else rev (mkStr(i, j, l))
279 :     in
280 :     scan (0, 0, [])
281 :     end (* compileFormat *)
282 :     handle _ => raise BadFormat)
283 :    
284 :     fun format s = let
285 :     val fmts = compileFormat false s
286 :     fun doArgs ([], [], l) = implode(rev l)
287 :     | doArgs ((Raw s)::rf, args, l) = doArgs(rf, args, s::l)
288 :     | doArgs (Field(flags, wid, ty)::rf, arg::ra, l) = let
289 :     fun padFn s = (case (#ljust flags, wid)
290 :     of (_, NoPad) => s
291 :     | (false, Wid i) => padLeft(s, i)
292 :     | (true, Wid i) => padRight(s, i)
293 :     (* end case *))
294 :     fun zeroPadFn (sign, s) = (case wid
295 :     of NoPad => raise BadFormat
296 :     | (Wid i) => zeroLPad(s, i - (String.size sign))
297 :     (* end case *))
298 :     fun negate i = ((PosInt(~i)) handle _ => MaxInt)
299 :     fun doSign i = (case (i < 0, #sign flags, #neg_char flags)
300 :     of (false, AlwaysSign, _) => ("+", PosInt i)
301 :     | (false, BlankSign, _) => (" ", PosInt i)
302 :     | (false, _, _) => ("", PosInt i)
303 :     | (true, _, TildeSign) => ("~", negate i)
304 :     | (true, _, _) => ("-", negate i)
305 :     (* end case *))
306 :     fun doRealSign sign = (case (sign, #sign flags, #neg_char flags)
307 :     of (false, AlwaysSign, _) => "+"
308 :     | (false, BlankSign, _) => " "
309 :     | (false, _, _) => ""
310 :     | (true, _, TildeSign) => "~"
311 :     | (true, _, _) => "-"
312 :     (* end case *))
313 :     fun doExpSign (exp, isCap) = let
314 :     val e = if isCap then "E" else "e"
315 :     fun mkExp e = zeroLPad(M.intToStr e, 2)
316 :     in
317 :     case (exp < 0, #neg_char flags)
318 :     of (false, _) => [e, mkExp exp]
319 :     | (true, TildeSign) => [e, "~", mkExp(~exp)]
320 :     | (true, _) => [e, "-", mkExp(~exp)]
321 :     (* end case *)
322 :     end
323 :     val s = (case (ty, arg)
324 :     of (OctalField, INT i) => let
325 :     val (sign, i) = doSign i
326 :     val sign = if (#base flags) then sign^"0" else sign
327 :     val s = intToOctal i
328 :     in
329 :     if (#zero_pad flags)
330 :     then sign ^ zeroPadFn(sign, s)
331 :     else padFn (sign ^ s)
332 :     end
333 :     | (IntField, INT i) => let
334 :     val (sign, i) = doSign i
335 :     in
336 :     padFn (sign ^ (intToStr i))
337 :     end
338 :     | (HexField, INT i) => let
339 :     val (sign, i) = doSign i
340 :     val sign = if (#base flags) then sign^"0x" else sign
341 :     val s = intToHex i
342 :     in
343 :     if (#zero_pad flags)
344 :     then sign ^ zeroPadFn(sign, s)
345 :     else padFn (sign ^ s)
346 :     end
347 :     | (CapHexField, INT i) => let
348 :     val (sign, i) = doSign i
349 :     val sign = if (#base flags) then sign^"0X" else sign
350 :     val s = intToHeX i
351 :     in
352 :     if (#zero_pad flags)
353 :     then sign ^ zeroPadFn(sign, s)
354 :     else padFn (sign ^ s)
355 :     end
356 :     | (CharField, INT i) => padFn(chr i)
357 :     | (BoolField, BOOL false) => padFn "false"
358 :     | (BoolField, BOOL true) => padFn "true"
359 :     | (StrField, STR s) => padFn s
360 :     | (RealField{prec, format=F_Format}, REAL r) => let
361 :     val {sign, mantissa} = M.realFFormat(r, prec)
362 :     val sign = doRealSign sign
363 :     in
364 :     if ((prec = 0) andalso (#base flags))
365 :     then padFn(implode[sign, mantissa, "."])
366 :     else padFn(sign ^ mantissa)
367 :     end
368 :     | (RealField{prec, format=E_Format isCap}, REAL r) => let
369 :     val {sign, mantissa, exp} = M.realEFormat(r, prec)
370 :     val sign = doRealSign sign
371 :     val expStr = doExpSign(exp, isCap)
372 :     in
373 :     if ((prec = 0) andalso (#base flags))
374 :     then padFn(implode(sign :: mantissa :: "." :: expStr))
375 :     else padFn(implode(sign :: mantissa :: expStr))
376 :     end
377 :     | (RealField{prec, format=G_Format isCap}, REAL r) => let
378 :     val prec = if (prec = 0) then 1 else prec
379 :     val {sign, whole, frac, exp} = M.realGFormat(r, prec)
380 :     val sign = doRealSign sign
381 :     val expStr = (case exp
382 :     of SOME e => doExpSign(e, isCap)
383 :     | NONE => [])
384 :     val num = if (#base flags)
385 :     then let
386 :     val diff = prec - ((size whole) + (size frac))
387 :     in
388 :     if (diff > 0)
389 :     then zeroRPad(frac, (size frac)+diff)
390 :     else frac
391 :     end
392 :     else if (frac = "")
393 :     then ""
394 :     else ("." ^ frac)
395 :     in
396 :     padFn(implode(sign::whole::frac::expStr))
397 :     end
398 :     | (_, LEFT(w, arg)) => let
399 :     val flags = {
400 :     sign = (#sign flags), neg_char = (#neg_char flags),
401 :     zero_pad = (#zero_pad flags), base = (#base flags),
402 :     ljust = true
403 :     }
404 :     in
405 :     doArgs (Field(flags, Wid w, ty)::rf, arg::ra, l)
406 :     end
407 :     | (_, RIGHT(w, arg)) =>
408 :     doArgs (Field(flags, Wid w, ty)::rf, arg::ra, l)
409 :     | _ => raise BadArgList
410 :     (* end case *))
411 :     in
412 :     doArgs (rf, ra, s::l)
413 :     end
414 :     | doArgs _ = raise BadArgList
415 :     in
416 :     fn args => doArgs(fmts, args, [])
417 :     end (* format *)
418 :    
419 :     fun formatf fmt = let
420 :     val f = format fmt
421 :     in
422 :     fn consumer => fn args => consumer(f args)
423 :     end
424 :    
425 :     (** NOTE: for the time being, this ignores flags and field width **)
426 :     fun scani fmt = let
427 :     val fmts = compileFormat true fmt
428 :     fun scan (_, i, [], items) = (rev items, i)
429 :     | scan (s, i, (Raw s')::rf, items) = (let
430 :     val len = String.size s'
431 :     fun match (i, j) = if (j < len)
432 :     then if (ordof(s, i) = ordof(s', j))
433 :     then match(i+1, j+1)
434 :     else raise BadInput(rev items)
435 :     else i
436 :     in
437 :     scan (s, match(eatWS(s, i), 0), rf, items)
438 :     end
439 :     handle _ => raise BadInput(rev items))
440 :     | scan (s, i, (CharSet pred)::rf, items) = let
441 :     fun scanSet i = if (pred (s, i)) then scanSet(i+1) else i
442 :     in
443 :     (scan (s, scanSet i, rf, items))
444 :     handle _ => scan(s, size s, rf, items)
445 :     end
446 :     | scan (s, i, Field(flags, wid, ty)::rf, items) = (let
447 :     fun strToInt base = let
448 :     val (n, indx) = SC.strToInt(s, i, base)
449 :     in
450 :     (INT n, indx)
451 :     end
452 :     val i = eatWS(s, i)
453 :     val (item, i) = (case ty
454 :     of OctalField => strToInt 8
455 :     | IntField => strToInt 10
456 :     | HexField => strToInt 16
457 :     | CapHexField => strToInt 16
458 :     | CharField => (INT(ordof(s, i)), i+1)
459 :     | BoolField => let val (b, indx) = SC.strToBool(s, i)
460 :     in
461 :     (BOOL b, indx)
462 :     end
463 :     | StrField => let
464 :     val l = (case wid
465 :     of NoPad => String.size s
466 :     | (Wid n) => min(i+n, String.size s)
467 :     (* end case *))
468 :     fun getStr j = if ((j = l) orelse CType.isSpace(s, j))
469 :     then (STR(substring(s, i, j-i)), j)
470 :     else getStr (j+1)
471 :     in
472 :     getStr i
473 :     end
474 :     | (RealField _) => let val (r, indx) = SC.strToReal(s, i)
475 :     in
476 :     (REAL r, indx)
477 :     end
478 :     (* end case *))
479 :     in
480 :     scan (s, i, rf, item::items)
481 :     end
482 :     handle _ => raise BadInput(rev items))
483 :     in
484 :     fn (s, i) => scan(s, i, fmts, [])
485 :     end (* scani *)
486 :    
487 :     fun scan fmt = let
488 :     val scani = scani fmt
489 :     in
490 :     fn s => #1(scani (s, 0))
491 :     end
492 :    
493 :     end (* Format *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0