Updating: adding a convenience function

Updating: adding a convenience function

(***********************************************************************)
(*                                                                     *)
(*                       ATS/contrib/libats-hwxi                       *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2014 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
** OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
** THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
** IN THE SOFTWARE.
*)

(* ****** ****** *)
//
// HX-2014-02-06
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

staload "libats/ML/SATS/basis.sats"
staload "libats/ML/SATS/list0.sats"
staload "libats/ML/SATS/array0.sats"

(* ****** ****** *)
//
staload
STDLIB = "libc/SATS/stdlib.sats"
staload TIME = "libc/SATS/time.sats"
//
staload
STAT = "libc/sys/SATS/stat.sats"
staload
TYPES = "libc/sys/SATS/types.sats"
//
(* ****** ****** *)

fun{
} test_file_ixoth
  (path: string): int = let
//
macdef S_IXOTH = $UN.cast2uint($STAT.S_IXOTH)
//
implement
test_file_mode$pred<> (mode) = (mode land S_IXOTH) != 0u
//
in
//
  test_file_mode (path)
//
end // end of [test_file_ixoth]

(* ****** ****** *)

extern
fun{}
randint{n:pos}(int(n)): natLt(n)
implement{}
randint{n}(n) = let
  val x = $STDLIB.random()
in
  $UN.cast{natLt(n)}(x mod $UN.cast2lint(n))
end // end of [randint]

(* ****** ****** *)

extern
fun{}
srandom_with_time((*void*)): void
implement{}
srandom_with_time () =
  $STDLIB.srandom($UN.cast{uint}($TIME.time_get()))
// end of [srandom_with_time]

(* ****** ****** *)

extern
fun{}
srand48_with_time((*void*)): void
implement{}
srand48_with_time () =
  $STDLIB.srand48($UN.cast{lint}($TIME.time_get()))
// end of [srand48_with_time]

(* ****** ****** *)
//
extern
fun{}
string_split_delim_string
  (source: string, delim: string): List0_vt(Strptr1)
//
implement{}
string_split_delim_string
  (source, delim) = let
//
#define NUL '\000'
vtypedef res = List0_vt(Strptr1)
//
fun loop
(
  p: ptr, res: res
) : res = let
//
val str = $UN.cast{String}(p)
val len = strspn (str, delim)
val p2 = ptr_add<char> (p, len)
val str2 = $UN.cast{String}(p2)
val len2 = strcspn (str2, delim)
//
in
//
if
len2 = 0
then res
else let
  val x =
  string_make_substring (str2, i2sz(0), len2)
  prval () = lemma_strnptr_param (x)
  val res = list_vt_cons (strnptr2strptr (x), res)
in
  loop (ptr_add<char> (p2, len2), res)
end // end of [else]
//
end // end of [loop]
//
val res =
  loop (string2ptr(source), list_vt_nil(*void*))
//
in
  list_vt_reverse<Strptr1> (res)
end // end of [string_split_delim_string]

(* ****** ****** *)
//
extern
fun{}
array0_make_argv{n:int}
  (argv: !argv(n), argc: int(n)):<!wrt> array0 (string)
//
implement
{}(*tmp*)
array0_make_argv
  {n}(argv, argc) = let
//
prval () =
  lemma_argv_param (argv)
//
val n = g1int2uint_int_size(argc)
//
val A =
$effmask_all (
arrayref_copy<string>
  ($UN.castvwtp1{arrayref(string,n)}(argv), n)
) (* end of [val] *)
//
in
  array0_make_arrayref (arrayptr_refize (A), n)
end // end of [array0_make_argv]
//
(* ****** ****** *)

(* end of [BUCS.dats] *)

(***********************************************************************)
(*                                                                     *)
(*                       ATS/contrib/libats-hwxi                       *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2014 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
** OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
** THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
** IN THE SOFTWARE.
*)

(* ****** ****** *)
//
// HX-2014-02-06
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload
STDLIB = "libc/SATS/stdlib.sats"
staload TIME = "libc/SATS/time.sats"
//
staload
STAT = "libc/sys/SATS/stat.sats"
staload
TYPES = "libc/sys/SATS/types.sats"
//
(* ****** ****** *)

fun{
} test_file_ixoth
  (path: string): int = let
//
macdef S_IXOTH = $UN.cast2uint($STAT.S_IXOTH)
//
implement
test_file_mode$pred<> (mode) = (mode land S_IXOTH) != 0u
//
in
//
  test_file_mode (path)
//
end // end of [test_file_ixoth]

(* ****** ****** *)

extern
fun{}
randint{n:pos}(int(n)): natLt(n)
implement{}
randint{n}(n) = let
  val x = $STDLIB.random()
in
  $UN.cast{natLt(n)}(x mod $UN.cast2lint(n))
end // end of [randint]

(* ****** ****** *)

extern
fun{}
srandom_with_time((*void*)): void
implement{}
srandom_with_time () =
  $STDLIB.srandom($UN.cast{uint}($TIME.time_get()))
// end of [srandom_with_time]

(* ****** ****** *)

extern
fun{}
srand48_with_time((*void*)): void
implement{}
srand48_with_time () =
  $STDLIB.srand48($UN.cast{lint}($TIME.time_get()))
// end of [srand48_with_time]

(* ****** ****** *)
//
extern
fun{}
string_split_delim_string
  (source: string, delim: string): List0_vt(Strptr1)
//
implement{}
string_split_delim_string
  (source, delim) = let
//
#define NUL '\000'
vtypedef res = List0_vt(Strptr1)
//
fun loop
(
  p: ptr, res: res
) : res = let
//
val str = $UN.cast{String}(p)
val len = strspn (str, delim)
val p2 = ptr_add<char> (p, len)
val str2 = $UN.cast{String}(p2)
val len2 = strcspn (str2, delim)
//
in
//
if
len2 = 0
then res
else let
  val x =
  string_make_substring (str2, i2sz(0), len2)
  prval () = lemma_strnptr_param (x)
  val res = list_vt_cons (strnptr2strptr (x), res)
in
  loop (ptr_add<char> (p2, len2), res)
end // end of [else]
//
end // end of [loop]
//
val res =
  loop (string2ptr(source), list_vt_nil(*void*))
//
in
  list_vt_reverse<Strptr1> (res)
end // end of [string_split_delim_string]

(* ****** ****** *)

(* end of [BUCS.dats] *)


Update basics.sats

Update basics.sats

(*
//
// For invoking [patsopt]
//
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#define
ATS_EXTERN_PREFIX "tutorats_"
//
(* ****** ****** *)
//
// HX: implemented in CATS/basics_cats.php
//
fun fname_dats_c (fname: string): string = "mac#%"
fun fname_dats_js (fname: string): string = "mac#%"
fun fname_dats_php (fname: string): string = "mac#%"
//
(* ****** ****** *)
//
fun exec_retval (command: string): int(*ret*) = "mac#%"
//
(* ****** ****** *)
//
datatype compres =
//
// HX-2014-09:
// the order must be maintained!!!
//
  | COMPRES0_succ of (string(*target*)) // success
  | COMPRES1_fail of (string(*target*)) // failure1
  | COMPRES2_fail of (string(*source*), string(*errmsg*)) // failure2
//
(* ****** ****** *)
//
fun{}
patsopt_get (): string
//
fun{}
patsopt_format_command
  (string, string, string): string
//
(* ****** ****** *)
//
fun{}
patsopt_file (fname: string): compres
fun{}
patsopt_code (ptext: string): compres
//
(* ****** ****** *)
//
fun{}
atscc2js_get (): string
//
fun{}
atscc2js_format_command
  (string, string, string): string
//
fun{}
atscc2js_file
  (flag: int, fname: string): compres
//
(* ****** ****** *)
//
fun{}
patsopt_continue (fname: string): compres
fun{}
patsopt_continue_file (fname: string): compres
fun{}
patsopt_continue_code (ptext: string): compres
//
(* ****** ****** *)
//
fun{}
patsopt_atscc2js_code (ptext: string): compres
//
(* ****** ****** *)

(* end of [basics.sats] *)

(*
//
// For invoking [patsopt]
//
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#define
ATS_EXTERN_PREFIX "tutorats_"
//
(* ****** ****** *)
//
// HX: implemented in CATS/basics_cats.php
//
fun fname_dats_c (fname: string): string = "mac#%"
fun fname_dats_js (fname: string): string = "mac#%"
fun fname_dats_php (fname: string): string = "mac#%"
//
(* ****** ****** *)
//
fun exec_retval (command: string): int(*ret*) = "mac#%"
//
(* ****** ****** *)
//
datatype compres =
//
// HX-2014-09:
// the order must be maintained!!!
//
  | COMPRES0 of (string(*target*)) // success
  | COMPRES1 of (string(*target*)) // failure1
  | COMPRES2 of (string(*source*), string(*errmsg*)) // failure2
//
(* ****** ****** *)
//
fun{}
patsopt_get (): string
//
fun{}
patsopt_format_command
  (string, string, string): string
//
(* ****** ****** *)
//
fun{}
patsopt_file (fname: string): compres
fun{}
patsopt_code (ptext: string): compres
//
(* ****** ****** *)
//
fun{}
atscc2js_get (): string
//
fun{}
atscc2js_format_command
  (string, string, string): string
//
fun{}
atscc2js_file
  (flag: int, fname: string): compres
//
(* ****** ****** *)
//
fun{}
patsopt_continue (fname: string): compres
fun{}
patsopt_continue_file (fname: string): compres
fun{}
patsopt_continue_code (ptext: string): compres
//
(* ****** ****** *)
//
fun{}
patsopt_atscc2js_code (ptext: string): compres
//
(* ****** ****** *)

(* end of [basics.sats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
** For writing ATS code
** that translates into JavaScript
*)

(* ****** ****** *)
//
// HX: prefix for external names
//
#define ATS_EXTERN_PREFIX "ats2jspre_"
//
(* ****** ****** *)
//
// HX: for signed integers
//
(* ****** ****** *)
//
fun
abs_int0 : int -> int = "mac#%"
//
overload abs with abs_int0 of 100
//
(* ****** ****** *)
//
fun
neg_int0 : int -> int = "mac#%"
//
overload ~ with neg_int0 of 100
overload neg with neg_int0 of 100
//
(* ****** ****** *)
//
fun succ_int0 : int -> int = "mac#%"
fun pred_int0 : int -> int = "mac#%"
//
fun succ_int1
  : {i:int} int(i) -> int(i+1) = "mac#%"
fun pred_int1
  : {i:int} int(i) -> int(i-1) = "mac#%"
//
overload succ with succ_int0 of 100
overload pred with pred_int0 of 100
//
overload succ with succ_int1 of 110
overload pred with pred_int1 of 110
//
(* ****** ****** *)
//
fun half_int0 : int -> int = "mac#%"
fun half_int1 : {i:int} int(i) -> int(i/2) = "mac#%"
//
overload half with half_int0 of 100
overload half with half_int1 of 110
//
(* ****** ****** *)
//
fun add_int0_int0: (int, int) -> int = "mac#%"
fun sub_int0_int0 : (int, int) -> int = "mac#%"
fun mul_int0_int0 : (int, int) -> int = "mac#%"
fun div_int0_int0 : (int, int) -> int = "mac#%"
fun mod_int0_int0 : (int, int) -> int = "mac#%"
//
fun add_int1_int1
  : {i,j:int} (int(i), int(j)) -> int(i+j) = "mac#%"
fun sub_int1_int1
  : {i,j:int} (int(i), int(j)) -> int(i-j) = "mac#%"
fun mul_int1_int1
  : {i,j:int} (int(i), int(j)) -> int(i*j) = "mac#%"
fun div_int1_int1
  : {i,j:int} (int(i), int(j)) -> int(i/j) = "mac#%"
//
(* ****** ****** *)
//
overload + with add_int0_int0 of 100
overload - with sub_int0_int0 of 100
overload * with mul_int0_int0 of 100
overload / with div_int0_int0 of 100
overload % with mod_int0_int0 of 100
overload mod with mod_int0_int0 of 100
//
overload + with add_int1_int1 of 120
overload - with sub_int1_int1 of 120
overload * with mul_int1_int1 of 120
overload / with div_int1_int1 of 120
//
(* ****** ****** *)
//
fun
asl_int0_int1
  : (int, intGte(0)) -> int = "mac#%"
fun
asr_int0_int1
  : (int, intGte(0)) -> int = "mac#%"
//
(* ****** ****** *)
//
overload << with asl_int0_int1 of 110
overload >> with asr_int0_int1 of 110
//
(* ****** ****** *)
//
fun lt_int0_int0: (int, int) -> bool = "mac#%"
fun lte_int0_int0: (int, int) -> bool = "mac#%"
fun gt_int0_int0: (int, int) -> bool = "mac#%"
fun gte_int0_int0: (int, int) -> bool = "mac#%"
//
fun eq_int0_int0: (int, int) -> bool = "mac#%"
fun neq_int0_int0: (int, int) -> bool = "mac#%"
//
fun compare_int0_int0: (int, int) -> int = "mac#"
//
fun lt_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i < j) = "mac#%"
fun lte_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i <= j) = "mac#%"
fun gt_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i > j) = "mac#%"
fun gte_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i >= j) = "mac#%"
//
fun eq_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i == j) = "mac#%"
fun neq_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i != j) = "mac#%"
//
(* ****** ****** *)
//
overload < with lt_int0_int0 of 100
overload <= with lte_int0_int0 of 100
overload > with gt_int0_int0 of 100
overload >= with gte_int0_int0 of 100
overload = with eq_int0_int0 of 100
overload != with neq_int0_int0 of 100
overload <> with neq_int0_int0 of 100
//
overload compare with compare_int0_int0 of 100
//
(* ****** ****** *)
//
overload < with lt_int1_int1 of 120
overload <= with lte_int1_int1 of 120
overload > with gt_int1_int1 of 120
overload >= with gte_int1_int1 of 120
overload = with eq_int1_int1 of 120
overload != with neq_int1_int1 of 120
overload <> with neq_int1_int1 of 120
//
(* ****** ****** *)
//
// HX: for unsigned integers
//
(* ****** ****** *)
//
fun add_uint0_uint0: (uint, uint) -> uint = "mac#%"
fun sub_uint0_uint0 : (uint, uint) -> uint = "mac#%"
fun mul_uint0_uint0 : (uint, uint) -> uint = "mac#%"
fun div_uint0_uint0 : (uint, uint) -> uint = "mac#%"
fun mod_uint0_uint0 : (uint, uint) -> uint = "mac#%"
//
(* ****** ****** *)
//
overload + with add_uint0_uint0 of 100
overload - with sub_uint0_uint0 of 100
overload * with mul_uint0_uint0 of 100
overload / with div_uint0_uint0 of 100
overload % with mod_uint0_uint0 of 100
overload mod with mod_uint0_uint0 of 100
//
(* ****** ****** *)
//
fun lt_uint0_uint0: (uint, uint) -> bool = "mac#%"
fun lte_uint0_uint0: (uint, uint) -> bool = "mac#%"
fun gt_uint0_uint0: (uint, uint) -> bool = "mac#%"
fun gte_uint0_uint0: (uint, uint) -> bool = "mac#%"
//
fun eq_uint0_uint0: (uint, uint) -> bool = "mac#%"
fun neq_uint0_uint0: (uint, uint) -> bool = "mac#%"
//
fun compare_uint0_uint0: (uint, uint) -> int = "mac#"
//
(* ****** ****** *)
//
overload < with lt_uint0_uint0 of 100
overload <= with lte_uint0_uint0 of 100
overload > with gt_uint0_uint0 of 100
overload >= with gte_uint0_uint0 of 100
overload = with eq_uint0_uint0 of 100
overload != with neq_uint0_uint0 of 100
overload <> with neq_uint0_uint0 of 100
//
overload compare with compare_uint0_uint0 of 100
//
(* ****** ****** *)

