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/branches/primop-branch-3/compiler/FLINT/trans/typestp.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-3/compiler/FLINT/trans/typestp.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3293 - (view) (download)

1 : gkuan 2948 structure TypesTP =
2 :     struct
3 :    
4 :     local
5 :     structure T = Types
6 :     structure ST = Stamps
7 :     structure IP = InvPath
8 :     structure LT = LtyExtern
9 :     structure EP = EntPath
10 :     structure TU = TypesUtil
11 :     structure A = Access
12 :     structure S = Symbol
13 :     structure IP = InvPath
14 :     in
15 :    
16 :     datatype tycpath (* (instantiated) functor type parameter path *)
17 :     = TP_VAR of { tdepth: DebIndex.depth, num: int, kind: LT.tkind }
18 :     | TP_TYC of tycon
19 :     | TP_FCT of tycpath list * tycpath list
20 :     | TP_APP of tycpath * tycpath list
21 :     | TP_SEL of tycpath * int
22 : dbm 3045
23 : gkuan 2948 and tycon
24 :     = GENtycTP of {stamp : ST.stamp,
25 :     arity : int,
26 :     eq : T.eqprop ref,
27 :     kind : tyckind,
28 :     path : IP.path,
29 :     stub : T.stubinfo option}
30 :     | NoTP of T.tycon
31 : dbm 3045
32 : gkuan 2948 and tyckind
33 :     = PRIMITIVE of int
34 :     | DATATYPE of
35 :     {index : int,
36 :     stamps : ST.stamp vector,
37 :     root : EP.entVar option,
38 :     freetycs : tycon list,
39 :     family : T.dtypeFamily}
40 :     | ABSTRACT of tycon
41 :     | FLEXTYC of tycpath
42 :    
43 :     datatype ty
44 :     = TyNoTP of T.ty
45 :     | CONty of tycon * ty list
46 :    
47 :     exception TYCTP (* Unexpected FLEXTYC, can convert from tyctp to tyc only
48 :     when no FLEXTYC *)
49 :    
50 :     (* TycToTypes : tycon -> Types.tycon *)
51 :     fun tycStripTP(NoTP tc) = tc
52 :     | tycStripTP(GENtycTP{stamp,arity,eq,kind,path,stub}) =
53 :     let
54 :     fun tyckind(PRIMITIVE i) = T.PRIMITIVE i
55 :     | tyckind(DATATYPE{index,stamps,root,freetycs,family}) =
56 :     T.DATATYPE{index=index,stamps=stamps,root=root,
57 :     freetycs=map tycStripTP freetycs,
58 :     family=family}
59 :     | tyckind(ABSTRACT tc) =
60 :     T.ABSTRACT(tycStripTP tc)
61 :     | tyckind(FLEXTYC _) = raise TYCTP
62 :     val kind' = tyckind kind
63 :     in
64 :     T.GENtyc{stamp=stamp,arity=arity,eq=eq,kind=kind',path=path,stub=stub}
65 :     end
66 :     (* TyToTypes : ty -> Types.ty *)
67 :     fun tyStripTP(TyNoTP t) = t
68 :     | tyStripTP(CONty(tc,args)) = T.CONty(tycStripTP tc, map tyStripTP args)
69 :    
70 :     exception IncomparableTypesTP
71 :    
72 :     (* eqTycon : TypesTP.tycon * TypesTP.tycon -> bool *)
73 :     fun eqTycon(x : tycon, y : tycon) =
74 :     (case (x, y)
75 :     of (NoTP tc, NoTP tc') => TU.eqTycon (tc, tc')
76 :     | (GENtycTP{stamp=s,...}, GENtycTP{stamp=s',...}) => ST.eq(s,s')
77 :     | _ => raise IncomparableTypesTP)
78 :    
79 :     (* Other TypeUtil functions used in FLINT trans *)
80 :    
81 :     (* applyTyfun : Types.tyfun * TypesTP.ty list -> TypesTP.ty *)
82 :     (* MU.transType *)
83 :     (* BT.isArrowType *)
84 : gkuan 3293 (* BT.--> *)
85 : gkuan 2948 end (* local *)
86 :    
87 : gkuan 3293 end (* struct *)

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