[project @ 2000-01-14 19:14:26 by rrt]

[ghc-hetmet.git] / ghc / interpreter / storage.c

diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index bc7c877..3443061 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.30 $
- * $Date: 2000/01/05 15:57:41 $
+ * $Revision: 1.40 $
+ * $Date: 2000/01/12 14:52:53 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -312,7 +312,7 @@ Text unZcodeThenFindText ( String s )
             if (*s != 'T') goto parse_error;
             s++;
             p[n++] = '(';
-            while (i >= 0) { p[n++] = ','; i--; };
+            while (i > 0) { p[n++] = ','; i--; };
             p[n++] = ')';
             break;
          default: 
@@ -353,6 +353,19 @@ Text enZcodeThenFindText ( String s )
          p[n] = *s; n++; s++;
          continue;
       }
+      if (*s == '(') {
+         int tup = 0;
+         char num[12];
+         s++;
+         while (*s && *s==',') { s++; tup++; };
+         if (*s != ')') internal("enZcodeThenFindText: invalid tuple type");
+         s++;
+         p[n++] = 'Z';
+         sprintf(num,"%d",tup);
+         p[n] = 0; strcat ( &(p[n]), num ); n += strlen(num);
+         p[n++] = 'T';
+         continue;         
+      }
       switch (*s++) {
          case '(': p[n++] = 'Z'; p[n++] = 'L'; break;
          case ')': p[n++] = 'Z'; p[n++] = 'R'; break;
@@ -586,13 +599,15 @@ List   ts; {                            /* Null pattern matches every tycon*/
 
 Text ghcTupleText_n ( Int n )
 {
-    Int  i;
+    Int i;
+    Int x = 0; 
     char buf[104];
     if (n < 0 || n >= 100) internal("ghcTupleText_n");
-    buf[0] = '(';
-    for (i = 1; i <= n; i++) buf[i] = ',';
-    buf[n+1] = ')';
-    buf[n+2] = 0;
+    if (n == 1) internal("ghcTupleText_n==1");
+    buf[x++] = '(';
+    for (i = 1; i <= n-1; i++) buf[x++] = ',';
+    buf[x++] = ')';
+    buf[x++] = 0;
     return findText(buf);
 }
 
@@ -779,34 +794,36 @@ Module findFakeModule ( Text t )
 
 Name addWiredInBoxingTycon
         ( String modNm, String typeNm, String constrNm,
-          Int arity, Int no, Int rep )
+          Int rep, Kind kind )
 {
-   Name  n;
-   Tycon t;
-   Text modT  = findText(modNm);
-   Text typeT = findText(typeNm);
-   Text conT  = findText(constrNm);
-   Module m = findFakeModule(modT);
+   Name   n;
+   Tycon  t;
+   Text   modT  = findText(modNm);
+   Text   typeT = findText(typeNm);
+   Text   conT  = findText(constrNm);
+   Module m     = findFakeModule(modT);
    setCurrModule(m);
    
    n = newName(conT,NIL);
-   name(n).arity = arity;
-   name(n).number = cfunNo(no);
-   name(n).type = NIL;
+   name(n).arity  = 1;
+   name(n).number = cfunNo(0);
+   name(n).type   = NIL;
    name(n).primop = (void*)rep;
 
    t = newTycon(typeT);
    tycon(t).what = DATATYPE;
+   tycon(t).kind = kind;
    return n;
 }
 
 
 Tycon addTupleTycon ( Int n )
 {
-   Int   i;
-   Kind  k;
-   Tycon t;
+   Int    i;
+   Kind   k;
+   Tycon  t;
    Module m;
+   Name   nm;
 
    for (i = TYCMIN; i < tyconHw; i++)
       if (tycon(i).tuple == n) return i;
@@ -822,6 +839,13 @@ Tycon addTupleTycon ( Int n )
    tycon(t).kind  = k;
    tycon(t).tuple = n;
    tycon(t).what  = DATATYPE;
+
+   if (n == 0) {
+      /* maybe we want to do this for all n ? */
+      nm = newName(ghcTupleText_n(n), t);
+      name(nm).type = t;   /* ummm ... for n > 0 */
+   }
+
    return t;
 }
 
@@ -1201,6 +1225,29 @@ Tycon findQualTyconWithoutConsultingExportList ( QualId q )
    return NIL;
 }
 
+Tycon findTyconInAnyModule ( Text t )
+{
+   Tycon tc;
+   for (tc = TYCMIN; tc < tyconHw; tc++)
+      if (tycon(tc).text == t) return tc;
+   return NIL;
+}
+
+Class findClassInAnyModule ( Text t )
+{
+   Class cc;
+   for (cc = CLASSMIN; cc < classHw; cc++)
+      if (cclass(cc).text == t) return cc;
+   return NIL;
+}
+
+Name findNameInAnyModule ( Text t )
+{
+   Name nm;
+   for (nm = NAMEMIN; nm < nameHw; nm++)
+      if (name(nm).text == t) return nm;
+   return NIL;
+}
 
 /* Same deal, except for Names. */
 Name findQualNameWithoutConsultingExportList ( QualId q )
@@ -1438,8 +1485,10 @@ char* nameFromOPtr ( void* p )
    int i;
    Module m;
    for (m=MODMIN; m<moduleHw; m++) {
-      char* nm = ocLookupAddr ( module(m).object, p );
-      if (nm) return nm;
+      if (module(m).object) {
+         char* nm = ocLookupAddr ( module(m).object, p );
+         if (nm) return nm;
+      }
    }
    return NULL;
 }
@@ -1467,13 +1516,22 @@ void* lookupOExtraTabName ( char* sym )
 
 OSectionKind lookupSection ( void* ad )
 {
-   int i;
-   Module m;
+   int          i;
+   Module       m;
+   ObjectCode*  oc;
+   OSectionKind sect;
+
    for (m=MODMIN; m<moduleHw; m++) {
-      OSectionKind sect
-         = ocLookupSection ( module(m).object, ad );
-      if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
-         return sect;
+      if (module(m).object) {
+         sect = ocLookupSection ( module(m).object, ad );
+         if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
+            return sect;
+      }
+      for (oc = module(m).objectExtras; oc; oc=oc->next) {
+         sect = ocLookupSection ( oc, ad );
+         if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
+            return sect;
+      }
    }
    return HUGS_SECTIONKIND_OTHER;
 }