More stdlib; memoized CPS parser combinators workout

runtime/runtime.c

@@ -517,7 +517,7 @@ void *Lclone (void *p) {
   return res;
 }
 
-# define HASH_DEPTH 10
+# define HASH_DEPTH 3
 # define HASH_APPEND(acc, x) (((acc + (unsigned) x) << (WORD_SIZE / 2)) | ((acc + (unsigned) x) >> (WORD_SIZE / 2)))
 
 int inner_hash (int depth, unsigned acc, void *p) {
@@ -1163,7 +1163,7 @@ extern void __gc_root_scan_stack ();
 /*           Mark-and-copy                  */
 /* ======================================== */
 
-static size_t SPACE_SIZE = 32 * 1024;
+static size_t SPACE_SIZE = 32 * 10240;
 // static size_t SPACE_SIZE = 128;
 // static size_t SPACE_SIZE = 1024 * 1024;
 

stdlib/Collection.expr

@@ -5,6 +5,7 @@
 -- data structures.
 
 import List;
+import Ref;
 
 fun insertColl (m, pk, v, sort) {
   local k = case sort of Hash -> hash (pk) | _ -> pk esac;
@@ -259,24 +260,24 @@ public fun foldSet (f, acc, s) {
 
 -- Hash consing
 public fun emptyMemo () {
-  [{}]
+  ref ({})
 }
 
 public fun lookupMemo (m, v) {
   case v of
     #unboxed -> v
   | _ ->
-     case findMap (m[0], v) of
+     case findMap (deref (m), v) of
        Some (w) -> w
      | None ->
         case v of
-          #string -> m[0] := addMap (m[0], v, v); v        
+          #string -> m ::= addMap (deref (m), v, v); v        
         | _ ->
           local vc = clone (v), i = case vc of #fun -> 1 | _ -> 0 esac;
           for skip, i < v.length, i := i + 1 do
             vc [i] := lookupMemo (m, vc [i])
           od;
-          m[0] := addMap (m[0], vc, vc);
+          m ::= addMap (deref (m), vc, vc);
           vc
         esac
      esac

stdlib/Fun.expr

@@ -0,0 +1,24 @@
+import Ref;
+
+public fun id (x) {
+  x
+}
+
+public infixl $ after * (f, x) {
+  f (x)
+}
+
+public infix # at $ (f, g) {
+  fun (x) {
+    f (g (x))
+  }
+}
+
+public fun fix (f) {
+  local knot = ref (0);
+  
+  knot ::= fun () {fun (x) {f (deref (knot) ()) (x)}};
+  
+
+  deref (knot) ()
+}

stdlib/Lazy.expr

@@ -0,0 +1,14 @@
+public fun lazy (f) {
+  local value, set = false;
+  
+  fun () {
+     if set
+     then value
+     else set := true; value := f (); value
+     fi
+  } 
+}
+
+public fun force (f) {
+  f ()
+}

stdlib/List.expr

@@ -1,3 +1,7 @@
+public fun list (x) {
+  x : {}
+}
+
 public fun size (l) {
   case l of
     {}    -> 0

stdlib/Makefile

@@ -6,10 +6,14 @@ RC=../src/rc.opt
 
 all: $(ALL)
 
-Collection.o: List.o
+Fun.o: Ref.o
+
+Collection.o: List.o Ref.o
 
 Array.o: List.o
 
+Ostap.o: List.o Collection.o Ref.o Fun.o
+
 %.o: %.expr
 	$(RC) -I . -c $<
 

stdlib/Ostap.expr

@@ -0,0 +1,178 @@
+import List;
+import Collection;
+import Ref;
+import Fun;
+
+fun token_k (x) {
+  fun (k) {
+    fun (s) {
+      case s of
+        h : t -> if compare (h, x) == 0 then k (Succ (x, t)) else k (Fail ("expected " ++ x.string)) fi
+      | _     -> k (Fail ("expected " ++ x.string))
+      esac
+    }
+  }   
+}
+
+fun token (x) {
+  fun (s) {
+    case s of
+      h : t -> if compare (h, x) == 0 then return Succ (list ([x, t]), {}) fi
+    | _     -> skip
+    esac;
+    Fail (list ("expected " ++ x.string))
+  }
+}
+
+fun eof_k (k) {
+  fun (s) {
+    case s of
+      {} -> k (Succ ({}, {}))
+    | _  -> k (Fail ("expected <EOF>"))
+    esac
+  }
+}
+
+fun eof (s) {
+   case s of
+    {} -> Succ (list ([{}, {}]), {})
+  | _  -> Fail (list ("expected <EOF>"))
+  esac
+}
+
+fun empty_k (k) {
+  fun (s) {k (Succ ({}, s))}
+}
+
+fun empty (s) {
+  Succ ({[{}, s]}, {})
+}
+
+infix ** at * (a, b) {
+  case [a, b] of
+    [Succ (r1, e1), Succ (r2, e2)] -> Succ (r1 +++ r2, e1 +++ e2)
+  | [Fail (e1)    , Fail (e2)    ] -> Fail (e1 +++ e2)
+  | [Succ (r1, e1), Fail (e2)    ] -> Succ (r1, e1 +++ e2)
+  | [Fail (e1)    , Succ (r2, e2)] -> Succ (r2, e1 +++ e2)
+  esac
+}
+
+fun alt_k (a, b) {
+  fun (k) {
+    fun (s) {
+      a (k) (s);
+      b (k) (s)
+    }
+  }
+}
+
+fun alt (a, b) {
+  fun (s) {a (s) ** b (s)}
+}
+
+fun seq_nm (a, b) {
+  fun (k) {
+    fun (s) {
+      a (fun (ar) {case ar of Fail (_) -> k (ar) | Succ (x, s) -> b (k) (s) esac}) (s)
+    }
+  }
+}
+
+fun seq_k (a, b) {
+  fun (k) {
+    fun (s) {
+      a (fun (ar) {case ar of Fail (_) -> k (ar) | Succ (x, s) -> b (x) (k) (s) esac}) (s)
+    }
+  }
+}
+
+fun seq (a, b) {
+  fun (s) {
+    case a (s) of
+      r@(Fail (_)) -> r
+    | Succ (r, e)  ->
+        foldl (fun (r, p) {r ** b (p.fst) (p.snd)}, Fail (e), r)
+    esac
+  }
+}
+
+
+--infixr |  before !! (a, b) {alt (a, b)}
+--infixr |> after  |  (a, b) {seq (a, b)}
+
+infixr ||  before !! (a, b) {alt_k (a, b)}
+infixr ||> after  ||  (a, b) {seq_nm (a, b)}
+
+infix @ at * (a, f) {
+  fun (k) {
+    fun (s) {
+      a (fun (x) {k (case x of Fail (_) -> x | Succ (x, s) -> Succ (f (x), s) esac)}) (s)
+    }
+  }
+}
+
+local tab = emptyMemo (), memo_tab = ref (emptyHashTab ());
+
+fun memo (f) {
+  local t;
+  
+  --f := lookupMemo (tab, f);
+  printf ("Memoizing: f=%x\n", f);
+
+  case findHashTab (deref (memo_tab), f) of
+    None      -> t := ref (emptyMap ()); memo_tab ::= addHashTab (deref (memo_tab), f, t)
+  | Some (tt) -> t := tt
+  esac;
+  
+  fun (k) {
+    fun (s) {
+      -- printf ("s=%s\n", s.string);
+      case findMap (deref (t), s) of
+        None  ->
+          t ::= addMap (deref (t), s, [addSet (emptySet (), k), emptySet ()]);
+          f (fun (r) {
+               -- printf ("Result: %s\n", r.string);
+               case findMap (deref (t), s) of
+                 Some ([ks, rs]) ->
+                   if memSet (rs, r)
+                   then skip
+                   else
+                     t ::= addMap (deref (t), s, [ks, addSet (rs, r)]);
+                     iterSet (fun (k) {k (r)}, ks)
+                   fi
+               esac
+             }          
+            )
+            (s)
+      | Some ([ks, rs]) ->
+          t ::= addMap (deref (t), s, [addSet (ks, k), rs]);
+          iterSet (k, rs)
+      esac
+    }
+  }
+}
+
+fun lift (f) {
+  fun (x) {f}
+}
+
+fun observe (name, f) {
+  fun (k) {
+    fun (s) {
+      printf ("%s at %s\n", name, s.string);
+      f (k)(s)
+    }
+  }
+}
+
+fun print (x) {printf ("k: %s\n", x.string)}
+
+local a = token_k ("a");
+
+local as = memo (
+  fun (k) {
+    (empty_k || (as ||> a)) (k) 
+  }
+);
+
+as (print) ({"a", "a"})

stdlib/Ref.expr

@@ -0,0 +1,11 @@
+public fun ref (x) {
+  [x]
+}
+
+public fun deref (x) {
+  x[0]
+}
+
+public infix ::= before := (x, y) {
+  x[0] := y
+}

stdlib/regression/orig/test08.log

@@ -0,0 +1,3 @@
+6
+120
+5040

stdlib/regression/test08.expr

@@ -0,0 +1,7 @@
+import Fun;
+
+local fact = fix (fun (self) {fun (n) {if n <= 1 then 1 else n * self (n-1) fi}});
+
+printf ("%d\n", fact (3));
+printf ("%d\n", fact (5));
+printf ("%d\n", fact (7))