Switching off invalid hashconsing

runtime/runtime.c

@@ -9,7 +9,7 @@
 # define alloc malloc
 # endif
 
-/* # define DEBUG_PRINT 1 */
+//# define DEBUG_PRINT 1 
 
 #ifdef DEBUG_PRINT
 int indent = 0;
@@ -342,7 +342,7 @@ extern int LtagHash (char *s) {
                
   p = s;
 
-  while (*p && limit++ < 4) {
+  while (*p && limit++ <= 4) {
     char *q = chars;
     int pos = 0;
     

src/Language.ml

@@ -802,6 +802,7 @@ module Expr =
              in
              (match arr with [a] -> a | _ -> Array (List.rev arr)), List.rev ss
         in
+        let escape = String.map (function '"' -> ' ' | x -> x) in
         List.fold_right (fun (loc, _, p, s) ->
                            let make_right =
                              match p with
@@ -813,7 +814,7 @@ module Expr =
                                                                                 )
                            in
                            function
-                           | Var "" -> Call (Var (infix_name "@"), [s; make_right sema])
+                           | Var "" -> Call (Var (infix_name "@@"), [Array [String (escape (show(t) s)); s]; make_right sema])
                            | acc    -> Call (Var "seq", [s; make_right acc])
                         ) ss (Var "")
       };

src/version.ml

@@ -1 +1 @@
-let version = "Version 1.10, 669a4288d, Mon Nov 22 15:51:47 2021 +0300"
+let version = "Version 1.10, f953814c7, Fri Dec 3 03:56:58 2021 +0300"

stdlib/Collection.lama

@@ -308,17 +308,28 @@ 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
+    esac
+  }   
+  (fun () {
+     case v of
        #val -> v
      | _ ->
         case findMap (m, v) of
@@ -327,7 +338,9 @@ public fun lookupMemo (mm@[p, m], v) {
            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
@@ -336,7 +349,10 @@ public fun lookupMemo (mm@[p, m], v) {
              vc
            esac 
         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}
 }