1(*
2 * @TAG(OTHER_PRINCETON_OSS)
3 *)
4(* ML-Yacc Parser Generator (c) 1991 Andrew W. Appel, David R. Tarditi
5 *
6 * $Log$
7 * Revision 1.1  2006/06/22 07:40:27  michaeln
8 * Add a MoscowML compilable implementation of MLyacc, using the MLton sources
9 * as the base.
10 *
11 * Revision 1.1.1.1  1997/01/14 01:38:05  george
12 *   Version 109.24
13 *
14 * Revision 1.3  1996/02/26  15:02:30  george
15 *    print no longer overloaded.
16 *    use of makestring has been removed and replaced with Int.toString ..
17 *    use of IO replaced with TextIO
18 *
19 * Revision 1.2  1996/02/15  01:51:38  jhr
20 * Replaced character predicates (isalpha, isnum) with functions from Char.
21 *
22 * Revision 1.1.1.1  1996/01/31  16:01:44  george
23 * Version 109
24 *
25 *)
26
27structure Absyn : ABSYN =
28  struct
29    datatype exp
30      = CODE of string
31      | EAPP of exp * exp
32      | EINT of int
33      | ETUPLE of exp list
34      | EVAR of string
35      | FN of pat * exp
36      | LET of decl list * exp
37      | SEQ of exp * exp
38      | UNIT
39    and pat
40      = PVAR of string
41      | PAPP of string * pat
42      | PINT of int
43      | PLIST of pat list
44      | PTUPLE of pat list
45      | WILD
46      | AS of pat * pat
47    and decl = VB of pat * exp
48    and rule = RULE of pat * exp
49
50    fun idchar #"'" = true
51      | idchar #"_" = true
52      | idchar c = Char.isAlpha c orelse Char.isDigit c
53
54    fun code_to_ids s = let
55          fun g(nil,r) = r
56            | g(a as (h::t),r) = if Char.isAlpha h then f(t,[h],r) else g(t,r)
57          and f(nil,accum,r)= implode(rev accum)::r
58            | f(a as (h::t),accum,r) =
59                if idchar h then f(t,h::accum,r) else g(a,implode (rev accum) :: r)
60          in g(explode s,nil)
61          end
62
63         val simplifyRule : rule -> rule = fn (RULE(p,e)) =>
64            let val used : (string -> bool) =
65               let fun f(CODE s) = code_to_ids s
66                     | f(EAPP(a,b)) = f a @ f b
67                     | f(ETUPLE l) = List.concat (map f l)
68                     | f(EVAR s) = [s]
69                     | f(FN(_,e)) = f e
70                     | f(LET(dl,e)) =
71                          (List.concat (map (fn VB(_,e) => f e) dl)) @ f e
72                     | f(SEQ(a,b)) = f a @ f b
73                     | f _ = nil
74                   val identifiers = f e
75               in fn s => List.exists (fn a=>a=s) identifiers
76               end
77              val simplifyPat : pat -> pat =
78                let fun f a =
79                    case a
80                    of (PVAR s) => if used s then a else WILD
81                     | (PAPP(s,pat)) =>
82                         (case f pat
83                          of WILD => WILD
84                           | pat' => PAPP(s,pat'))
85                     | (PLIST l) =>
86                          let val l' = map f l
87                          in if List.exists(fn WILD=>false | _ => true) l'
88                                then PLIST l'
89                             else WILD
90                          end
91                     | (PTUPLE l) =>
92                          let val l' = map f l
93                          in if List.exists(fn WILD=>false | _ => true) l'
94                             then PTUPLE l'
95                             else WILD
96                          end
97                     | (AS(a,b)) =>
98                         let val a'=f a
99                             val b'=f b
100                         in case(a',b')
101                            of (WILD,_) => b'
102                             | (_,WILD) => a'
103                             | _ => AS(a',b')
104                         end
105                     | _ => a
106               in f
107               end
108           val simplifyExp : exp -> exp =
109               let fun f(EAPP(a,b)) = EAPP(f a,f b)
110                     | f(ETUPLE l) = ETUPLE(map f l)
111                     | f(FN(p,e)) = FN(simplifyPat p,f e)
112                     | f(LET(dl,e)) =
113                          LET(map (fn VB(p,e) =>
114                                  VB(simplifyPat p,f e)) dl,
115                              f e)
116                     | f(SEQ(a,b)) = SEQ(f a,f b)
117                     | f a = a
118               in f
119               end
120       in RULE(simplifyPat p,simplifyExp e)
121       end
122
123       fun printRule (say : string -> unit, sayln:string -> unit) = let
124         val lp = ["("]
125         val rp = [")"]
126         val sp = [" "]
127         val sm = [";"]
128         val cm = [","]
129         val cr = ["\n"]
130         val unit = ["()"]
131          fun printExp c =
132           let fun f (CODE c) = ["(",c,")"]
133                 | f (EAPP(EVAR a,UNIT)) = [a," ","()"]
134                 | f (EAPP(EVAR a,EINT i)) =  [a," ",Int.toString i]
135                 | f (EAPP(EVAR a,EVAR b)) = [a," ",b]
136                 | f (EAPP(EVAR a,b)) = List.concat[[a],lp,f b,rp]
137                 | f (EAPP(a,b)) = List.concat [lp,f a,rp,lp,f b,rp]
138                 | f (EINT i) = [Int.toString i]
139                 | f (ETUPLE (a::r)) =
140                      let fun scan nil = [rp]
141                            | scan (h :: t) = cm :: f h :: scan t
142                      in List.concat (lp :: f a :: scan r)
143                      end
144                 | f (ETUPLE _) = ["<bogus-tuple>"]
145                 | f (EVAR s) = [s]
146                 | f (FN (p,b)) = List.concat[["fn "],printPat p,[" => "],f b]
147                 | f (LET (nil,body)) = f body
148                 | f (LET (dl,body)) =
149                      let fun scan nil = [[" in "],f body,[" end"],cr]
150                            | scan (h :: t) = printDecl h :: scan t
151                      in List.concat(["let "] :: scan dl)
152                      end
153                 | f (SEQ (a,b)) = List.concat [lp,f a,sm,f b,rp]
154                 | f (UNIT) = unit
155          in f c
156          end
157         and printDecl (VB (pat,exp)) =
158                  List.concat[["val "],printPat pat,["="],printExp exp,cr]
159         and printPat c =
160           let fun f (AS(PVAR a,PVAR b)) = [a," as ",b]
161                 | f (AS(a,b)) = List.concat [lp,f a,[") as ("],f b,rp]
162                 | f (PAPP(a,WILD)) = [a," ","_"]
163                 | f (PAPP(a,PINT i)) =  [a," ",Int.toString i]
164                 | f (PAPP(a,PVAR b)) = [a," ",b]
165                 | f (PAPP(a,b)) = List.concat [lp,[a],sp,f b,rp]
166                 | f (PINT i) = [Int.toString i]
167                 | f (PLIST nil) = ["<bogus-list>"]
168                 | f (PLIST l) =
169                      let fun scan (h :: nil) = [f h]
170                            | scan (h :: t) = f h :: ["::"] :: scan t
171                            | scan _ = raise Fail "scan"
172                      in List.concat (scan l)
173                      end
174                 | f (PTUPLE (a::r)) =
175                      let fun scan nil = [rp]
176                            | scan (h :: t) = cm :: f h :: scan t
177                      in List.concat (lp :: f a :: scan r)
178                      end
179                 | f (PTUPLE nil) = ["<bogus-pattern-tuple>"]
180                 | f (PVAR a) = [a]
181                 | f WILD = ["_"]
182           in f c
183           end
184           fun oursay "\n" = sayln ""
185             | oursay a = say a
186         in fn a =>
187              let val RULE(p,e) = simplifyRule a
188              in app oursay (printPat p);
189                 say " => ";
190                 app oursay (printExp e)
191              end
192         end
193end;
194