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

Annotation of /sml/trunk/src/ml-yacc/src/yacc.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 503 - (view) (download)

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

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