Mercurial > urweb

changeset 58:fd8a81ecd598

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
include
author Adam Chlipala <adamc@hcoop.net>
date Sun, 22 Jun 2008 18:17:21 -0400
parents 618b7054f931
children abb2b32c19fb
files src/elaborate.sml src/lacweb.grm src/lacweb.lex src/source.sml src/source_print.sml tests/include.lac
diffstat 6 files changed, 43 insertions(+), 7 deletions(-) [+]
line wrap: on
line diff
--- a/src/elaborate.sml	Sun Jun 22 15:23:16 2008 -0400
+++ b/src/elaborate.sml	Sun Jun 22 18:17:21 2008 -0400
@@ -977,6 +977,7 @@
        | SgiWrongCon of L'.sgn_item * L'.con * L'.sgn_item * L'.con * cunify_error
        | SgnWrongForm of L'.sgn * L'.sgn
        | UnWhereable of L'.sgn * string
+       | NotIncludable of L'.sgn
 
 fun sgnError env err =
     case err of
@@ -1007,6 +1008,9 @@
         (ErrorMsg.errorAt (#2 sgn) "Unavailable field for 'where'";
          eprefaces' [("Signature", p_sgn env sgn),
                      ("Field", PD.string x)])
+      | NotIncludable sgn =>
+        (ErrorMsg.errorAt (#2 sgn) "Invalid signature to 'include'";
+         eprefaces' [("Signature", p_sgn env sgn)])
 
 datatype str_error =
          UnboundStr of ErrorMsg.span * string
@@ -1047,7 +1051,7 @@
                         ()
                     );
 
-                ((L'.SgiConAbs (x, n, k'), loc), env')
+                ([(L'.SgiConAbs (x, n, k'), loc)], env')
             end
 
           | L.SgiCon (x, ko, c) =>
@@ -1075,7 +1079,7 @@
                         ()
                     );
 
-                ((L'.SgiCon (x, n, k', c'), loc), env')
+                ([(L'.SgiCon (x, n, k', c'), loc)], env')
             end
 
           | L.SgiVal (x, c) =>
@@ -1095,7 +1099,7 @@
                         ()
                     );
 
-                ((L'.SgiVal (x, n, c'), loc), env')
+                ([(L'.SgiVal (x, n, c'), loc)], env')
             end
 
           | L.SgiStr (x, sgn) =>
@@ -1103,16 +1107,26 @@
                 val sgn' = elabSgn env sgn
                 val (env', n) = E.pushStrNamed env x sgn'
             in
-                ((L'.SgiStr (x, n, sgn'), loc), env')
+                ([(L'.SgiStr (x, n, sgn'), loc)], env')
             end
-            
+
+          | L.SgiInclude sgn =>
+            let
+                val sgn' = elabSgn env sgn
+            in
+                case #1 (hnormSgn env sgn') of
+                    L'.SgnConst sgis =>
+                    (sgis, foldl (fn (sgi, env) => E.sgiBinds env sgi) env sgis)
+                  | _ => (sgnError env (NotIncludable sgn');
+                          ([], env))
+            end
     end
 
 and elabSgn env (sgn, loc) =
     case sgn of
         L.SgnConst sgis =>
         let
-            val (sgis', _) = ListUtil.foldlMap elabSgn_item env sgis
+            val (sgis', _) = ListUtil.foldlMapConcat elabSgn_item env sgis
         in
             (L'.SgnConst sgis', loc)
         end
--- a/src/lacweb.grm	Sun Jun 22 15:23:16 2008 -0400
+++ b/src/lacweb.grm	Sun Jun 22 18:17:21 2008 -0400
@@ -44,7 +44,7 @@
  | TYPE | NAME
  | ARROW | LARROW | DARROW
  | FN | PLUSPLUS | DOLLAR
- | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN
+ | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | INCLUDE | OPEN
 
 %nonterm
    file of decl list
@@ -147,6 +147,7 @@
                                         (SgiStr (CSYMBOL1,
                                                  (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))),
                                          s (FUNCTORleft, sgn2right))
+       | INCLUDE sgn                    (SgiInclude sgn, s (INCLUDEleft, sgnright))
 
 sgis   :                                ([])
        | sgi sgis                       (sgi :: sgis)
--- a/src/lacweb.lex	Sun Jun 22 15:23:16 2008 -0400
+++ b/src/lacweb.lex	Sun Jun 22 18:17:21 2008 -0400
@@ -155,6 +155,8 @@
 <INITIAL> "functor"   => (Tokens.FUNCTOR (pos yypos, pos yypos + size yytext));
 <INITIAL> "where"     => (Tokens.WHERE (pos yypos, pos yypos + size yytext));
 <INITIAL> "extern"    => (Tokens.EXTERN (pos yypos, pos yypos + size yytext));
+<INITIAL> "include"   => (Tokens.INCLUDE (pos yypos, pos yypos + size yytext));
+<INITIAL> "open"      => (Tokens.OPEN (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "Type"      => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
 <INITIAL> "Name"      => (Tokens.NAME (pos yypos, pos yypos + size yytext));
--- a/src/source.sml	Sun Jun 22 15:23:16 2008 -0400
+++ b/src/source.sml	Sun Jun 22 18:17:21 2008 -0400
@@ -67,6 +67,7 @@
        | SgiCon of string * kind option * con
        | SgiVal of string * con
        | SgiStr of string * sgn
+       | SgiInclude of sgn
 
 and sgn' =
     SgnConst of sgn_item list
--- a/src/source_print.sml	Sun Jun 22 15:23:16 2008 -0400
+++ b/src/source_print.sml	Sun Jun 22 18:17:21 2008 -0400
@@ -238,6 +238,9 @@
                                 string ":",
                                 space,
                                 p_sgn sgn]
+      | SgiInclude sgn => box [string "include",
+                               space,
+                               p_sgn sgn]
 
 and p_sgn (sgn, _) =
     case sgn of
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/include.lac	Sun Jun 22 18:17:21 2008 -0400
@@ -0,0 +1,15 @@
+signature S = sig
+        type t
+        val x : t
+end
+
+signature S' = sig
+        include S
+        val y : t
+end
+
+signature S'' = sig
+        type u
+        include S' where type t = int
+        type v
+end