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/src/compiler/FLINT/trans/mccommon.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/trans/mccommon.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :     (* mccommon.sml *)
3 :    
4 :     (* TODO: this module requires a signature ! *)
5 :    
6 :     structure MCCommon =
7 :     struct
8 :    
9 :     local structure EM = ErrorMsg
10 :     open Types VarCon PLambda Absyn
11 :    
12 :     in
13 :    
14 :     datatype simp
15 :     = VARsimp of var
16 :     | RECORDsimp of (label * simp) list
17 :    
18 :     type dconinfo = datacon * ty list
19 :    
20 :     datatype pcon
21 :     = DATApcon of dconinfo
22 :     | INTpcon of int
23 :     | INT32pcon of Int32.int
24 :     | WORDpcon of word
25 :     | WORD32pcon of Word32.word
26 :     | REALpcon of string
27 :     | STRINGpcon of string
28 :     | VLENpcon of int * ty
29 :    
30 :     datatype path
31 :     = RECORDPATH of path list
32 :     | PIPATH of int * path
33 :     | VPIPATH of int * ty * path
34 :     | VLENPATH of path * ty
35 :     | DELTAPATH of pcon * path
36 :     | ROOTPATH
37 :    
38 :     datatype dectree
39 :     = CASETEST of
40 :     path * Access.consig * (pcon * dectree) list
41 :     * dectree option
42 :     | ABSTEST0 of path * dconinfo * dectree * dectree
43 :     | ABSTEST1 of path * dconinfo * dectree * dectree
44 :     | RHS of int
45 :     | BIND of path * dectree
46 :    
47 :     fun bug s = EM.impossible ("MCCommon: " ^ s)
48 :    
49 :     fun mkRECORDpat (RECORDpat{fields, flex=false, typ, ...}) pats =
50 :     RECORDpat {flex=false, typ=typ,
51 :     fields=ListPair.map(fn((id,_),p)=>(id,p))(fields,pats)}
52 :     | mkRECORDpat (RECORDpat{flex=true,...}) _ =
53 :     bug "flex record passed to mkRECORDpat"
54 :     | mkRECORDpat _ _ = bug "non record passed to mkRECORDpat"
55 :    
56 :     fun conEq(DATACON{rep=a1,...},DATACON{rep=a2,...}) = (a1 = a2)
57 :    
58 :     fun conEq'((DATACON{rep=a1,...},_), (DATACON{rep=a2,...},_)) = (a1 = a2)
59 :    
60 :     (*
61 :     fun constantEq (INTcon n, INTcon n') = n = n'
62 :     | constantEq (WORDcon n, WORDcon n') = n = n'
63 :     | constantEq (INT32con n, INT32con n') = n = n'
64 :     | constantEq (WORD32con n, WORD32con n') = n = n'
65 :     | constantEq (REALcon r, REALcon r') = r = r'
66 :     | constantEq (STRINGcon s, STRINGcon s') = s = s'
67 :     | constantEq (VLENcon n, VLENcon n') = n = n'
68 :     | constantEq (DATAcon(_,krep,_), DATAcon(_,krep',_)) = krep = krep'
69 :     | constantEq _ = false
70 :     *)
71 :    
72 :     fun constantEq (INTpcon n, INTpcon n') = n = n'
73 :     | constantEq (WORDpcon n, WORDpcon n') = n = n'
74 :     | constantEq (INT32pcon n, INT32pcon n') = n = n'
75 :     | constantEq (WORD32pcon n, WORD32pcon n') = n = n'
76 :     | constantEq (REALpcon r, REALpcon r') = r = r'
77 :     | constantEq (STRINGpcon s, STRINGpcon s') = s = s'
78 :     | constantEq (VLENpcon (n, _), VLENpcon (n',_)) = n = n'
79 :     | constantEq (DATApcon (d1, _), DATApcon (d2, _)) = conEq(d1, d2)
80 :     | constantEq _ = false
81 :    
82 :    
83 :     fun pathEq(RECORDPATH(a::ar),RECORDPATH(b::br)) =
84 :     pathEq(a,b) andalso pathEq(RECORDPATH ar, RECORDPATH br)
85 :     | pathEq(RECORDPATH nil, RECORDPATH nil) = true
86 :     | pathEq(PIPATH(i1,p1),PIPATH(i2,p2)) = i1=i2 andalso pathEq(p1,p2)
87 :     | pathEq(VPIPATH(i1,_,p1),VPIPATH(i2,_,p2)) = i1=i2 andalso pathEq(p1,p2)
88 :     | pathEq(VLENPATH(p1, _),VLENPATH(p2,_)) = pathEq(p1,p2)
89 :     | pathEq(DELTAPATH(c1,p1),DELTAPATH(c2,p2)) =
90 :     constantEq(c1,c2) andalso pathEq(p1,p2)
91 :     | pathEq(ROOTPATH,ROOTPATH) = true
92 :     | pathEq _ = false
93 :    
94 :     fun lookupPath (a, (b,c)::d) =
95 :     if pathEq(a,b) then c else lookupPath(a, d)
96 :     | lookupPath _ = bug "unexpected args in lookupPath"
97 :    
98 :     fun abstract x = false
99 :     fun template x = false
100 :     fun isAnException x = false
101 :     fun signOfCon (DATACON{sign,...}) = sign
102 :     fun unary (DATACON{const,...},_) = const
103 :    
104 :     end (* toplevel local *)
105 :     end (* structure MCCommon *)
106 :    
107 :    
108 :    
109 :     (*
110 :     * $Log: mccommon.sml,v $
111 :     * Revision 1.2 1997/05/05 20:00:14 george
112 :     * Change the term language into the quasi-A-normal form. Added a new round
113 :     * of lambda contraction before and after type specialization and
114 :     * representation analysis. Type specialization including minimum type
115 :     * derivation is now turned on all the time. Real array is now implemented
116 :     * as realArray. A more sophisticated partial boxing scheme is added and
117 :     * used as the default.
118 :     *
119 :     * Revision 1.1.1.1 1997/01/14 01:38:47 george
120 :     * Version 109.24
121 :     *
122 :     *)

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