Initial data commit

Task/Queue-Definition/ATS/queue-definition-1.ats

@@ -0,0 +1,181 @@
+(*------------------------------------------------------------------*)
+
+#define ATS_DYNLOADFLAG 0
+
+#include "share/atspre_staload.hats"
+
+staload UN = "prelude/SATS/unsafe.sats"
+
+(*------------------------------------------------------------------*)
+
+vtypedef queue_vt (vt : vt@ype+, n : int) =
+  (* A list that forms the queue, and a pointer to its last node. *)
+  @(list_vt (vt, n), ptr)
+
+#define NIL list_vt_nil ()
+#define :: list_vt_cons
+
+fn {}
+queue_vt_nil {vt : vt@ype}
+            () :
+    queue_vt (vt, 0) =
+  @(NIL, the_null_ptr)
+
+fn {}
+queue_vt_is_empty
+          {n  : int}
+          {vt : vt@ype}
+          (q  : !queue_vt (vt, n)) :
+    [is_empty : bool | is_empty == (n == 0)]
+    bool is_empty =
+  case+ q.0 of
+  | NIL => true
+  | _ :: _ => false
+
+fn {vt : vt@ype}
+queue_vt_enqueue
+          {n : int}
+          (q : queue_vt (vt, n),
+           x : vt) :
+    (* Returns the new queue. *)
+    [m : int | 1 <= m; m == n + 1]
+    queue_vt (vt, m) =
+  let
+    val @(lst, tail_ptr) = q
+    prval _ = lemma_list_vt_param lst
+  in
+    case+ lst of
+    | ~ NIL =>
+      let
+        val lst = x :: NIL
+        val tail_ptr = $UN.castvwtp1{ptr} lst
+      in
+        @(lst, tail_ptr)
+      end
+    | _ :: _ =>
+      let
+        val old_tail = $UN.castvwtp0{list_vt (vt, 1)} tail_ptr
+        val+ @ (hd :: tl) = old_tail
+
+        (* Extend the list by one node, at its tail end. *)
+        val new_tail : list_vt (vt, 1) = x :: NIL
+        val tail_ptr = $UN.castvwtp1{ptr} new_tail
+        prval _ = $UN.castvwtp0{void} tl
+        val _ = tl := new_tail
+
+        prval _ = fold@ old_tail
+        prval _ = $UN.castvwtp0{void} old_tail
+
+        (* Let us cheat and simply *assert* (rather than prove) that
+           the list has grown by one node. *)
+        val lst = $UN.castvwtp0{list_vt (vt, n + 1)} lst
+      in
+        @(lst, tail_ptr)
+      end
+  end
+
+(* The dequeue routine simply CANNOT BE CALLED with an empty queue.
+   It requires a queue of type queue_vt (vt, n) where n is positive. *)
+fn {vt : vt@ype}
+queue_vt_dequeue
+          {n : int | 1 <= n}
+          (q : queue_vt (vt, n)) :
+    (* Returns a tuple: the dequeued element and the new queue. *)
+    [m : int | 0 <= m; m == n - 1]
+    @(vt, queue_vt (vt, m)) =
+  case+ q.0 of
+  | ~ (x :: lst) => @(x, @(lst, q.1))
+
+(* queue_vt is a linear type that must be freed. *)
+extern fun {vt : vt@ype}
+queue_vt$element_free : vt -> void
+fn {vt : vt@ype}
+queue_vt_free {n : int}
+              (q : queue_vt (vt, n)) :
+    void =
+  let
+    fun
+    loop {n : nat} .<n>. (lst : list_vt (vt, n)) : void =
+      case+ lst of
+      | ~ NIL => begin end
+      | ~ (hd :: tl) =>
+        begin
+          queue_vt$element_free<vt> hd;
+          loop tl
+        end
+    prval _ = lemma_list_vt_param (q.0)
+  in
+    loop (q.0)
+  end
+
+(*------------------------------------------------------------------*)
+(* An example: a queue of nonlinear strings. *)
+
+vtypedef strq_vt (n : int) = queue_vt (string, n)
+
+fn {}                  (* A parameterless template, for efficiency. *)
+strq_vt_nil () : strq_vt 0 =
+  queue_vt_nil ()
+
+fn {}                  (* A parameterless template, for efficiency. *)
+strq_vt_is_empty {n : int} (q : !strq_vt n) :
+    [is_empty : bool | is_empty == (n == 0)] bool is_empty =
+  queue_vt_is_empty<> q
+
+fn
+strq_vt_enqueue {n : int} (q : strq_vt n, x : string) :
+    [m : int | 1 <= m; m == n + 1] strq_vt m =
+  queue_vt_enqueue<string> (q, x)
+
+fn (* Impossible to...     VVVVVV   ...call with an empty queue. *)
+strq_vt_dequeue {n : int | 1 <= n} (q : strq_vt n) :
+    [m : int | 0 <= m; m == n - 1] @(string, strq_vt m) =
+  queue_vt_dequeue<string> q
+
+fn
+strq_vt_free {n : int} (q : strq_vt n) : void =
+  let
+    implement
+    queue_vt$element_free<string> x =
+      (* A nonlinear string will be allowed to leak. (It might be
+         collected as garbage, however.) *)
+      begin end
+  in
+    queue_vt_free<string> q
+  end
+
+macdef qnil = strq_vt_nil ()
+overload iseqz with strq_vt_is_empty
+overload << with strq_vt_enqueue
+overload pop with strq_vt_dequeue
+overload free with strq_vt_free
+
+implement
+main0 () =
+  {
+    val q = qnil
+    val _ = println! ("val q = qnil")
+    val _ = println! ("iseqz q = ", iseqz q)
+    val _ = println! ("val q = q << \"one\" << \"two\" << \"three\"")
+    val q = q << "one" << "two" << "three"
+    val _ = println! ("iseqz q = ", iseqz q)
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("val q = q << \"four\"")
+    val q = q << "four"
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("iseqz q = ", iseqz q)
+    //val (x, q) = pop q  // If you uncomment this you cannot compile!
+    val _ = free q
+  }
+
+(*------------------------------------------------------------------*)

