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/SMLNJ/src/ml-yacc/src/yacc.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/ml-yacc/src/yacc.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 167 - (view) (download)

1 : monnier 2 (* ML-Yacc Parser Generator (c) 1989, 1990 Andrew W. Appel, David R. Tarditi
2 :     *
3 :     * $Log$
4 : monnier 167 * Revision 1.1.1.6 1998/11/07 20:11:15 monnier
5 :     * version $version
6 : monnier 2 *
7 : monnier 139 * Revision 1.1.1.1 1998/04/08 18:40:17 george
8 :     * Version 110.5
9 :     *
10 : monnier 8 * Revision 1.2 1997/07/25 16:01:29 jhr
11 :     * Fixed bug with long constructor names (#1237).
12 :     *
13 : monnier 2 # Revision 1.1.1.1 1997/01/14 01:38:06 george
14 :     # Version 109.24
15 :     #
16 :     * Revision 1.3 1996/05/30 18:05:09 dbm
17 :     * Made changes to generate code that conforms to the value restriction by
18 :     * lifting lets to locals in the code generated to define errtermvalue and action.
19 :     *
20 :     * Revision 1.2 1996/02/26 15:02:40 george
21 :     * print no longer overloaded.
22 :     * use of makestring has been removed and replaced with Int.toString ..
23 :     * use of IO replaced with TextIO
24 :     *
25 :     * Revision 1.1.1.1 1996/01/31 16:01:48 george
26 :     * Version 109
27 :     *
28 :     *)
29 :    
30 :     functor ParseGenFun(structure ParseGenParser : PARSE_GEN_PARSER
31 :     structure MakeTable : MAKE_LR_TABLE
32 :     structure Verbose : VERBOSE
33 :     structure PrintStruct : PRINT_STRUCT
34 :    
35 :     sharing MakeTable.LrTable = PrintStruct.LrTable
36 :     sharing MakeTable.Errs = Verbose.Errs
37 :    
38 :     structure Absyn : ABSYN
39 :     ) : PARSE_GEN =
40 :     struct
41 :     open Array List
42 :     infix 9 sub
43 :     structure Grammar = MakeTable.Grammar
44 :     structure Header = ParseGenParser.Header
45 :    
46 :     open Header Grammar
47 :    
48 :     (* approx. maximum length of a line *)
49 :    
50 :     val lineLength = 70
51 :    
52 :     (* record type describing names of structures in the program being
53 :     generated *)
54 :    
55 :     datatype names = NAMES
56 :     of {miscStruct : string, (* Misc{n} struct name *)
57 :     tableStruct : string, (* LR table structure *)
58 :     tokenStruct : string, (* Tokens{n} struct name *)
59 :     actionsStruct : string, (* Actions structure *)
60 :     valueStruct: string, (* semantic value structure *)
61 :     ecStruct : string, (* error correction structure *)
62 :     arg: string, (* user argument for parser *)
63 :     tokenSig : string, (* TOKENS{n} signature *)
64 :     miscSig :string, (* Signature for Misc structure *)
65 :     dataStruct:string, (* name of structure in Misc *)
66 :     (* which holds parser data *)
67 :     dataSig:string (* signature for this structure *)
68 :    
69 :     }
70 :    
71 :     val DEBUG = true
72 :     exception Semantic
73 :    
74 :     (* common functions and values used in printing out program *)
75 :    
76 :     datatype values = VALS
77 :     of {say : string -> unit,
78 :     saydot : string -> unit,
79 :     sayln : string -> unit,
80 :     pureActions: bool,
81 :     pos_type : string,
82 :     arg_type : string,
83 :     ntvoid : string,
84 :     termvoid : string,
85 :     start : Grammar.nonterm,
86 :     hasType : Grammar.symbol -> bool,
87 :    
88 :     (* actual (user) name of terminal *)
89 :    
90 :     termToString : Grammar.term -> string,
91 :     symbolToString : Grammar.symbol -> string,
92 :    
93 :     (* type symbol comes from the HDR structure,
94 :     and is now abstract *)
95 :    
96 :     term : (Header.symbol * ty option) list,
97 :     nonterm : (Header.symbol * ty option) list,
98 : monnier 139 terms : Grammar.term list,
99 :    
100 :     (* tokenInfo is the user inserted spec in
101 :     the *_TOKEN sig*)
102 :     tokenInfo : string option}
103 : monnier 2
104 :     structure SymbolHash = Hash(type elem = string
105 :     val gt = (op >) : string*string -> bool)
106 :    
107 :     structure TermTable = Table(type key = Grammar.term
108 :     val gt = fn (T i,T j) => i > j)
109 :    
110 :     structure SymbolTable = Table(
111 :     type key = Grammar.symbol
112 :     val gt = fn (TERM(T i),TERM(T j)) => i>j
113 :     | (NONTERM(NT i),NONTERM(NT j)) => i>j
114 :     | (NONTERM _,TERM _) => true
115 :     | (TERM _,NONTERM _) => false)
116 :    
117 :     (* printTypes: function to print the following types in the LrValues
118 :     structure and a structure containing the datatype svalue:
119 :    
120 :     type svalue -- it holds semantic values on the parse
121 :     stack
122 :     type pos -- the type of line numbers
123 :     type result -- the type of the value that results
124 :     from the parse
125 :    
126 :     The type svalue is set equal to the datatype svalue declared
127 :     in the structure named by valueStruct. The datatype svalue
128 :     is declared inside the structure named by valueStruct to deal
129 :     with the scope of constructors.
130 :     *)
131 :    
132 :     val printTypes = fn (VALS {say,sayln,term,nonterm,symbolToString,pos_type,
133 :     arg_type,
134 :     termvoid,ntvoid,saydot,hasType,start,
135 :     pureActions,...},
136 :     NAMES {valueStruct,...},symbolType) =>
137 :     let val prConstr = fn (symbol,SOME s) =>
138 :     say (" | " ^ (symbolName symbol) ^ " of " ^
139 :     (if pureActions then "" else "unit -> ") ^
140 :     " (" ^ tyName s ^ ")"
141 :     )
142 :     | _ => ()
143 :     in sayln "local open Header in";
144 :     sayln ("type pos = " ^ pos_type);
145 :     sayln ("type arg = " ^ arg_type);
146 :     sayln ("structure " ^ valueStruct ^ " = ");
147 :     sayln "struct";
148 :     say ("datatype svalue = " ^ termvoid ^ " | " ^ ntvoid ^ " of" ^
149 :     (if pureActions then "" else " unit -> ") ^ " unit");
150 :     app prConstr term;
151 :     app prConstr nonterm;
152 :     sayln "\nend";
153 :     sayln ("type svalue = " ^ valueStruct ^ ".svalue");
154 :     say "type result = ";
155 :     case symbolType (NONTERM start)
156 :     of NONE => sayln "unit"
157 :     | SOME t => (say (tyName t); sayln "");
158 :     sayln "end"
159 :     end
160 :    
161 :     (* function to print Tokens{n} structure *)
162 :    
163 :     val printTokenStruct =
164 :     fn (VALS {say, sayln, termToString, hasType,termvoid,terms,
165 : monnier 139 pureActions,tokenInfo,...},
166 : monnier 2 NAMES {miscStruct,tableStruct,valueStruct,
167 :     tokenStruct,tokenSig,dataStruct,...}) =>
168 :     (sayln ("structure " ^ tokenStruct ^ " : " ^ tokenSig ^ " =");
169 :     sayln "struct";
170 : monnier 139 (case tokenInfo of
171 :     NONE => ()
172 :     | _ => sayln ("open "^dataStruct^".Header"));
173 : monnier 2 sayln ("type svalue = " ^ dataStruct ^ ".svalue");
174 :     sayln "type ('a,'b) token = ('a,'b) Token.token";
175 :     let val f = fn term as T i =>
176 :     (say "fun "; say (termToString term);
177 :     say " (";
178 :     if (hasType (TERM term)) then say "i," else ();
179 :     say "p1,p2) = Token.TOKEN (";
180 :     say (dataStruct ^ "." ^ tableStruct ^ ".T ");
181 :     say (Int.toString i);
182 :     say ",(";
183 :     say (dataStruct ^ "." ^ valueStruct ^ ".");
184 :     if (hasType (TERM term)) then
185 :     (say (termToString term);
186 :     if pureActions then say " i"
187 :     else say " (fn () => i)")
188 :     else say termvoid;
189 :     say ",";
190 :     sayln "p1,p2))")
191 :     in app f terms
192 :     end;
193 :     sayln "end")
194 :    
195 :     (* function to print signatures out - takes print function which
196 :     does not need to insert line breaks *)
197 :    
198 : monnier 139 val printSigs = fn (VALS {term,tokenInfo,...},
199 : monnier 2 NAMES {tokenSig,tokenStruct,miscSig,
200 :     dataStruct, dataSig, ...},
201 :     say) =>
202 : monnier 139 say ("signature " ^ tokenSig ^ " =\nsig\n"^
203 :     (case tokenInfo of NONE => "" | SOME s => (s^"\n"))^
204 :     "type ('a,'b) token\ntype svalue\n" ^
205 : monnier 2 (List.foldr (fn ((s,ty),r) => String.concat [
206 :     "val ", symbolName s,
207 :     (case ty
208 :     of NONE => ": "
209 :     | SOME l => ": (" ^ (tyName l) ^ ") * "),
210 :     " 'a * 'a -> (svalue,'a) token\n", r]) "" term) ^
211 :     "end\nsignature " ^ miscSig ^
212 :     "=\nsig\nstructure Tokens : " ^ tokenSig ^
213 :     "\nstructure " ^ dataStruct ^ ":" ^ dataSig ^
214 :     "\nsharing type " ^ dataStruct ^
215 :     ".Token.token = Tokens.token\nsharing type " ^
216 :     dataStruct ^ ".svalue = Tokens.svalue\nend\n")
217 :    
218 :     (* function to print structure for error correction *)
219 :    
220 :     val printEC = fn (keyword : term list,
221 :     preferred_change : (term list * term list) list,
222 :     noshift : term list,
223 :     value : (term * string) list,
224 :     VALS {termToString, say,sayln,terms,saydot,hasType,
225 :     termvoid,pureActions,...},
226 :     NAMES {ecStruct,tableStruct,valueStruct,...}) =>
227 :     let
228 :    
229 :     val sayterm = fn (T i) => (say "(T "; say (Int.toString i); say ")")
230 :    
231 :     val printBoolCase = fn ( l : term list) =>
232 :     (say "fn ";
233 :     app (fn t => (sayterm t; say " => true"; say " | ")) l;
234 :     sayln "_ => false")
235 :    
236 :     val printTermList = fn (l : term list) =>
237 :     (app (fn t => (sayterm t; say " :: ")) l; sayln "nil")
238 :    
239 :     fun printChange () =
240 :     (sayln "val preferred_change = ";
241 :     app (fn (d,i) =>
242 :     (say"("; printTermList d; say ","; printTermList i;
243 :     sayln ")::"
244 :     )
245 :     ) preferred_change;
246 :     sayln "nil")
247 :    
248 :     val printErrValues = fn (l : (term * string) list) =>
249 :     (sayln "local open Header in";
250 :     sayln "val errtermvalue=";
251 :     say "fn ";
252 :     app (fn (t,s) =>
253 :     (sayterm t; say " => ";
254 :     saydot valueStruct; say (termToString t);
255 :     say "(";
256 :     if pureActions then () else say "fn () => ";
257 :     say "("; say s; say "))";
258 :     sayln " | "
259 :     )
260 :     ) l;
261 :     say "_ => ";
262 :     say (valueStruct ^ ".");
263 :     sayln termvoid; sayln "end")
264 :    
265 :    
266 :     val printNames = fn () =>
267 :     let val f = fn term => (
268 :     sayterm term; say " => ";
269 :     sayln (String.concat["\"", termToString term, "\""]);
270 :     say " | ")
271 :     in (sayln "val showTerminal =";
272 :     say "fn ";
273 :     app f terms;
274 :     sayln "_ => \"bogus-term\"")
275 :     end
276 :    
277 :     val ecTerms =
278 :     List.foldr (fn (t,r) =>
279 :     if hasType (TERM t) orelse exists (fn (a,_)=>a=t) value
280 :     then r
281 :     else t::r)
282 :     [] terms
283 :    
284 :     in say "structure ";
285 :     say ecStruct;
286 :     sayln "=";
287 :     sayln "struct";
288 :     say "open ";
289 :     sayln tableStruct;
290 :     sayln "val is_keyword =";
291 :     printBoolCase keyword;
292 :     printChange();
293 :     sayln "val noShift = ";
294 :     printBoolCase noshift;
295 :     printNames ();
296 :     printErrValues value;
297 :     say "val terms = ";
298 :     printTermList ecTerms;
299 :     sayln "end"
300 :     end
301 :    
302 :     val printAction = fn (rules,
303 :     VALS {hasType,say,sayln,termvoid,ntvoid,
304 :     symbolToString,saydot,start,pureActions,...},
305 :     NAMES {actionsStruct,valueStruct,tableStruct,arg,...}) =>
306 :     let val printAbsynRule = Absyn.printRule(say,sayln)
307 :     val is_nonterm = fn (NONTERM i) => true | _ => false
308 :     val numberRhs = fn r =>
309 :     List.foldl (fn (e,(r,table)) =>
310 :     let val num = case SymbolTable.find(e,table)
311 :     of SOME i => i
312 :     | NONE => 1
313 :     in ((e,num,hasType e orelse is_nonterm e)::r,
314 :     SymbolTable.insert((e,num+1),table))
315 :     end) (nil,SymbolTable.empty) r
316 :    
317 :     val saySym = symbolToString
318 :    
319 :     val printCase = fn (i:int, r as {lhs=lhs as (NT lhsNum),prec,
320 :     rhs,code,rulenum}) =>
321 :    
322 :     (* mkToken: Build an argument *)
323 :    
324 :     let open Absyn
325 :     val mkToken = fn (sym,num : int,typed) =>
326 :     let val symString = symbolToString sym
327 :     val symNum = symString ^ (Int.toString num)
328 :     in PTUPLE[WILD,
329 :     PTUPLE[if not (hasType sym) then
330 :     (if is_nonterm sym then
331 :     PAPP(valueStruct^"."^ntvoid,
332 :     PVAR symNum)
333 :     else WILD)
334 :     else
335 :     PAPP(valueStruct^"."^symString,
336 :     if num=1 andalso pureActions
337 :     then AS(PVAR symNum,PVAR symString)
338 :     else PVAR symNum),
339 :     if num=1 then AS(PVAR (symString^"left"),
340 :     PVAR(symNum^"left"))
341 :     else PVAR(symNum^"left"),
342 :     if num=1 then AS(PVAR(symString^"right"),
343 :     PVAR(symNum^"right"))
344 :     else PVAR(symNum^"right")]]
345 :     end
346 :    
347 :     val numberedRhs = #1 (numberRhs rhs)
348 :    
349 :     (* construct case pattern *)
350 :    
351 :     val pat = PTUPLE[PINT i,PLIST(map mkToken numberedRhs @
352 :     [PVAR "rest671"])]
353 :    
354 :     (* remove terminals in argument list w/o types *)
355 :    
356 :     val argsWithTypes =
357 :     List.foldr (fn ((_,_,false),r) => r
358 :     | (s as (_,_,true),r) => s::r) nil numberedRhs
359 :    
360 :     (* construct case body *)
361 :    
362 :     val defaultPos = EVAR "defaultPos"
363 :     val resultexp = EVAR "result"
364 :     val resultpat = PVAR "result"
365 :     val code = CODE code
366 :     val rest = EVAR "rest671"
367 :    
368 :     val body =
369 :     LET([VB(resultpat,
370 :     EAPP(EVAR(valueStruct^"."^
371 :     (if hasType (NONTERM lhs)
372 :     then saySym(NONTERM lhs)
373 :     else ntvoid)),
374 :     if pureActions then code
375 :     else if argsWithTypes=nil then FN(WILD,code)
376 :     else
377 :     FN(WILD,
378 :     let val body =
379 :     LET(map (fn (sym,num:int,_) =>
380 :     let val symString = symbolToString sym
381 :     val symNum = symString ^ Int.toString num
382 :     in VB(if num=1 then
383 :     AS(PVAR symString,PVAR symNum)
384 :     else PVAR symNum,
385 :     EAPP(EVAR symNum,UNIT))
386 :     end) (rev argsWithTypes),
387 :     code)
388 :     in if hasType (NONTERM lhs) then
389 :     body else SEQ(body,UNIT)
390 :     end)))],
391 :     ETUPLE[EAPP(EVAR(tableStruct^".NT"),EINT(lhsNum)),
392 :     case rhs
393 :     of nil => ETUPLE[resultexp,defaultPos,defaultPos]
394 :     | r =>let val (rsym,rnum,_) = hd(numberedRhs)
395 :     val (lsym,lnum,_) = hd(rev numberedRhs)
396 :     in ETUPLE[resultexp,
397 :     EVAR (symbolToString lsym ^
398 :     Int.toString lnum ^ "left"),
399 :     EVAR (symbolToString rsym ^
400 :     Int.toString rnum ^ "right")]
401 :     end,
402 :     rest])
403 :     in printAbsynRule (RULE(pat,body))
404 :     end
405 :    
406 :     val prRules = fn () =>
407 :     (sayln "fn (i392,defaultPos,stack,";
408 :     say " ("; say arg; sayln "):arg) =>";
409 :     sayln "case (i392,stack)";
410 :     say "of ";
411 :     app (fn (rule as {rulenum,...}) =>
412 :     (printCase(rulenum,rule); say "| ")) rules;
413 :     sayln "_ => raise (mlyAction i392)")
414 :    
415 :     in say "structure ";
416 :     say actionsStruct;
417 :     sayln " =";
418 :     sayln "struct ";
419 :     sayln "exception mlyAction of int";
420 :     sayln "local open Header in";
421 :     sayln "val actions = ";
422 :     prRules();
423 :     sayln "end";
424 :     say "val void = ";
425 :     saydot valueStruct;
426 :     sayln termvoid;
427 :     say "val extract = ";
428 :     say "fn a => (fn ";
429 :     saydot valueStruct;
430 :     if hasType (NONTERM start)
431 :     then say (symbolToString (NONTERM start))
432 :     else say "ntVOID";
433 :     sayln " x => x";
434 :     sayln "| _ => let exception ParseInternal";
435 :     say "\tin raise ParseInternal end) a ";
436 :     sayln (if pureActions then "" else "()");
437 :     sayln "end"
438 :     end
439 :    
440 :     val make_parser = fn ((header,
441 :     DECL {eop,change,keyword,nonterm,prec,
442 :     term, control,value} : declData,
443 :     rules : rule list),spec,error : pos -> string -> unit,
444 :     wasError : unit -> bool) =>
445 :     let
446 :     val verbose = List.exists (fn VERBOSE=>true | _ => false) control
447 :     val defaultReductions = not (List.exists (fn NODEFAULT=>true | _ => false) control)
448 :     val pos_type =
449 :     let fun f nil = NONE
450 :     | f ((POS s)::r) = SOME s
451 :     | f (_::r) = f r
452 :     in f control
453 :     end
454 :     val start =
455 :     let fun f nil = NONE
456 :     | f ((START_SYM s)::r) = SOME s
457 :     | f (_::r) = f r
458 :     in f control
459 :     end
460 :     val name =
461 :     let fun f nil = NONE
462 :     | f ((PARSER_NAME s)::r) = SOME s
463 :     | f (_::r) = f r
464 :     in f control
465 :     end
466 :     val header_decl =
467 :     let fun f nil = NONE
468 :     | f ((FUNCTOR s)::r) = SOME s
469 :     | f (_::r) = f r
470 :     in f control
471 :     end
472 : monnier 139
473 :     val token_sig_info_decl =
474 :     let fun f nil = NONE
475 :     | f ((TOKEN_SIG_INFO s)::_) = SOME s
476 :     | f (_::r) = f r
477 :     in f control
478 :     end
479 :    
480 : monnier 2 val arg_decl =
481 :     let fun f nil = ("()","unit")
482 :     | f ((PARSE_ARG s)::r) = s
483 :     | f (_::r) = f r
484 :     in f control
485 :     end
486 :    
487 :     val noshift =
488 :     let fun f nil = nil
489 :     | f ((NSHIFT s)::r) = s
490 :     | f (_::r) = f r
491 :     in f control
492 :     end
493 :    
494 :     val pureActions =
495 :     let fun f nil = false
496 :     | f ((PURE)::r) = true
497 :     | f (_::r) = f r
498 :     in f control
499 :     end
500 :    
501 :     val term =
502 :     case term
503 :     of NONE => (error 1 "missing %term definition"; nil)
504 :     | SOME l => l
505 :    
506 :     val nonterm =
507 :     case nonterm
508 :     of NONE => (error 1 "missing %nonterm definition"; nil)
509 :     | SOME l => l
510 :    
511 :     val pos_type =
512 :     case pos_type
513 :     of NONE => (error 1 "missing %pos definition"; "")
514 :     | SOME l => l
515 :    
516 :    
517 :     val termHash =
518 :     List.foldr (fn ((symbol,_),table) =>
519 :     let val name = symbolName symbol
520 :     in if SymbolHash.exists(name,table) then
521 :     (error (symbolPos symbol)
522 :     ("duplicate definition of " ^ name ^ " in %term");
523 :     table)
524 :     else SymbolHash.add(name,table)
525 :     end) SymbolHash.empty term
526 :    
527 :     val isTerm = fn name => SymbolHash.exists(name,termHash)
528 :    
529 :     val symbolHash =
530 :     List.foldr (fn ((symbol,_),table) =>
531 :     let val name = symbolName symbol
532 :     in if SymbolHash.exists(name,table) then
533 :     (error (symbolPos symbol)
534 :     (if isTerm name then
535 :     name ^ " is defined as a terminal and a nonterminal"
536 :     else
537 :     "duplicate definition of " ^ name ^ " in %nonterm");
538 :     table)
539 :     else SymbolHash.add(name,table)
540 :     end) termHash nonterm
541 :    
542 :     fun makeUniqueId s =
543 :     if SymbolHash.exists(s,symbolHash) then makeUniqueId (s ^ "'")
544 :     else s
545 :    
546 :     val _ = if wasError() then raise Semantic else ()
547 :    
548 :     val numTerms = SymbolHash.size termHash
549 :     val numNonterms = SymbolHash.size symbolHash - numTerms
550 :    
551 :     val symError = fn sym => fn err => fn symbol =>
552 :     error (symbolPos symbol)
553 :     (symbolName symbol^" in "^err^" is not defined as a " ^ sym)
554 :    
555 :     val termNum : string -> Header.symbol -> term =
556 :     let val termError = symError "terminal"
557 :     in fn stmt =>
558 :     let val stmtError = termError stmt
559 :     in fn symbol =>
560 :     case SymbolHash.find(symbolName symbol,symbolHash)
561 :     of NONE => (stmtError symbol; T ~1)
562 :     | SOME i => T (if i<numTerms then i
563 :     else (stmtError symbol; ~1))
564 :     end
565 :     end
566 :    
567 :     val nontermNum : string -> Header.symbol -> nonterm =
568 :     let val nontermError = symError "nonterminal"
569 :     in fn stmt =>
570 :     let val stmtError = nontermError stmt
571 :     in fn symbol =>
572 :     case SymbolHash.find(symbolName symbol,symbolHash)
573 :     of NONE => (stmtError symbol; NT ~1)
574 :     | SOME i => if i>=numTerms then NT (i-numTerms)
575 :     else (stmtError symbol;NT ~1)
576 :     end
577 :     end
578 :    
579 :     val symbolNum : string -> Header.symbol -> Grammar.symbol =
580 :     let val symbolError = symError "symbol"
581 :     in fn stmt =>
582 :     let val stmtError = symbolError stmt
583 :     in fn symbol =>
584 :     case SymbolHash.find(symbolName symbol,symbolHash)
585 :     of NONE => (stmtError symbol; NONTERM (NT ~1))
586 :     | SOME i => if i>=numTerms then NONTERM(NT (i-numTerms))
587 :     else TERM(T i)
588 :     end
589 :     end
590 :    
591 :     (* map all symbols in the following values to terminals and check that
592 :     the symbols are defined as terminals:
593 :    
594 :     eop : symbol list
595 :     keyword: symbol list
596 :     prec: (lexvalue * (symbol list)) list
597 :     change: (symbol list * symbol list) list
598 :     *)
599 :    
600 :     val eop = map (termNum "%eop") eop
601 :     val keyword = map (termNum "%keyword") keyword
602 :     val prec = map (fn (a,l) =>
603 :     (a,case a
604 :     of LEFT => map (termNum "%left") l
605 :     | RIGHT => map (termNum "%right") l
606 :     | NONASSOC => map (termNum "%nonassoc") l
607 :     )) prec
608 :     val change =
609 :     let val mapTerm = termNum "%prefer, %subst, or %change"
610 :     in map (fn (a,b) => (map mapTerm a, map mapTerm b)) change
611 :     end
612 :     val noshift = map (termNum "%noshift") noshift
613 :     val value =
614 :     let val mapTerm = termNum "%value"
615 :     in map (fn (a,b) => (mapTerm a,b)) value
616 :     end
617 :     val (rules,_) =
618 :     let val symbolNum = symbolNum "rule"
619 :     val nontermNum = nontermNum "rule"
620 :     val termNum = termNum "%prec tag"
621 :     in List.foldr
622 :     (fn (RULE {lhs,rhs,code,prec},(l,n)) =>
623 :     ( {lhs=nontermNum lhs,rhs=map symbolNum rhs,
624 :     code=code,prec=case prec
625 :     of NONE => NONE
626 :     | SOME t => SOME (termNum t),
627 :     rulenum=n}::l,n-1))
628 :     (nil,length rules-1) rules
629 :     end
630 :    
631 :     val _ = if wasError() then raise Semantic else ()
632 :    
633 :     (* termToString: map terminals back to strings *)
634 :    
635 :     val termToString =
636 :     let val data = array(numTerms,"")
637 :     val unmap = fn (symbol,_) =>
638 :     let val name = symbolName symbol
639 :     in update(data,
640 :     case SymbolHash.find(name,symbolHash)
641 :     of SOME i => i,name)
642 :     end
643 :     val _ = app unmap term
644 :     in fn T i =>
645 :     if DEBUG andalso (i<0 orelse i>=numTerms)
646 :     then "bogus-num" ^ (Int.toString i)
647 :     else data sub i
648 :     end
649 :    
650 :     val nontermToString =
651 :     let val data = array(numNonterms,"")
652 :     val unmap = fn (symbol,_) =>
653 :     let val name = symbolName symbol
654 :     in update(data,
655 :     case SymbolHash.find(name,symbolHash)
656 :     of SOME i => i-numTerms,name)
657 :     end
658 :     val _ = app unmap nonterm
659 :     in fn NT i =>
660 :     if DEBUG andalso (i<0 orelse i>=numNonterms)
661 :     then "bogus-num" ^ (Int.toString i)
662 :     else data sub i
663 :     end
664 :    
665 :     (* create functions mapping terminals to precedence numbers and rules to
666 :     precedence numbers.
667 :    
668 :     Precedence statements are listed in order of ascending (tighter binding)
669 :     precedence in the specification. We receive a list composed of pairs
670 :     containing the kind of precedence (left,right, or assoc) and a list of
671 :     terminals associated with that precedence. The list has the same order as
672 :     the corresponding declarations did in the specification.
673 :    
674 :     Internally, a tighter binding has a higher precedence number. We give
675 :     precedences using multiples of 3:
676 :    
677 :     p+2 = right associative (force shift of symbol)
678 :     p+1 = precedence for rule
679 :     p = left associative (force reduction of rule)
680 :    
681 :     Nonassociative terminals are given also given a precedence of p+1. The
682 :     table generator detects when the associativity of a nonassociative terminal
683 :     is being used to resolve a shift/reduce conflict by checking if the
684 :     precedences of the rule and the terminal are equal.
685 :    
686 :     A rule is given the precedence of its rightmost terminal *)
687 :    
688 :     val termPrec =
689 :     let val precData = array(numTerms, NONE : int option)
690 :     val addPrec = fn termPrec => fn term as (T i) =>
691 :     case precData sub i
692 :     of SOME _ =>
693 :     error 1 ("multiple precedences specified for terminal " ^
694 :     (termToString term))
695 :     | NONE => update(precData,i,termPrec)
696 :     val termPrec = fn ((LEFT,_) ,i) => i
697 :     | ((RIGHT,_),i) => i+2
698 :     | ((NONASSOC,l),i) => i+1
699 :     val _ = List.foldl (fn (args as ((_,l),i)) =>
700 :     (app (addPrec (SOME (termPrec args))) l; i+3))
701 :     0 prec
702 :     in fn (T i) =>
703 :     if DEBUG andalso (i < 0 orelse i >= numTerms) then
704 :     NONE
705 :     else precData sub i
706 :     end
707 :    
708 :     val elimAssoc = fn i => (i - (i mod 3) + 1)
709 :     val rulePrec =
710 :     let fun findRightTerm (nil,r) = r
711 :     | findRightTerm (TERM t :: tail,r) =
712 :     findRightTerm(tail,SOME t)
713 :     | findRightTerm (_ :: tail,r) = findRightTerm(tail,r)
714 :     in fn rhs =>
715 :     case findRightTerm(rhs,NONE)
716 :     of NONE => NONE
717 :     | SOME term =>
718 :     case termPrec term
719 :     of SOME i => SOME (elimAssoc i)
720 :     | a => a
721 :     end
722 :    
723 :     val grammarRules =
724 :     let val conv = fn {lhs,rhs,code,prec,rulenum} =>
725 :     {lhs=lhs,rhs =rhs,precedence=
726 :     case prec
727 :     of SOME t => (case termPrec t
728 :     of SOME i => SOME(elimAssoc i)
729 :     | a => a)
730 :     | _ => rulePrec rhs,
731 :     rulenum=rulenum}
732 :     in map conv rules
733 :     end
734 :    
735 :     (* get start symbol *)
736 :    
737 :     val start =
738 :     case start
739 :     of NONE => #lhs (hd grammarRules)
740 :     | SOME name =>
741 :     nontermNum "%start" name
742 :    
743 :     val symbolType =
744 :     let val data = array(numTerms+numNonterms,NONE : ty option)
745 :     val unmap = fn (symbol,ty) =>
746 :     update(data,
747 :     case SymbolHash.find(symbolName symbol,symbolHash)
748 :     of SOME i => i,ty)
749 :     val _ = (app unmap term; app unmap nonterm)
750 :     in fn NONTERM(NT i) =>
751 :     if DEBUG andalso (i<0 orelse i>=numNonterms)
752 :     then NONE
753 :     else data sub (i+numTerms)
754 :     | TERM (T i) =>
755 :     if DEBUG andalso (i<0 orelse i>=numTerms)
756 :     then NONE
757 :     else data sub i
758 :     end
759 :    
760 :     val symbolToString =
761 :     fn NONTERM i => nontermToString i
762 :     | TERM i => termToString i
763 :    
764 :     val grammar = GRAMMAR {rules=grammarRules,
765 :     terms=numTerms,nonterms=numNonterms,
766 :     eop = eop, start=start,noshift=noshift,
767 :     termToString = termToString,
768 :     nontermToString = nontermToString,
769 :     precedence = termPrec}
770 :    
771 :     val name' = case name
772 :     of NONE => ""
773 :     | SOME s => symbolName s
774 :    
775 :     val names = NAMES {miscStruct=name' ^ "LrValsFun",
776 :     valueStruct="MlyValue",
777 :     tableStruct="LrTable",
778 :     tokenStruct="Tokens",
779 :     actionsStruct="Actions",
780 :     ecStruct="EC",
781 :     arg= #1 arg_decl,
782 :     tokenSig = name' ^ "_TOKENS",
783 :     miscSig = name' ^ "_LRVALS",
784 :     dataStruct = "ParserData",
785 :     dataSig = "PARSER_DATA"}
786 :    
787 :     val (table,stateErrs,corePrint,errs) =
788 :     MakeTable.mkTable(grammar,defaultReductions)
789 :    
790 :     val entries = ref 0 (* save number of action table entries here *)
791 :    
792 :     in let val result = TextIO.openOut (spec ^ ".sml")
793 :     val sigs = TextIO.openOut (spec ^ ".sig")
794 :     val pos = ref 0
795 :     val pr = fn s => TextIO.output(result,s)
796 :     val say = fn s => let val l = String.size s
797 :     val newPos = (!pos) + l
798 :     in if newPos > lineLength
799 :     then (pr "\n"; pos := l)
800 :     else (pos := newPos);
801 :     pr s
802 :     end
803 :     val saydot = fn s => (say (s ^ "."))
804 :     val sayln = fn t => (pr t; pr "\n"; pos := 0)
805 :     val termvoid = makeUniqueId "VOID"
806 :     val ntvoid = makeUniqueId "ntVOID"
807 :     val hasType = fn s => case symbolType s
808 :     of NONE => false
809 :     | _ => true
810 :     val terms = let fun f n = if n=numTerms then nil
811 :     else (T n) :: f(n+1)
812 :     in f 0
813 :     end
814 :     val values = VALS {say=say,sayln=sayln,saydot=saydot,
815 :     termvoid=termvoid, ntvoid = ntvoid,
816 :     hasType=hasType, pos_type = pos_type,
817 :     arg_type = #2 arg_decl,
818 :     start=start,pureActions=pureActions,
819 :     termToString=termToString,
820 :     symbolToString=symbolToString,term=term,
821 : monnier 139 nonterm=nonterm,terms=terms,
822 :     tokenInfo=token_sig_info_decl}
823 : monnier 2
824 :     val (NAMES {miscStruct,tableStruct,dataStruct,tokenSig,tokenStruct,dataSig,...}) = names
825 :     in case header_decl
826 :     of NONE => (say "functor "; say miscStruct;
827 :     sayln "(structure Token : TOKEN)";
828 :     say " : sig structure ";
829 :     say dataStruct;
830 :     say " : "; sayln dataSig;
831 :     say " structure ";
832 :     say tokenStruct; say " : "; sayln tokenSig;
833 :     sayln " end")
834 :     | SOME s => say s;
835 :     sayln " = ";
836 :     sayln "struct";
837 :     sayln ("structure " ^ dataStruct ^ "=");
838 :     sayln "struct";
839 :     sayln "structure Header = ";
840 :     sayln "struct";
841 :     sayln header;
842 :     sayln "end";
843 :     sayln "structure LrTable = Token.LrTable";
844 :     sayln "structure Token = Token";
845 :     sayln "local open LrTable in ";
846 :     entries := PrintStruct.makeStruct{table=table,print=pr,
847 :     name = "table",
848 :     verbose=verbose};
849 :     sayln "end";
850 :     printTypes(values,names,symbolType);
851 :     printEC (keyword,change,noshift,value,values,names);
852 :     printAction(rules,values,names);
853 :     sayln "end";
854 :     printTokenStruct(values,names);
855 :     sayln "end";
856 :     printSigs(values,names,fn s => TextIO.output(sigs,s));
857 :     TextIO.closeOut sigs;
858 :     TextIO.closeOut result;
859 :     MakeTable.Errs.printSummary (fn s => TextIO.output(TextIO.stdOut,s)) errs
860 :     end;
861 :     if verbose then
862 :     let val f = TextIO.openOut (spec ^ ".desc")
863 :     val say = fn s=> TextIO.output(f,s)
864 :     val printRule =
865 :     let val rules = Array.fromList grammarRules
866 :     in fn say =>
867 :     let val prRule = fn {lhs,rhs,precedence,rulenum} =>
868 :     ((say o nontermToString) lhs; say " : ";
869 :     app (fn s => (say (symbolToString s); say " ")) rhs)
870 :     in fn i => prRule (rules sub i)
871 :     end
872 :     end
873 :     in Verbose.printVerbose
874 :     {termToString=termToString,nontermToString=nontermToString,
875 :     table=table, stateErrs=stateErrs,errs = errs,entries = !entries,
876 :     print=say, printCores=corePrint,printRule=printRule};
877 :     TextIO.closeOut f
878 :     end
879 :     else ()
880 :     end
881 :    
882 :     val parseGen = fn spec =>
883 :     let val (result,inputSource) = ParseGenParser.parse spec
884 :     in make_parser(getResult result,spec,Header.error inputSource,
885 :     errorOccurred inputSource)
886 :     end
887 :     end;

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