Switching off invalid hashconsing

stdlib/Collection.lama

@@ -308,35 +308,51 @@ public fun emptyCustomMemo (pred, compare) {
 }
 
 public fun emptyMemo () {
---  ref (emptyMap (compare))
   emptyCustomMemo ({}, compare)
 }
 
 public fun lookupMemo (mm@[p, m], v) {
+  var f = case v of
+            [Right, _] : _ -> true
+          | _              -> false
+          esac;
+
+  if f then
+    skip -- printf ("Looked up 0x%.8x | 0x%.8x | %s\n", mm, v, v.string)
+  fi;
+
+  case
   fun (x) {
     case p of
       #fun -> if p (v) then v else x () fi
     | _    -> x ()
-    esac}   
-  (fun () {case v of
-     #val -> v
-   | _ ->
-      case findMap (m, v) of
-        Some (w) -> w
-      | None ->
-         case v of
-           #str -> mm[1] := addMap (m, v, v); v        
-         | _ ->
-           var vc = clone (v), i = case vc of #fun -> 1 | _ -> 0 esac;          
-           for skip, i < v.length, i := i + 1 do
-             var vci = lookupMemo (mm, vc [i]);
-             vc [i] := vci
-           od;
-           mm [1] := addMap (m, vc, vc);
-           vc
-         esac
-      esac
-   esac})
+    esac
+  }   
+  (fun () {
+     case v of
+       #val -> v
+     | _ ->
+        case findMap (m, v) of
+          Some (w) -> w
+        | None ->
+           case v of
+             #str -> mm[1] := addMap (m, v, v); v
+           | _ ->
+             var v0 = v;
+             var vc = clone (v), i = case vc of #fun -> 1 | _ -> 0 esac;
+--             printf ("Cloning: 0x%.8x\n", v);
+             for skip, i < v.length, i := i + 1 do
+               var vci = lookupMemo (mm, vc [i]);
+               vc [i] := vci
+             od;
+             mm [1] := addMap (m, vc, vc);
+             vc
+           esac 
+        esac
+     esac}) of
+     r -> -- if f then printf ("Result | 0x%.8x | %s\n", r, r.string) fi;
+     r
+     esac
 }
 
 -- Maps of hashed pointers

stdlib/Data.lama

@@ -7,6 +7,35 @@ import Collection;
 import Ref;
 
 -- Generic comparison for shared/cyclic data structures
+
+public fun trace (x) {
+  fun tracerec (s, x) {
+    case x of
+      #val -> skip -- printf ("unboxed:%d;", x)
+    | _ ->
+       if memSet (s, x)
+       then printf ("<knot: 0x%.8x>", x)
+       else
+         var s_ = addSet (s, x);
+         printf ("[0x%.8x: ", x);
+         case x of
+           #array -> printf ("a; ")
+         | #fun   -> printf ("f<0x%.8x>; ", x[0])
+         | #sexp  -> printf ("s; ")
+         | #str   -> printf ("c<%s>; ", x)
+         esac;
+         for var i = case x of #fun -> 1 | _ -> 0 esac;, i<x.length, i := i+1
+         do
+           tracerec (s_, x[i])
+         od;
+         printf ("]")
+       fi
+    esac
+  }
+
+  tracerec (emptySet (flatCompare), x)
+}
+
 public infix =?= at < (x, y) {
   var m = ref (emptyMap (flatCompare));
 

stdlib/Ostap.lama

@@ -9,6 +9,7 @@ import Collection;
 import Ref;
 import Fun;
 import Matcher;
+import Data;
 
 var tab, hct, restab, log = false;
 
@@ -23,7 +24,7 @@ public fun initOstap () {
 }
 
 public fun memo (f) {
-  f := lookupMemo (hct, f);
+  -- f := lookupMemo (hct, f);
   
   if log then printf ("Memoizing %x=%s\n", f, f.string) fi;
   
@@ -135,6 +136,21 @@ public infix @ at * (a, f) {
   }
 }
 
+public infix @@ at * ([name, a], f) {
+  fun (k) {
+    fun (s) {
+      var aa =
+      a (fun (x) {k (case x of                       
+                       Succ (x, s) -> Succ (f (x), s)
+                     | _           -> x
+                     esac)});
+--      printf ("aa=%s\n", aa.string);
+--      printf ("@@: %s\n", name);
+      aa (s)
+    }
+  }
+}
+
 public fun lift (f) {
   fun (x) {f}
 }
@@ -294,7 +310,7 @@ public fun expr (ops, opnd) {
       {}         -> fun (c) {opnd @ c}
     | level : tl ->
         var lops = altl (level),
-              next = inner (tl);
+            next = inner (tl);
 
         case level.fst of
           Nona ->