(* end of [integer.sats] *)

(*
** For writing ATS code
** that translates into JavaScript
*)

(* ****** ****** *)
//
// HX: prefix for external names
//
#define ATS_EXTERN_PREFIX "ats2jspre_"
//
(* ****** ****** *)
//
// HX: for signed integers
//
(* ****** ****** *)
//
fun
abs_int0 : int -> int = "mac#%"
//
overload abs with abs_int0 of 100
//
(* ****** ****** *)
//
fun
neg_int0 : int -> int = "mac#%"
//
overload ~ with neg_int0 of 100
overload neg with neg_int0 of 100
//
(* ****** ****** *)
//
fun succ_int0 : int -> int = "mac#%"
fun pred_int0 : int -> int = "mac#%"
//
fun succ_int1
  : {i:int} int(i) -> int(i+1) = "mac#%"
fun pred_int1
  : {i:int} int(i) -> int(i-1) = "mac#%"
//
overload succ with succ_int0 of 100
overload pred with pred_int0 of 100
//
overload succ with succ_int1 of 110
overload pred with pred_int1 of 110
//
(* ****** ****** *)
//
fun half_int0 : int -> int = "mac#%"
fun half_int1 : {i:int} int(i) -> int(i/2) = "mac#%"
//
overload half with half_int0 of 100
overload half with half_int1 of 110
//
(* ****** ****** *)
//
fun add_int0_int0: (int, int) -> int = "mac#%"
fun sub_int0_int0 : (int, int) -> int = "mac#%"
fun mul_int0_int0 : (int, int) -> int = "mac#%"
fun div_int0_int0 : (int, int) -> int = "mac#%"
fun mod_int0_int0 : (int, int) -> int = "mac#%"
//
fun add_int1_int1
  : {i,j:int} (int(i), int(j)) -> int(i+j) = "mac#%"
fun sub_int1_int1
  : {i,j:int} (int(i), int(j)) -> int(i-j) = "mac#%"
fun mul_int1_int1
  : {i,j:int} (int(i), int(j)) -> int(i*j) = "mac#%"
fun div_int1_int1
  : {i,j:int} (int(i), int(j)) -> int(i/j) = "mac#%"
//
(* ****** ****** *)
//
overload + with add_int0_int0 of 100
overload - with sub_int0_int0 of 100
overload * with mul_int0_int0 of 100
overload / with div_int0_int0 of 100
overload % with mod_int0_int0 of 100
overload mod with mod_int0_int0 of 100
//
overload + with add_int1_int1 of 120
overload - with sub_int1_int1 of 120
overload * with mul_int1_int1 of 120
overload / with div_int1_int1 of 120
//
(* ****** ****** *)
//
fun
asl_int0_int1
  : (int, intGte(0)) -> int = "mac#%"
fun
asr_int0_int1
  : (int, intGte(0)) -> int = "mac#%"
//
(* ****** ****** *)
//
overload << with asl_int0_int1 of 110
overload >> with asr_int0_int1 of 110
//
(* ****** ****** *)
//
fun lt_int0_int0: (int, int) -> bool = "mac#%"
fun lte_int0_int0: (int, int) -> bool = "mac#%"
fun gt_int0_int0: (int, int) -> bool = "mac#%"
fun gte_int0_int0: (int, int) -> bool = "mac#%"
//
fun eq_int0_int0: (int, int) -> bool = "mac#%"
fun neq_int0_int0: (int, int) -> bool = "mac#%"
//
fun compare_int0_int0: (int, int) -> int = "mac#"
//
fun lt_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i < j) = "mac#%"
fun lte_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i <= j) = "mac#%"
fun gt_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i > j) = "mac#%"
fun gte_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i >= j) = "mac#%"
//
fun eq_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i == j) = "mac#%"
fun neq_int1_int1
  : {i,j:int} (int(i), int(j)) -> bool(i != j) = "mac#%"
//
(* ****** ****** *)
//
overload < with lt_int0_int0 of 100
overload <= with lte_int0_int0 of 100
overload > with gt_int0_int0 of 100
overload >= with gte_int0_int0 of 100
overload = with eq_int0_int0 of 100
overload != with neq_int0_int0 of 100
overload <> with neq_int0_int0 of 100
//
overload compare with compare_int0_int0 of 100
//
(* ****** ****** *)
//
overload < with lt_int1_int1 of 120
overload <= with lte_int1_int1 of 120
overload > with gt_int1_int1 of 120
overload >= with gte_int1_int1 of 120
overload = with eq_int1_int1 of 120
overload != with neq_int1_int1 of 120
overload <> with neq_int1_int1 of 120
//
(* ****** ****** *)
//
// HX: for unsigned integers
//
(* ****** ****** *)
//
fun add_uint0_uint0: (uint, uint) -> uint = "mac#%"
fun sub_uint0_uint0 : (uint, uint) -> uint = "mac#%"
fun mul_uint0_uint0 : (uint, uint) -> uint = "mac#%"
fun div_uint0_uint0 : (uint, uint) -> uint = "mac#%"
fun mod_uint0_uint0 : (uint, uint) -> uint = "mac#%"
//
(* ****** ****** *)
//
overload + with add_uint0_uint0 of 100
overload - with sub_uint0_uint0 of 100
overload * with mul_uint0_uint0 of 100
overload / with div_uint0_uint0 of 100
overload % with mod_uint0_uint0 of 100
overload mod with mod_uint0_uint0 of 100
//
(* ****** ****** *)
//
fun lt_uint0_uint0: (uint, uint) -> bool = "mac#%"
fun lte_uint0_uint0: (uint, uint) -> bool = "mac#%"
fun gt_uint0_uint0: (uint, uint) -> bool = "mac#%"
fun gte_uint0_uint0: (uint, uint) -> bool = "mac#%"
//
fun eq_uint0_uint0: (uint, uint) -> bool = "mac#%"
fun neq_uint0_uint0: (uint, uint) -> bool = "mac#%"
//
fun compare_int0_int0: (uint, uint) -> int = "mac#"
//
(* ****** ****** *)
//
overload < with lt_uint0_uint0 of 100
overload <= with lte_uint0_uint0 of 100
overload > with gt_uint0_uint0 of 100
overload >= with gte_uint0_uint0 of 100
overload = with eq_uint0_uint0 of 100
overload != with neq_uint0_uint0 of 100
overload <> with neq_uint0_uint0 of 100
//
overload compare with compare_uint0_uint0 of 100
//
(* ****** ****** *)

(* end of [integer.sats] *)


Updating: very minorly tidying-up

Updating: very minorly tidying-up

(***********************************************************************)
(*                                                                     *)
(*                       ATS/contrib/libats-hwxi                       *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2014 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
** OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
** THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
** IN THE SOFTWARE.
*)

(* ****** ****** *)
//
// HX-2014-02-06
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

staload "libats/ML/SATS/basis.sats"
staload "libats/ML/SATS/list0.sats"
staload "libats/ML/SATS/array0.sats"

(* ****** ****** *)
//
staload
STDLIB = "libc/SATS/stdlib.sats"
staload TIME = "libc/SATS/time.sats"
//
staload
STAT = "libc/sys/SATS/stat.sats"
staload
TYPES = "libc/sys/SATS/types.sats"
//
(* ****** ****** *)

fun{
} test_file_ixoth
  (path: string): int = let
//
macdef S_IXOTH = $UN.cast2uint($STAT.S_IXOTH)
//
implement
test_file_mode$pred<> (mode) = (mode land S_IXOTH) != 0u
//
in
//
  test_file_mode (path)
//
end // end of [test_file_ixoth]

(* ****** ****** *)

extern
fun{}
randint{n:pos}(int(n)): natLt(n)
implement
{}(*tmp*)
randint{n}(n) = let
  val x = $STDLIB.random()
in
  $UN.cast{natLt(n)}(x mod $UN.cast2lint(n))
end // end of [randint]

(* ****** ****** *)

extern
fun{}
srandom_with_time((*void*)): void
implement
{}(*tmp*)
srandom_with_time () =
  $STDLIB.srandom($UN.cast{uint}($TIME.time_get()))
// end of [srandom_with_time]

(* ****** ****** *)

extern
fun{}
srand48_with_time((*void*)): void
implement
{}(*tmp*)
srand48_with_time () =
  $STDLIB.srand48($UN.cast{lint}($TIME.time_get()))
// end of [srand48_with_time]

(* ****** ****** *)
//
extern
fun{}
string_split_delim_string
  (source: string, delim: string): List0_vt(Strptr1)
//
implement
{}(*tmp*)
string_split_delim_string
  (source, delim) = let
//
#define NUL '\000'
vtypedef res = List0_vt(Strptr1)
//
fun loop
(
  p: ptr, res: res
) : res = let
//
val str = $UN.cast{String}(p)
val len = strspn (str, delim)
val p2 = ptr_add<char> (p, len)
val str2 = $UN.cast{String}(p2)
val len2 = strcspn (str2, delim)
//
in
//
if
len2 = 0
then res
else let
  val x =
  string_make_substring (str2, i2sz(0), len2)
  prval () = lemma_strnptr_param (x)
  val res = list_vt_cons (strnptr2strptr (x), res)
in
  loop (ptr_add<char> (p2, len2), res)
end // end of [else]
//
end // end of [loop]
//
val res =
  loop (string2ptr(source), list_vt_nil(*void*))
//
in
  list_vt_reverse<Strptr1> (res)
end // end of [string_split_delim_string]

(* ****** ****** *)
//
extern
fun{}
array0_make_argv{n:int}
  (argv: !argv(n), argc: int(n)):<!wrt> array0 (string)
//
implement
{}(*tmp*)
array0_make_argv
  {n}(argv, argc) = let
//
prval () =
  lemma_argv_param (argv)
//
val n = g1int2uint_int_size(argc)
//
val A =
$effmask_all (
arrayref_copy<string>
  ($UN.castvwtp1{arrayref(string,n)}(argv), n)
) (* end of [val] *)
//
in
  array0_make_arrayref (arrayptr_refize (A), n)
end // end of [array0_make_argv]
//
(* ****** ****** *)

(* end of [BUCS.dats] *)

(***********************************************************************)
(*                                                                     *)
(*                       ATS/contrib/libats-hwxi                       *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2014 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
** OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
** THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
** IN THE SOFTWARE.
*)

(* ****** ****** *)
//
// HX-2014-02-06
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

staload "libats/ML/SATS/basis.sats"
staload "libats/ML/SATS/list0.sats"
staload "libats/ML/SATS/array0.sats"

(* ****** ****** *)
//
staload
STDLIB = "libc/SATS/stdlib.sats"
staload TIME = "libc/SATS/time.sats"
//
staload
STAT = "libc/sys/SATS/stat.sats"
staload
TYPES = "libc/sys/SATS/types.sats"
//
(* ****** ****** *)

fun{
} test_file_ixoth
  (path: string): int = let
//
macdef S_IXOTH = $UN.cast2uint($STAT.S_IXOTH)
//
implement
test_file_mode$pred<> (mode) = (mode land S_IXOTH) != 0u
//
in
//
  test_file_mode (path)
//
end // end of [test_file_ixoth]

(* ****** ****** *)

extern
fun{}
randint{n:pos}(int(n)): natLt(n)
implement{}
randint{n}(n) = let
  val x = $STDLIB.random()
in
  $UN.cast{natLt(n)}(x mod $UN.cast2lint(n))
end // end of [randint]

(* ****** ****** *)

extern
fun{}
srandom_with_time((*void*)): void
implement{}
srandom_with_time () =
  $STDLIB.srandom($UN.cast{uint}($TIME.time_get()))
// end of [srandom_with_time]

(* ****** ****** *)

extern
fun{}
srand48_with_time((*void*)): void
implement{}
srand48_with_time () =
  $STDLIB.srand48($UN.cast{lint}($TIME.time_get()))
// end of [srand48_with_time]

(* ****** ****** *)
//
extern
fun{}
string_split_delim_string
  (source: string, delim: string): List0_vt(Strptr1)
//
implement{}
string_split_delim_string
  (source, delim) = let
//
#define NUL '\000'
vtypedef res = List0_vt(Strptr1)
//
fun loop
(
  p: ptr, res: res
) : res = let
//
val str = $UN.cast{String}(p)
val len = strspn (str, delim)
val p2 = ptr_add<char> (p, len)
val str2 = $UN.cast{String}(p2)
val len2 = strcspn (str2, delim)
//
in
//
if
len2 = 0
then res
else let
  val x =
  string_make_substring (str2, i2sz(0), len2)
  prval () = lemma_strnptr_param (x)
  val res = list_vt_cons (strnptr2strptr (x), res)
