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/MiscUtil/print/ppval.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/MiscUtil/print/ppval.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* ppval.sml *)
3 :    
4 :     signature PPVAL =
5 :     sig
6 :     val ppAccess: PrettyPrint.ppstream -> Access.access -> unit
7 :     val ppRep: PrettyPrint.ppstream -> Access.conrep -> unit
8 :     val ppDcon: PrettyPrint.ppstream -> VarCon.datacon -> unit
9 :     val ppVar: PrettyPrint.ppstream -> VarCon.var -> unit
10 :     val ppDebugDcon : PrettyPrint.ppstream
11 :     -> StaticEnv.staticEnv -> VarCon.datacon -> unit
12 :     val ppDebugVar: PrettyPrint.ppstream
13 :     -> StaticEnv.staticEnv -> VarCon.var -> unit
14 :     end (* signature PPVAL *)
15 :    
16 :     structure PPVal : PPVAL =
17 :     struct
18 :    
19 :     local structure PP = PrettyPrint
20 :     structure TU = TypesUtil
21 :     structure LU = Lookup
22 :     structure A = Access
23 :     structure II = InlInfo
24 :     open PrettyPrint PPUtil VarCon Types
25 :    
26 :     in
27 :    
28 :     val internals = Control.internals
29 :    
30 :     fun C f x y = f y x
31 :    
32 :     val pps = PP.add_string
33 :     val ppType = PPType.ppType
34 :     val ppTycon = PPType.ppTycon
35 :     val ppTyfun = PPType.ppTyfun
36 :    
37 :     fun ppAccess ppstrm a = pps ppstrm (" ["^(A.prAcc a)^"]")
38 :    
39 :     fun ppInfo ppstrm a = pps ppstrm (" ["^(II.prInfo a)^"]")
40 :    
41 :     fun ppRep ppstrm =
42 :     let val {pps,...} = en_pp ppstrm
43 :     in fn rep => pps (A.prRep rep)
44 :     end
45 :    
46 :     fun ppCsig ppstrm =
47 :     let val {pps, ...} = en_pp ppstrm
48 :     in fn csig => pps (A.prCsig csig)
49 :     end
50 :    
51 :     fun ppDcon ppstrm =
52 :     let fun ppD(DATACON{name, rep=A.EXN acc, ...}) =
53 :     (ppSym ppstrm (name);
54 :     if !internals then ppAccess ppstrm acc else ())
55 :     | ppD(DATACON{name,...}) = ppSym ppstrm (name)
56 :     in ppD
57 :     end
58 :    
59 :     fun ppDebugDcon ppstrm env (DATACON{name,rep,const,typ,sign}) =
60 :     let val {begin_block,end_block,pps,add_break,...} = en_pp ppstrm
61 :     val ppSym = ppSym ppstrm
62 :     in begin_block CONSISTENT 3;
63 :     pps "DATACON";
64 :     add_break(0,0);
65 :     pps "{name = "; ppSym name; add_comma_nl ppstrm;
66 :     pps "const = "; pps (Bool.toString const); add_comma_nl ppstrm;
67 :     pps "typ = "; ppType env ppstrm typ; add_comma_nl ppstrm;
68 :     pps "conrep ="; ppRep ppstrm rep; add_comma_nl ppstrm;
69 :     pps "sign = ["; ppCsig ppstrm sign; pps "]}";
70 :     end_block()
71 :     end
72 :    
73 :     fun ppDatacon (env:StaticEnv.staticEnv,DATACON{name,typ,...}) ppstrm =
74 :     let val {begin_block,end_block,pps,...} = en_pp ppstrm
75 :     in begin_block INCONSISTENT 0;
76 :     ppSym ppstrm name; pps " : "; ppType env ppstrm typ;
77 :     end_block()
78 :     end
79 :    
80 :     fun ppConBinding ppstrm =
81 :     let val {begin_block,end_block,pps,...} = en_pp ppstrm
82 :     fun ppCon (DATACON{name, typ, rep=A.EXN _, ...}, env) =
83 :     (begin_block CONSISTENT 0;
84 :     pps "exception "; ppSym ppstrm name;
85 :     if BasicTypes.isArrowType typ then
86 :     (pps " of ";
87 :     ppType env ppstrm (BasicTypes.domain typ))
88 :     else ();
89 :     end_block())
90 :     | ppCon (con,env) =
91 :     let exception Hidden
92 :     val visibleDconTyc =
93 :     let val tyc = TU.dconTyc con
94 :     in
95 :     (TypesUtil.equalTycon
96 :     (LU.lookTyc
97 :     (env,SymPath.SPATH
98 :     [InvPath.last(TypesUtil.tycPath tyc)],
99 :     fn _ => raise Hidden),
100 :     tyc)
101 :     handle Hidden => false)
102 :     end
103 :     in if !internals orelse not visibleDconTyc
104 :     then (begin_block CONSISTENT 0;
105 :     pps "con ";
106 :     ppDatacon(env,con) ppstrm;
107 :     end_block())
108 :     else ()
109 :     end
110 :     in ppCon
111 :     end
112 :    
113 :     fun ppVar ppstrm (VALvar {access,path,...}) =
114 :     (pps ppstrm (SymPath.toString path);
115 :     if !internals then ppAccess ppstrm access else ())
116 :     | ppVar ppstrm (OVLDvar {name,...}) = ppSym ppstrm (name)
117 :     | ppVar ppstrm (ERRORvar) = add_string ppstrm "<errorvar>"
118 :    
119 :     fun ppDebugVar ppstrm env =
120 :     let val {begin_block,end_block,pps,...} = en_pp ppstrm
121 :     val ppAccess = ppAccess ppstrm
122 :     val ppInfo = ppInfo ppstrm
123 :     fun ppDV(VALvar {access,path,typ,info}) =
124 :     (begin_block CONSISTENT 0;
125 :     pps "VALvar";
126 :     begin_block CONSISTENT 3;
127 :     pps "({access="; ppAccess access; add_comma_nl ppstrm;
128 :     pps "info="; ppInfo info; add_comma_nl ppstrm;
129 :     pps "path="; pps (SymPath.toString path); add_comma_nl ppstrm;
130 :     pps "typ=ref "; ppType env ppstrm (!typ);
131 :     pps "})";
132 :     end_block(); end_block())
133 :     | ppDV (OVLDvar {name,options,scheme}) =
134 :     (begin_block CONSISTENT 0;
135 :     pps "OVLDvar";
136 :     begin_block CONSISTENT 3;
137 :     pps "({name="; ppSym ppstrm (name); add_comma_nl ppstrm;
138 :     pps "options=[";
139 :     (ppvseq ppstrm 0 ","
140 :     (fn ppstrm => fn {indicator,variant} =>
141 :     (pps "{indicator=";ppType env ppstrm indicator;
142 :     add_comma_nl ppstrm;
143 :     pps " variant ="; ppDebugVar ppstrm env variant; pps "}"))
144 :     (!options));
145 :     pps "]"; add_comma_nl ppstrm;
146 :     pps "scheme="; ppTyfun env ppstrm scheme; pps "})";
147 :     end_block();
148 :     end_block())
149 :     | ppDV (ERRORvar) = pps "<ERRORvar>"
150 :     in ppDV
151 :     end
152 :    
153 :     fun ppVariable ppstrm =
154 :     let val {begin_block,end_block,pps,...} = en_pp ppstrm
155 :     fun ppV(env:StaticEnv.staticEnv,VALvar{path,access,typ,info}) =
156 :     (begin_block CONSISTENT 0;
157 :     pps(SymPath.toString path);
158 :     if !internals then ppAccess ppstrm access else ();
159 :     pps " : "; ppType env ppstrm (!typ);
160 :     end_block())
161 :     | ppV (env,OVLDvar {name,options=ref optl,scheme=TYFUN{body,...}}) =
162 :     (begin_block CONSISTENT 0;
163 :     ppSym ppstrm (name); pps " : "; ppType env ppstrm body;
164 :     pps " as ";
165 :     ppSequence ppstrm
166 :     {sep=C PrettyPrint.add_break(1,0),
167 :     pr=(fn ppstrm => fn{variant,...} =>ppV(env,variant)),
168 :     style=CONSISTENT}
169 :     optl;
170 :     end_block())
171 :     | ppV(_,ERRORvar) = pps "<ERRORvar>"
172 :     in ppV
173 :     end
174 :    
175 :     end (* local *)
176 :     end (* structure PPVal *)
177 :    
178 :     (*
179 :     * $Log: ppval.sml,v $
180 :     * Revision 1.3 1997/12/16 17:51:37 dbm
181 :     * Fix bug 1325. Add ERRORvar case to ppVar.
182 :     *
183 :     * Revision 1.2 1997/11/11 05:28:38 dbm
184 :     * Fix variable printing: get rid of ": overload".
185 :     *
186 :     * Revision 1.1.1.1 1997/01/14 01:38:44 george
187 :     * Version 109.24
188 :     *
189 :     *)

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