[project @ 1999-12-03 17:01:20 by sewardj]

More mods to interface file parsing:
* Strictness annotations in data decls
* Allow qualified names in a couple more places

diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c
index 76e5549..8aad0eb 100644 (file)
--- a/ghc/interpreter/hugs.c
+++ b/ghc/interpreter/hugs.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: hugs.c,v $
- * $Revision: 1.27 $
- * $Date: 1999/12/03 14:38:39 $
+ * $Revision: 1.28 $
+ * $Date: 1999/12/03 17:01:20 $
  * ------------------------------------------------------------------------*/
 
 #include <setjmp.h>
@@ -97,7 +97,7 @@ static Void   local browse          Args((Void));
  * Machine dependent code for Hugs interpreter:
  * ------------------------------------------------------------------------*/
 
-       Bool   combined      = FALSE;
+       Bool   combined      = TRUE;
 
 #include "machdep.c"
 #ifdef WANT_TIMER

diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c
index 6eed036..28562d9 100644 (file)
--- a/ghc/interpreter/interface.c
+++ b/ghc/interpreter/interface.c
@@ -7,8 +7,8 @@
  * Hugs version 1.4, December 1997
  *
  * $RCSfile: interface.c,v $
- * $Revision: 1.8 $
- * $Date: 1999/12/03 12:39:40 $
+ * $Revision: 1.9 $
+ * $Date: 1999/12/03 17:01:21 $
  * ------------------------------------------------------------------------*/
 
 /* ToDo:
@@ -431,8 +431,8 @@ List   syms; {   /* [ConId | VarId] -- the names to import */
     printf("\naddGHCImport %s\n", textToStr(mn) );
 #   endif
   
