1 (* Copyright (C) 2017 Matthew Fluet.
2 * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor PrimTycons (S: PRIM_TYCONS_STRUCTS): PRIM_TYCONS =
15 datatype z = datatype RealSize.t
20 fun make s = (s, fromString s)
22 val array = make "array"
23 val arrow = make "arrow"
24 val bool = make "bool"
25 val cpointer = make "cpointer"
27 val intInf = make "intInf"
28 val list = make "list"
30 val thread = make "thread"
31 val tuple = make "tuple"
32 val vector = make "vector"
33 val weak = make "weak"
36 datatype z = datatype Kind.t
37 datatype z = datatype AdmitsEquality.t
40 fun 'a make (prefix: string,
43 equalsA: 'a * 'a -> bool,
44 memo: ('a -> t) -> ('a -> t),
45 admitsEquality: AdmitsEquality.t) =
50 val name = concat [prefix, Bits.toString (bits s)]
54 tycon = fromString name}
59 case Vector.peek (all, fn {size = s', ...} => equalsA (s, s')) of
60 NONE => Error.bug "PrimTycons.make.fromSize"
61 | SOME {tycon, ...} => tycon)
62 fun is t = Vector.exists (all, fn {tycon = t', ...} => equals (t, t'))
64 case Vector.peek (all, fn {tycon = t', ...} => equals (t, t')) of
65 NONE => Error.bug "PrimTycons.make.de"
66 | SOME {size, ...} => size
68 Vector.toListMap (all, fn {name, tycon, ...} =>
69 {admitsEquality = admitsEquality,
73 val all = Vector.map (all, fn {tycon, size, ...} => (tycon, size))
75 (fromSize, all, is, de, prims)
78 val (char, _, isCharX, deCharX, primChars) =
82 make ("char", all, bits, equals, memoize, Sometimes)
84 val (int, ints, isIntX, deIntX, primInts) =
88 make ("int", all, bits, equals, memoize, Sometimes)
90 val (real, reals, isRealX, deRealX, primReals) =
94 make ("real", all, bits, equals, memoize, Never)
96 val (word, words, isWordX, deWordX, primWords) =
100 make ("word", all, bits, equals, memoize, Sometimes)
105 List.map ([(array, Arity 1, Always),
106 (arrow, Arity 2, Never),
107 (bool, Arity 0, Sometimes),
108 (cpointer, Arity 0, Always),
109 (exn, Arity 0, Never),
110 (intInf, Arity 0, Sometimes),
111 (list, Arity 1, Sometimes),
112 (reff, Arity 1, Always),
113 (thread, Arity 0, Never),
114 (tuple, Nary, Sometimes),
115 (vector, Arity 1, Sometimes),
116 (weak, Arity 1, Never)],
117 fn ((name, tycon), kind, admitsEquality) =>
118 {admitsEquality = admitsEquality,
122 @ primChars @ primInts @ primReals @ primWords
127 val cpointer = #2 cpointer
129 val intInf = #2 intInf
132 val thread = #2 thread
134 val vector = #2 vector
137 val defaultChar = fn () =>
138 case !Control.defaultChar of
139 "char8" => char CharSize.C8
140 | _ => Error.bug "PrimTycons.defaultChar"
141 val defaultInt = fn () =>
142 case !Control.defaultInt of
143 "int8" => int (IntSize.fromBits (Bits.fromInt 8))
144 | "int16" => int (IntSize.fromBits (Bits.fromInt 16))
145 | "int32" => int (IntSize.fromBits (Bits.fromInt 32))
146 | "int64" => int (IntSize.fromBits (Bits.fromInt 64))
148 | _ => Error.bug "PrimTycons.defaultInt"
149 val defaultReal = fn () =>
150 case !Control.defaultReal of
151 "real32" => real RealSize.R32
152 | "real64" => real RealSize.R64
153 | _ => Error.bug "PrimTycons.defaultReal"
154 val defaultWord = fn () =>
155 case !Control.defaultWord of
156 "word8" => word (WordSize.fromBits (Bits.fromInt 8))
157 | "word16" => word (WordSize.fromBits (Bits.fromInt 16))
158 | "word32" => word (WordSize.fromBits (Bits.fromInt 32))
159 | "word64" => word (WordSize.fromBits (Bits.fromInt 64))
160 | _ => Error.bug "PrimTycons.defaultWord"
162 val isBool = fn c => equals (c, bool)
163 val isCPointer = fn c => equals (c, cpointer)
164 val isIntX = fn c => equals (c, intInf) orelse isIntX c
165 val deIntX = fn c => if equals (c, intInf) then NONE else SOME (deIntX c)
171 val mayAlign = mayAlign
175 datatype z = datatype BindingStrength.t
176 datatype binding_context =
182 fun maybe bindingContext (l, ({isChar = _}, bindingStrength)) =
183 case (bindingStrength, bindingContext) of
185 | (Tuple, ArrowLhs) => l
186 | (Tuple, ArrowRhs) => l
187 | (Tuple, TyseqN) => l
188 | (Arrow, ArrowRhs) => l
189 | (Arrow, TyseqN) => l
190 | _ => Layout.paren l
191 fun normal (c: Layout.t, args: LayoutPretty.t vector, {isChar}) =
194 case Vector.length args of
196 | 1 => seq [maybe Tyseq1 (Vector.first args),
198 | _ => seq [Layout.tuple (Vector.toListMap (args, maybe TyseqN)),
201 (lay, ({isChar = isChar}, Unit))
205 fun layoutAppPrettyNormal (c: Layout.t, args: LayoutPretty.t vector) =
206 normal (c, args, {isChar = false})
207 fun layoutAppPretty (c: t, args: LayoutPretty.t vector, {layoutPretty}) =
209 then (mayAlign [maybe ArrowLhs (Vector.first args),
211 maybe ArrowRhs (Vector.sub (args, 1))]],
212 ({isChar = false}, Arrow))
213 else if equals (c, tuple)
214 then if Vector.isEmpty args
215 then LayoutPretty.simple (str "unit")
216 else (mayAlign (Layout.separateLeft
217 (Vector.toListMap (args, maybe TupleElem), "* ")),
218 ({isChar = false}, Tuple))
219 else if equals (c, vector)
220 then if #isChar (#1 (#2 (Vector.first args)))
221 then LayoutPretty.simple (str "string")
222 else normal (layoutPretty c, args, {isChar = false})
223 else normal (layoutPretty c, args, {isChar = equals (c, defaultChar ())})
226 fun layoutApp (c: t, args: Layout.t vector) =
236 if equals (c, tuple) andalso Vector.isEmpty args
238 else (case List.peekMap (prims, fn {name, tycon, ...} =>
239 if equals (c, tycon) then SOME name else NONE) of
240 SOME name => str name
243 if Vector.isEmpty args
245 else seq [Layout.tuple (Vector.toList args), str " "]