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 2 - (view) (download)
Original Path: sml/trunk/src/ml-yacc/src/yacc.sml

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

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