-    // Hack to avoid chasing Prel* junk right now
-    if (strncmp(textToStr(mn), "Prel",4)==0) return;
+    /* Don't chase PrelGHC -- it doesn't exist */
+    if (strncmp(textToStr(mn), "PrelGHC",7)==0) return;
 
     found = FALSE;
     for (t=ifImports; nonNull(t); t=tl(t)) {
@@ -552,9 +552,10 @@ Int  line;
 List ctx0;      /* [(QConId,VarId)]              */
 Cell tycon;     /* ConId                         */
 List ktyvars;   /* [(VarId,Kind)] */
-List constrs0;  /* [(ConId,[(Type,Text)],NIL)]  
+List constrs0;  /* [(ConId,[(Type,Text,Int)],NIL)]  
                    The NIL will become the constr's type
-                   The Text is an optional field name */
+                   The Text is an optional field name
+                   The Int indicates strictness */
     /* ToDo: worry about being given a decl for (->) ?
      * and worry about qualidents for ()
      */
@@ -566,6 +567,7 @@ List constrs0;  /* [(ConId,[(Type,Text)],NIL)]
     Cell    conid;
     Pair    conArg, ctxElem;
     Text    conArgNm;
+    Int     conArgStrictness;
 
     Text t = textOf(tycon);
 #   ifdef DEBUG_IFACE
@@ -607,11 +609,13 @@ List constrs0;  /* [(ConId,[(Type,Text)],NIL)]
            tyvarsMentioned = NIL;  /* [VarId] */
            conArgs = reverse(fields);
            for (; nonNull(conArgs); conArgs=tl(conArgs)) {
-              conArg   = hd(conArgs); /* (Type,Text) */
-              conArgTy = fst(conArg);
-              conArgNm = snd(conArg);
+              conArg           = hd(conArgs); /* (Type,Text) */
+              conArgTy         = fst3(conArg);
+              conArgNm         = snd3(conArg);
+              conArgStrictness = intOf(thd3(conArg));
               tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
                                             tyvarsMentioned);
+              if (conArgStrictness > 0) conArgTy = bang(conArgTy);
               ty = fn(conArgTy,ty);
               if (nonNull(conArgNm)) {
                 /* a field name is mentioned too */
@@ -663,7 +667,7 @@ List constrs0;  /* [(ConId,[(Type,Text)],NIL)]
 
 static List local addGHCConstrs(line,cons,sels)
 Int  line;
-List cons;   /* [(ConId,[(Type,Text)],Type)] */
+List cons;   /* [(ConId,[(Type,Text,Int)],Type)] */
 List sels; { /* [(VarId,Type)]         */
     List cs, ss;
     Int  conNo = 0; /*  or maybe 1? */
@@ -707,7 +711,7 @@ Pair sel;    /* (VarId,Type)        */
 static Name local addGHCConstr(line,conNo,constr)
 Int    line;
 Int    conNo;
-Triple constr; { /* (ConId,[(Type,Text)],Type) */
+Triple constr; { /* (ConId,[(Type,Text,Int)],Type) */
     /* ToDo: add rank2 annotation and existential annotation
      * these affect how constr can be used.
      */
@@ -1052,6 +1056,8 @@ List ktyvars; { /* [(VarId|Text,Kind)] */
          return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
       case UNBOXEDTUP:  /* bogus?? */
          return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
+      case BANG:  /* bogus?? */
+         return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
       case VARIDCELL: /* Ha! some real work to do! */
        { Int i = 0;
          Text tv = textOf(type);

diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y
index 8073580..300028d 100644 (file)
--- a/ghc/interpreter/parser.y
+++ b/ghc/interpreter/parser.y
@@ -12,8 +12,8 @@
  * included in the distribution.
  *
  * $RCSfile: parser.y,v $
- * $Revision: 1.16 $
- * $Date: 1999/12/03 12:39:42 $
+ * $Revision: 1.17 $
+ * $Date: 1999/12/03 17:01:22 $
  * ------------------------------------------------------------------------*/
 
 %{
@@ -25,7 +25,6 @@
 #define fixdecl(l,ops,a,p)       ap(FIXDECL,\
                                     triple(l,ops,mkInt(mkSyntax(a,intOf(p)))))
 #define grded(gs)                ap(GUARDED,gs)
-#define bang(t)                  ap(BANG,t)
 #define only(t)                  ap(ONLY,t)
 #define letrec(bs,e)             (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
 #define qualify(ps,t)            (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t)
@@ -121,8 +120,8 @@ start     : EXPR exp wherePart          {inputExpr = letrec($3,$2); sp-=2;}
  */
 
 /*- Top-level interface files -----------------------------*/
-iface     : INTERFACE ifName NUMLIT checkVersion WHERE ifDecls 
-                                        {$$ = gc6(NIL); }
+iface     : INTERFACE ifName NUMLIT orphans checkVersion WHERE ifDecls 
+                                        {$$ = gc7(NIL); }
           | INTERFACE error             {syntaxError("interface file");}
           ;
 ifDecls:                                {$$=gc0(NIL);}
@@ -132,12 +131,6 @@ varid_or_conid
           : VARID                       { $$=gc1($1); }
           | CONID                       { $$=gc1($1); }
           ;
-opt_bang  : '!'                         {$$=gc1(NIL);}
-          |                             {$$=gc0(NIL);}
-          ;
-opt_COCO  : COCO                        {$$=gc1(NIL);}
-          |                             {$$=gc0(NIL);}
-          ;
 
 ifName    : CONID                       {openGHCIface(textOf($1)); 
                                          $$ = gc1(NIL);}
@@ -145,7 +138,7 @@ checkVersion
           : NUMLIT                      {$$ = gc1(NIL); }
           ;
 ifDecl    
-          : IMPORT CONID NUMLIT opt_bang opt_COCO version_list_junk
+          : IMPORT CONID NUMLIT orphans opt_COCO version_list_junk
                                         { addGHCImports(intOf($3),textOf($2),
                                                        $6);
                                           $$ = gc6(NIL); 
@@ -194,6 +187,16 @@ ifDecl
           ;
 
 
+/*- Top-level misc interface stuff ------------------------*/
+orphans   : '!'                         {$$=gc1(NIL);}
+          |                             {$$=gc0(NIL);}
+          ;
+opt_COCO  : COCO                        {$$=gc1(NIL);}
+          |                             {$$=gc0(NIL);}
+          ;
+
+
+
 /*- Interface variable and constructor ids ----------------*/
 ifTyvar   : VARID                       {$$ = $1;}
           ;
@@ -228,7 +231,7 @@ ifCtxInst /* __forall [a b] {M.C1 a, M.C2 b} =>  */
           |                             {$$=gc0(NIL);}
           ;
 ifInstHd /* { Class aType }    :: (ConId, Type) */
-          : '{' ifCon ifAType '}'       {$$=gc4(ap(DICTAP,pair($2,singleton($3))));}
+          : '{' ifQCon ifAType '}'       {$$=gc4(ap(DICTAP,pair($2,singleton($3))));}
           ;
 
 ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an }   :: [(ConId, Type)] */
@@ -257,35 +260,45 @@ ifCtxDeclLE /* M.C1 a   :: (QConId,VarId) */
 
 
 /*- Interface data declarations - constructor lists -------*/
-ifConstrs /* = Con1 | ... | ConN  :: [(ConId,[(Type,Text)],NIL)] */
+/* The (Type,Text,Int) are (field type, name (or NIL), strictness).
+   Strictness is a number: mkInt(0) indicates lazy, mkInt(1)
+   indicates a strict field (!type) as in standard H98, and 
+   mkInt(2) indicates unpacked -- a GHC extension.
+*/
+
+ifConstrs /* = Con1 | ... | ConN  :: [(ConId,[(Type,Text,Int)],NIL)] */
           :                             {$$ = gc0(NIL);}
           | '=' ifConstrL               {$$ = gc2($2);}
           ;
-ifConstrL /* [(ConId,[(Type,Text)],NIL)] */
+ifConstrL /* [(ConId,[(Type,Text,Int)],NIL)] */
           : ifConstr                    {$$ = gc1(singleton($1));}
           | ifConstr '|' ifConstrL      {$$ = gc3(cons($1,$3));}
           ;
-ifConstr /* (ConId,[(Type,Text)],NIL) */
+ifConstr /* (ConId,[(Type,Text,Int)],NIL) */
           : ifConData ifDataAnonFieldL  {$$ = gc2(triple($1,$2,NIL));}
           | ifConData '{' ifDataNamedFieldL '}' 
                                         {$$ = gc4(triple($1,$3,NIL));}
           ;
-ifDataAnonFieldL /* [(Type,Text)] */
+ifDataAnonFieldL /* [(Type,Text,Int)] */
           :                             {$$=gc0(NIL);}
           | ifDataAnonField ifDataAnonFieldL
                                         {$$=gc2(cons($1,$2));}
           ;
-ifDataNamedFieldL /* [(Type,Text)] */
+ifDataNamedFieldL /* [(Type,Text,Int)] */
           :                             {$$=gc0(NIL);}
           | ifDataNamedField            {$$=gc1(cons($1,NIL));}
           | ifDataNamedField ',' ifDataNamedFieldL 
                                         {$$=gc3(cons($1,$3));}
           ;
-ifDataAnonField /* (Type,Text) */
-          : ifAType                     {$$=gc1(pair($1,NIL));}
+ifDataAnonField /* (Type,Text,Int) */
+          : ifAType                     {$$=gc1(triple($1,NIL,mkInt(0)));}
+          | '!' ifAType                 {$$=gc2(triple($2,NIL,mkInt(1)));}
+          | '!' '!' ifAType             {$$=gc3(triple($3,NIL,mkInt(2)));}
           ;
-ifDataNamedField  /* (Type,Text) */
-          : VARID COCO ifAType          {$$=gc3(pair($3,$1));}
+ifDataNamedField  /* (Type,Text,Int) */
+          : VARID COCO ifAType          {$$=gc3(triple($3,$1,mkInt(0)));}
+          | VARID COCO '!' ifAType      {$$=gc4(triple($4,$1,mkInt(1)));}
+          | VARID COCO '!' '!' ifAType  {$$=gc5(triple($5,$1,mkInt(2)));}
           ;
 
 

diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index c705286..a050959 100644 (file)
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.c,v $
- * $Revision: 1.20 $
- * $Date: 1999/12/03 12:39:46 $
+ * $Revision: 1.21 $
+ * $Date: 1999/12/03 17:01:23 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -2048,6 +2048,11 @@ Int  depth; {
                 print(snd(c),depth-1);
                 Putchar(')');
                 break;
+        case BANG:
+                Printf("(BANG,");
+                print(snd(c),depth-1);
+                Putchar(')');
+                break;
         default:
                 if (isBoxTag(tag)) {
                     Printf("Tag(%d)=%d", c, tag);

diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h
index 9d127b4..36bb320 100644 (file)
--- a/ghc/interpreter/storage.h
+++ b/ghc/interpreter/storage.h
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.h,v $
- * $Revision: 1.15 $
- * $Date: 1999/12/03 12:39:48 $
+ * $Revision: 1.16 $
+ * $Date: 1999/12/03 17:01:25 $
  * ------------------------------------------------------------------------*/
 
 /* --------------------------------------------------------------------------
@@ -516,6 +516,8 @@ extern Tycon addPrimTycon Args((Text,Kind,Int,Cell,Cell));
 #define polySigOf(t)    fst(snd(t))
 #define monotypeOf(t)   snd(snd(t))
 
+#define bang(t)         ap(BANG,t)
+
 /* --------------------------------------------------------------------------
  * Globally defined name values:
  * ------------------------------------------------------------------------*/

diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index f85275e..0fb0439 100644 (file)
--- a/ghc/interpreter/translate.c
+++ b/ghc/interpreter/translate.c
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: translate.c,v $
- * $Revision: 1.20 $
- * $Date: 1999/11/29 18:53:15 $
+ * $Revision: 1.21 $
+ * $Date: 1999/12/03 17:01:26 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -469,7 +469,7 @@ Void stgDefn( Name n, Int arity, Cell e )
 
 Void implementCfun(c,scs)               /* Build implementation for constr */
 Name c;                                 /* fun c.  scs lists integers (1..)*/
-List scs; {                             /* in incr order of strict comps.  */
+List scs; {                             /* in incr order of strict fields. */
     Int a = name(c).arity;
 
     if (a > 0) {