[MLton-commit] r6282
Vesa Karvonen
vesak at mlton.org
Tue Dec 18 05:11:05 PST 2007
Changed ML-Yacc to output line directives so that MLton's def-use
information points to the source grammar (.grm) file instead of the
generated implementation file (.grm.sml).
In order to output the line directives, some parts of yacc.lex and
absyn.sml had to be modified extensively, although the changes are mostly
trivial in nature.
In addition to adding the line directives, changes to yacc.sml and
absyn.sml make the whitespace in the generated implementation file
different. If you wish to compare the output to what is generated by the
original ML-Yacc from SML/NJ's distribution, e.g. after propagating
changes from SML/NJ's version, you can probably do so most conveniently by
eliminating whitespace, and the line directives, from both outputs or by
using a whitespace aware diff tool.
Otherwise I have tried to keep the diffs minimal to reduce difficulties
with propagating future changes from SML/NJ's version.
----------------------------------------------------------------------
U mlton/trunk/mlyacc/src/absyn.sig
U mlton/trunk/mlyacc/src/absyn.sml
U mlton/trunk/mlyacc/src/hdr.sml
U mlton/trunk/mlyacc/src/parse.sml
U mlton/trunk/mlyacc/src/sigs.sml
U mlton/trunk/mlyacc/src/yacc.grm
U mlton/trunk/mlyacc/src/yacc.lex
U mlton/trunk/mlyacc/src/yacc.sml
----------------------------------------------------------------------
Modified: mlton/trunk/mlyacc/src/absyn.sig
===================================================================
--- mlton/trunk/mlyacc/src/absyn.sig 2007-12-18 00:45:41 UTC (rev 6281)
+++ mlton/trunk/mlyacc/src/absyn.sig 2007-12-18 13:11:04 UTC (rev 6282)
@@ -18,7 +18,7 @@
| LET of decl list * exp
| UNIT
| SEQ of exp * exp
- | CODE of string
+ | CODE of {text : string, pos : Header.pos}
and pat = PVAR of string
| PAPP of string * pat
| PTUPLE of pat list
@@ -28,5 +28,6 @@
| AS of string * pat
and decl = VB of pat * exp
and rule = RULE of pat * exp
- val printRule : ((string -> unit) * (string -> unit)) -> rule -> unit
+ val printRule : ((string -> unit) * (Header.pos option -> unit))
+ -> rule -> unit
end
Modified: mlton/trunk/mlyacc/src/absyn.sml
===================================================================
--- mlton/trunk/mlyacc/src/absyn.sml 2007-12-18 00:45:41 UTC (rev 6281)
+++ mlton/trunk/mlyacc/src/absyn.sml 2007-12-18 13:11:04 UTC (rev 6282)
@@ -3,7 +3,7 @@
structure Absyn : ABSYN =
struct
datatype exp
- = CODE of string
+ = CODE of {text : string, pos : Header.pos}
| EAPP of exp * exp
| EINT of int
| ETUPLE of exp list
@@ -38,7 +38,7 @@
val simplifyRule : rule -> rule = fn (RULE(p,e)) =>
let val used : (string -> bool) =
- let fun f(CODE s) = code_to_ids s
+ let fun f(CODE s) = code_to_ids (#text s)
| f(EAPP(a,b)) = f a @ f b
| f(ETUPLE l) = List.concat (map f l)
| f(EVAR s) = [s]
@@ -99,64 +99,42 @@
in RULE(simplifyPat p,simplifyExp e)
end
- fun printRule (say : string -> unit, sayln:string -> unit) r = let
+ fun printRule (S : string -> unit, sayPos) r = let
fun flat (a, []) = rev a
| flat (a, SEQ (e1, e2) :: el) = flat (a, e1 :: e2 :: el)
| flat (a, e :: el) = flat (e :: a, el)
- fun pl (lb, rb, c, f, [], a) = " " :: lb :: rb :: a
- | pl (lb, rb, c, f, h :: t, a) =
- " " :: lb :: f (h, foldr (fn (x, a) => c :: f (x, a))
- (rb :: a)
- t)
- fun pe (CODE c, a) = " (" :: c :: ")" :: a
- | pe (EAPP (x, y as (EAPP _)), a) =
- pe (x, " (" :: pe (y, ")" :: a))
- | pe (EAPP (x, y), a) =
- pe (x, pe (y, a))
- | pe (EINT i, a) =
- " " :: Int.toString i :: a
- | pe (ETUPLE l, a) = pl ("(", ")", ",", pe, l, a)
- | pe (EVAR v, a) =
- " " :: v :: a
- | pe (FN (p, b), a) =
- " (fn" :: pp (p, " =>" :: pe (b, ")" :: a))
- | pe (LET ([], b), a) =
- pe (b, a)
- | pe (LET (dl, b), a) =
- let fun pr (VB (p, e), a) =
- " val " :: pp (p, " =" :: pe (e, "\n" :: a))
- in " let" :: foldr pr (" in" :: pe (b, "\nend" :: a)) dl
+ fun pl (lb, rb, c, f, []) = (S" "; S lb; S rb)
+ | pl (lb, rb, c, f, h :: t) =
+ (S" "; S lb; f h; app (fn x => (S c ; f x)) t; S rb)
+ fun pe (CODE {text, pos}) =
+ (S" ("; sayPos (SOME pos); S text; sayPos NONE; S")")
+ | pe (EAPP (x, y as (EAPP _))) = (pe x; S" ("; pe y; S")")
+ | pe (EAPP (x, y)) = (pe x; pe y)
+ | pe (EINT i) = (S" "; S (Int.toString i))
+ | pe (ETUPLE l) = pl ("(", ")", ",", pe, l)
+ | pe (EVAR v) = (S" "; S v)
+ | pe (FN (p, b)) = (S" (fn"; pp p; S" =>"; pe b; S")")
+ | pe (LET ([], b)) = pe b
+ | pe (LET (dl, b)) =
+ let fun pr (VB (p, e)) = (S"\n"; S" val "; pp p; S" ="; pe e)
+ in
+ S" let"; app pr dl ; S"\n"; S" in"; pe b; S"\n"; S" end"
end
- | pe (SEQ (e1, e2), a) =
- pl ("(", ")", ";", pe, flat ([], [e1, e2]), a)
- | pe (UNIT, a) =
- " ()" :: a
- and pp (PVAR v, a) =
- " " :: v :: a
- | pp (PAPP (x, y as PAPP _), a) =
- " " :: x :: " (" :: pp (y, ")" :: a)
- | pp (PAPP (x, y), a) =
- " " :: x :: pp (y, a)
- | pp (PINT i, a) =
- " " :: Int.toString i :: a
- | pp (PLIST (l, NONE), a) =
- pl ("[", "]", ",", pp, l, a)
- | pp (PLIST (l, SOME t), a) =
- " (" :: foldr (fn (x, a) => pp (x, " ::" :: a))
- (pp (t, ")" :: a))
- l
- | pp (PTUPLE l, a) =
- pl ("(", ")", ",", pp, l, a)
- | pp (WILD, a) =
- " _" :: a
- | pp (AS (v, PVAR v'), a) =
- " (" :: v :: " as " :: v' :: ")" :: a
- | pp (AS (v, p), a) =
- " (" :: v :: " as (" :: pp (p, "))" :: a)
- fun out "\n" = sayln ""
- | out s = say s
+ | pe (SEQ (e1, e2)) = pl ("(", ")", ";", pe, flat ([], [e1, e2]))
+ | pe (UNIT) = S" ()"
+ and pp (PVAR v) = (S" "; S v)
+ | pp (PAPP (x, y as PAPP _)) = (S" "; S x; S" ("; pp y; S")")
+ | pp (PAPP (x, y)) = (S" "; S x; pp y)
+ | pp (PINT i) = (S" "; S (Int.toString i))
+ | pp (PLIST (l, NONE)) = (pl ("[", "]", ",", pp, l))
+ | pp (PLIST (l, SOME t)) =
+ (S" ("; app (fn x => (pp x; S" ::")) l; pp t; S")")
+ | pp (PTUPLE l) = pl ("(", ")", ",", pp, l)
+ | pp (WILD) = S" _"
+ | pp (AS (v, PVAR v')) = (S" ("; S v; S" as "; S v'; S")")
+ | pp (AS (v, p)) = (S" ("; S v; S" as ("; pp p; S"))")
in
case simplifyRule r of
- RULE (p, e) => app out (pp (p, " =>" :: pe (e, ["\n"])))
+ RULE (p, e) => (pp p; S" =>"; pe e; S"\n")
end
end;
Modified: mlton/trunk/mlyacc/src/hdr.sml
===================================================================
--- mlton/trunk/mlyacc/src/hdr.sml 2007-12-18 00:45:41 UTC (rev 6281)
+++ mlton/trunk/mlyacc/src/hdr.sml 2007-12-18 13:11:04 UTC (rev 6282)
@@ -12,8 +12,8 @@
struct
val DEBUG = true
- type pos = int
- val lineno: int ref = ref 0
+ type pos = {line : int, col : int}
+ val pos = {line = ref 1, start = ref 0}
val text = ref (nil: string list)
type inputSource = {name : string,
errStream : TextIO.outstream,
@@ -32,15 +32,15 @@
val error = fn {name,errStream, errorOccurred,...} : inputSource =>
let val pr = pr errStream
in fn l : pos => fn msg : string =>
- (pr name; pr ", line "; pr (Int.toString l); pr ": Error: ";
- pr msg; pr "\n"; errorOccurred := true)
+ (pr name; pr ", line "; pr (Int.toString (#line l));
+ pr ": Error: "; pr msg; pr "\n"; errorOccurred := true)
end
val warn = fn {name,errStream, errorOccurred,...} : inputSource =>
let val pr = pr errStream
in fn l : pos => fn msg : string =>
- (pr name; pr ", line "; pr (Int.toString l); pr ": Warning: ";
- pr msg; pr "\n")
+ (pr name; pr ", line "; pr (Int.toString (#line l));
+ pr ": Warning: "; pr msg; pr "\n")
end
datatype prec = LEFT | RIGHT | NONASSOC
@@ -72,7 +72,8 @@
type rhsData = {rhs:symbol list,code:string, prec:symbol option} list
datatype rule = RULE of {lhs : symbol, rhs : symbol list,
- code : string, prec : symbol option}
+ code : {text : string, pos : pos},
+ prec : symbol option}
type parseResult = string * declData * rule list
val getResult = fn p => p
Modified: mlton/trunk/mlyacc/src/parse.sml
===================================================================
--- mlton/trunk/mlyacc/src/parse.sml 2007-12-18 00:45:41 UTC (rev 6281)
+++ mlton/trunk/mlyacc/src/parse.sml 2007-12-18 13:11:04 UTC (rev 6282)
@@ -14,11 +14,12 @@
let
val in_str = TextIO.openIn file
val source = Header.newSource(file,in_str,TextIO.stdOut)
- val error = fn (s : string,i:int,_) =>
- Header.error source i s
+ val error = fn (s : string,p:Header.pos,_) =>
+ Header.error source p s
val stream = Parser.makeLexer (fn i => (TextIO.inputN(in_str,i)))
source
- val (result,_) = (Header.lineno := 1;
+ val (result,_) = (#line Header.pos := 1;
+ #start Header.pos := 0;
Header.text := nil;
Parser.parse(15,stream,error,source))
in (TextIO.closeIn in_str; (result,source))
Modified: mlton/trunk/mlyacc/src/sigs.sml
===================================================================
--- mlton/trunk/mlyacc/src/sigs.sml 2007-12-18 00:45:41 UTC (rev 6281)
+++ mlton/trunk/mlyacc/src/sigs.sml 2007-12-18 13:11:04 UTC (rev 6282)
@@ -10,8 +10,8 @@
signature HEADER =
sig
- type pos = int
- val lineno : pos ref
+ type pos = {line : int, col : int}
+ val pos : {line : int ref, start : int ref}
val text : string list ref
type inputSource
@@ -23,7 +23,7 @@
datatype symbol = SYMBOL of string * pos
val symbolName : symbol -> string
val symbolPos : symbol -> pos
- val symbolMake : string * int -> symbol
+ val symbolMake : string * pos -> symbol
type ty
val tyName : ty -> string
@@ -40,7 +40,8 @@
TOKEN_SIG_INFO of string
datatype rule = RULE of {lhs : symbol, rhs : symbol list,
- code : string, prec : symbol option}
+ code : {text : string, pos : pos},
+ prec : symbol option}
datatype declData = DECL of
{eop : symbol list,
Modified: mlton/trunk/mlyacc/src/yacc.grm
===================================================================
--- mlton/trunk/mlyacc/src/yacc.grm 2007-12-18 00:45:41 UTC (rev 6281)
+++ mlton/trunk/mlyacc/src/yacc.grm 2007-12-18 13:11:04 UTC (rev 6282)
@@ -10,11 +10,11 @@
%noshift EOF
%right ARROW
%left ASTERISK
-%pos int
+%pos pos
%term ARROW | ASTERISK | BLOCK | BAR | CHANGE | COLON |
COMMA | DELIMITER | EOF | FOR |
- HEADER of string | ID of string*int | IDDOT of string |
+ HEADER of string | ID of string*Header.pos | IDDOT of string |
PERCENT_HEADER | INT of string | KEYWORD | LBRACE | LPAREN |
NAME | NODEFAULT | NONTERM | NOSHIFT | OF |
PERCENT_EOP | PERCENT_PURE | PERCENT_POS | PERCENT_ARG |
@@ -33,7 +33,7 @@
MPC_DECLS of Hdr.declData |
QUAL_ID of string |
RECORD_LIST of string |
- RHS_LIST of {rhs:Hdr.symbol list,code:string,
+ RHS_LIST of {rhs:Hdr.symbol list,code:{text:string, pos:Header.pos},
prec:Hdr.symbol option} list |
G_RULE of Hdr.rule list |
G_RULE_LIST of Hdr.rule list |
@@ -193,10 +193,11 @@
| (nil)
RHS_LIST : ID_LIST G_RULE_PREC PROG
- ([{rhs=ID_LIST,code=PROG,prec=G_RULE_PREC}])
+ ([{rhs=ID_LIST,code={text=PROG,pos=PROGleft},prec=G_RULE_PREC}])
| RHS_LIST BAR ID_LIST G_RULE_PREC PROG
- ({rhs=ID_LIST,code=PROG,prec=G_RULE_PREC}::RHS_LIST)
+ ({rhs=ID_LIST,code={text=PROG,pos=PROGleft},
+ prec=G_RULE_PREC}::RHS_LIST)
TY : TYVAR
(TYVAR)
Modified: mlton/trunk/mlyacc/src/yacc.lex
===================================================================
--- mlton/trunk/mlyacc/src/yacc.lex 2007-12-18 00:45:41 UTC (rev 6281)
+++ mlton/trunk/mlyacc/src/yacc.lex 2007-12-18 13:11:04 UTC (rev 6282)
@@ -12,7 +12,7 @@
structure Tokens = Tokens
type svalue = Tokens.svalue
-type pos = int
+type pos = Header.pos
type ('a,'b) token = ('a,'b) Tokens.token
type lexresult = (svalue,pos) token
@@ -21,17 +21,19 @@
open Tokens
val error = Hdr.error
-val lineno = Hdr.lineno
val text = Hdr.text
val pcount: int ref = ref 0
val commentLevel: int ref = ref 0
-val actionstart: int ref = ref 0
+val actionstart: pos ref = ref {line = 1, col = 0}
+fun linePos () = {line = !(#line Hdr.pos), col = 0}
+fun pos pos = {line = !(#line Hdr.pos), col = pos - !(#start Hdr.pos)}
+
val eof = fn i => (if (!pcount)>0 then
error i (!actionstart)
" eof encountered in action beginning here !"
- else (); EOF(!lineno,!lineno))
+ else (); EOF(linePos (), linePos ()))
val Add = fn s => (text := s::(!text))
@@ -58,6 +60,8 @@
fun inc (ri as ref i : int ref) = (ri := i+1)
fun dec (ri as ref i : int ref) = (ri := i-1)
+fun incLineNum pos = (inc (#line Hdr.pos) ; #start Hdr.pos := pos)
+
%%
%header (
functor LexMLYACC(structure Tokens : Mlyacc_TOKENS
@@ -80,37 +84,37 @@
<CODE>"(*" => (Add yytext; YYBEGIN COMMENT; commentLevel := 1;
continue() before YYBEGIN CODE);
<INITIAL>[^%\013\n]+ => (Add yytext; continue());
-<INITIAL>"%%" => (YYBEGIN A; HEADER (concat (rev (!text)),!lineno,!lineno));
-<INITIAL,CODE,COMMENT,F,EMPTYCOMMENT>{eol} => (Add yytext; inc lineno; continue());
+<INITIAL>"%%" => (YYBEGIN A; HEADER (concat (rev (!text)),pos yypos,pos yypos));
+<INITIAL,CODE,COMMENT,F,EMPTYCOMMENT>{eol} => (Add yytext; incLineNum yypos; continue());
<INITIAL>. => (Add yytext; continue());
-<A>{eol} => (inc lineno; continue ());
+<A>{eol} => (incLineNum yypos; continue ());
<A>{ws}+ => (continue());
-<A>of => (OF(!lineno,!lineno));
-<A>for => (FOR(!lineno,!lineno));
-<A>"{" => (LBRACE(!lineno,!lineno));
-<A>"}" => (RBRACE(!lineno,!lineno));
-<A>"," => (COMMA(!lineno,!lineno));
-<A>"*" => (ASTERISK(!lineno,!lineno));
-<A>"->" => (ARROW(!lineno,!lineno));
-<A>"%left" => (PREC(Hdr.LEFT,!lineno,!lineno));
-<A>"%right" => (PREC(Hdr.RIGHT,!lineno,!lineno));
-<A>"%nonassoc" => (PREC(Hdr.NONASSOC,!lineno,!lineno));
-<A>"%"[a-z_]+ => (lookup(yytext,!lineno,!lineno));
-<A>{tyvar} => (TYVAR(yytext,!lineno,!lineno));
-<A>{qualid} => (IDDOT(yytext,!lineno,!lineno));
-<A>[0-9]+ => (INT (yytext,!lineno,!lineno));
-<A>"%%" => (DELIMITER(!lineno,!lineno));
-<A>":" => (COLON(!lineno,!lineno));
-<A>"|" => (BAR(!lineno,!lineno));
-<A>{id} => (ID ((yytext,!lineno),!lineno,!lineno));
-<A>"(" => (pcount := 1; actionstart := (!lineno);
+<A>of => (OF(pos yypos,pos yypos));
+<A>for => (FOR(pos yypos,pos yypos));
+<A>"{" => (LBRACE(pos yypos,pos yypos));
+<A>"}" => (RBRACE(pos yypos,pos yypos));
+<A>"," => (COMMA(pos yypos,pos yypos));
+<A>"*" => (ASTERISK(pos yypos,pos yypos));
+<A>"->" => (ARROW(pos yypos,pos yypos));
+<A>"%left" => (PREC(Hdr.LEFT,pos yypos,pos yypos));
+<A>"%right" => (PREC(Hdr.RIGHT,pos yypos,pos yypos));
+<A>"%nonassoc" => (PREC(Hdr.NONASSOC,pos yypos,pos yypos));
+<A>"%"[a-z_]+ => (lookup(yytext,pos yypos,pos yypos));
+<A>{tyvar} => (TYVAR(yytext,pos yypos,pos yypos));
+<A>{qualid} => (IDDOT(yytext,pos yypos,pos yypos));
+<A>[0-9]+ => (INT (yytext,pos yypos,pos yypos));
+<A>"%%" => (DELIMITER(pos yypos,pos yypos));
+<A>":" => (COLON(pos yypos,pos yypos));
+<A>"|" => (BAR(pos yypos,pos yypos));
+<A>{id} => (ID ((yytext,pos yypos),pos yypos,pos yypos));
+<A>"(" => (pcount := 1; actionstart := pos yypos;
text := nil; YYBEGIN CODE; continue() before YYBEGIN A);
-<A>. => (UNKNOWN(yytext,!lineno,!lineno));
+<A>. => (UNKNOWN(yytext,pos yypos,pos yypos));
<CODE>"(" => (inc pcount; Add yytext; continue());
<CODE>")" => (dec pcount;
if !pcount = 0 then
- PROG (concat (rev (!text)),!lineno,!lineno)
+ PROG (concat (rev (!text)),!actionstart,pos yypos)
else (Add yytext; continue()));
<CODE>"\"" => (Add yytext; YYBEGIN STRING; continue());
<CODE>[^()"\n\013]+ => (Add yytext; continue());
@@ -118,7 +122,7 @@
<COMMENT>[(*)] => (Add yytext; continue());
<COMMENT>"*)" => (Add yytext; dec commentLevel;
if !commentLevel=0
- then BOGUS_VALUE(!lineno,!lineno)
+ then BOGUS_VALUE(pos yypos,pos yypos)
else continue()
);
<COMMENT>"(*" => (Add yytext; inc commentLevel; continue());
@@ -133,15 +137,15 @@
<STRING>"\"" => (Add yytext; YYBEGIN CODE; continue());
<STRING>\\ => (Add yytext; continue());
-<STRING>{eol} => (Add yytext; error inputSource (!lineno) "unclosed string";
- inc lineno; YYBEGIN CODE; continue());
+<STRING>{eol} => (Add yytext; error inputSource (pos yypos) "unclosed string";
+ incLineNum yypos; YYBEGIN CODE; continue());
<STRING>[^"\\\n\013]+ => (Add yytext; continue());
<STRING>\\\" => (Add yytext; continue());
-<STRING>\\{eol} => (Add yytext; inc lineno; YYBEGIN F; continue());
+<STRING>\\{eol} => (Add yytext; incLineNum yypos; YYBEGIN F; continue());
<STRING>\\[\ \t] => (Add yytext; YYBEGIN F; continue());
<F>{ws} => (Add yytext; continue());
<F>\\ => (Add yytext; YYBEGIN STRING; continue());
-<F>. => (Add yytext; error inputSource (!lineno) "unclosed string";
+<F>. => (Add yytext; error inputSource (pos yypos) "unclosed string";
YYBEGIN CODE; continue());
Modified: mlton/trunk/mlyacc/src/yacc.sml
===================================================================
--- mlton/trunk/mlyacc/src/yacc.sml 2007-12-18 00:45:41 UTC (rev 6281)
+++ mlton/trunk/mlyacc/src/yacc.sml 2007-12-18 13:11:04 UTC (rev 6282)
@@ -58,6 +58,7 @@
of {say : string -> unit,
saydot : string -> unit,
sayln : string -> unit,
+ sayPos : {line : int, col : int} option -> unit,
pureActions: bool,
pos_type : string,
arg_type : string,
@@ -284,10 +285,10 @@
end
val printAction = fn (rules,
- VALS {hasType,say,sayln,termvoid,ntvoid,
+ VALS {hasType,say,sayln,sayPos,termvoid,ntvoid,
symbolToString,saydot,start,pureActions,...},
NAMES {actionsStruct,valueStruct,tableStruct,arg,...}) =>
-let val printAbsynRule = Absyn.printRule(say,sayln)
+let val printAbsynRule = Absyn.printRule(say,sayPos)
val is_nonterm = fn (NONTERM i) => true | _ => false
val numberRhs = fn r =>
List.foldl (fn (e,(r,table)) =>
@@ -485,17 +486,17 @@
val term =
case term
- of NONE => (error 1 "missing %term definition"; nil)
+ of NONE => (error {line = 1, col = 0} "missing %term definition"; nil)
| SOME l => l
val nonterm =
case nonterm
- of NONE => (error 1 "missing %nonterm definition"; nil)
+ of NONE => (error {line = 1, col = 0} "missing %nonterm definition"; nil)
| SOME l => l
val pos_type =
case pos_type
- of NONE => (error 1 "missing %pos definition"; "")
+ of NONE => (error {line = 1, col = 0} "missing %pos definition"; "")
| SOME l => l
@@ -679,7 +680,8 @@
val addPrec = fn termPrec => fn term as (T i) =>
case precData sub i
of SOME _ =>
- error 1 ("multiple precedences specified for terminal " ^
+ error {line = 1, col = 0}
+ ("multiple precedences specified for terminal " ^
(termToString term))
| NONE => update(precData,i,termPrec)
val termPrec = fn ((LEFT,_) ,i) => i
@@ -798,17 +800,24 @@
in let val result = TextIO.openOut (spec ^ ".sml")
val sigs = TextIO.openOut (spec ^ ".sig")
- val pos = ref 0
- val pr = fn s => TextIO.output(result,s)
- val say = fn s => let val l = String.size s
- val newPos = (!pos) + l
- in if newPos > lineLength
- then (pr "\n"; pos := l)
- else (pos := newPos);
- pr s
- end
+ val specPath = OS.FileSys.fullPath spec
+ val resultPath = OS.FileSys.fullPath (spec ^ ".sml")
+ val line = ref 1
+ val col = ref 0
+ fun say s =
+ (TextIO.output (result, s)
+ ; CharVector.app
+ (fn #"\n" => (line := !line + 1 ; col := 0)
+ | _ => col := !col + 1)
+ s)
val saydot = fn s => (say (s ^ "."))
- val sayln = fn t => (pr t; pr "\n"; pos := 0)
+ val sayln = fn t => (say t; say "\n")
+ fun fmtLineDir {line, col} path =
+ String.concat ["(*#line ", Int.toString line, ".",
+ Int.toString (col+1), " \"", path, "\"*)"]
+ val sayPos =
+ fn NONE => sayln (fmtLineDir {line = !line, col = 0} resultPath)
+ | SOME pos => say (fmtLineDir pos specPath)
val termvoid = makeUniqueId "VOID"
val ntvoid = makeUniqueId "ntVOID"
val hasType = fn s => case symbolType s
@@ -818,7 +827,7 @@
else (T n) :: f(n+1)
in f 0
end
- val values = VALS {say=say,sayln=sayln,saydot=saydot,
+ val values = VALS {say=say,sayln=sayln,saydot=saydot,sayPos=sayPos,
termvoid=termvoid, ntvoid = ntvoid,
hasType=hasType, pos_type = pos_type,
arg_type = #2 arg_decl,
@@ -845,12 +854,14 @@
sayln "struct";
sayln "structure Header = ";
sayln "struct";
+ sayPos (SOME {line = 1, col = 1});
sayln header;
+ sayPos NONE;
sayln "end";
sayln "structure LrTable = Token.LrTable";
sayln "structure Token = Token";
sayln "local open LrTable in ";
- entries := PrintStruct.makeStruct{table=table,print=pr,
+ entries := PrintStruct.makeStruct{table=table,print=say,
name = "table",
verbose=verbose};
sayln "end";
More information about the MLton-commit
mailing list