Mercurial > urweb
changeset 14:f1c36df29ed7
Primitive type constants
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 08 Jun 2008 12:27:08 -0400 |
| parents | 6049e2193bf2 |
| children | 1e645beb3f3b |
| files | src/compiler.sml src/elab.sml src/elab_env.sig src/elab_env.sml src/elab_print.sml src/elab_util.sml src/elaborate.sml src/lacweb.grm src/lacweb.lex src/main.mlton.sml src/prim.sig src/prim.sml src/source.sml src/source_print.sml src/sources tests/prim.lac |
| diffstat | 16 files changed, 161 insertions(+), 14 deletions(-) [+] |
line wrap: on
line diff
--- a/src/compiler.sml Sun Jun 08 11:32:48 2008 -0400 +++ b/src/compiler.sml Sun Jun 08 12:27:08 2008 -0400 @@ -76,10 +76,10 @@ print "\n") fun testElaborate filename = - (case elaborate ElabEnv.empty filename of + (case elaborate ElabEnv.basis filename of NONE => print "Failed\n" | SOME (_, file) => - (Print.print (ElabPrint.p_file ElabEnv.empty file); + (Print.print (ElabPrint.p_file ElabEnv.basis file); print "\n")) handle ElabEnv.UnboundNamed n => print ("Unbound named " ^ Int.toString n ^ "\n")
--- a/src/elab.sml Sun Jun 08 11:32:48 2008 -0400 +++ b/src/elab.sml Sun Jun 08 12:27:08 2008 -0400 @@ -65,7 +65,8 @@ withtype con = con' located datatype exp' = - ERel of int + EPrim of Prim.t + | ERel of int | ENamed of int | EApp of exp * exp | EAbs of string * con * exp
--- a/src/elab_env.sig Sun Jun 08 11:32:48 2008 -0400 +++ b/src/elab_env.sig Sun Jun 08 12:27:08 2008 -0400 @@ -33,6 +33,7 @@ type env val empty : env + val basis : env exception UnboundRel of int exception UnboundNamed of int
--- a/src/elab_env.sml Sun Jun 08 11:32:48 2008 -0400 +++ b/src/elab_env.sml Sun Jun 08 12:27:08 2008 -0400 @@ -193,4 +193,13 @@ DCon (x, n, k, c) => pushCNamedAs env x n k (SOME c) | DVal (x, n, t, _) => pushENamedAs env x n t +val ktype = (KType, ErrorMsg.dummySpan) + +fun bbind env x = #1 (pushCNamed env x ktype NONE) + +val basis = empty +val basis = bbind basis "int" +val basis = bbind basis "float" +val basis = bbind basis "string" + end
--- a/src/elab_print.sml Sun Jun 08 11:32:48 2008 -0400 +++ b/src/elab_print.sml Sun Jun 08 12:27:08 2008 -0400 @@ -151,7 +151,8 @@ fun p_exp' par env (e, _) = case e of - ERel n => + EPrim p => Prim.p_t p + | ERel n => if !debug then string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) else
--- a/src/elab_util.sml Sun Jun 08 11:32:48 2008 -0400 +++ b/src/elab_util.sml Sun Jun 08 12:27:08 2008 -0400 @@ -205,7 +205,8 @@ and mfe' ctx (eAll as (e, loc)) = case e of - ERel _ => S.return2 eAll + EPrim _ => S.return2 eAll + | ERel _ => S.return2 eAll | ENamed _ => S.return2 eAll | EApp (e1, e2) => S.bind2 (mfe ctx e1,
--- a/src/elaborate.sml Sun Jun 08 11:32:48 2008 -0400 +++ b/src/elaborate.sml Sun Jun 08 12:27:08 2008 -0400 @@ -27,6 +27,7 @@ structure Elaborate :> ELABORATE = struct +structure P = Prim structure L = Source structure L' = Elab structure E = ElabEnv @@ -440,8 +441,8 @@ and unifySummaries env (k, s1 : record_summary, s2 : record_summary) = let - val () = eprefaces "Summaries" [("#1", p_summary env s1), - ("#2", p_summary env s2)] + (*val () = eprefaces "Summaries" [("#1", p_summary env s1), + ("#2", p_summary env s2)]*) fun eatMatching p (ls1, ls2) = let @@ -471,8 +472,8 @@ true) else false) (#fields s1, #fields s2) - val () = eprefaces "Summaries2" [("#1", p_summary env {fields = fs1, unifs = #unifs s1, others = #others s1}), - ("#2", p_summary env {fields = fs2, unifs = #unifs s2, others = #others s2})] + (*val () = eprefaces "Summaries2" [("#1", p_summary env {fields = fs1, unifs = #unifs s1, others = #others s1}), + ("#2", p_summary env {fields = fs2, unifs = #unifs s2, others = #others s2})]*) val (unifs1, unifs2) = eatMatching (fn ((_, r1), (_, r2)) => r1 = r2) (#unifs s1, #unifs s2) val (others1, others2) = eatMatching (consEq env) (#others s1, #others s2) @@ -665,6 +666,20 @@ handle CUnify (c1, c2, err) => expError env (Unify (e, c1, c2, err)) +fun primType env p = + let + val s = case p of + P.Int _ => "int" + | P.Float _ => "float" + | P.String _ => "string" + in + case E.lookupC env s of + E.NotBound => raise Fail ("Primitive type " ^ s ^ " unbound") + | E.Rel _ => raise Fail ("Primitive type " ^ s ^ " bound as relative") + | E.Named (n, (L'.KType, _)) => L'.CNamed n + | E.Named _ => raise Fail ("Primitive type " ^ s ^ " bound at non-Type kind") + end + fun elabExp env (e, loc) = case e of L.EAnnot (e, t) => @@ -676,6 +691,7 @@ (e', t') end + | L.EPrim p => ((L'.EPrim p, loc), (primType env p, loc)) | L.EVar s => (case E.lookupE env s of E.NotBound =>
--- a/src/lacweb.grm Sun Jun 08 11:32:48 2008 -0400 +++ b/src/lacweb.grm Sun Jun 08 12:27:08 2008 -0400 @@ -36,6 +36,7 @@ %term EOF + | STRING of string | INT of Int64.int | FLOAT of Real64.real | SYMBOL of string | CSYMBOL of string | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH @@ -155,6 +156,10 @@ | SYMBOL (EVar SYMBOL, s (SYMBOLleft, SYMBOLright)) | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright)) + | INT (EPrim (Prim.Int INT), s (INTleft, INTright)) + | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) + | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + rexp : ([]) | ident EQ eexp ([(ident, eexp)]) | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp)
--- a/src/lacweb.lex Sun Jun 08 11:32:48 2008 -0400 +++ b/src/lacweb.lex Sun Jun 08 12:27:08 2008 -0400 @@ -59,14 +59,19 @@ end end +val str = ref ([] : char list) +val strStart = ref 0 + %% %header (functor LacwebLexFn(structure Tokens : Lacweb_TOKENS)); %full -%s COMMENT; +%s COMMENT STRING; id = [a-z_][A-Za-z0-9_]*; cid = [A-Z][A-Za-z0-9_]*; ws = [\ \t\012]; +intconst = [0-9]+; +realconst = [0-9]+\.[0-9]*; %% @@ -88,6 +93,14 @@ <COMMENT> "*)" => (if exitComment () then YYBEGIN INITIAL else (); continue ()); +<INITIAL> "\"" => (YYBEGIN STRING; strStart := yypos; str := []; continue()); +<STRING> "\\\"" => (str := #"\"" :: !str; continue()); +<STRING> "\"" => (YYBEGIN INITIAL; + Tokens.STRING (String.implode (List.rev (!str)), !strStart, yypos + 1)); +<STRING> "\n" => (ErrorMsg.newline yypos; + str := #"\n" :: !str; continue()); +<STRING> . => (str := String.sub (yytext, 0) :: !str; continue()); + <INITIAL> "(" => (Tokens.LPAREN (yypos, yypos + size yytext)); <INITIAL> ")" => (Tokens.RPAREN (yypos, yypos + size yytext)); <INITIAL> "[" => (Tokens.LBRACK (yypos, yypos + size yytext)); @@ -119,6 +132,17 @@ <INITIAL> {id} => (Tokens.SYMBOL (yytext, yypos, yypos + size yytext)); <INITIAL> {cid} => (Tokens.CSYMBOL (yytext, yypos, yypos + size yytext)); +<INITIAL> {intconst} => (case Int64.fromString yytext of + SOME x => Tokens.INT (x, yypos, yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (yypos, yypos) + ("Expected int, received: " ^ yytext); + continue ())); +<INITIAL> {realconst} => (case Real64.fromString yytext of + SOME x => Tokens.FLOAT (x, yypos, yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (yypos, yypos) + ("Expected float, received: " ^ yytext); + continue ())); + <COMMENT> . => (continue()); <INITIAL> . => (ErrorMsg.errorAt' (yypos, yypos)
--- a/src/main.mlton.sml Sun Jun 08 11:32:48 2008 -0400 +++ b/src/main.mlton.sml Sun Jun 08 12:27:08 2008 -0400 @@ -26,5 +26,5 @@ *) val () = case CommandLine.arguments () of - [filename] => Compiler.testParse filename + [filename] => Compiler.testElaborate filename | _ => print "Bad arguments"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/prim.sig Sun Jun 08 12:27:08 2008 -0400 @@ -0,0 +1,37 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature PRIM = sig + + datatype t = + Int of Int64.int + | Float of Real64.real + | String of string + + val p_t : t Print.printer + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/prim.sml Sun Jun 08 12:27:08 2008 -0400 @@ -0,0 +1,44 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Prim :> PRIM = struct + +datatype t = + Int of Int64.int + | Float of Real64.real + | String of string + +open Print.PD +open Print + +fun p_t t = + case t of + Int n => string (Int64.toString n) + | Float n => string (Real64.toString n) + | String s => box [string "\"", string s, string "\""] + +end
--- a/src/source.sml Sun Jun 08 11:32:48 2008 -0400 +++ b/src/source.sml Sun Jun 08 12:27:08 2008 -0400 @@ -62,6 +62,7 @@ datatype exp' = EAnnot of exp * con + | EPrim of Prim.t | EVar of string | EApp of exp * exp | EAbs of string * con option * exp
--- a/src/source_print.sml Sun Jun 08 11:32:48 2008 -0400 +++ b/src/source_print.sml Sun Jun 08 12:27:08 2008 -0400 @@ -131,6 +131,7 @@ p_con t, string ")"] + | EPrim p => Prim.p_t p | EVar s => string s | EApp (e1, e2) => parenIf par (box [p_exp e1, space,