Switching off invalid hashconsing

runtime/runtime.c

@@ -4,12 +4,12 @@
 
 # include "runtime.h"
 
-# define __ENABLE_GC__
+# define __ENABLE_GC__ 
 # ifndef __ENABLE_GC__
 # 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;
     
@@ -2075,7 +2075,7 @@ extern void * alloc (size_t size) {
 #endif
     return p;
   }
-  
+
   init_to_space (0);
 #ifdef DEBUG_PRINT
   print_indent ();

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,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}   
+    esac
-  (fun () {case v of
+  }   
-     #val -> v
+  (fun () {
-   | _ ->
+     case v of
-      case findMap (m, v) of
+       #val -> v
-        Some (w) -> w
+     | _ ->
-      | None ->
+        case findMap (m, v) of
-         case v of
+          Some (w) -> w
-           #str -> mm[1] := addMap (m, v, v); v        
+        | None ->
-         | _ ->
+           case v of
-           var vc = clone (v), i = case vc of #fun -> 1 | _ -> 0 esac;          
+             #str -> mm[1] := addMap (m, v, v); v
-           for skip, i < v.length, i := i + 1 do
+           | _ ->
-             var vci = lookupMemo (mm, vc [i]);
+             var v0 = v;
-             vc [i] := vci
+             var vc = clone (v), i = case vc of #fun -> 1 | _ -> 0 esac;
-           od;
+--             printf ("Cloning: 0x%.8x\n", v);
-           mm [1] := addMap (m, vc, vc);
+             for skip, i < v.length, i := i + 1 do
-           vc
+               var vci = lookupMemo (mm, vc [i]);
-         esac
+               vc [i] := vci
-      esac
+             od;
-   esac})
+             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 ->