in
  loop (ptr_add<char> (p2, len2), res)
end // end of [else]
//
end // end of [loop]
//
val res =
  loop (string2ptr(source), list_vt_nil(*void*))
//
in
  list_vt_reverse<Strptr1> (res)
end // end of [string_split_delim_string]

(* ****** ****** *)
//
extern
fun{}
array0_make_argv{n:int}
  (argv: !argv(n), argc: int(n)):<!wrt> array0 (string)
//
implement
{}(*tmp*)
array0_make_argv
  {n}(argv, argc) = let
//
prval () =
  lemma_argv_param (argv)
//
val n = g1int2uint_int_size(argc)
//
val A =
$effmask_all (
arrayref_copy<string>
  ($UN.castvwtp1{arrayref(string,n)}(argv), n)
) (* end of [val] *)
//
in
  array0_make_arrayref (arrayptr_refize (A), n)
end // end of [array0_make_argv]
//
(* ****** ****** *)

(* end of [BUCS.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
** HX-2014-11-09:
** This is adapted from
** some code by Kiwamu Okabe
** See:
** https://raw.githubusercontent.com/fpiot/arduino-ats/master/demo/lcd_ats/DATS/main.dats
*)

(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$ARDUINO}/staloadall.hats"
//
staload
"{$ARDUINO}/SATS/LiquidCrystal/LiquidCrystal.sats"
//
typedef lcd = LiquidCrystal_ptr
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

#define LCD_WIDTH 16

(* ****** ****** *)

val g_str_atsrun = "<ATS running!>"
val g_str_message = "\
ATS is a statically typed programming language that \
unifies implementation with formal specification. It \
is equipped with a highly expressive type system rooted \
in the framework Applied Type System, which gives the \
language its name. In particular, both dependent types \
and linear types are available in ATS.\
" // end of [g_str_message]

(* ****** ****** *)
//
extern
fun{}
myprint_one (): void
extern
fun{}
myprint_many (n: intGte(0)): void
//
implement
{}(*tmp*)
myprint_many
  (n) = let
in
  if n > 0 then (myprint_one(); myprint_many(n-1))
end // end of [myprint_many]
//
(* ****** ****** *)
//
extern
fun{}
myprint_char (char): void
extern
fun{}
myprint_string (str: string): void
//
implement
{}(*tmp*)
myprint_string
  (str) = let
//
fun
loop
(
  p: ptr
) : void = let
  val c = $UN.ptr0_get<char> (p)
in
  if isneqz(c) then (myprint_char(c); loop(ptr0_succ<char>(p)))
end // end of [loop]
//
in
  loop (string2ptr(str))
end // end of [myprint_string]
//
(* ****** ****** *)
//
extern
fun
lcd_print_row0 (lcd): void
//
implement
lcd_print_row0 (lcd) = let
//
val str = g_str_atsrun
val len = length (str)
val margin = half(LCD_WIDTH - sz2i(len))
val () = lcd.setCursor(0, margin)
//
implement
myprint_char<> (c) =
(
  ignoret(lcd.write($UN.cast{natLt(256)}(c)))
) (* end of [myprint_char] *)
//
in
  myprint_string (str)
end // end of [lcd_print_row0]
//
(* ****** ****** *)
//
extern
fun
lcd_print_row1
  (lcd, pos: intGte(0)): int
//
implement
lcd_print_row1
  (lcd, pos) = let
//
val p0 = string2ptr(g_str_message)
//
var i0: int = pos
fun{}
i0_get () = $UN.ptr0_get<int> (addr@i0)
fun{}
i0_set (i: int) = $UN.ptr0_set<int> (addr@i0, i)
fun{}
getc(): char = let
  val i = i0_get()
in
//
if
i < LCD_WIDTH
then
(
  i0_set (i+1); ' '
) (* end of [then] *)
else let
  val c =
  $UN.ptr0_get_at<char> (p0, i-LCD_WIDTH)
in
  if isneqz(c) then (i0_set (i+1); c) else ' '
end // end of [else]
//
end // end of [getc]
//
implement
myprint_one<> () =
(
  ignoret(lcd.write($UN.cast{natLt(256)}(getc())))
) (* end of [myprint_one] *)
//
val () = myprint_many (LCD_WIDTH)
//
in
  i0 - (pos)
end // end of [lcd_print_row1]
//
(* ****** ****** *)

#define NDELAY 250

(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () = ()
//
(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
and loop2 (lcd, pos: intGte(0)): void = "mac#"
//
%{$
void
loop ()
{
  LiquidCrystal
  lcd(8, 13, 9, 4, 5, 6, 7);
  lcd.begin(16, 2); loop2(&lcd, 0); return;
}
%} // end of [%{$]
//
(* ****** ****** *)

implement
loop2 (lcd, pos) = let
//
val () = lcd_print_row0 (lcd)
val n1 = lcd_print_row1 (lcd, 0)
val () = delay (NDELAY)
//
in
  if n1 > 0 then loop2 (lcd, pos + 1) else loop2 (lcd, 0)
end // end of [loop2]

(* ****** ****** *)

(* end of [ATSgreet.dats] *)

(*
** HX-2014-11-09:
** This is adapted from
** some code by Kiwamu Okabe
** See:
** https://raw.githubusercontent.com/fpiot/arduino-ats/master/demo/lcd_ats/DATS/main.dats
*)

(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$ARDUINO}/staloadall.hats"
//
staload
"{$ARDUINO}/SATS/LiquidCrystal/LiquidCrystal.sats"
//
typedef lcd = LiquidCrystal_ptr
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

#define LCD_WIDTH 16

(* ****** ****** *)

val g_str_atsrun = "<ATS running!>"
val g_str_message = "\
ATS is a statically typed programming language that \
unifies implementation with formal specification. It \
is equipped with a highly expressive type system rooted \
in the framework Applied Type System, which gives the \
language its name. In particular, both dependent types \
and linear types are available in ATS.\
" // end of [g_str_message]

(* ****** ****** *)
//
extern
fun{}
myprint_one (): void
extern
fun{}
myprint_many (n: intGte(0)): void
//
implement
{}(*tmp*)
myprint_many
  (n) = let
in
  if n > 0 then (myprint_one(); myprint_many(n-1))
end // end of [myprint_many]
//
(* ****** ****** *)
//
extern
fun{}
myprint_char (char): void
extern
fun{}
myprint_string (str: string): void
//
implement
{}(*tmp*)
myprint_string
  (str) = let
//
fun
loop
(
  p: ptr
) : void = let
  val c = $UN.ptr0_get<char> (p)
in
  if isneqz(c) then (myprint_char(c); loop(ptr0_succ<char>(p)))
end // end of [loop]
//
in
  loop (string2ptr(str))
end // end of [myprint_string]
//
(* ****** ****** *)
//
extern
fun
lcd_print_row0 (lcd): void
//
implement
lcd_print_row0 (lcd) = let
//
val str = g_str_atsrun
val len = length (str)
val margin = half(LCD_WIDTH - sz2i(len))
val () = lcd.setCursor(0, margin)
//
implement
myprint_char<> (c) =
(
  ignoret(lcd.write($UN.cast{natLt(256)}(c)))
) (* end of [myprint_char] *)
//
in
  myprint_string (str)
end // end of [lcd_print_row0]
//
(* ****** ****** *)
//
extern
fun
lcd_print_row1
  (lcd, pos: intGte(0)): int
//
implement
lcd_print_row1
  (lcd, pos) = let
//
val p0 = string2ptr(g_str_message)
//
var i0: int = pos
fun{}
i0_get () = $UN.ptr0_get<int> (addr@i0)
fun{}
i0_set (i: int) = $UN.ptr0_set<int> (addr@i0, i)
fun{}
getc(): char = let
  val i = i0_get()
in
//
if
i < LCD_WIDTH
then
(
  i0_set (i+1); ' '
) (* end of [then] *)
else let
  val c =
  $UN.ptr0_get_at<char> (p0, i-LCD_WIDTH)
in
  if isneqz(c) then (i0_set (i+1); c) else ' '
end // end of [else]
//
end // end of [getc]
//
implement
myprint_one<> () =
(
  ignoret(lcd.write($UN.cast{natLt(256)}(getc())))
) (* end of [myprint_one] *)
//
val () = myprint_many (LCD_WIDTH)
//
in
  i0 - (pos)
end // end of [lcd_print_row1]
//
(* ****** ****** *)

#define NDELAY 250

(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () = ()
//
(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
and loop2 (lcd, pos: intGte(0)): void = "mac#"
//
%{$
void
loop ()
{
  LiquidCrystal lcd(8, 13, 9, 4, 5, 6, 7); loop2(&lcd, 0); return;
}
%} // end of [%{$]
//
(* ****** ****** *)

implement
loop2 (lcd, pos) = let
//
val () = lcd_print_row0 (lcd)
val n1 = lcd_print_row1 (lcd, 0)
val () = delay (NDELAY)
//
in
  if n1 > 0 then loop2 (lcd, pos + 1) else loop2 (lcd, 0)
end // end of [loop2]

(* ****** ****** *)

(* end of [ATSgreet.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
**
** HX-2014-09-14:
** [weboxy] is a small package that
** does webpage layout by generating CSS;
** it also generats HTML for reviewing purpose
**
*)

(* ****** ****** *)
//
%{#
//
#ifdef CHARPTR
#define CHARPTR
typedef char *charptr ;
#endif // #ifndef
//
%} ; // end of [%{#]
//
abstype charptr = $extype"charptr"
//
(* ****** ****** *)

abstype webox_type = ptr
typedef webox = webox_type
typedef weboxlst = List (webox)
typedef weboxopt = Option (webox)

(* ****** ****** *)

typedef color = string

(* ****** ****** *)

fun randcolor ((*void*)): color
fun randcolor_initize ((*void*)): void

(* ****** ****** *)

datatype
tabstyle =
  | TSnone of () | TShbox of () | TSvbox of ()
// end of [tabstyle]

(* ****** ****** *)
//
fun tabstyle_isbox (ts: tabstyle): bool
fun tabstyle_ishbox (ts: tabstyle): bool
fun tabstyle_isvbox (ts: tabstyle): bool
//
overload .isbox with tabstyle_isbox
overload .ishbox with tabstyle_ishbox
overload .isvbox with tabstyle_isvbox
//
(* ****** ****** *)
//
#define UID "uid"
#define NAME "name"
//
#define WIDTH "width"
#define PWIDTH "pwidth"
//
#define HEIGHT "height"
#define PHEIGHT "pheight"
//
#define COLOR "color"
#define BGCOLOR "bgcolor"
//
#define PARENT "parent"
#define CHILDREN "children"
//
#define TABSTYLE "tabstyle"
#define PERCENTLST "percentlst"
//
#define CONTENT "content"
//
(* ****** ****** *)
//
// HX-2014-09-13:
// uid: unique indentification
//
fun{}
webox_get_uid (webox): int
//
// HX-2014-09-13:
// name: name given by the user
//
fun{}
webox_get_name (webox): string
//
overload .uid with webox_get_uid
overload .name with webox_get_name
//
(* ****** ****** *)
//
fun{}
webox_get_width (webox): int
fun{}
webox_set_width (webox, width: int): void
//
overload .width with webox_get_width
overload .width with webox_set_width
//
(* ****** ****** *)
//
// HX: p...: percentage
//
fun{}
webox_get_pwidth (webox): int
fun{}
webox_set_pwidth (webox, pwidth: int): void
//
overload .pwidth with webox_get_pwidth
overload .pwidth with webox_set_pwidth
//
(* ****** ****** *)
//
fun{}
webox_get_height (webox): int
fun{}
webox_set_height (webox, height: int): void
//
overload .height with webox_get_height
overload .height with webox_set_height
//
(* ****** ****** *)
//
// HX: p...: percentage
//
fun{}
webox_get_pheight (webox): int
fun{}
webox_set_pheight (webox, pheight: int): void
//
overload .pheight with webox_get_pheight
overload .pheight with webox_set_pheight
//
(* ****** ****** *)
//
fun{}
webox_get_color (webox): color
fun{}
webox_set_color (webox, c: color): void
//
overload .color with webox_get_color
overload .color with webox_set_color
//
(* ****** ****** *)
//
fun{}
webox_get_bgcolor (webox): color
fun{}
webox_set_bgcolor (webox, c: color): void
//
overload .bgcolor with webox_get_bgcolor
overload .bgcolor with webox_set_bgcolor
//
(* ****** ****** *)
//
fun{}
webox_isrt (x: webox): bool
fun{}
webox_get_parent (webox): weboxopt
fun{}
webox_set_parent (webox, opt: weboxopt): void
//
overload .isrt with webox_isrt
overload .parent with webox_get_parent
overload .parent with webox_set_parent
//
(* ****** ****** *)
//
fun{}
webox_get_children (webox): weboxlst
fun{}
webox_set_children (webox, xs: weboxlst): void
fun{}
webox_set_children_1 (webox, x: webox): void
fun{}
webox_set_children_2 (webox, x1: webox, x2: webox): void
fun{}
webox_set_children_3 (webox, x1: webox, x2: webox, x3: webox): void
//
overload .children with webox_get_children
overload .children with webox_set_children
overload .children with webox_set_children_1
overload .children with webox_set_children_3
overload .children with webox_set_children_2
//
(* ****** ****** *)
//
fun{}
webox_get_tabstyle (webox): tabstyle
fun{}
webox_set_tabstyle (webox, sty: tabstyle): void
//
overload .tabstyle with webox_get_tabstyle
overload .tabstyle with webox_set_tabstyle
//
(* ****** ****** *)
//
fun{}
webox_get_percentlst (webox): List0(int)
fun{}
webox_set_percentlst (webox, pcs: List(int)): void
//
overload .percentlst with webox_get_percentlst
overload .percentlst with webox_set_percentlst
//
(* ****** ****** *)
//
fun{}
percentlst_get_at (pcs: List0(int), i: intGte(0)): int
//
(* ****** ****** *)
//
fun{}
webox_get_content (webox): string
fun{}
webox_set_content (webox, content: string): void
//
overload .content with webox_get_content
overload .content with webox_set_content
//
(* ****** ****** *)
//
fun
webox0_make ((*void*)): webox
//
fun{}
webox_make ((*void*)): webox
fun{}
webox_make_name (name: string): webox
fun{}
webox_make_name_width (name: string, width: int): webox
fun{}
webox_make_name_pwidth (name: string, pwidth: int): webox
//
(* ****** ****** *)

fun{}
fprint_webox_width (out: FILEref, wbx: webox): void

(* ****** ****** *)

fun{}
fprint_webox_height (out: FILEref, wbx: webox): void

(* ****** ****** *)

fun{}
fprint_webox_color (out: FILEref, wbx: webox): void
fun{}
fprint_webox_bgcolor (out: FILEref, wbx: webox): void

(* ****** ****** *)

fun{}
fprint_css_preamble (out: FILEref): void
fun{}
fprint_css_postamble (out: FILEref): void

(* ****** ****** *)

fun{}
fprint_webox_css_one (out: FILEref, webox): void
fun{}
fprint_webox_css_all (out: FILEref, webox): void
fun{}
fprint_weboxlst_css_all (out: FILEref, weboxlst): void

(* ****** ****** *)

fun{}
fprint_webox_head_beg (out: FILEref): void
fun{}
fprint_webox_head_end (out: FILEref): void

(* ****** ****** *)

fun{}
fprint_webox_body_end (out: FILEref): void
fun{}
fprint_webox_body_after (out: FILEref): void

(* ****** ****** *)

fun{}
fprint_webox_html_all (out: FILEref, webox): void

(* ****** ****** *)

(* end of [weboxy.sats] *)

(*
**
** HX-2014-09-14:
** [weboxy] is a small package that
** does webpage layout by generating CSS;
** it also generats HTML for reviewing purpose
**
*)

(* ****** ****** *)

%{#
typedef char *charptr ;
%} ;
abstype charptr = $extype"charptr"

(* ****** ****** *)

abstype webox_type = ptr
typedef webox = webox_type
typedef weboxlst = List (webox)
typedef weboxopt = Option (webox)

(* ****** ****** *)

typedef color = string

(* ****** ****** *)

fun randcolor ((*void*)): color
fun randcolor_initize ((*void*)): void

(* ****** ****** *)

datatype
tabstyle =
  | TSnone of () | TShbox of () | TSvbox of ()
// end of [tabstyle]

(* ****** ****** *)
//
fun tabstyle_isbox (ts: tabstyle): bool
fun tabstyle_ishbox (ts: tabstyle): bool
fun tabstyle_isvbox (ts: tabstyle): bool
//
overload .isbox with tabstyle_isbox
overload .ishbox with tabstyle_ishbox
overload .isvbox with tabstyle_isvbox
//
(* ****** ****** *)
//
#define UID "uid"
#define NAME "name"
//
#define WIDTH "width"
#define PWIDTH "pwidth"
//
#define HEIGHT "height"
#define PHEIGHT "pheight"
//
#define COLOR "color"
#define BGCOLOR "bgcolor"
//
#define PARENT "parent"
#define CHILDREN "children"
//
#define TABSTYLE "tabstyle"
#define PERCENTLST "percentlst"
//
#define CONTENT "content"
//
(* ****** ****** *)
//
// HX-2014-09-13:
// uid: unique indentification
//
fun{}
webox_get_uid (webox): int
//
// HX-2014-09-13:
// name: name given by the user
//
fun{}
webox_get_name (webox): string
//
overload .uid with webox_get_uid
overload .name with webox_get_name
//
(* ****** ****** *)
//
fun{}
webox_get_width (webox): int
fun{}
webox_set_width (webox, width: int): void
//
overload .width with webox_get_width
overload .width with webox_set_width
//
(* ****** ****** *)
//
// HX: p...: percentage
//
fun{}
webox_get_pwidth (webox): int
fun{}
webox_set_pwidth (webox, pwidth: int): void
//
overload .pwidth with webox_get_pwidth
overload .pwidth with webox_set_pwidth
//
(* ****** ****** *)
//
fun{}
webox_get_height (webox): int
fun{}
webox_set_height (webox, height: int): void
//
overload .height with webox_get_height
overload .height with webox_set_height
//
(* ****** ****** *)
//
// HX: p...: percentage
//
fun{}
webox_get_pheight (webox): int
fun{}
webox_set_pheight (webox, pheight: int): void
//
overload .pheight with webox_get_pheight
overload .pheight with webox_set_pheight
//
(* ****** ****** *)
//
fun{}
webox_get_color (webox): color
fun{}
webox_set_color (webox, c: color): void
//
overload .color with webox_get_color
overload .color with webox_set_color
//
(* ****** ****** *)
//
fun{}
webox_get_bgcolor (webox): color
fun{}
webox_set_bgcolor (webox, c: color): void
//
overload .bgcolor with webox_get_bgcolor
overload .bgcolor with webox_set_bgcolor
//
(* ****** ****** *)
//
fun{}
webox_isrt (x: webox): bool
fun{}
webox_get_parent (webox): weboxopt
fun{}
webox_set_parent (webox, opt: weboxopt): void
//
overload .isrt with webox_isrt
overload .parent with webox_get_parent
overload .parent with webox_set_parent
//
(* ****** ****** *)
//
fun{}
webox_get_children (webox): weboxlst
fun{}
webox_set_children (webox, xs: weboxlst): void
fun{}
webox_set_children_1 (webox, x: webox): void
fun{}
webox_set_children_2 (webox, x1: webox, x2: webox): void
fun{}
webox_set_children_3 (webox, x1: webox, x2: webox, x3: webox): void
//
overload .children with webox_get_children
overload .children with webox_set_children
overload .children with webox_set_children_1
overload .children with webox_set_children_3
overload .children with webox_set_children_2
//
(* ****** ****** *)
//
fun{}
webox_get_tabstyle (webox): tabstyle
fun{}
webox_set_tabstyle (webox, sty: tabstyle): void
//
overload .tabstyle with webox_get_tabstyle
overload .tabstyle with webox_set_tabstyle
//
(* ****** ****** *)
//
fun{}
webox_get_percentlst (webox): List0(int)
fun{}
webox_set_percentlst (webox, pcs: List(int)): void
//
overload .percentlst with webox_get_percentlst
overload .percentlst with webox_set_percentlst
//
(* ****** ****** *)
//
fun{}
percentlst_get_at (pcs: List0(int), i: intGte(0)): int
//
(* ****** ****** *)
//
fun{}
webox_get_content (webox): string
fun{}
webox_set_content (webox, content: string): void
//
overload .content with webox_get_content
overload .content with webox_set_content
//
(* ****** ****** *)
//
fun
webox0_make ((*void*)): webox
//
fun{}
webox_make ((*void*)): webox
fun{}
webox_make_name (name: string): webox
fun{}
webox_make_name_width (name: string, width: int): webox
fun{}
webox_make_name_pwidth (name: string, pwidth: int): webox
//
(* ****** ****** *)

fun{}
fprint_webox_width (out: FILEref, wbx: webox): void

(* ****** ****** *)

fun{}
fprint_webox_height (out: FILEref, wbx: webox): void

(* ****** ****** *)

fun{}
fprint_webox_color (out: FILEref, wbx: webox): void
fun{}
fprint_webox_bgcolor (out: FILEref, wbx: webox): void

(* ****** ****** *)

fun{}
fprint_css_preamble (out: FILEref): void
fun{}
fprint_css_postamble (out: FILEref): void

(* ****** ****** *)

fun{}
fprint_webox_css_one (out: FILEref, webox): void
fun{}
fprint_webox_css_all (out: FILEref, webox): void
fun{}
fprint_weboxlst_css_all (out: FILEref, weboxlst): void

(* ****** ****** *)

fun{}
fprint_webox_head_beg (out: FILEref): void
fun{}
fprint_webox_head_end (out: FILEref): void

(* ****** ****** *)

fun{}
fprint_webox_body_end (out: FILEref): void
fun{}
fprint_webox_body_after (out: FILEref): void

(* ****** ****** *)

fun{}
fprint_webox_html_all (out: FILEref, webox): void

(* ****** ****** *)

(* end of [weboxy.sats] *)


Updating: minorly improving

Updating: minorly improving

(*
** HX-2014-11-09:
** This is adapted from
** some code by Kiwamu Okabe
** See:
** https://raw.githubusercontent.com/fpiot/arduino-ats/master/demo/lcd_ats/DATS/main.dats
*)

(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$ARDUINO}/staloadall.hats"
//
staload
"{$ARDUINO}/SATS/LiquidCrystal/LiquidCrystal.sats"
//
typedef lcd = LiquidCrystal_ptr
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

#define LCD_WIDTH 16

(* ****** ****** *)

val g_str_atsrun = "<ATS running!>"
val g_str_message = "\
ATS is a statically typed programming language that \
unifies implementation with formal specification. It \
is equipped with a highly expressive type system rooted \
in the framework Applied Type System, which gives the \
language its name. In particular, both dependent types \
and linear types are available in ATS.\
" // end of [g_str_message]

(* ****** ****** *)
//
extern
fun{}
myprint_one (): void
extern
fun{}
myprint_many (n: intGte(0)): void
//
implement
{}(*tmp*)
myprint_many
  (n) = let
in
  if n > 0 then (myprint_one(); myprint_many(n-1))
end // end of [myprint_many]
//
(* ****** ****** *)
//
extern
fun{}
myprint_char (char): void
extern
fun{}
myprint_string (str: string): void
//
implement
{}(*tmp*)
myprint_string
  (str) = let
//
fun
loop
(
  p: ptr
) : void = let
  val c = $UN.ptr0_get<char> (p)
in
  if isneqz(c) then (myprint_char(c); loop(ptr0_succ<char>(p)))
end // end of [loop]
//
in
  loop (string2ptr(str))
end // end of [myprint_string]
//
(* ****** ****** *)
//
extern
fun
lcd_print_row0 (lcd): void
//
implement
lcd_print_row0 (lcd) = let
//
val str = g_str_atsrun
val len = length (str)
val margin = half(LCD_WIDTH - sz2i(len))
val () = lcd.setCursor(0, margin)
//
implement
myprint_char<> (c) =
(
  ignoret(lcd.write($UN.cast{natLt(256)}(c)))
) (* end of [myprint_char] *)
//
in
  myprint_string (str)
end // end of [lcd_print_row0]
//
(* ****** ****** *)
//
extern
fun
lcd_print_row1
  (lcd, pos: intGte(0)): int
//
implement
lcd_print_row1
  (lcd, pos) = let
//
val p0 = string2ptr(g_str_message)
//
var i0: int = pos
fun{}
i0_get () = $UN.ptr0_get<int> (addr@i0)
fun{}
i0_set (i: int) = $UN.ptr0_set<int> (addr@i0, i)
fun{}
getc(): char = let
  val i = i0_get()
in
//
if
i < LCD_WIDTH
then
(
  i0_set (i+1); ' '
) (* end of [then] *)
else let
  val c =
  $UN.ptr0_get_at<char> (p0, i-LCD_WIDTH)
in
  if isneqz(c) then (i0_set (i+1); c) else ' '
end // end of [else]
//
end // end of [getc]
//
implement
myprint_one<> () =
(
  ignoret(lcd.write($UN.cast{natLt(256)}(getc())))
) (* end of [myprint_one] *)
//
val () = myprint_many (LCD_WIDTH)
//
in
  i0 - (pos)
end // end of [lcd_print_row1]
//
(* ****** ****** *)

#define NDELAY 250

(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () = ()
//
(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
and loop2 (lcd, pos: intGte(0)): void = "mac#"
//
%{$
void
loop ()
{
  LiquidCrystal lcd(8, 13, 9, 4, 5, 6, 7); loop2(&lcd, 0); return;
}
%} // end of [%{$]
//
(* ****** ****** *)

implement
loop2 (lcd, pos) = let
//
val () = lcd_print_row0 (lcd)
val n1 = lcd_print_row1 (lcd, 0)
val () = delay (NDELAY)
//
in
  if n1 > 0 then loop2 (lcd, pos + 1) else loop2 (lcd, 0)
end // end of [loop2]

(* ****** ****** *)

(* end of [ATSgreet.dats] *)

(*
** HX-2014-11-09:
** This is adapted from
** some code by Kiwamu Okabe
** See:
** https://raw.githubusercontent.com/fpiot/arduino-ats/master/demo/lcd_ats/DATS/main.dats
*)

(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$ARDUINO}/staloadall.hats"
//
staload
"{$ARDUINO}/SATS/LiquidCrystal/LiquidCrystal.sats"
//
typedef lcd = LiquidCrystal_ptr
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

#define LCD_WIDTH 16

(* ****** ****** *)

val g_str_atsrun = "<ATS running!>"
val g_str_message = "\
ATS is a statically typed programming language that \
unifies implementation with formal specification. It \
is equipped with a highly expressive type system rooted \
in the framework Applied Type System, which gives the \
language its name. In particular, both dependent types \
and linear types are available in ATS.\
" // end of [g_str_message]

(* ****** ****** *)
//
extern
fun{}
myprint_one (): void
extern
fun{}
myprint_many (n: intGte(0)): void
//
implement
{}(*tmp*)
myprint_many
  (n) = let
in
  if n > 0 then (myprint_one(); myprint_many(n-1))
end // end of [myprint_many]
//
(* ****** ****** *)
//
extern
fun{}
myprint_char (char): void
extern
fun{}
myprint_string (str: string): void
//
implement
{}(*tmp*)
myprint_string
  (str) = let
//
fun
loop
(
  p: ptr
) : void = let
  val c = $UN.ptr0_get<char> (p)
in
  if isneqz(c) then (myprint_char(c); loop(ptr0_succ<char>(p)))
end // end of [loop]
//
in
  loop (string2ptr(str))
end // end of [myprint_string]
//
(* ****** ****** *)
//
extern
fun
lcd_print_row0 (lcd): void
//
implement
lcd_print_row0 (lcd) = let
//
val str = g_str_atsrun
val len = length (str)
val margin = half(LCD_WIDTH - sz2i(len))
val () = lcd.setCursor(0, margin)
//
implement
myprint_char<> (c) =
(
  ignoret(lcd.write($UN.cast{natLt(256)}(c)))
) (* end of [myprint_char] *)
//
in
  myprint_string (str)
end // end of [lcd_print_row0]
//
(* ****** ****** *)
//
extern
fun
lcd_print_row1
  (lcd, pos: intGte(0)): int
//
implement
lcd_print_row1
  (lcd, pos) = let
//
val p0 = string2ptr(g_str_message)
//
var i0: int = pos
fun{}
i0_get () = $UN.ptr0_get<int> (addr@i0)
fun{}
i0_set (i: int) = $UN.ptr0_set<int> (addr@i0, i)
fun{}
getc(): char = let
  val i = i0_get()
in
//
if
i < LCD_WIDTH
then
(
  i0_set (i+1); ' '
) (* end of [then] *)
else let
  val c =
  $UN.ptr0_get_at<char> (p0, i-LCD_WIDTH)
in
  if isneqz(c) then (i0_set (i+1); c) else ' '
end // end of [else]
//
end // end of [getc]
//
implement
myprint_one<> () =
(
  ignoret(lcd.write($UN.cast{natLt(256)}(getc())))
) (* end of [myprint_one] *)
//
val () = myprint_many (LCD_WIDTH)
//
in
  i0 - (pos)
end // end of [lcd_print_row1]
//
(* ****** ****** *)

extern
fun lcd_create (): lcd

(* ****** ****** *)

#define NDELAY 250

(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () = ()
//
(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
and loop2 (lcd, pos: intGte(0)): void = "mac#"
//
%{$
void
loop ()
{
  LiquidCrystal lcd(8, 13, 9, 4, 5, 6, 7); loop2(&lcd, 0); return;
}
%} // end of [%{$]
//
(* ****** ****** *)

implement
loop2 (lcd, pos) = let
//
val () = lcd_print_row0 (lcd)
val n1 = lcd_print_row1 (lcd, 0)
val () = delay (NDELAY)
//
in
  if n1 > 0 then loop2 (lcd, pos + 1) else loop2 (lcd, 0)
end // end of [loop2]

(* ****** ****** *)

(* end of [ATSgreet.dats] *)


Updating: adding a tail-recursive implementation for P2

(*
** Project Euler: P2
** See https://projecteuler.net
*)

(* ****** ****** *)
//
// HX-2015-02-01:
// Please note that
// the solution is
// verified and tail-recursive
//
(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: February 1, 2015
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/PEULER/SATS/peuler.sats"
//
(* ****** ****** *)
//
(*
staload
"{$LIBATSHWXI}/PEULER/PROJECT/P2/P2.sats"
*)
staload "./P2.sats"
//
(* ****** ****** *)
//
dataprop
FIB_(int(*n*), int(*r*)) =
| FIB_rule0 (0, 0)
| FIB_rule1 (1, 1)
| {n:nat}{r0,r1:int}
  FIB_rule2 (n+2, r0+r1) of (FIB_(n, r0), FIB_(n+1, r1))
//
(* ****** ****** *)

assume FIB(n:int, r:int) = FIB_(n, r)

(* ****** ****** *)
//
extern
praxi
FIB_isfun{n:nat}{r1,r2:int}
  (FIB(n, r1), FIB(n, r2)): [r1==r2] void
//
extern
praxi
MYSUM_istot{n:pos}(): [t:int] MYSUM(n, t)
//
(* ****** ****** *)
//
extern
praxi
MYSUM_un_rule0
  {n:nat}
  {r:int | r > LIMIT}
  {t:int}(pf1: FIB(n, r), pf2: MYSUM(n, t)): [t==0] void
//
extern
praxi
MYSUM_un_rule1
  {n:nat}
  {r:int | r <= LIMIT; r mod 2 > 0}
  {t:int}(pf1: FIB(n, r), pf2: MYSUM(n, t)): MYSUM(n+1, t)
extern
praxi
MYSUM_un_rule2
  {n:nat}
  {r:int | r <= LIMIT; r mod 2 == 0}
  {t:int}(pf1: FIB(n, r), pf2: MYSUM(n, t)): MYSUM(n+1, t-r)
//
(* ****** ****** *)

implement
mysum((*void*)) = let
//
prval
[t0:int]
pfres = MYSUM_istot{1}()
//
fun
loop
{n:pos}
{r0,r1:nat}
{res:int}
(
  pf0: FIB(n, r0)
, pf1: FIB(n-1, r1)
, pf2: MYSUM(n, t0-res)
| n: int(n), r0: int(r0), r1: int(r1), res: int(res)
) : int(t0) =
(
if
r0 > LIMIT
then let
  prval () = MYSUM_un_rule0 (pf0, pf2) in res
end // end of [then]
else let
  val
  (
    pf_divmod | k0
  ) = nmod2_g1int_int1(r0, 2)
  prval () =
    divmod_mul_elim (pf_divmod)
  // end of [prval]
in
  if k0 > 0
    then let
      prval pf2 = MYSUM_un_rule1 (pf0, pf2)
    in
      loop (FIB_rule2(pf1, pf0), pf0, pf2 | n+1, r0+r1, r0, res)
    end // end of [then]
    else let
      prval pf2 = MYSUM_un_rule2 (pf0, pf2)
    in
      loop (FIB_rule2(pf1, pf0), pf0, pf2 | n+1, r0+r1, r0, res+r0)
    end // end of [else]
  // end of [if]
end // end of [else]
)
//
in
  (pfres | loop (FIB_rule1(), FIB_rule0(), pfres | 1, 1, 0, 0))
end // end of [mysum]

(* ****** ****** *)

implement
main0 () =
{
//
val (pf | ans) = mysum()
val () =
(
  println! ("The sum of all the even fibs < ", LIMIT, " equals ", ans)
) (* end of [val] *)
} (* end of [main0] *)

(* ****** ****** *)

(* end of [P2-hwxi.dats] *)

(*
** Project Euler: P2
** See https://projecteuler.net
*)

(* ****** ****** *)
//
// HX-2015-02-01:
// Please note that
// the solution is
// verified and tail-recursive
//
(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: February 1, 2015
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/PEULER/SATS/peuler.sats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/PEULER/PROJECT/P2/P2.sats"
//
(* ****** ****** *)
//
dataprop
FIB_(int(*n*), int(*r*)) =
| FIB_rule0 (0, 0)
| FIB_rule1 (1, 1)
| {n:nat}{r0,r1:int}
  FIB_rule2 (n+2, r0+r1) of (FIB_(n, r0), FIB_(n+1, r1))
//
(* ****** ****** *)

assume FIB(n:int, r:int) = FIB_(n, r)

(* ****** ****** *)
//
extern
praxi
FIB_isfun{n:nat}{r1,r2:int}
  (FIB(n, r1), FIB(n, r2)): [r1==r2] void
//
extern
praxi
MYSUM_istot{n:pos}(): [t:int] MYSUM(n, t)
//
(* ****** ****** *)
//
extern
praxi
MYSUM_un_rule0
  {n:nat}
  {r:int | r > LIMIT}
  {t:int}(pf1: FIB(n, r), pf2: MYSUM(n, t)): [t==0] void
//
extern
praxi
MYSUM_un_rule1
  {n:nat}
  {r:int | r <= LIMIT; r mod 2 > 0}
  {t:int}(pf1: FIB(n, r), pf2: MYSUM(n, t)): MYSUM(n+1, t)
extern
praxi
MYSUM_un_rule2
  {n:nat}
  {r:int | r <= LIMIT; r mod 2 == 0}
  {t:int}(pf1: FIB(n, r), pf2: MYSUM(n, t)): MYSUM(n+1, t-r)
//
(* ****** ****** *)

implement
mysum((*void*)) = let
//
prval
[t0:int]
pfres = MYSUM_istot{1}()
//
fun
loop
{n:pos}
{r0,r1:nat}
{res:int}
(
  pf0: FIB(n, r0)
, pf1: FIB(n-1, r1)
, pf2: MYSUM(n, t0-res)
| n: int(n), r0: int(r0), r1: int(r1), res: int(res)
) : int(t0) =
(
if
r0 > LIMIT
then let
  prval () = MYSUM_un_rule0 (pf0, pf2) in res
end // end of [then]
else let
  val k0 = r0-2*half(r0)
in
  if k0 > 0
    then let
      prval pf2 = MYSUM_un_rule1 (pf0, pf2)
    in
      loop (FIB_rule2(pf1, pf0), pf0, pf2 | n+1, r0+r1, r0, res)
    end // end of [then]
    else let
      prval pf2 = MYSUM_un_rule2 (pf0, pf2)
    in
      loop (FIB_rule2(pf1, pf0), pf0, pf2 | n+1, r0+r1, r0, res+r0)
    end // end of [else]
  // end of [if]
end // end of [else]
)
//
in
  (pfres | loop (FIB_rule1(), FIB_rule0(), pfres | 1, 1, 0, 0))
end // end of [mysum]

(* ****** ****** *)

implement
main0 () =
{
//
val (pf | ans) = mysum()
val () =
(
  println! ("The sum of all the even fibs < ", LIMIT, " equals ", ans)
) (* end of [val] *)
} (* end of [main0] *)

(* ****** ****** *)

(* end of [P2-hwxi.dats] *)


Updating: scratching a bit

Updating: scratching a bit

(* ****** ****** *)
//
// HX-2014-12-23:
// For the purpose of
// studying session types
//
(* ****** ****** *)

(*
client: send(string) -> send(int) -> recv(int)
server: recv(string) -> recv(int) -> send(int)
*)

(* ****** ****** *)

typedef str = string

(* ****** ****** *)
//
absview send_v (a:t@ype)
absview recv_v (a:t@ype)
//
(* ****** ****** *)

stadef nil = unit_v
stadef :: (a:view, b:view) = (a, b)

(* ****** ****** *)

extern
fun{a:t@ype}
send{ps:view}
  (pf: !send_v(a) :: ps >> ps | x: a): void
extern
fun{a:t@ype}
recv{ps:view}
  (pf: !recv_v(a) :: ps >> ps | (*void*)): a

(* ****** ****** *)
//
viewdef
client_v = send_v(str) :: send_v(int) :: recv_v(int) :: nil
viewdef
server_v = recv_v(str) :: recv_v(int) :: send_v(int) :: nil
//
(* ****** ****** *)
//
extern
fun
client
  (pf: client_v | (*void*)): void
//
implement
client
(
  pf | (*void*)
) =
{
  val () = send (pf | "candy")
  val () = send (pf | 1357902468)
  val receipt = recv (pf | (*void*))
  prval () = unit_v_elim (pf)
}
//
(* ****** ****** *)
//
extern
fun
server
  (pf: server_v | (*void*)) : void
//
implement
server
(
  pf | (*void*)
) =
{
  val name = recv (pf | (*void*))
  val number = recv (pf | (*void*))
  val ((*void*)) = send (pf | 12345)
  prval () = unit_v_elim (pf)
}
//
(* ****** ****** *)

(* end of [scratch02.dats] *)

(* ****** ****** *)
//
// HX-2014-12-23:
// For the purpose of
// studying session types
//
(* ****** ****** *)

(*
client: send(string) -> send(int) -> recv(int)
server: recv(string) -> recv(int) -> send(int)
*)

(* ****** ****** *)

typedef str = string

(* ****** ****** *)
//
dataview
send_v (a:t@ype) = SEND of ()
//
dataview
recv_v (a:t@ype) = RECV of ()
//
(* ****** ****** *)

stadef nil = unit_v
stadef :: (a:view, b:view) = (a, b)

(* ****** ****** *)

extern
fun{a:t@ype}
send{ps:view}
  (pf: !send_v(a) :: ps >> ps | x: a): void
extern
fun{a:t@ype}
recv{ps:view}
  (pf: !recv_v(a) :: ps >> ps | (*void*)): a

(* ****** ****** *)
//
viewdef
client_v = send_v(str) :: send_v(int) :: recv_v(int) :: nil
viewdef
server_v = recv_v(str) :: recv_v(int) :: send_v(int) :: nil
//
(* ****** ****** *)
//
extern
fun
client
  (pf: client_v | (*void*)): void
//
implement
client
(
  pf | (*void*)
) =
{
  val () = send (pf | "candy")
  val () = send (pf | 1357902468)
  val receipt = recv (pf | (*void*))
  prval () = unit_v_elim (pf)
}
//
(* ****** ****** *)
//
extern
fun
server
  (pf: server_v | (*void*)) : void
//
implement
server
(
  pf | (*void*)
) =
{
  val name = recv (pf | (*void*))
  val number = recv (pf | (*void*))
  val ((*void*)) = send (pf | 12345)
  prval () = unit_v_elim (pf)
}
//
(* ****** ****** *)

(* end of [scratch02.dats] *)


Updating: very minorly tidying-up

Updating: very minorly tidying-up

(**
  Will Blair

  October 2014
*)

(* ****** ****** *)

%{#
#include "libats-/wdblair/python/CATS/Python.cats"
%} // end of [%{#]

(* ****** ****** *)

abstype PyObject = ptr

fun Py_SetProgramName (string): void = "mac#"

(* ****** ****** *)

macdef Py_file_input = $extval(int, "Py_file_input")

(* ****** ****** *)

fun Py_Initialize (): void = "mac#"

(**
  1 - load signal handlers
  0 - don't

  This is good for when you want to embed python and
  not worry about it initializing extra things like its
  signal handlers.
*)
fun Py_InitializeEx (int): void = "mac#"

fun Py_Finalize (): void = "mac#"

(* ****** ****** *)

fun Py_InitModule (string, ptr): PyObject = "mac#"

(* ****** ****** *)

fun PyImport_Import (PyObject): PyObject = "mac#"
fun PyImport_ImportModule (string): PyObject = "mac#"
fun PyImport_AddModule (string): PyObject = "mac#"

(* ****** ****** *)

fun PyModule_GetDict (PyObject): PyObject = "mac#"

(* ****** ****** *)

fun PyRun_SimpleString (string): PyObject = "mac#"

fun PyRun_File (
  FILEref, string, int, PyObject, PyObject
): PyObject = "mac#"

(* ****** ****** *)

fun PyDict_New (): PyObject = "mac#"

fun PyDict_GetItem (PyObject, PyObject): PyObject = "mac#"

fun PyDict_GetItemString (PyObject, string): PyObject = "mac#"
fun PyDict_SetItemString (PyObject, string, PyObject): PyObject = "mac#"

fun PyDict_Keys (PyObject): PyObject = "mac#"
fun PyDict_Items (PyObject): PyObject = "mac#"

fun PyDict_Copy (PyObject): PyObject = "mac#"

(* ****** ****** *)

fun PyList_Size (PyObject): ssize_t = "mac#"
fun PyList_GetItem (PyObject, ssize_t): PyObject = "mac#"

(* ****** ****** *)

fun PyTuple_New (ssize_t): PyObject = "mac#"
fun PyTuple_SetItem (PyObject, ssize_t, PyObject): int = "mac#"
fun PyTuple_GetItem (PyObject, ssize_t): PyObject = "mac#"

(* ****** ****** *)

fun PyObject_GetAttrString (PyObject, string): PyObject = "mac#"
fun PyObject_SetAttrString (PyObject, string, PyObject): int = "mac#"

fun PyObject_CallObject (PyObject, PyObject): PyObject = "mac#"

fun PyObject_Str (PyObject): PyObject = "mac#"

fun PyObject_IsInstance (PyObject, PyObject): int = "mac#"

(* ****** ****** *)

fun PyLong_FromVoidPtr (ptr): PyObject = "mac#"
fun PyLong_AsVoidPtr (PyObject): ptr = "mac#"

(* ****** ****** *)

fun PyString_FromString (string): PyObject = "mac#"
fun PyString_AsString (PyObject): string = "mac#"

(* ****** ****** *)

fun PyErr_Fetch (
  &PyObject? >> PyObject,
  &PyObject? >> PyObject,
  &PyObject? >> PyObject
): void = "mac#"

fun PyErr_NormalizeException (
  &PyObject >> _,
  &PyObject >> _,
  &PyObject >> _
): void = "mac#"

(* ****** ****** *)

macdef Py_None = $extval (PyObject, "Py_None")

(* ****** ****** *)

fun PyFunction_Check (PyObject): bool = "mac#"

(* ****** ****** *)

fun Py_INCREF (PyObject): void = "mac#"
fun Py_DECREF (PyObject): void = "mac#"

(* ****** ****** *)

%{#
#include "contrib/libats-/wdblair/python/CATS/Python.cats"
%}

(**
  Will Blair

  October 2014
*)

abstype PyObject = ptr

fun Py_SetProgramName (string): void = "mac#"

(* ****** ****** *)

macdef Py_file_input = $extval(int, "Py_file_input")

(* ****** ****** *)

fun Py_Initialize (): void = "mac#"

(**
  1 - load signal handlers
  0 - don't

  This is good for when you want to embed python and
  not worry about it initializing extra things like its
  signal handlers.
*)
fun Py_InitializeEx (int): void = "mac#"

fun Py_Finalize (): void = "mac#"

(* ****** ****** *)

fun Py_InitModule (string, ptr): PyObject = "mac#"

(* ****** ****** *)

fun PyImport_Import (PyObject): PyObject = "mac#"
fun PyImport_ImportModule (string): PyObject = "mac#"
fun PyImport_AddModule (string): PyObject = "mac#"

(* ****** ****** *)

fun PyModule_GetDict (PyObject): PyObject = "mac#"

(* ****** ****** *)

fun PyRun_SimpleString (string): PyObject = "mac#"

fun PyRun_File (
  FILEref, string, int, PyObject, PyObject
): PyObject = "mac#"

(* ****** ****** *)

fun PyDict_New (): PyObject = "mac#"

fun PyDict_GetItem (PyObject, PyObject): PyObject = "mac#"

fun PyDict_GetItemString (PyObject, string): PyObject = "mac#"
fun PyDict_SetItemString (PyObject, string, PyObject): PyObject = "mac#"

fun PyDict_Keys (PyObject): PyObject = "mac#"
fun PyDict_Items (PyObject): PyObject = "mac#"

fun PyDict_Copy (PyObject): PyObject = "mac#"

(* ****** ****** *)

fun PyList_Size (PyObject): ssize_t = "mac#"
fun PyList_GetItem (PyObject, ssize_t): PyObject = "mac#"

(* ****** ****** *)

fun PyTuple_New (ssize_t): PyObject = "mac#"
fun PyTuple_SetItem (PyObject, ssize_t, PyObject): int = "mac#"
fun PyTuple_GetItem (PyObject, ssize_t): PyObject = "mac#"

(* ****** ****** *)

fun PyObject_GetAttrString (PyObject, string): PyObject = "mac#"
fun PyObject_SetAttrString (PyObject, string, PyObject): int = "mac#"

fun PyObject_CallObject (PyObject, PyObject): PyObject = "mac#"

fun PyObject_Str (PyObject): PyObject = "mac#"

fun PyObject_IsInstance (PyObject, PyObject): int = "mac#"

(* ****** ****** *)

fun PyLong_FromVoidPtr (ptr): PyObject = "mac#"
fun PyLong_AsVoidPtr (PyObject): ptr = "mac#"

(* ****** ****** *)

fun PyString_FromString (string): PyObject = "mac#"
fun PyString_AsString (PyObject): string = "mac#"

(* ****** ****** *)

fun PyErr_Fetch (
  &PyObject? >> PyObject,
  &PyObject? >> PyObject,
  &PyObject? >> PyObject
): void = "mac#"

fun PyErr_NormalizeException (
  &PyObject >> _,
  &PyObject >> _,
  &PyObject >> _
): void = "mac#"

(* ****** ****** *)

macdef Py_None = $extval (PyObject, "Py_None")

(* ****** ****** *)

fun PyFunction_Check (PyObject): bool = "mac#"

(* ****** ****** *)

fun Py_INCREF (PyObject): void = "mac#"
fun Py_DECREF (PyObject): void = "mac#"

(* ****** ****** *)


Updating: merging

Updating: merging

(*
** CML.channel
*)

(* ****** ****** *)
//
#define
ATS_EXTERN_PREFIX "ats2erlcml_cml_"
//
(* ****** ****** *)

abstype thread_id
typedef tid = thread_id

(* ****** ****** *)
//
abstype
chan_type(a:t@ype)
//
typedef
chan(a:t@ype) = chan_type(a)
//
(* ****** ****** *)
//
abstype
event_type(a:t@ype)
//
typedef
event(a:t@ype) = event_type(a)
//
(* ****** ****** *)
//
fun spawn
  (f: () -<cloref1> void): thread_id = "mac#%"
//
fun
spawnc{a:t@ype}
  (f: (a) -<cloref1> void, env: a): thread_id = "mac#%"
//
(* ****** ****** *)

fun exit : {a:t@ype} ((*void*)) -> a = "mac#%"

(* ****** ****** *)
//
fun
channel{a:t@ype}(): chan(a) = "mac#%"
//
fun recv{a:t@ype} (ch: chan(a)): a = "mac#%"
fun send{a:t@ype} (ch: chan(a), x: a): void = "mac#%"
//
(* ****** ****** *)

(* end of [CML.sats] *)


Updating: very minorly tidying-up

Updating: very minorly tidying-up

(*
** Channels
*)

(* ****** ****** *)
//
staload
UN =
"prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload
"libats/SATS/athread.sats"
//
(* ****** ****** *)
//
absvtype
queue_vtype (a:vt@ype+, int(*id*)) = ptr
//
vtypedef
queue(a:vt0p, id:int) = queue_vtype(a, id)
vtypedef queue(a:vt0p) = [id:int] queue(a, id)
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
queue_make (cap: intGt(0)): queue(a)
//
extern
fun
{a:vt0p}
queue_free_exn (que: queue(a)): void
//
(* ****** ****** *)
//
absprop ISNIL(id:int, b:bool)
absprop ISFUL(id:int, b:bool)
//
extern
fun
{a:vt0p}
queue_isnil{id:int}(!queue(a, id)): [b:bool] (ISNIL(id, b) | bool(b))
extern
fun
{a:vt0p}
queue_isful{id:int}(!queue(a, id)): [b:bool] (ISFUL(id, b) | bool(b))
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
queue_insert
  {id:int}
(
  ISFUL(id, false)
| xs: !queue(a, id) >> queue(a, id2), x: a
) : #[id2:int] void
//
extern
fun
{a:vt0p}
queue_remove
  {id:int}
(
  ISNIL(id, false) | xs: !queue(a, id) >> queue(a, id2)
) : #[id2:int] a // end-of-fun
//
(* ****** ****** *)

local
//
staload
"libats/SATS/deqarray.sats"
//
assume
queue_vtype(a:vt0p, id:int) = deqarray(a)
//
assume ISNIL(id:int, b:bool) = unit_p
assume ISFUL(id:int, b:bool) = unit_p
//
in (* in-of-local *)
//
implement
{a}(*tmp*)
queue_make(cap) =
  deqarray_make_cap(i2sz(cap))
//
implement
{a}(*tmp*)
queue_free_exn(que) = let
//
val () = assertloc(deqarray_is_nil(que))
//
in
  deqarray_free_nil(que)
end // end of [queue_free_exn]
//
implement
{a}(*tmp*)
queue_isnil(xs) = (unit_p() | deqarray_is_nil(xs))
//
implement
{a}(*tmp*)
queue_isful(xs) = (unit_p() | deqarray_is_full(xs))
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
queue_insert
  (pf | xs, x0) =
{
//
prval () =
__assert (pf) where
{
  extern
  praxi
  __assert
    {id:int}
  (
    pf: ISFUL(id, false)
  ) : [false] void
} (* end of [prval] *)
//
val () =
  deqarray_insert_atend<a> (xs, x0)
//
} (* end of [queue_insert] *)
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
queue_remove
  (pf | xs) = let
//
prval () =
__assert (pf) where
{
  extern
  praxi
  __assert
    {id:int}
  (
    pf: ISNIL(id, false)
  ) : [false] void
} (* end of [prval] *)
//
in
  deqarray_takeout_atbeg<a> (xs)
end (* end of [queue_remove] *)
//
end // end of [local]

(* ****** ****** *)
//
absvtype
channel_vtype(a:vt@ype) = ptr
vtypedef
channel(a:vt0p) = channel_vtype(a)
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
channel_make(cap: intGt(0)): channel(a)
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
channel_ref
  (ch: !channel(a)): channel(a)
//
extern
fun
{a:vt0p}
channel_unref(ch: channel(a)): void
//
(* ****** ****** *)

extern
fun{}
channel_rfcnt{a:vt0p}(ch: !channel(a)): intGt(0)

(* ****** ****** *)

extern
fun{a:vt0p}
channel_insert (!channel(a), a): void
extern
fun{a:vt0p}
channel_remove (chan: &channel(a) >> _): (a)

(* ****** ****** *)
//
extern
fun{a:vt0p}
channel_qinsert
  (ch0: !channel(a), chx: channel(a)): void
//
(* ****** ****** *)
//
datavtype
channel_ =
{
l0,l1,l2,l3:agz
} CHANNEL of
@{
  cap=intGt(0)
//
, rfcnt=intGt(0) // by spin
//
, queue=ptr(*deque*) // by mutex
, qnext=ptr(*channel*) // by mutex
//
, spin=spin_vt(l0)
, mutex=mutex_vt(l1)
, CVisnil=condvar_vt(l2)
, CVisful=condvar_vt(l3)
//
} (* end of [channel] *)
//
(* ****** ****** *)

assume
channel_vtype(a:vt0p) = channel_

(* ****** ****** *)

implement
{a}(*tmp*)
channel_make
  (cap) = let
//
extern
praxi __assert(): [l:agz] void
//
prval [l0:addr] () = __assert()
prval [l1:addr] () = __assert()
prval [l2:addr] () = __assert()
prval [l3:addr] () = __assert()
//
val chan = CHANNEL{l0,l1,l2,l3}(_)
//
val+CHANNEL(ch) = chan
//
val () = ch.cap := cap
val () = ch.rfcnt := 1
//
val q0 = queue_make<a>(cap)
val () = ch.queue := $UN.castvwtp0{ptr}(q0)
//
val () = ch.qnext := the_null_ptr
//
local
val x = spin_create_exn()
in(*in-of-local*)
val () = ch.spin := unsafe_spin_t2vt(x)
end // end of [local]
//
local
val x = mutex_create_exn()
in(*in-of-local*)
val () = ch.mutex := unsafe_mutex_t2vt(x)
end // end of [local]
//
local
val x = condvar_create_exn()
in(*in-of-local*)
val () = ch.CVisnil := unsafe_condvar_t2vt(x)
end // end of [local]
//
local
val x = condvar_create_exn()
in(*in-of-local*)
val () = ch.CVisful := unsafe_condvar_t2vt(x)
end // end of [local]
//
in
  fold@(chan); chan
end // end of [channel_make]

(* ****** ****** *)

implement
{a}(*tmp*)
channel_ref
  (chan) = let
//
val@CHANNEL(ch) = chan
//
val spin =
  unsafe_spin_vt2t(ch.spin)
//
val
(pf | ()) = spin_lock (spin)
val () = ch.rfcnt := ch.rfcnt + 1
val ((*void*)) = spin_unlock (pf | spin)
//
prval ((*fold*)) = fold@(chan)
//
in
  $UN.castvwtp1{channel(a)}(chan)
end // end of [channel_ref]

(* ****** ****** *)

implement
{a}(*tmp*)
channel_unref
  (chan) = let
//
val@CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val spin =
  unsafe_spin_vt2t(ch.spin)
//
val
(pf | ()) = spin_lock (spin)
val rfcnt = ch.rfcnt
val ((*void*)) = spin_unlock (pf | spin)
//
in (* in-of-let *)
//
if
rfcnt <= 1
then let
  val que =
    $UN.castvwtp0{queue(a)}(ch.queue)
  // end of [val]
  val qnxt = ch.qnext
//
  val ((*freed*)) = queue_free_exn (que)
  val ((*freed*)) = spin_vt_destroy(ch.spin)
  val ((*freed*)) = mutex_vt_destroy(ch.mutex)
  val ((*freed*)) = condvar_vt_destroy(ch.CVisnil)
  val ((*freed*)) = condvar_vt_destroy(ch.CVisful)
  val ((*freed*)) = free@{l0,l1,l2,l3}(chan)
//
  val ((*freed*)) =
  if qnxt > 0
     then channel_unref($UN.castvwtp0{channel(a)}(qnxt))
  // end of [if]
//
in
  // nothing
end // end of [then]
else let
  val () = ch.rfcnt := rfcnt - 1
  prval ((*fold*)) = fold@(chan)
  prval ((*freed*)) = $UN.cast2void(chan)
in
  // nothing
end // end of [else]
//
end // end of [channel_unref]

(* ****** ****** *)

implement
{}(*tmp*)
channel_rfcnt
  {a}(chan) = let
//
val@CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val rfcnt = ch.rfcnt
//
in
  fold@(chan); rfcnt
end // end of [channel_rfcnt]

(* ****** ****** *)
//
extern
fun{a:vt0p}
channel_insert2
  (!channel(a), queue(a), a): void
//
(* ****** ****** *)

implement
{a}(*tmp*)
channel_insert
  (chan, x0) = let
//
val+CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
val (pfmut | ()) = mutex_lock (mutex)
//
val xs = $UN.castvwtp0{queue(a)}((pfmut | ch.queue))
//
val ((*void*)) = channel_insert2<a> (chan, xs, x0)
//
in
  // nothing
end // end of [channel_insert]

(* ****** ****** *)

implement
{a}(*tmp*)
channel_insert2
  (chan, xs, x0) = let
//
val+CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
val (pf | isful) = queue_isful (xs)
//
in
//
if
isful
then let
  prval
  (pfmut, fpf) =
  __assert () where
  {
    extern
    praxi __assert (): vtakeout0(locked_v(l1))
  } (* end of [prval] *)
  val
  CVisful = unsafe_condvar_vt2t(ch.CVisful)
  val () = condvar_wait (pfmut | CVisful, mutex)
  prval ((*ret*)) = fpf (pfmut)
in
  channel_insert2 (chan, xs, x0)
end // end of [then]
else let
  val
  isnil = queue_isnil (xs)
  val () = queue_insert (pf | xs, x0)
  val () =
  if isnil.1
    then condvar_broadcast(unsafe_condvar_vt2t(ch.CVisnil))
  // end of [if]
  val ((*void*)) =
  mutex_unlock ($UN.castview0{locked_v(l1)}(xs) | mutex)
//
in
  // nothing
end // end of [else]
//
end // end of [channel_insert2]

(* ****** ****** *)
//
extern
fun{a:vt0p}
channel_remove2
  (chan: &channel(a) >> _, queue(a)): (a)
//
(* ****** ****** *)

implement
{a}(*tmp*)
channel_remove
  (chan) = let
//
val+CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
val (pfmut | ()) = mutex_lock (mutex)
//
val xs =
  $UN.castvwtp0{queue(a)}((pfmut | ch.queue))
//
in
  channel_remove2<a> (chan, xs)
end // end of [channel_remove]

(* ****** ****** *)

implement
{a}(*tmp*)
channel_remove2
  (chan, xs) = let
//
val+@CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
macdef
queue_unlock_mac(xs) =
mutex_unlock
  ($UN.castview0{locked_v(l1)}(,(xs)) | mutex)
//
val (pf | isnil) = queue_isnil (xs)
//
in
//
if
isnil
then let
  val qnxt = ch.qnext
in
  if qnxt > 0
    then let
      val () =
      ch.qnext := the_null_ptr
      val () = queue_unlock_mac(xs)
      prval ((*fold*)) = fold@chan
      val () = channel_unref (chan)
      val () =
      chan := $UN.castvwtp0{channel(a)}(qnxt)
    in
      channel_remove (chan)
    end (* end of [then] *)
    else let
      prval
      (pfmut, fpf) =
      __assert () where
      {
        extern
        praxi __assert (): vtakeout0(locked_v(l1))
      } (* end of [prval] *)
      val CVisnil = unsafe_condvar_vt2t(ch.CVisnil)
      val ((*void*)) = condvar_wait (pfmut | CVisnil, mutex)
      prval ((*ret*)) = fpf (pfmut)
      prval ((*fold*)) = fold@chan
    in
      channel_remove2 (chan, xs)
    end // end of [else]
  // end of [if]
end // end of [then]
else let
  val isful = queue_isful (xs)
  val x0_out = queue_remove (pf | xs)
  val () =
  if isful.1
    then condvar_broadcast(unsafe_condvar_vt2t(ch.CVisful))
  // end of [if]
  val () = queue_unlock_mac(xs)
  prval ((*fold*)) = fold@chan
in
  x0_out
end // end of [else]
//
end // end of [channel_remove2]

(* ****** ****** *)
//
extern
fun{a:vt0p}
qnext_insert
  (chx0: &ptr >> _, chx: channel(a)): void
//
extern
fun{a:vt0p}
channel_qinsert2
  (!channel(a), queue(a), channel(a)): void
//
(* ****** ****** *)

implement
{a}(*tmp*)
channel_qinsert
  (chan, chx) = let
//
val+CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
val (pfmut | ()) = mutex_lock (mutex)
//
val xs = $UN.castvwtp0{queue(a)}((pfmut | ch.queue))
//
val ((*void*)) = channel_qinsert2<a> (chan, xs, chx)
//
in
  // nothing
end // end of [channel_qinsert]

(* ****** ****** *)

implement
{a}(*tmp*)
qnext_insert
  (chx0, chx) = let
in
//
if
chx0 = 0
then (
  chx0 := $UN.castvwtp0{ptr}(chx)
) // end of [then]
else let
//
val chan =
$UN.castvwtp0{channel(a)}(chx0)
val ((*void*)) = channel_qinsert (chan, chx)
prval ((*void*)) = $UN.cast2void(chan)
//
in
  // nothing
end // end of [else]
//
end // end of [qnext_insert]

(* ****** ****** *)

implement
{a}(*tmp*)
channel_qinsert2
  (chan, xs, chx) = let
//
val+@CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
val isnil = queue_isnil (xs)
//
val () = qnext_insert (ch.qnext, chx)
//
val () =
if isnil.1
  then condvar_broadcast(unsafe_condvar_vt2t(ch.CVisnil))
// end of [if]
//
prval ((*fold*)) = fold@chan
//
in
  mutex_unlock ($UN.castview0{locked_v(l1)}(xs) | mutex)
end // end of [channel_qinsert2]

(* ****** ****** *)

(* end of [basis_chan.dats] *)

(*
** Channels
*)

(* ****** ****** *)
//
staload
UN =
"prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload
"libats/SATS/athread.sats"
//
(* ****** ****** *)
//
absvtype
queue_vtype (a:vt@ype+, int(*id*)) = ptr
//
vtypedef
queue(a:vt0p, id:int) = queue_vtype(a, id)
vtypedef queue(a:vt0p) = [id:int] queue(a, id)
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
queue_make (cap: intGt(0)): queue(a)
//
extern
fun
{a:vt0p}
queue_free_exn (que: queue(a)): void
//
(* ****** ****** *)
//
absprop ISNIL(id:int, b:bool)
absprop ISFUL(id:int, b:bool)
//
extern
fun
{a:vt0p}
queue_isnil{id:int}(!queue(a, id)): [b:bool] (ISNIL(id, b) | bool(b))
extern
fun
{a:vt0p}
queue_isful{id:int}(!queue(a, id)): [b:bool] (ISFUL(id, b) | bool(b))
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
queue_insert
  {id:int}
(
  ISFUL(id, false)
| xs: !queue(a, id) >> queue(a, id2), x: a
) : #[id2:int] void
//
extern
fun
{a:vt0p}
queue_remove
  {id:int}
(
  ISNIL(id, false) | xs: !queue(a, id) >> queue(a, id2)
) : #[id2:int] a // end-of-fun
//
(* ****** ****** *)

local
//
staload
"libats/SATS/deqarray.sats"
//
assume
queue_vtype(a:vt0p, id:int) = deqarray(a)
//
assume ISNIL(id:int, b:bool) = unit_p
assume ISFUL(id:int, b:bool) = unit_p
//
in (* in-of-local *)
//
implement
{a}(*tmp*)
queue_make(cap) =
  deqarray_make_cap(i2sz(cap))
//
implement
{a}(*tmp*)
queue_free_exn(que) = let
//
val () = assertloc(deqarray_is_nil(que))
//
in
  deqarray_free_nil(que)
end // end of [queue_free_exn]
//
implement
{a}(*tmp*)
queue_isnil(xs) = (unit_p() | deqarray_is_nil(xs))
//
implement
{a}(*tmp*)
queue_isful(xs) = (unit_p() | deqarray_is_full(xs))
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
queue_insert
  (pf | xs, x0) =
{
//
prval () =
__assert (pf) where
{
  extern
  praxi
  __assert
    {id:int}
  (
    pf: ISFUL(id, false)
  ) : [false] void
} (* end of [prval] *)
//
val () =
  deqarray_insert_atend<a> (xs, x0)
//
} (* end of [queue_insert] *)
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
queue_remove
  (pf | xs) = let
//
prval () =
__assert (pf) where
{
  extern
  praxi
  __assert
    {id:int}
  (
    pf: ISNIL(id, false)
  ) : [false] void
} (* end of [prval] *)
//
in
  deqarray_takeout_atbeg<a> (xs)
end (* end of [queue_remove] *)
//
end // end of [local]

(* ****** ****** *)
//
absvtype
channel_vtype(a:vt@ype) = ptr
vtypedef
channel(a:vt0p) = channel_vtype(a)
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
channel_make(cap: intGt(0)): channel(a)
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
channel_ref
  (ch: !channel(a)): channel(a)
//
extern
fun
{a:vt0p}
channel_unref(ch: channel(a)): void
//
(* ****** ****** *)

extern
fun{}
channel_rfcnt{a:vt0p}(ch: !channel(a)): intGt(0)

(* ****** ****** *)

extern
fun{a:vt0p}
channel_insert (!channel(a), a): void
extern
fun{a:vt0p}
channel_remove (chan: &channel(a) >> _): (a)

(* ****** ****** *)
//
extern
fun{a:vt0p}
channel_qinsert
  (ch0: !channel(a), chx: channel(a)): void
//
(* ****** ****** *)
//
datavtype
channel_ =
{
l0,l1,l2,l3:agz
} CHANNEL of
@{
  cap=intGt(0)
//
, rfcnt=intGt(0) // by spin
//
, queue=ptr(*deque*) // by mutex
, qnext=ptr(*channel*) // by mutex
//
, spin=spin_vt(l0)
, mutex=mutex_vt(l1)
, CVisnil=condvar_vt(l2)
, CVisful=condvar_vt(l3)
//
} (* end of [channel] *)
//
(* ****** ****** *)

assume
channel_vtype(a:vt0p) = channel_

(* ****** ****** *)

implement
{a}(*tmp*)
channel_make
  (cap) = let
//
extern
praxi __assert(): [l:agz] void
//
prval [l0:addr] () = __assert()
prval [l1:addr] () = __assert()
prval [l2:addr] () = __assert()
prval [l3:addr] () = __assert()
//
val chan = CHANNEL{l0,l1,l2,l3}(_)
//
val+CHANNEL(ch) = chan
//
val () = ch.cap := cap
val () = ch.rfcnt := 1
//
val q0 = queue_make<a>(cap)
val () = ch.queue := $UN.castvwtp0{ptr}(q0)
//
val () = ch.qnext := the_null_ptr
//
local
val x = spin_create_exn()
in(*in-of-local*)
val () = ch.spin := unsafe_spin_t2vt(x)
end // end of [local]
//
local
val x = mutex_create_exn()
in(*in-of-local*)
val () = ch.mutex := unsafe_mutex_t2vt(x)
end // end of [local]
//
local
val x = condvar_create_exn()
in(*in-of-local*)
val () = ch.CVisnil := unsafe_condvar_t2vt(x)
end // end of [local]
//
local
val x = condvar_create_exn()
in(*in-of-local*)
val () = ch.CVisful := unsafe_condvar_t2vt(x)
end // end of [local]
//
in
  fold@(chan); chan
end // end of [channel_make]

(* ****** ****** *)

implement
{a}(*tmp*)
channel_ref
  (chan) = let
//
val@CHANNEL(ch) = chan
//
val spin =
  unsafe_spin_vt2t(ch.spin)
//
val
(pf | ()) = spin_lock (spin)
val () = ch.rfcnt := ch.rfcnt + 1
val ((*void*)) = spin_unlock (pf | spin)
//
prval ((*fold*)) = fold@(chan)
//
in
  $UN.castvwtp1{channel(a)}(chan)
end // end of [channel_ref]

(* ****** ****** *)

implement
{a}(*tmp*)
channel_unref
  (chan) = let
//
val@CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val spin =
  unsafe_spin_vt2t(ch.spin)
//
val
(pf | ()) = spin_lock (spin)
val rfcnt = ch.rfcnt
val ((*void*)) = spin_unlock (pf | spin)
//
in (* in-of-let *)
//
if
rfcnt <= 1
then let
  val que =
    $UN.castvwtp0{queue(a)}(ch.queue)
  // end of [val]
  val qnxt = ch.qnext
//
  val ((*freed*)) = queue_free_exn (que)
  val ((*freed*)) = spin_vt_destroy(ch.spin)
  val ((*freed*)) = mutex_vt_destroy(ch.mutex)
  val ((*freed*)) = condvar_vt_destroy(ch.CVisnil)
  val ((*freed*)) = condvar_vt_destroy(ch.CVisful)
  val ((*freed*)) = free@{l0,l1,l2,l3}(chan)
//
  val ((*freed*)) =
  if qnxt > 0
     then channel_unref($UN.castvwtp0{channel(a)}(qnxt))
  // end of [if]
//
in
  // nothing
end // end of [then]
else let
  val () = ch.rfcnt := rfcnt - 1
  prval ((*fold*)) = fold@(chan)
  prval ((*freed*)) = $UN.cast2void(chan)
in
  // nothing
end // end of [else]
//
end // end of [channel_unref]

(* ****** ****** *)

implement
{}(*tmp*)
channel_rfcnt
  {a}(chan) = let
//
val@CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val rfcnt = ch.rfcnt
//
in
  fold@(chan); rfcnt
end // end of [channel_rfcnt]

(* ****** ****** *)
//
extern
fun{a:vt0p}
channel_insert2
  (!channel(a), queue(a), a): void
//
(* ****** ****** *)

implement{a}
channel_insert
  (chan, x0) = let
//
val+CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
val (pfmut | ()) = mutex_lock (mutex)
//
val xs = $UN.castvwtp0{queue(a)}((pfmut | ch.queue))
//
val ((*void*)) = channel_insert2<a> (chan, xs, x0)
//
in
  // nothing
end // end of [channel_insert]

(* ****** ****** *)

implement
{a}(*tmp*)
channel_insert2
  (chan, xs, x0) = let
//
val+CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
val (pf | isful) = queue_isful (xs)
//
in
//
if
isful
then let
  prval
  (pfmut, fpf) =
  __assert () where
  {
    extern
    praxi __assert (): vtakeout0(locked_v(l1))
  } (* end of [prval] *)
  val
  CVisful = unsafe_condvar_vt2t(ch.CVisful)
  val () = condvar_wait (pfmut | CVisful, mutex)
  prval ((*ret*)) = fpf (pfmut)
in
  channel_insert2 (chan, xs, x0)
end // end of [then]
else let
  val
  isnil = queue_isnil (xs)
  val () = queue_insert (pf | xs, x0)
  val () =
  if isnil.1
    then condvar_broadcast(unsafe_condvar_vt2t(ch.CVisnil))
  // end of [if]
  val ((*void*)) =
  mutex_unlock ($UN.castview0{locked_v(l1)}(xs) | mutex)
//
in
  // nothing
end // end of [else]
//
end // end of [channel_insert2]

(* ****** ****** *)
//
extern
fun{a:vt0p}
channel_remove2
  (chan: &channel(a) >> _, queue(a)): (a)
//
(* ****** ****** *)

implement
{a}(*tmp*)
channel_remove
  (chan) = let
//
val+CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
val (pfmut | ()) = mutex_lock (mutex)
//
val xs =
  $UN.castvwtp0{queue(a)}((pfmut | ch.queue))
//
in
  channel_remove2<a> (chan, xs)
end // end of [channel_remove]

(* ****** ****** *)

implement{a}
channel_remove2
  (chan, xs) = let
//
val+@CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
macdef
queue_unlock_mac(xs) =
mutex_unlock
  ($UN.castview0{locked_v(l1)}(,(xs)) | mutex)
//
val (pf | isnil) = queue_isnil (xs)
//
in
//
if
isnil
then let
  val qnxt = ch.qnext
in
  if qnxt > 0
    then let
      val () =
      ch.qnext := the_null_ptr
      val () = queue_unlock_mac(xs)
      prval ((*fold*)) = fold@chan
      val () = channel_unref (chan)
      val () =
      chan := $UN.castvwtp0{channel(a)}(qnxt)
    in
      channel_remove (chan)
    end (* end of [then] *)
    else let
      prval
      (pfmut, fpf) =
      __assert () where
      {
        extern
        praxi __assert (): vtakeout0(locked_v(l1))
      } (* end of [prval] *)
      val CVisnil = unsafe_condvar_vt2t(ch.CVisnil)
      val ((*void*)) = condvar_wait (pfmut | CVisnil, mutex)
      prval ((*ret*)) = fpf (pfmut)
      prval ((*fold*)) = fold@chan
    in
      channel_remove2 (chan, xs)
    end // end of [else]
  // end of [if]
end // end of [then]
else let
  val isful = queue_isful (xs)
  val x0_out = queue_remove (pf | xs)
  val () =
  if isful.1
    then condvar_broadcast(unsafe_condvar_vt2t(ch.CVisful))
  // end of [if]
  val () = queue_unlock_mac(xs)
  prval ((*fold*)) = fold@chan
in
  x0_out
end // end of [else]
//
end // end of [channel_remove2]

(* ****** ****** *)
//
extern
fun{a:vt0p}
qnext_insert
  (chx0: &ptr >> _, chx: channel(a)): void
//
extern
fun{a:vt0p}
channel_qinsert2
  (!channel(a), queue(a), channel(a)): void
//
(* ****** ****** *)

implement
{a}(*tmp*)
channel_qinsert
  (chan, chx) = let
//
val+CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
val (pfmut | ()) = mutex_lock (mutex)
//
val xs = $UN.castvwtp0{queue(a)}((pfmut | ch.queue))
//
val ((*void*)) = channel_qinsert2<a> (chan, xs, chx)
//
in
  // nothing
end // end of [channel_qinsert]

(* ****** ****** *)

implement
{a}(*tmp*)
qnext_insert
  (chx0, chx) = let
in
//
if
chx0 = 0
then (
  chx0 := $UN.castvwtp0{ptr}(chx)
) // end of [then]
else let
//
val chan =
$UN.castvwtp0{channel(a)}(chx0)
val ((*void*)) = channel_qinsert (chan, chx)
prval ((*void*)) = $UN.cast2void(chan)
//
in
  // nothing
end // end of [else]
//
end // end of [qnext_insert]

(* ****** ****** *)

implement
{a}(*tmp*)
channel_qinsert2
  (chan, xs, chx) = let
//
val+@CHANNEL
  {l0,l1,l2,l3}(ch) = chan
//
val
mutex = unsafe_mutex_vt2t(ch.mutex)
//
val isnil = queue_isnil (xs)
//
val () = qnext_insert (ch.qnext, chx)
//
val () =
if isnil.1
  then condvar_broadcast(unsafe_condvar_vt2t(ch.CVisnil))
// end of [if]
//
prval ((*fold*)) = fold@chan
//
in
  mutex_unlock ($UN.castview0{locked_v(l1)}(xs) | mutex)
end // end of [channel_qinsert2]

(* ****** ****** *)

(* end of [basis_chan.dats] *)


Updating: merging

Updating: merging

(*
** Channel pairs
*)

(* ****** ****** *)
//
staload
"./../SATS/basis.sats"
staload
"./../SATS/intset.sats"
//
staload "./basis_uchan.dats"
//
(* ****** ****** *)
//
absvtype
channel0_vtype(a:vt@ype, n:int)
//
stadef channel0 = channel0_vtype
//
extern
praxi
lemma_channel0_param
  {a:vt0p}{n:int}
  (chan0: !channel0(a, n)): [n >= 0] void
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
channel0_posneg
  {n:nat}
(
  cap: intGt(0)
, nrole: int(n), G: intset(n)
) :
(
  channel0(a, n)(*pos*), channel0(a, n)(*neg*)
) (* end of [channel0_posneg] *)
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
channel0_free
  {n:int}(chan0: channel0(a, n)): void
//
(* ****** ****** *)
//
extern
fun{a:vt0p}
channel0_send
  {n:int}
(
  !channel0(a, n)
, i: natLt(n), j: natLt(n), x: a
) : void // end-of-function
//
extern
fun{a:vt0p}
channel0_recv
  {n:int}
(
  !channel0(a, n)
, i: natLt(n), j: natLt(n), x: &a? >> a
) : void // end-of-function
extern
fun{a:vt0p}
channel0_recv_val
  {n:int}
(
  !channel0(a, n), i: natLt(n), j: natLt(n)
) : (a) // end of [channel0_recv_val]
//
(* ****** ****** *)
//
datavtype
channel0_
(
  a:vt@ype, n:int
) =
CHANNEL0 of
(
  int(n), intset(n), matrixptr(uchan(a), n, n)
) (* end of [channel0_] *)
//
(* ****** ****** *)
//
assume
channel0_vtype
  (a:vt0p, n:int) = channel0_(a, n)
//
(* ****** ****** *)

implement
{a}(*tmp*)
channel0_free
  (chan0) = let
//
val () =
lemma_channel0_param(chan0)
//
val
~CHANNEL0(n, G, chmat) = chan0
//
implement
(elt:vtype)
matrix_uninitize$clear<elt>
  (i, j, x) = let
//
val x = $UN.castvwtp0{ptr}(x)
//
in
//
if
isneqz(x)
then (
  uchan_unref($UN.castvwtp0{uchan(a)}(x))
) (* end of [if] *)
//
end // end of [matrix_uninitize$clear]
//
val n = i2sz(n)
//
val () = matrixptr_freelin(chmat, n, n)
//
in
  // nothing
end // end of [channel0_free]

(* ****** ****** *)

implement
{a}(*tmp*)
channel0_send
  (chan0, i, j, x0) =
{
//
val+CHANNEL0(n, G, chmat) = chan0
//
val p0 = ptrcast(chmat)
//
val uch =
  $UN.ptr0_get_at<uchan(a)>(p0, i*n+j)
//
val ((*void*)) = uchan_insert<a> (uch, x0)
//
val ((*returned*)) = $UN.cast2void(uch)
//
} (* end of [channel0_send] *)

(* ****** ****** *)

implement
{a}(*tmp*)
channel0_recv
  (chan0, i, j, x0) = let
//
val+CHANNEL0(n, G, chmat) = chan0
//
val p0 = ptrcast(chmat)
//
val p_ij =
  ptr_add<uchan(a)>(p0, i*n+j)
//
val (pf, fpf | p_ij) =
  $UN.ptr_vtake{uchan(a)}(p_ij)
//
val () = (x0 := uchan_remove<a> (!p_ij))
//
prval ((*returned*)) = fpf(pf)
//
in
  // nothing
end // end of [channel0_recv]

(* ****** ****** *)

implement
{a}(*tmp*)
channel0_recv_val
  (chan0, i, j) = x0 where
{
//
var x0: a // uninitized
//
val () = channel0_recv(chan0, i, j, x0)
//
} (* end of [channel0_recv_val] *)

(* ****** ****** *)

(* end of [basic_channel0.dats] *)

(*
** Channel pairs
*)

(* ****** ****** *)
//
staload
"./../SATS/basis.sats"
staload
"./../SATS/intset.sats"
//
staload "./basis_uchan.dats"
//
(* ****** ****** *)
//
absvtype
channel0_vtype(a:vt@ype, n:int)
//
stadef channel0 = channel0_vtype
//
extern
praxi
lemma_channel0_param
  {a:vt0p}{n:int}(!channel0(a, n)): [n >= 0] void
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
channel0_make_pair
  {n:nat}
(
  n: int(n), capacity: intGt(0)
) : (channel0(a, n), channel0(a, n))
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
channel0_free
  {n:int}(chan0: channel0(a, n)): void
//
(* ****** ****** *)
//
extern
fun{a:vt0p}
channel0_send
  {n:int}
(
  !channel0(a, n)
, i: natLt(n), j: natLt(n), x: a
) : void // end-of-function
//
extern
fun{a:vt0p}
channel0_recv
  {n:int}
(
  !channel0(a, n)
, i: natLt(n), j: natLt(n), x: &a? >> a
) : void // end-of-function
extern
fun{a:vt0p}
channel0_recv_val
  {n:int}
(
  !channel0(a, n), i: natLt(n), j: natLt(n)
) : (a) // end of [channel0_recv_val]
//
(* ****** ****** *)
//
datavtype
channel0_
(
  a:vt@ype, n:int
) =
CHANNEL0 of
(
  int(n), intset(n), matrixptr(uchan(a), n, n)
) (* end of [channel0_] *)
//
(* ****** ****** *)
//
assume
channel0_vtype
  (a:vt0p, n:int) = channel0_(a, n)
//
(* ****** ****** *)

implement
{a}(*tmp*)
channel0_free
  (chan0) = let
//
val () =
lemma_channel0_param(chan0)
//
val
~CHANNEL0(n, G, chmat) = chan0
//
implement
(elt:vtype)
matrix_uninitize$clear<elt>
  (i, j, x) = let
//
val x = $UN.castvwtp0{ptr}(x)
//
in
//
if
isneqz(x)
then (
  uchan_unref($UN.castvwtp0{uchan(a)}(x))
) (* end of [if] *)
//
end // end of [matrix_uninitize$clear]
//
val n = i2sz(n)
//
val () = matrixptr_freelin(chmat, n, n)
//
in
  // nothing
end // end of [channel0_free]

(* ****** ****** *)

implement
{a}(*tmp*)
channel0_send
  (chan0, i, j, x0) =
{
//
val+CHANNEL0(n, G, chmat) = chan0
//
val p0 = ptrcast(chmat)
//
val uch =
  $UN.ptr0_get_at<uchan(a)>(p0, i*n+j)
//
val ((*void*)) = uchan_insert<a> (uch, x0)
//
val ((*returned*)) = $UN.cast2void(uch)
//
} (* end of [channel0_send] *)

(* ****** ****** *)

implement
{a}(*tmp*)
channel0_recv
  (chan0, i, j, x0) = let
//
val+CHANNEL0(n, G, chmat) = chan0
//
val p0 = ptrcast(chmat)
//
val p_ij =
  ptr_add<uchan(a)>(p0, i*n+j)
//
val (pf, fpf | p_ij) =
  $UN.ptr_vtake{uchan(a)}(p_ij)
//
val () = (x0 := uchan_remove<a> (!p_ij))
//
prval ((*returned*)) = fpf(pf)
//
in
  // nothing
end // end of [channel0_recv]

(* ****** ****** *)

implement
{a}(*tmp*)
channel0_recv_val
  (chan0, i, j) = x0 where
{
//
var x0: a // uninitized
//
val () = channel0_recv(chan0, i, j, x0)
//
} (* end of [channel0_recv_val] *)

(* ****** ****** *)

(* end of [basic_channel0.dats] *)