Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * Copyright (C) 1997-2000 NEC Research Institute. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | functor TypeOps (S: TYPE_OPS_STRUCTS): TYPE_OPS = | |
10 | struct | |
11 | ||
12 | open S | |
13 | ||
14 | local | |
15 | open Tycon | |
16 | in | |
17 | structure RealSize = RealSize | |
18 | structure WordSize = WordSize | |
19 | end | |
20 | type realSize = RealSize.t | |
21 | type tycon = Tycon.t | |
22 | type wordSize = WordSize.t | |
23 | ||
24 | local | |
25 | fun nullary tycon = con (tycon, Vector.new0 ()) | |
26 | in | |
27 | val bool = nullary Tycon.bool | |
28 | val cpointer = nullary Tycon.cpointer | |
29 | val exn = nullary Tycon.exn | |
30 | val intInf = nullary Tycon.intInf | |
31 | val real = RealSize.memoize (fn s => nullary (Tycon.real s)) | |
32 | val thread = nullary Tycon.thread | |
33 | val word = WordSize.memoize (fn s => nullary (Tycon.word s)) | |
34 | end | |
35 | ||
36 | local | |
37 | fun unary tycon t = con (tycon, Vector.new1 t) | |
38 | in | |
39 | val array = unary Tycon.array | |
40 | val list = unary Tycon.list | |
41 | val reff = unary Tycon.reff | |
42 | val vector = unary Tycon.vector | |
43 | val weak = unary Tycon.weak | |
44 | end | |
45 | ||
46 | val word8 = word WordSize.word8 | |
47 | val word8Vector = vector word8 | |
48 | val word32 = word WordSize.word32 | |
49 | ||
50 | local | |
51 | fun binary tycon (t1, t2) = con (tycon, Vector.new2 (t1, t2)) | |
52 | in | |
53 | val arrow = binary Tycon.arrow | |
54 | end | |
55 | ||
56 | val arrow = | |
57 | Trace.trace ("TypeOps.arrow", Layout.tuple2 (layout, layout), layout) arrow | |
58 | ||
59 | fun deUnaryOpt tycon t = | |
60 | case deConOpt t of | |
61 | SOME (c, ts) => if Tycon.equals (c, tycon) | |
62 | then SOME (Vector.first ts) | |
63 | else NONE | |
64 | | _ => NONE | |
65 | ||
66 | fun deUnary tycon t = | |
67 | case deUnaryOpt tycon t of | |
68 | SOME t => t | |
69 | | NONE => Error.bug "TypeOps.deUnary" | |
70 | ||
71 | val deArray = deUnary Tycon.array | |
72 | val deRef = deUnary Tycon.reff | |
73 | val deVector = deUnary Tycon.vector | |
74 | val deWeak = deUnary Tycon.weak | |
75 | ||
76 | fun tuple ts = | |
77 | if 1 = Vector.length ts | |
78 | then Vector.first ts | |
79 | else con (Tycon.tuple, ts) | |
80 | ||
81 | val unit = tuple (Vector.new0 ()) | |
82 | ||
83 | fun deTupleOpt t = | |
84 | case deConOpt t of | |
85 | SOME (c, ts) => if Tycon.equals (c, Tycon.tuple) then SOME ts else NONE | |
86 | | NONE => NONE | |
87 | ||
88 | val isTuple = Option.isSome o deTupleOpt | |
89 | ||
90 | fun deTuple t = | |
91 | case deTupleOpt t of | |
92 | SOME t => t | |
93 | | NONE => Error.bug "TypeOps.deTuple" | |
94 | ||
95 | val unitRef = reff unit | |
96 | ||
97 | fun deArrowOpt t = | |
98 | case deConOpt t of | |
99 | SOME (c, ts) => if Tycon.equals (c, Tycon.arrow) | |
100 | then SOME (Vector.sub (ts, 0), Vector.sub (ts, 1)) | |
101 | else NONE | |
102 | | _ => NONE | |
103 | ||
104 | fun deArrow t = | |
105 | case deArrowOpt t of | |
106 | SOME x => x | |
107 | | NONE => Error.bug "TypeOps.deArrow" | |
108 | ||
109 | val deArrow = | |
110 | Trace.trace | |
111 | ("TypeOps.deArrow", layout, Layout.tuple2 (layout, layout)) | |
112 | deArrow | |
113 | ||
114 | end |