1(*
2 * @TAG(OTHER_PRINCETON_OSS)
3 *)
4(* Modified by sweeks@acm.org on 2000-8-24.
5 * Ported to MLton.
6 *)
7type int = Int.int
8
9(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi
10 *
11 * $Log$
12 * Revision 1.1  2006/06/22 07:40:27  michaeln
13 * Add a MoscowML compilable implementation of MLyacc, using the MLton sources
14 * as the base.
15 *
16 * Revision 1.1.1.1  1998/04/08 18:40:16  george
17 * Version 110.5
18 *
19 * Revision 1.1.1.1  1997/01/14 01:38:05  george
20 *   Version 109.24
21 *
22 * Revision 1.2  1996/02/26  15:02:34  george
23 *    print no longer overloaded.
24 *    use of makestring has been removed and replaced with Int.toString ..
25 *    use of IO replaced with TextIO
26 *
27 * Revision 1.1.1.1  1996/01/31  16:01:45  george
28 * Version 109
29 *
30 *)
31
32functor HeaderFun () : HEADER =
33  struct
34        val DEBUG = true
35
36        type pos = int
37        val lineno: int ref = ref 0
38        val text = ref (nil: string list)
39        type inputSource = {name : string,
40                            errStream : TextIO.outstream,
41                            inStream : TextIO.instream,
42                            errorOccurred : bool ref}
43
44        val newSource =
45          fn (s : string,i : TextIO.instream ,errs : TextIO.outstream) =>
46              {name=s,errStream=errs,inStream=i,
47               errorOccurred = ref false}
48
49        val errorOccurred = fn (s : inputSource) =>fn () => !(#errorOccurred s)
50
51        val pr = fn out : TextIO.outstream => fn s : string => TextIO.output(out,s)
52
53        val error = fn {name,errStream, errorOccurred,...} : inputSource =>
54              let val pr = pr errStream
55              in fn l : pos => fn msg : string =>
56                  (pr name; pr ", line "; pr (Int.toString l); pr ": Error: ";
57                   pr msg; pr "\n"; errorOccurred := true)
58              end
59
60        val warn = fn {name,errStream, errorOccurred,...} : inputSource =>
61              let val pr = pr errStream
62              in fn l : pos => fn msg : string =>
63                  (pr name; pr ", line "; pr (Int.toString l); pr ": Warning: ";
64                   pr msg; pr "\n")
65              end
66
67        datatype prec = LEFT | RIGHT | NONASSOC
68
69        datatype symbol = SYMBOL of string * pos
70        val symbolName = fn SYMBOL(s,_) => s
71        val symbolPos = fn SYMBOL(_,p) => p
72        val symbolMake = fn sp => SYMBOL sp
73
74        type ty = string
75        val tyName = fn i => i
76        val tyMake = fn i => i
77
78        datatype control = NODEFAULT | VERBOSE | PARSER_NAME of symbol |
79                           FUNCTOR of string  | START_SYM of symbol |
80                           NSHIFT of symbol list | POS of string | PURE |
81                           PARSE_ARG of string * string |
82                           TOKEN_SIG_INFO of string
83
84        datatype declData = DECL of
85                        {eop : symbol list,
86                         keyword : symbol list,
87                         nonterm : (symbol*ty option) list option,
88                         prec : (prec * (symbol list)) list,
89                         change: (symbol list * symbol list) list,
90                         term : (symbol* ty option) list option,
91                         control : control list,
92                         value : (symbol * string) list}
93
94        type rhsData = {rhs:symbol list,code:string, prec:symbol option} list
95        datatype rule = RULE of {lhs : symbol, rhs : symbol list,
96                                 code : string, prec : symbol option}
97
98         type parseResult = string * declData * rule list
99        val getResult = fn p => p
100
101        fun join_decls
102              (DECL {eop=e,control=c,keyword=k,nonterm=n,prec,
103                change=su,term=t,value=v}:declData,
104               DECL {eop=e',control=c',keyword=k',nonterm=n',prec=prec',
105                     change=su',term=t',value=v'} : declData,
106               inputSource,pos) =
107          let val ignore = fn s =>
108                        (warn inputSource pos ("ignoring duplicate " ^ s ^
109                                            " declaration"))
110              val join = fn (e,NONE,NONE) => NONE
111                          | (e,NONE,a) => a
112                          | (e,a,NONE) => a
113                          | (e,a,b) => (ignore e; a)
114              fun mergeControl (nil,a) = [a]
115                | mergeControl (l as h::t,a) =
116                     case (h,a)
117                       of (PARSER_NAME _,PARSER_NAME n1) => (ignore "%name"; l)
118                      | (FUNCTOR _,FUNCTOR _) => (ignore "%header"; l)
119                      | (PARSE_ARG _,PARSE_ARG _) => (ignore "%arg"; l)
120                      | (START_SYM _,START_SYM s) => (ignore "%start"; l)
121                      | (POS _,POS _) => (ignore "%pos"; l)
122                      | (TOKEN_SIG_INFO _, TOKEN_SIG_INFO _)
123                         => (ignore "%token_sig_info"; l)
124                      | (NSHIFT a,NSHIFT b) => (NSHIFT (a@b)::t)
125                      | _ => h :: mergeControl(t,a)
126              fun loop (nil,r) = r
127                | loop (h::t,r) = loop(t,mergeControl(r,h))
128         in DECL {eop=e@e',control=loop(c',c),keyword=k'@k,
129            nonterm=join("%nonterm",n,n'), prec=prec@prec',
130            change=su@su', term=join("%term",t,t'),value=v@v'} :
131                   declData
132        end
133end;
134
135structure Header = HeaderFun();
136
137