Task/Queue-Definition/ATS/queue-definition-2.ats

@@ -0,0 +1,208 @@
+(*------------------------------------------------------------------*)
+(*
+
+  The following implementation prevents us from trying to dequeue
+  from an empty queue. A program that tries to do so cannot be
+  compiled.
+
+  However, it does not prove there are no buffer overruns.
+
+  It contains much embedded C code, for which I used the quick and
+  dirty "$extfcall" method.
+
+*)
+(*------------------------------------------------------------------*)
+
+#define ATS_DYNLOADFLAG 0
+
+#include "share/atspre_staload.hats"
+
+(*------------------------------------------------------------------*)
+
+(* For the demonstration, let us set BUFSIZE_INITIAL to the minimum
+   possible. If you try setting it any lower, though, you cannot
+   compile the program. *)
+#define BUFSIZE_INITIAL 2
+
+prval _ = prop_verify {2 <= BUFSIZE_INITIAL} ()
+
+datatype queue_t (t : t@ype+,
+                  n : int) =
+| queue_t_empty (t, 0) of (size_t, ptr)
+| {1 <= n}
+  queue_t_nonempty (t, n) of
+    (size_t, ptr, size_t n, size_t, size_t)
+
+fn
+queue_t_new {t : t@ype}
+            () : queue_t (t, 0) =
+  queue_t_empty (i2sz 0, the_null_ptr)
+
+fn
+queue_t_is_empty
+          {n : int}
+          {t : t@ype}
+          (q : queue_t (t, n)) :
+    [b : bool | b == (n == 0)]
+    bool b =
+  case+ q of
+  | queue_t_empty _ => true
+  | queue_t_nonempty _ => false
+
+fn {t : t@ype}
+queue_t_enqueue
+          {n : int}
+          (q : queue_t (t, n),
+           x : t) :
+    [m : int | 1 <= m; m == n + 1]
+    queue_t (t, m) =
+  let
+    macdef tsz = sizeof<t>
+    macdef zero = i2sz 0
+    macdef one = i2sz 1
+    var xvar = x
+    val px = addr@ xvar
+  in
+    case+ q of
+    | queue_t_empty (bufsize, pbuf) =>
+      if bufsize = zero then
+        let
+          val bufsize = i2sz BUFSIZE_INITIAL
+          val pbuf =
+            $extfcall (ptr, "ATS_MALLOC", bufsize * tsz)
+          val _ = $extfcall (ptr, "memcpy", pbuf, px, tsz)
+        in
+          queue_t_nonempty (bufsize, pbuf, one, zero, one)
+        end
+      else
+        let
+          val _ = $extfcall (ptr, "memcpy", pbuf, px, tsz)
+        in
+          queue_t_nonempty (bufsize, pbuf, one, zero, one)
+        end
+    | queue_t_nonempty (bufsize, pbuf, n, ihead, itail) =>
+      if n = bufsize then
+        let
+          (* Resize the buffer. *)
+          val bsize = i2sz 2 * bufsize
+          val _ = assertloc (itail = ihead)   (* Sanity check. *)
+          val _ = assertloc (bufsize < bsize) (* Overflow? *)
+          val p = $extfcall (ptr, "ATS_MALLOC", bsize * tsz)
+          val _ = $extfcall (ptr, "memcpy", p,
+                             ptr_add<t> (pbuf, ihead),
+                             (bufsize - ihead) * tsz)
+          val _ = $extfcall (ptr, "memcpy",
+                             ptr_add<t> (p, bufsize - ihead),
+                             pbuf, ihead * tsz)
+          val _ = $extfcall (ptr, "memcpy", ptr_add<t> (p, n),
+                             px, tsz)
+        in
+          queue_t_nonempty (bsize, p, succ n, zero, succ n)
+        end
+      else
+        let
+          val _ = $extfcall (ptr, "memcpy", ptr_add<t> (pbuf, itail),
+                             px, tsz)
+          val itail = (succ itail) mod bufsize
+        in
+          queue_t_nonempty (bufsize, pbuf, succ n, ihead, itail)
+        end
+  end
+
+fn {t : t@ype}
+queue_t_dequeue
+          {n : int | 1 <= n}
+          (q : queue_t (t, n)) :
+    [m : int | m == n - 1]
+    @(t, queue_t (t, m)) =
+  let
+    macdef tsz = sizeof<t>
+    macdef zero = i2sz 0
+    macdef one = i2sz 1
+    var xvar : t
+    val px = addr@ xvar
+    val queue_t_nonempty (bufsize, pbuf, n, ihead, itail) = q
+    val _ = $extfcall (ptr, "memcpy", px, ptr_add<t> (pbuf, ihead),
+                       tsz)
+    val ihead = (succ ihead) mod bufsize
+    val x = $UNSAFE.cast{t} xvar
+  in
+    if n = one then
+      @(x, queue_t_empty (bufsize, pbuf))
+    else
+      @(x, queue_t_nonempty (bufsize, pbuf, pred n, ihead, itail))
+  end
+
+(*------------------------------------------------------------------*)
+(* An example: a queue of strings. *)
+
+vtypedef strq_t (n : int) = queue_t (string, n)
+
+fn
+strq_t_new () : strq_t 0 =
+  queue_t_new ()
+
+fn {}                  (* A parameterless template, for efficiency. *)
+strq_t_is_empty {n : int} (q : strq_t n) :
+    [is_empty : bool | is_empty == (n == 0)] bool is_empty =
+  queue_t_is_empty q
+
+fn
+strq_t_enqueue {n : int} (q : strq_t n, x : string) :
+    [m : int | 1 <= m; m == n + 1] strq_t m =
+  queue_t_enqueue<string> (q, x)
+
+fn (* Impossible to...    VVVVVV   ...call with an empty queue. *)
+strq_t_dequeue {n : int | 1 <= n} (q : strq_t n) :
+    [m : int | 0 <= m; m == n - 1] @(string, strq_t m) =
+  queue_t_dequeue<string> q
+
+overload strq with strq_t_new
+overload iseqz with strq_t_is_empty
+overload << with strq_t_enqueue
+overload pop with strq_t_dequeue
+
+implement
+main0 () =
+  {
+    val q = strq ()
+    val _ = println! ("val q = strq ()")
+    val _ = println! ("iseqz q = ", iseqz q)
+    val _ = println! ("val q = q << \"one\" << \"two\" << \"three\"")
+    val q = q << "one" << "two" << "three"
+    val _ = println! ("val q = q << \"ett\" << \"två\" << \"tre\"")
+    val q = q << "ett" << "två" << "tre"
+    val _ = println! ("iseqz q = ", iseqz q)
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("val q = q << \"four\"")
+    val q = q << "four"
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("val q = q << \"fyra\"")
+    val q = q << "fyra"
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("val (x, q) = pop q")
+    val (x, q) = pop q
+    val _ = println! ("x = ", x)
+    val _ = println! ("iseqz q = ", iseqz q)
+    //val (x, q) = pop q  // If you uncomment this you cannot compile!
+  }
+
+(*------------------------------------------------------------------*)