Fix comment.

Fix comment.

(*-*-Mode:ats;coding:utf-8;tab-width:4;c-basic-offset:4;indent-tabs-mode:()-*-
  ex: set ft=ats fenc=utf-8 sts=4 ts=4 sw=4 et nomod: *)

(*

  MIT License

  Copyright (c) 2021 Michael Truog <mjtruog at protonmail dot com>

  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 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.

 *)

%{#
#ifndef CLOUDI_H
#define CLOUDI_H
#include <alloca.h> /* due to !defined(_ATS_CCOMP_EXCEPTION_NONE_) */
typedef struct cloudi_instance_t
{
    void * state;
    void * lookup;
    void * buffer_send;
    void * buffer_recv;
    void * buffer_call;
    void * poll_timer;
    char * prefix;
    char * response_info;
    char * response;
    char * trans_id;
    uint32_t buffer_size;
    uint32_t buffer_recv_index;
    uint32_t process_index;
    uint32_t process_count;
    uint32_t process_count_max;
    uint32_t process_count_min;
    uint32_t timeout_initialize;
    uint32_t timeout_async;
    uint32_t timeout_sync;
    uint32_t timeout_terminate;
    uint32_t response_info_size;
    uint32_t response_size;
    uint32_t trans_id_count;
    uint32_t subscribe_count;
    int fd;
    int8_t priority_default;
    unsigned int use_header:1;
    unsigned int initialization_complete:1;
    unsigned int terminate:1;
    unsigned int cxx_terminate_exception:1;
    unsigned int free_with_delete:1;
    unsigned int free_name:1;
    unsigned int free_pattern:1;
    unsigned int free_request_info:1;
    unsigned int free_request:1;
    unsigned int free_response_info:1;
    unsigned int free_response:1;

} cloudi_instance_t;
#endif /* CLOUDI_H */
%}
typedef c_instance = $extype"cloudi_instance_t"

absvtype instance_vtype(s:vt@ype+) = ptr
vtypedef instance(s:vt@ype) = instance_vtype(s)
vtypedef stateptr(s:vt@ype) = aPtr1(s)
absvtype trans_id_vtype = ptr
vtypedef trans_id = trans_id_vtype

absvtype threads_vtype = ptr
vtypedef threads = threads_vtype

datavtype
result (a:vt@ype+) =
  | Ok (a) of (a)
  | Error (a) of (intGt(0))

#define ASYNC 1
#define SYNC ~1
typedef request_type = [a:int | a == ASYNC || a == SYNC] int(a)

typedef
c_callback =
    (request_type,
     ptr,
     ptr,
     ptr,
     uint32,
     ptr,
     uint32,
     uint32,
     int8,
     ptr,
     ptr,
     uint32,
     ptr,
     ptr) -<fun1>
    void

(*

   function effect tags:
   !ntm - possibly non-terminating (divergent)
   !exn - may raise an exception (partial functions)
   !ref - write to memory not owned (no proof)
          (includes file descriptors, not reentrant)
   !wrt - write (includes alloc/free) to memory owned (reentrant)
   fun0 - mathematical purity (no side-effects)
   fun1 - may have all possible side-effects (default)

   operational purity (Haskell's purity) is similar to <!ntm,!exn>
   (catching exceptions breaks referential transparency and
    most Haskell source code uses throwIO for raising exceptions,
    so <!ntm> should be closer in practice)

 *)

fn
trans_id_null
    ():<fun0>
    trans_id
fn
trans_id_is_null
    (trans_id: !trans_id):<!wrt>
    bool
fn
trans_id_isnot_null
    (trans_id: !trans_id):<!wrt>
    bool
fn
trans_id_eq
    (trans_id1: !trans_id,
     trans_id2: !trans_id):<fun0>
    bool
fn
trans_id_neq
    (trans_id1: !trans_id,
     trans_id2: !trans_id):<fun0>
    bool
fn
trans_id_copy
    (trans_id: !trans_id):<!wrt>
    trans_id
fn
trans_id_store
    (trans_id: trans_id):<!wrt>
    trans_id
fn
trans_ids_store {l:addr}{n:int}
    (trans_ids: !arrayptr(trans_id, l, n),
     trans_ids_size: size_t(n)):<!wrt>
    void
fn
trans_id_free
    (trans_id: trans_id):<!wrt>
    void
fn
trans_ids_free {l:addr}{n:int}
    (trans_ids: arrayptr(trans_id, l, n),
     trans_ids_size: size_t(n)):<!wrt>
    void

datavtype
memory_ptr = Ptr of (Ptr1, uint32)

fn
string2read
    (str: string):<fun0>
    memory_ptr
fn
memory2string
    (ptr: !memory_ptr):<fun0>
    string

datavtype
memory_free_ptr =
  | StringLiteral of (string) (* not freed *)
  | PtrFree of (Ptr1, uint32) (* ptr to be freed *)

fn
memory2free
    (ptr: memory_ptr):<!wrt>
    memory_free_ptr
fn
stropt2free
    (str: Stropt0,
     default: string):<fun0>
    memory_free_ptr
fn
strptr2free
    (str: Strptr1):<fun0>
    memory_free_ptr
fn
strnptr2free {l:agz}{n:nat}
    (str: strnptr(l, n)):<fun0>
    memory_free_ptr

typedef timeout_initialize = uintBtwe(101, 4294967195)
typedef timeout_async = uintBtwe(499, 4294967295)
typedef timeout_sync = uintBtwe(499, 4294967295)
typedef timeout_terminate = uintBtwe(10, 60000)
typedef timeout = uintBtwe(0, 4294967295)
#define PRIORITY_HIGH ~128
#define PRIORITY_LOW 127
typedef priority = intBtwe(PRIORITY_HIGH, PRIORITY_LOW)

datavtype
response =
  | Response of (memory_free_ptr)
  | ResponseInfo of (memory_free_ptr, memory_free_ptr)
  | Forward of (memory_free_ptr, memory_free_ptr, memory_free_ptr)
  | Forward_ of (memory_free_ptr, memory_free_ptr, memory_free_ptr,
                 timeout, priority)
  | Null of ()
  | NullError of (string)

exception Terminate of ()
exception FatalError of ()

typedef
callback (s:vt@ype) =
    (request_type,
     string,
     string,
     memory_ptr,
     memory_ptr,
     timeout,
     priority,
     !trans_id,
     !memory_ptr,
     !stateptr(s),
     !instance(s)) -<fun1>
    response

fn {s:vt@ype}
callback_attach
    (callback: callback(s),
     request_type: request_type,
     name_c: ptr,
     pattern_c: ptr,
     request_info_c: ptr,
     request_info_size_c: uint32,
     request_c: ptr,
     request_size_c: uint32,
     timeout_c: uint32,
     priority_c: int8,
     trans_id_c: ptr,
     pid_c: ptr,
     pid_size_c: uint32,
     state_c: ptr,
     api_c: ptr):<fun1>
    void

fn
thread_count():<!exn>
    uintGt(0)

fn {s:vt@ype}
new
    (thread_index: uint,
     state_value: s,
     terminate_return_value: bool):<!ref,!wrt>
    result(instance(s))

fn {s:vt@ype}
destroy
    (api: instance(s)):<!ref,!wrt>
    s

fn {s:vt@ype}
destroy2void
    (api: instance(s)):<!ref,!wrt>
    void

fn
subscribe {s:vt@ype}
    (api: !instance(s),
     suffix: string,
     f: c_callback):<!exn,!ref,!wrt>
    result(unit)

fn
subscribe_count {s:vt@ype}
    (api: !instance(s),
     suffix: string):<!exn,!ref,!wrt>
    result(uint)

fn
unsubscribe {s:vt@ype}
    (api: !instance(s),
     suffix: string):<!exn,!ref,!wrt>
    result(unit)

fn
send_async {s:vt@ype}
    (api: !instance(s),
     name: string,
     request: memory_ptr,
     timeout_opt: Option_vt(timeout),
     request_info_opt: Option_vt(memory_ptr),
     priority_opt: Option_vt(priority)):<!exn,!ref,!wrt>
    result(trans_id)

fn
send_sync {s:vt@ype}
    (api: !instance(s),
     name: string,
     request: memory_ptr,
     timeout_opt: Option_vt(timeout),
     request_info_opt: Option_vt(memory_ptr),
     priority_opt: Option_vt(priority)):<!exn,!ref,!wrt>
    result(@(memory_ptr, memory_ptr, trans_id))

fn
mcast_async {s:vt@ype}
    (api: !instance(s),
     name: string,
     request: memory_ptr,
     timeout_opt: Option_vt(timeout),
     request_info_opt: Option_vt(memory_ptr),
     priority_opt: Option_vt(priority)):<!exn,!ref,!wrt>
    [l:addr][n:int]
    result(@(arrayptr(trans_id, l, n), size_t(n)))

fn
forward_async {s:vt@ype}
    (api: !instance(s),
     name: memory_free_ptr,
     request_info: memory_free_ptr,
     request: memory_free_ptr,
     timeout: timeout,
     priority: priority,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
forward_sync {s:vt@ype}
    (api: !instance(s),
     name: memory_free_ptr,
     request_info: memory_free_ptr,
     request: memory_free_ptr,
     timeout: timeout,
     priority: priority,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
forward {s:vt@ype}
    (api: !instance(s),
     request_type: request_type,
     name: memory_free_ptr,
     request_info: memory_free_ptr,
     request: memory_free_ptr,
     timeout: timeout,
     priority: priority,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
return_async {s:vt@ype}
    (api: !instance(s),
     name: string,
     pattern: string,
     response_info: memory_free_ptr,
     response: memory_free_ptr,
     timeout: timeout,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
return_sync {s:vt@ype}
    (api: !instance(s),
     name: string,
     pattern: string,
     response_info: memory_free_ptr,
     response: memory_free_ptr,
     timeout: timeout,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
return {s:vt@ype}
    (api: !instance(s),
     request_type: request_type,
     name: string,
     pattern: string,
     response_info: memory_free_ptr,
     response: memory_free_ptr,
     timeout: timeout,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
recv_async {s:vt@ype}
    (api: !instance(s),
     timeout_opt: Option_vt(timeout),
     trans_id_opt: Option_vt(trans_id),
     consume_opt: Option_vt(bool)):<!exn,!ref,!wrt>
    result(@(memory_ptr, memory_ptr, trans_id))

fn
process_index {s:vt@ype}
    (api: !instance(s)):<fun0>
    uint

fn
process_count {s:vt@ype}
    (api: !instance(s)):<fun0>
    uintGt(0)

fn
process_count_max {s:vt@ype}
    (api: !instance(s)):<fun0>
    uintGt(0)

fn
process_count_min {s:vt@ype}
    (api: !instance(s)):<fun0>
    uintGt(0)

fn
prefix_ {s:vt@ype}
    (api: !instance(s)):<fun0>
    string

fn
timeout_initialize {s:vt@ype}
    (api: !instance(s)):<fun0>
    timeout_initialize

fn
timeout_async {s:vt@ype}
    (api: !instance(s)):<fun0>
    timeout_async

fn
timeout_sync {s:vt@ype}
    (api: !instance(s)):<fun0>
    timeout_sync

fn
timeout_terminate {s:vt@ype}
    (api: !instance(s)):<fun0>
    timeout_terminate

fn
priority_default {s:vt@ype}
    (api: !instance(s)):<fun0>
    priority

fn
poll {s:vt@ype}
    (api: !instance(s),
     timeout: int):<!ntm,!ref,!wrt>
    result(bool)

fn
shutdown {s:vt@ype}
    (api: !instance(s),
     reason: Option_vt(string)):<!exn,!ref,!wrt>
    result(unit)

fn
info_key_value_parse
    (info: memory_ptr):<!wrt>
    [l:addr][n:int]
    @(arrayptr(string, l, n), size_t(n))

fn
info_key_value_new {l:addr}{n:int}
    (pairs: arrayptr(string, l, n),
     size: size_t(n),
     response_opt: Option_vt(bool)):<!wrt>
    memory_free_ptr

fn
info_key_value_new1
    (key0: string,
     value0: string):<!wrt>
    memory_free_ptr

fn
info_key_value_new2
    (key0: string,
     value0: string,
     key1: string,
     value1: string):<!wrt>
    memory_free_ptr

fn
info_key_value_new3
    (key0: string,
     value0: string,
     key1: string,
     value1: string,
     key2: string,
     value2: string):<!wrt>
    memory_free_ptr

fn
threads_create
    (thread_count: uintGt(0),
     f: (uint) -<fun1> void):<!ref,!wrt>
    threads

fn
threads_wait
    (threads: threads):<!ntm,!ref,!wrt>
    void

(*-*-Mode:ats;coding:utf-8;tab-width:4;c-basic-offset:4;indent-tabs-mode:()-*-
  ex: set ft=ats fenc=utf-8 sts=4 ts=4 sw=4 et nomod: *)

(*

  MIT License

  Copyright (c) 2021 Michael Truog <mjtruog at protonmail dot com>

  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 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.

 *)

%{#
#ifndef CLOUDI_H
#define CLOUDI_H
#include <alloca.h> /* due to !defined(_ATS_CCOMP_EXCEPTION_NONE_) */
typedef struct cloudi_instance_t
{
    void * state;
    void * lookup;
    void * buffer_send;
    void * buffer_recv;
    void * buffer_call;
    void * poll_timer;
    char * prefix;
    char * response_info;
    char * response;
    char * trans_id;
    uint32_t buffer_size;
    uint32_t buffer_recv_index;
    uint32_t process_index;
    uint32_t process_count;
    uint32_t process_count_max;
    uint32_t process_count_min;
    uint32_t timeout_initialize;
    uint32_t timeout_async;
    uint32_t timeout_sync;
    uint32_t timeout_terminate;
    uint32_t response_info_size;
    uint32_t response_size;
    uint32_t trans_id_count;
    uint32_t subscribe_count;
    int fd;
    int8_t priority_default;
    unsigned int use_header:1;
    unsigned int initialization_complete:1;
    unsigned int terminate:1;
    unsigned int cxx_terminate_exception:1;
    unsigned int free_with_delete:1;
    unsigned int free_name:1;
    unsigned int free_pattern:1;
    unsigned int free_request_info:1;
    unsigned int free_request:1;
    unsigned int free_response_info:1;
    unsigned int free_response:1;

} cloudi_instance_t;
#endif /* CLOUDI_H */
%}
typedef c_instance = $extype"cloudi_instance_t"

absvtype instance_vtype(s:vt@ype+) = ptr
vtypedef instance(s:vt@ype) = instance_vtype(s)
vtypedef stateptr(s:vt@ype) = aPtr1(s)
absvtype trans_id_vtype = ptr
vtypedef trans_id = trans_id_vtype

absvtype threads_vtype = ptr
vtypedef threads = threads_vtype

datavtype
result (a:vt@ype+) =
  | Ok (a) of (a)
  | Error (a) of (intGt(0))

#define ASYNC 1
#define SYNC ~1
typedef request_type = [a:int | a == ASYNC || a == SYNC] int(a)

typedef
c_callback =
    (request_type,
     ptr,
     ptr,
     ptr,
     uint32,
     ptr,
     uint32,
     uint32,
     int8,
     ptr,
     ptr,
     uint32,
     ptr,
     ptr) -<fun1>
    void

(*

   function effect tags:
   !ntm - possibly non-terminating (divergent)
   !exn - may raise an exception (partial functions)
   !ref - write to memory not owned (no proof)
          (includes file descriptors, not reentrant)
   !wrt - write (includes alloc/free) to memory owned (reentrant)
   fun0 - mathematical purity (no side-effects)
   fun1 - may have all possible side-effects (default)

   operational purity (Haskell's purity) is similar to <!ntm,!exn>
   (catching exceptions breaks referential transparency and
    most Haskell source code uses throwIO for raising exceptions)

 *)

fn
trans_id_null
    ():<fun0>
    trans_id
fn
trans_id_is_null
    (trans_id: !trans_id):<!wrt>
    bool
fn
trans_id_isnot_null
    (trans_id: !trans_id):<!wrt>
    bool
fn
trans_id_eq
    (trans_id1: !trans_id,
     trans_id2: !trans_id):<fun0>
    bool
fn
trans_id_neq
    (trans_id1: !trans_id,
     trans_id2: !trans_id):<fun0>
    bool
fn
trans_id_copy
    (trans_id: !trans_id):<!wrt>
    trans_id
fn
trans_id_store
    (trans_id: trans_id):<!wrt>
    trans_id
fn
trans_ids_store {l:addr}{n:int}
    (trans_ids: !arrayptr(trans_id, l, n),
     trans_ids_size: size_t(n)):<!wrt>
    void
fn
trans_id_free
    (trans_id: trans_id):<!wrt>
    void
fn
trans_ids_free {l:addr}{n:int}
    (trans_ids: arrayptr(trans_id, l, n),
     trans_ids_size: size_t(n)):<!wrt>
    void

datavtype
memory_ptr = Ptr of (Ptr1, uint32)

fn
string2read
    (str: string):<fun0>
    memory_ptr
fn
memory2string
    (ptr: !memory_ptr):<fun0>
    string

datavtype
memory_free_ptr =
  | StringLiteral of (string) (* not freed *)
  | PtrFree of (Ptr1, uint32) (* ptr to be freed *)

fn
memory2free
    (ptr: memory_ptr):<!wrt>
    memory_free_ptr
fn
stropt2free
    (str: Stropt0,
     default: string):<fun0>
    memory_free_ptr
fn
strptr2free
    (str: Strptr1):<fun0>
    memory_free_ptr
fn
strnptr2free {l:agz}{n:nat}
    (str: strnptr(l, n)):<fun0>
    memory_free_ptr

typedef timeout_initialize = uintBtwe(101, 4294967195)
typedef timeout_async = uintBtwe(499, 4294967295)
typedef timeout_sync = uintBtwe(499, 4294967295)
typedef timeout_terminate = uintBtwe(10, 60000)
typedef timeout = uintBtwe(0, 4294967295)
#define PRIORITY_HIGH ~128
#define PRIORITY_LOW 127
typedef priority = intBtwe(PRIORITY_HIGH, PRIORITY_LOW)

datavtype
response =
  | Response of (memory_free_ptr)
  | ResponseInfo of (memory_free_ptr, memory_free_ptr)
  | Forward of (memory_free_ptr, memory_free_ptr, memory_free_ptr)
  | Forward_ of (memory_free_ptr, memory_free_ptr, memory_free_ptr,
                 timeout, priority)
  | Null of ()
  | NullError of (string)

exception Terminate of ()
exception FatalError of ()

typedef
callback (s:vt@ype) =
    (request_type,
     string,
     string,
     memory_ptr,
     memory_ptr,
     timeout,
     priority,
     !trans_id,
     !memory_ptr,
     !stateptr(s),
     !instance(s)) -<fun1>
    response

fn {s:vt@ype}
callback_attach
    (callback: callback(s),
     request_type: request_type,
     name_c: ptr,
     pattern_c: ptr,
     request_info_c: ptr,
     request_info_size_c: uint32,
     request_c: ptr,
     request_size_c: uint32,
     timeout_c: uint32,
     priority_c: int8,
     trans_id_c: ptr,
     pid_c: ptr,
     pid_size_c: uint32,
     state_c: ptr,
     api_c: ptr):<fun1>
    void

fn
thread_count():<!exn>
    uintGt(0)

fn {s:vt@ype}
new
    (thread_index: uint,
     state_value: s,
     terminate_return_value: bool):<!ref,!wrt>
    result(instance(s))

fn {s:vt@ype}
destroy
    (api: instance(s)):<!ref,!wrt>
    s

fn {s:vt@ype}
destroy2void
    (api: instance(s)):<!ref,!wrt>
    void

fn
subscribe {s:vt@ype}
    (api: !instance(s),
     suffix: string,
     f: c_callback):<!exn,!ref,!wrt>
    result(unit)

fn
subscribe_count {s:vt@ype}
    (api: !instance(s),
     suffix: string):<!exn,!ref,!wrt>
    result(uint)

fn
unsubscribe {s:vt@ype}
    (api: !instance(s),
     suffix: string):<!exn,!ref,!wrt>
    result(unit)

fn
send_async {s:vt@ype}
    (api: !instance(s),
     name: string,
     request: memory_ptr,
     timeout_opt: Option_vt(timeout),
     request_info_opt: Option_vt(memory_ptr),
     priority_opt: Option_vt(priority)):<!exn,!ref,!wrt>
    result(trans_id)

fn
send_sync {s:vt@ype}
    (api: !instance(s),
     name: string,
     request: memory_ptr,
     timeout_opt: Option_vt(timeout),
     request_info_opt: Option_vt(memory_ptr),
     priority_opt: Option_vt(priority)):<!exn,!ref,!wrt>
    result(@(memory_ptr, memory_ptr, trans_id))

fn
mcast_async {s:vt@ype}
    (api: !instance(s),
     name: string,
     request: memory_ptr,
     timeout_opt: Option_vt(timeout),
     request_info_opt: Option_vt(memory_ptr),
     priority_opt: Option_vt(priority)):<!exn,!ref,!wrt>
    [l:addr][n:int]
    result(@(arrayptr(trans_id, l, n), size_t(n)))

fn
forward_async {s:vt@ype}
    (api: !instance(s),
     name: memory_free_ptr,
     request_info: memory_free_ptr,
     request: memory_free_ptr,
     timeout: timeout,
     priority: priority,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
forward_sync {s:vt@ype}
    (api: !instance(s),
     name: memory_free_ptr,
     request_info: memory_free_ptr,
     request: memory_free_ptr,
     timeout: timeout,
     priority: priority,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
forward {s:vt@ype}
    (api: !instance(s),
     request_type: request_type,
     name: memory_free_ptr,
     request_info: memory_free_ptr,
     request: memory_free_ptr,
     timeout: timeout,
     priority: priority,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
return_async {s:vt@ype}
    (api: !instance(s),
     name: string,
     pattern: string,
     response_info: memory_free_ptr,
     response: memory_free_ptr,
     timeout: timeout,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
return_sync {s:vt@ype}
    (api: !instance(s),
     name: string,
     pattern: string,
     response_info: memory_free_ptr,
     response: memory_free_ptr,
     timeout: timeout,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
return {s:vt@ype}
    (api: !instance(s),
     request_type: request_type,
     name: string,
     pattern: string,
     response_info: memory_free_ptr,
     response: memory_free_ptr,
     timeout: timeout,
     trans_id: !trans_id,
     source: !memory_ptr):<!exn,!wrt>
    void

fn
recv_async {s:vt@ype}
    (api: !instance(s),
     timeout_opt: Option_vt(timeout),
     trans_id_opt: Option_vt(trans_id),
     consume_opt: Option_vt(bool)):<!exn,!ref,!wrt>
    result(@(memory_ptr, memory_ptr, trans_id))

fn
process_index {s:vt@ype}
    (api: !instance(s)):<fun0>
    uint

fn
process_count {s:vt@ype}
    (api: !instance(s)):<fun0>
    uintGt(0)

fn
process_count_max {s:vt@ype}
    (api: !instance(s)):<fun0>
    uintGt(0)

fn
process_count_min {s:vt@ype}
    (api: !instance(s)):<fun0>
    uintGt(0)

fn
prefix_ {s:vt@ype}
    (api: !instance(s)):<fun0>
    string

fn
timeout_initialize {s:vt@ype}
    (api: !instance(s)):<fun0>
    timeout_initialize

fn
timeout_async {s:vt@ype}
    (api: !instance(s)):<fun0>
    timeout_async

fn
timeout_sync {s:vt@ype}
    (api: !instance(s)):<fun0>
    timeout_sync

fn
timeout_terminate {s:vt@ype}
    (api: !instance(s)):<fun0>
    timeout_terminate

fn
priority_default {s:vt@ype}
    (api: !instance(s)):<fun0>
    priority

fn
poll {s:vt@ype}
    (api: !instance(s),
     timeout: int):<!ntm,!ref,!wrt>
    result(bool)

fn
shutdown {s:vt@ype}
    (api: !instance(s),
     reason: Option_vt(string)):<!exn,!ref,!wrt>
    result(unit)

fn
info_key_value_parse
    (info: memory_ptr):<!wrt>
    [l:addr][n:int]
    @(arrayptr(string, l, n), size_t(n))

fn
info_key_value_new {l:addr}{n:int}
    (pairs: arrayptr(string, l, n),
     size: size_t(n),
     response_opt: Option_vt(bool)):<!wrt>
    memory_free_ptr

fn
info_key_value_new1
    (key0: string,
     value0: string):<!wrt>
    memory_free_ptr

fn
info_key_value_new2
    (key0: string,
     value0: string,
     key1: string,
     value1: string):<!wrt>
    memory_free_ptr

fn
info_key_value_new3
    (key0: string,
     value0: string,
     key1: string,
     value1: string,
     key2: string,
     value2: string):<!wrt>
    memory_free_ptr

fn
threads_create
    (thread_count: uintGt(0),
     f: (uint) -<fun1> void):<!ref,!wrt>
    threads

fn
threads_wait
    (threads: threads):<!ntm,!ref,!wrt>
    void


Updating: improving atsparemit_lexing

Updating: improving atsparemit_lexing

(* ****** ****** *)
//
// ATS-parse-emit
//
(* ****** ****** *)
//
// HX-2014-07-02: start
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload UN = $UNSAFE

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

staload "./atsparemit.sats"

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

macdef EOL = char2int0('\n')

(* ****** ****** *)
//
implement
token_make (loc, node) =
  '{ token_loc= loc, token_node= node }
//
(* ****** ****** *)
//
implement
lexerr_make (loc, node) =
  '{ lexerr_loc= loc, lexerr_node= node }
//
(* ****** ****** *)

fun BLANK_test (i: int): bool = isspace (i)

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

fun
IDENTFST_test
  (i: int): bool = let
//
val c = int2char0 (i)
//
in
  case+ 0 of
  | _ when ('a' <= c andalso c <= 'z') => true
  | _ when ('A' <= c andalso c <= 'Z') => true
  | _ when c = '_' => true
  | _ (*rest-of-char*) => false
end (* end of [IDENTFST_test] *)

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

fun
IDENTRST_test
  (i: int): bool = let
//
val c = int2char0 (i)
//
in
  case+ 0 of
  | _ when ('a' <= c andalso c <= 'z') => true
  | _ when ('A' <= c andalso c <= 'Z') => true
  | _ when ('0' <= c andalso c <= '9') => true
  | _ when c = '_' => true
  | _ when c = '\'' => true
  | _ when c = '$' => true
  | _ (*rest-of-char*) => false
end (* end of [IDENTRST_test] *)

(* ****** ****** *)
//
fun xX_test
  (i: int): bool = let
//
val c = int2char0 (i) in c = 'x' || c = 'X'
//
end // end of [xX_test]
//
fun eE_test
  (i: int): bool = let
//
val c = int2char0 (i) in c = 'e' || c = 'E'
//
end // end of [eE_test]
//
fun pP_test
  (i: int): bool = let
//
val c = int2char0 (i) in c = 'p' || c = 'P'
//
end // end of [pP_test]
//
(* ****** ****** *)
//
fun ZERO_test
  (i: int): bool = (i = char2int0('0'))
//
fun OCTAL_test (i: int): bool =
  (char2int0('0') <= i && i <= char2int0('7'))
//
fun DIGIT_test (i: int): bool =
  (char2int0('0') <= i && i <= char2int0('9'))
//
fun XDIGIT_test (i: int): bool = isxdigit (i)
//
(* ****** ****** *)
//
fun INTSP_test
  (i: int): bool = let
//
val c = toupper(int2char0(i)) in c = 'L' || c = 'U'
//
end // end of [INTSP_test]
//
fun FLOATSP_test
  (i: int): bool = let
//
val c = toupper(int2char0(i)) in c = 'F' || c = 'L'
//
end // end of [FLOATSP_test]
//
(* ****** ****** *)
//
fun SIGN_test (c: char): bool = (c = '-' || c = '+')
//
(* ****** ****** *)
//
extern
fun
ftesting_one
(
  buf: &lexbuf >> _, f: int -> bool
) : intGte(0) // end of [ftesting_one]
//
implement
ftesting_one
  (buf, f) = let
//
val i = lexbuf_get_char (buf)
//
in
//
if (
i > 0
) then (
  if f(i) then 1 else (lexbuf_incby_nback (buf, 1); 0)
) else (0)
//
end // end of [ftesting_one]
//
(* ****** ****** *)
//
extern
fun
ftesting_seq0
(
  buf: &lexbuf >> _, f: int -> bool
) : intGte(0) // end of [ftesting_seq0]
implement
ftesting_seq0
  (buf, f) = let
//
fun loop
(
  buf: &lexbuf >> _, nchr: intGte(0)
) : intGte(0) = let
  val i = lexbuf_get_char (buf)
in
//
if (
i > 0
) then (
//
if f(i)
  then
    loop (buf, succ(nchr))
  // end of [then]
  else let
    val () = lexbuf_incby_nback (buf, 1) in nchr
  end // end of [else]
//
) else (nchr)
//
end // end of [loop]
//
in
  loop (buf, 0)
end // end of [ftesting_seq0]

(* ****** ****** *)
//
fun
skip_blankseq0
(
  buf: &lexbuf >> _
) : intGte(0) = let
//
fun loop
(
  buf: &lexbuf >> _
, pos: &position >> _, nchr: intGte(0)
) : intGte(0) = let
//
val i = lexbuf_get_char (buf)
//
in
//
if
i > 0
then (
  if isspace(i)
    then let
      val c = int2char0 (i)
      val () = position_incby_char (pos, c)
    in
      loop (buf, pos, succ(nchr))
    end // end of [then]
    else nchr // end of [else]
  // end of [if]
) (* end of [then] *)
else nchr // end of [else]
//
end // end of [loop]
//
var pos: position
val () = lexbuf_get_position (buf, pos)
val nchr = loop (buf, pos, 0)
val () = lexbuf_remove (buf, nchr)
val () = lexbuf_set_position (buf, pos)
//
in
  nchr
end // end of [skip_blankseq0]
//
(* ****** ****** *)
//
fun
testing_identseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, IDENTRST_test)
//
(* ****** ****** *)
//
extern
fun
lexing_IDENT_alp (buf: &lexbuf): token
//
implement
lexing_IDENT_alp
  (buf) = let
//
val nchr = testing_identseq0 (buf)
val nchr1 = succ(nchr)
val name = lexbuf_takeout (buf, nchr1)
val name = strptr2string (name)
//
val loc = lexbuf_getincby_location (buf, nchr1)
//
in
  token_make (loc, T_IDENT_alp(name))
end // end of [lexing_IDENT_alp]

(* ****** ****** *)
//
fun
testing_octalseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, OCTAL_test)
//
(* ****** ****** *)
//
fun
testing_digitseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, DIGIT_test)
//
(* ****** ****** *)
//
fun
testing_xdigitseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, XDIGIT_test)
//
(* ****** ****** *)
//
fun
testing_intspseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, INTSP_test)
//
(* ****** ****** *)
//
extern
fun
lexing_INTEGER_oct (buf: &lexbuf): token
//
implement
lexing_INTEGER_oct
  (buf) = let
val k0 = testing_octalseq0 (buf)
val k1 = testing_intspseq0 (buf)
val nchr = succ(k0 + k1)
val intrep = lexbuf_takeout (buf, nchr)
val intrep = strptr2string (intrep)
//
val loc = lexbuf_getincby_location (buf, nchr)
//
val base =
  (if k0 > 0 then 8 else 10): int
//
in
  token_make (loc, T_INTEGER(base, intrep))
end // end of [lexing_INTEGER_oct]

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

extern
fun
lexing_INTEGER_dec (buf: &lexbuf): token
//
implement
lexing_INTEGER_dec
  (buf) = let
//
val k0 = testing_digitseq0 (buf)
val k1 = testing_intspseq0 (buf)
val nchr = succ(k0 + k1)
val intrep = lexbuf_takeout (buf, nchr)
val intrep = strptr2string (intrep)
//
val loc = lexbuf_getincby_location (buf, nchr)
//
in
  token_make (loc, T_INTEGER(10, intrep))
end // end of [lexing_INTEGER_dec]

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

extern
fun
lexing_INTEGER_hex (buf: &lexbuf): token
//
implement
lexing_INTEGER_hex
  (buf) = let
//
val k0 =
  testing_xdigitseq0 (buf)
val k1 = testing_intspseq0 (buf)
val nchr = k0 + k1 + 2
val intrep = lexbuf_takeout (buf, nchr)
val intrep = strptr2string (intrep)
//
val loc = lexbuf_getincby_location (buf, nchr)
//
in
  token_make (loc, T_INTEGER(16, intrep))
end // end of [lexing_INTEGER_hex]

(* ****** ****** *)
//
#define COMMA ','
#define COLON ':'
#define SEMICOLON ';'
//
#define QUOTE '''
#define DQUOTE '"'
//
#define LPAREN '\('
#define RPAREN ')';
#define LBRACE '\{'
#define RBRACE '}';
#define LBRACKET '\['
#define RBRACKET ']';
//
#define SHARP '#'
#define SLASH '/'
#define BACKSLASH '\\'
//
(* ****** ****** *)
//
extern
fun
lexing_litchar
  (buf: &lexbuf, node: tnode): token
//
implement
lexing_litchar
  (buf, node) = let
//
val () = lexbuf_remove (buf, 1)
val loc = lexbuf_getincby_location (buf, 1)
//
in
  token_make (loc, node)
end // end of [lexing_litchar]
//
(* ****** ****** *)
//
extern
fun
lexing_SHARP (buf: &lexbuf): token
//
implement
lexing_SHARP
  (buf) = let
//
val nchr = testing_identseq0 (buf)
val nchr1 = succ(nchr)
val name = lexbuf_takeout (buf, nchr1)
val name = strptr2string (name)
//
val loc = lexbuf_getincby_location (buf, nchr1)
//
in
  token_make (loc, T_IDENT_srp(name))
end // end of [lexing_SHARP]

(* ****** ****** *)
//
extern
fun
lexing_SLASH (buf: &lexbuf): token
extern
fun
lexing_SLASHSTAR (buf: &lexbuf): token
extern
fun
lexing_SLASHSLASH (buf: &lexbuf): token
//
(* ****** ****** *)

implement
lexing_SLASH
  (buf) = let
//
val i0 = lexbuf_get_char(buf)
//
in
//
if
i0 > 0
then let
//
val c0 = int2char0(i0)
//
in
//
case+ 0 of
//
| _ when c0 = '*' => lexing_SLASHSTAR (buf)
| _ when c0 = '/' => lexing_SLASHSLASH (buf)
//
| _ (*rest-of-char*) => lexing_litchar (buf, T_SLASH)
//
end // end of [then]
else lexing_litchar (buf, T_SLASH)
//
end // end of [lexing_SLASH]

(* ****** ****** *)
//
extern
fun
lexing_quote
(
  buf: &lexbuf, quote: char
) : token // end-of-fun
//
implement
lexing_quote
  (buf, quote) = let
//
fun
loop (
  buf: &lexbuf
, pos: &position >> _, nchr: intGte(0)
) : intGte(0) = let
//
val i = lexbuf_get_char (buf)
//
in
//
if
i > 0
then let
  val c = int2char0 (i)
  val () = position_incby_char (pos, c)
  val nchr = succ (nchr)
in
  case+ 0 of
  | _ when c = quote => nchr
  | _ when c = BACKSLASH => loop2 (buf, pos, nchr)
  | _ (*rest-of-char*) => loop (buf, pos, nchr)
end // end of [then]
else nchr // end of [else]
//
end // end of [loop]
//
and
loop2 (
  buf: &lexbuf
, pos: &position >> _, nchr: intGte(0)
) : intGte(0) = let
//
val i = lexbuf_get_char (buf)
//
in
//
if
i > 0
then let
  val c = int2char0 (i)
  val () = position_incby_char (pos, c)
  val nchr = succ (nchr)
in
  loop (buf, pos, nchr)
end // end of [then]
else nchr // end of [else]
//
end // end of [loop2]
//
var pos: position
val () = lexbuf_get_position (buf, pos)
val nchr = loop (buf, pos, 0)
val loc = lexbufpos_get_location (buf, pos)
val strp = lexbuf_takeout (buf, nchr+1)
val () = lexbuf_set_position (buf, pos)
//
in
  token_make (loc, T_STRING(strptr2string(strp)))
end // end of [lexing_quote]

(* ****** ****** *)
//
extern
fun
lexing_QUOTE (buf: &lexbuf): token
implement
lexing_QUOTE (buf) = lexing_quote (buf, QUOTE)
//
extern
fun
lexing_DQUOTE (buf: &lexbuf): token
implement
lexing_DQUOTE (buf) = lexing_quote (buf, DQUOTE)
//
(* ****** ****** *)
//
extern
fun
testing_until_literal
  (buf: &lexbuf >> _, pos: &position >> _, lit: string): intGte(0)
//
implement
testing_until_literal
  (buf, pos, lit0) = let
//
val [n0:int]
  lit0 = g1ofg0 (lit0)
val n0 = length (lit0)
//
fun
loop
  {n:nat | n0 >= n}
(
  buf: &lexbuf >> _
, pos: &position >> _
, lit: string(n), n: size_t(n)
, nchr: intGte(0)
) : intGte(0) = let
in
//
if
n > 0
then let
  val i = lexbuf_get_char (buf)
in
//
if i <= 0
  then nchr
  else let
    val c = int2char0(i)
    val () = position_incby_char (pos, c)
  in
    if c != lit.head
      then let
        val np = sz2i(n0 - n)
        val () = position_decby (pos, np)
        val () = lexbuf_incby_nback (buf, np)
      in
        loop (buf, pos, lit0, n0, succ(nchr))
      end // end of [then]
      else (
        loop (buf, pos, lit.tail, pred(n), succ(nchr))
      ) (* end of [else] *)
  end // end of [else]
//
end // end of [then]
else nchr // end of [else]
//
end // end of [loop]
//
in
  loop (buf, pos, lit0, n0, 0)
end // end of [testing_until_literal]

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

implement
lexing_SLASHSTAR
  (buf) = let
//
var pos: position
val () = lexbuf_get_position (buf, pos)
val () = position_incby (pos, 2)
//
#define STARSLASH "*/"
//
val nchr =
  testing_until_literal (buf, pos, STARSLASH)
//
val () = lexbuf_remove (buf, nchr + 2)
val loc = lexbufpos_get_location (buf, pos)
val ((*void*)) = lexbuf_set_position (buf, pos)
//
in
  token_make (loc, T_COMMENT_block)
end // end of [lexing_SLASHSTAR]

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

implement
lexing_SLASHSLASH
  (buf) = let
//
val nchr =
ftesting_seq0 (buf, lam i => i != EOL)
val () = lexbuf_remove_all (buf)
val loc = lexbuf_getincby_location (buf, nchr)
//
in
  token_make (loc, T_COMMENT_line)
end // end of [lexing_SLASHSLASH]

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

implement
lexbuf_get_token
  (buf) = let
//
var res: int
val k0 = skip_blankseq0 (buf)
val () = lexbuf_set_nspace (buf, k0)
//
val i0 = lexbuf_get_char (buf)
//
in
//
if
i0 > 0
then let
//
val c0 = $UN.cast{charNZ}(i0)
//
in
//
case+ 0 of
//
| _ when
    IDENTFST_test (i0) => lexing_IDENT_alp (buf)
//
| _ when DIGIT_test (i0) =>
  (
    if ZERO_test(i0)
      then let
        val k = ftesting_one (buf, xX_test)
      in
        if k = 0
          then lexing_INTEGER_oct (buf) else lexing_INTEGER_hex (buf)
        // end of [if]
      end // end of [then]
      else lexing_INTEGER_dec (buf)
   )
//
| _ when i0 = COMMA => lexing_litchar (buf, T_COMMA)
| _ when i0 = COLON => lexing_litchar (buf, T_COLON)
| _ when i0 = SEMICOLON => lexing_litchar (buf, T_SEMICOLON)
//
| _ when i0 = LPAREN => lexing_litchar (buf, T_LPAREN)
| _ when i0 = RPAREN => lexing_litchar (buf, T_RPAREN)
| _ when i0 = LBRACE => lexing_litchar (buf, T_LBRACE)
| _ when i0 = RBRACE => lexing_litchar (buf, T_RBRACE)
| _ when i0 = LBRACKET => lexing_litchar (buf, T_LBRACKET)
| _ when i0 = RBRACKET => lexing_litchar (buf, T_RBRACKET)
//
| _ when c0 = SHARP => lexing_SHARP (buf)
//
| _ when i0 = SLASH => lexing_SLASH (buf)
//
| _ when i0 = QUOTE => lexing_QUOTE (buf)
| _ when i0 = DQUOTE => lexing_DQUOTE (buf)
//
| _ (*rest-of-char*) => let
//
// HX: skipping the unrecognized char
//
    val () =
    println! ("Unrecognized char: c0 = ", c0)
//
    val () = lexbuf_remove_all (buf)
    val loc = lexbuf_getincby_location (buf, 1)
//
    val err =
      lexerr_make (loc, LEXERR_UNSUPPORTED_char(c0))
    val () = the_lexerrlst_insert (err)
  in
    lexbuf_get_token (buf)
  end // end of [rest-of-char]
//
end // end of [then]
else let
  val loc =
    lexbuf_getincby_location (buf, 0) in token_make (loc, T_EOF)
  // end of [val]
end // end of [else]
//
end // end of [lexing_get_token]

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

(* end of [atsparemit_lexing.dats] *)

(* ****** ****** *)
//
// ATS-parse-emit
//
(* ****** ****** *)
//
// HX-2014-07-02: start
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload UN = $UNSAFE

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

staload "./atsparemit.sats"

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

macdef EOL = char2int0('\n')

(* ****** ****** *)
//
implement
token_make (loc, node) =
  '{ token_loc= loc, token_node= node }
//
(* ****** ****** *)
//
implement
lexerr_make (loc, node) =
  '{ lexerr_loc= loc, lexerr_node= node }
//
(* ****** ****** *)

fun BLANK_test (i: int): bool = isspace (i)

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

fun
IDENTFST_test
  (i: int): bool = let
//
val c = int2char0 (i)
//
in
  case+ 0 of
  | _ when ('a' <= c andalso c <= 'z') => true
  | _ when ('A' <= c andalso c <= 'Z') => true
  | _ when c = '_' => true
  | _ (*rest-of-char*) => false
end (* end of [IDENTFST_test] *)

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

fun
IDENTRST_test
  (i: int): bool = let
//
val c = int2char0 (i)
//
in
  case+ 0 of
  | _ when ('a' <= c andalso c <= 'z') => true
  | _ when ('A' <= c andalso c <= 'Z') => true
  | _ when ('0' <= c andalso c <= '9') => true
  | _ when c = '_' => true
  | _ when c = '\'' => true
  | _ when c = '$' => true
  | _ (*rest-of-char*) => false
end (* end of [IDENTRST_test] *)

(* ****** ****** *)
//
fun xX_test
  (i: int): bool = let
//
val c = int2char0 (i) in c = 'x' || c = 'X'
//
end // end of [xX_test]
//
fun eE_test
  (i: int): bool = let
//
val c = int2char0 (i) in c = 'e' || c = 'E'
//
end // end of [eE_test]
//
fun pP_test
  (i: int): bool = let
//
val c = int2char0 (i) in c = 'p' || c = 'P'
//
end // end of [pP_test]
//
(* ****** ****** *)
//
fun DIGIT_test (i: int): bool = isdigit (i)
fun XDIGIT_test (i: int): bool = isxdigit (i)
//
(* ****** ****** *)
//
fun INTSP_test
  (i: int): bool = let
//
val c = toupper(int2char0(i)) in c = 'L' || c = 'U'
//
end // end of [INTSP_test]
//
fun FLOATSP_test
  (i: int): bool = let
//
val c = toupper(int2char0(i)) in c = 'F' || c = 'L'
//
end // end of [FLOATSP_test]
//
(* ****** ****** *)
//
fun SIGN_test (c: char): bool = (c = '-' || c = '+')
//
(* ****** ****** *)
//
extern
fun
ftesting_seq0
(
  buf: &lexbuf >> _, f: int -> bool
) : intGte(0) // end of [ftesting_seq0]
implement
ftesting_seq0
  (buf, f) = let
//
fun loop
(
  buf: &lexbuf >> _, nchr: intGte(0)
) : intGte(0) = let
  val i = lexbuf_get_char (buf)
in
//
if (
i > 0
) then (
//
if f(i)
  then
    loop (buf, succ(nchr))
  // end of [then]
  else let
    val () = lexbuf_incby_nback (buf, 1) in nchr
  end // end of [else]
//
) else (nchr)
//
end // end of [loop]
//
in
  loop (buf, 0)
end // end of [ftesting_seq0]

(* ****** ****** *)
//
fun
skip_blankseq0
(
  buf: &lexbuf >> _
) : intGte(0) = let
//
fun loop
(
  buf: &lexbuf >> _
, pos: &position >> _, nchr: intGte(0)
) : intGte(0) = let
//
val i = lexbuf_get_char (buf)
//
in
//
if
i > 0
then (
  if isspace(i)
    then let
      val c = int2char0 (i)
      val () = position_incby_char (pos, c)
    in
      loop (buf, pos, succ(nchr))
    end // end of [then]
    else nchr // end of [else]
  // end of [if]
) (* end of [then] *)
else nchr // end of [else]
//
end // end of [loop]
//
var pos: position
val () = lexbuf_get_position (buf, pos)
val nchr = loop (buf, pos, 0)
val () = lexbuf_remove (buf, nchr)
val () = lexbuf_set_position (buf, pos)
//
in
  nchr
end // end of [skip_blankseq0]
//
(* ****** ****** *)
//
fun
testing_identseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, IDENTRST_test)
//
(* ****** ****** *)
//
extern
fun
lexing_IDENT_alp (buf: &lexbuf): token
//
implement
lexing_IDENT_alp
  (buf) = let
//
val nchr = testing_identseq0 (buf)
val nchr1 = succ(nchr)
val name = lexbuf_takeout (buf, nchr1)
val name = strptr2string (name)
//
val loc = lexbuf_getincby_location (buf, nchr1)
//
in
  token_make (loc, T_IDENT_alp(name))
end // end of [lexing_IDENT_alp]

(* ****** ****** *)
//
fun
testing_digitseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, DIGIT_test)
//
(* ****** ****** *)
//
fun
testing_intspseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, INTSP_test)
//
(* ****** ****** *)
//
extern
fun
lexing_INTEGER_dec (buf: &lexbuf): token
//
implement
lexing_INTEGER_dec
  (buf) = let
//
val k0 = testing_digitseq0 (buf)
val k1 = testing_intspseq0 (buf)
val nchr = succ(k0 + k1)
val intrep = lexbuf_takeout (buf, nchr)
val intrep = strptr2string (intrep)
//
val loc = lexbuf_getincby_location (buf, nchr)
//
in
  token_make (loc, T_INTEGER(10, intrep))
end // end of [lexing_INTEGER_dec]

(* ****** ****** *)
//
#define COMMA ','
#define COLON ':'
#define SEMICOLON ';'
//
#define LPAREN '\('
#define RPAREN ')';
#define LBRACE '\{'
#define RBRACE '}';
#define LBRACKET '\['
#define RBRACKET ']';
//
#define SHARP '#'
#define SLASH '/'
//
(* ****** ****** *)
//
extern
fun
lexing_litchar
  (buf: &lexbuf, node: tnode): token
//
implement
lexing_litchar
  (buf, node) = let
//
val () = lexbuf_remove (buf, 1)
val loc = lexbuf_getincby_location (buf, 1)
//
in
  token_make (loc, node)
end // end of [lexing_litchar]
//
(* ****** ****** *)
//
extern
fun
lexing_SHARP (buf: &lexbuf): token
//
implement
lexing_SHARP
  (buf) = let
//
val nchr = testing_identseq0 (buf)
val nchr1 = succ(nchr)
val name = lexbuf_takeout (buf, nchr1)
val name = strptr2string (name)
//
val loc = lexbuf_getincby_location (buf, nchr1)
//
in
  token_make (loc, T_IDENT_srp(name))
end // end of [lexing_SHARP]

(* ****** ****** *)
//
extern
fun
lexing_SLASH (buf: &lexbuf): token
extern
fun
lexing_SLASHSTAR (buf: &lexbuf): token
extern
fun
lexing_SLASHSLASH (buf: &lexbuf): token
//
(* ****** ****** *)

implement
lexing_SLASH
  (buf) = let
//
val i0 = lexbuf_get_char(buf)
//
in
//
if
i0 > 0
then let
//
val c0 = int2char0(i0)
//
in
//
case+ 0 of
//
| _ when c0 = '*' => lexing_SLASHSTAR (buf)
| _ when c0 = '/' => lexing_SLASHSLASH (buf)
//
| _ (*rest-of-char*) => lexing_litchar (buf, T_SLASH)
//
end // end of [then]
else lexing_litchar (buf, T_SLASH)
//
end // end of [lexing_SLASH]

(* ****** ****** *)
//
extern
fun
testing_until_literal
  (buf: &lexbuf >> _, pos: &position >> _, lit: string): intGte(0)
//
implement
testing_until_literal
  (buf, pos, lit0) = let
//
val [n0:int]
  lit0 = g1ofg0 (lit0)
val n0 = length (lit0)
//
fun
loop
  {n:nat | n0 >= n}
(
  buf: &lexbuf >> _
, pos: &position >> _
, lit: string(n), n: size_t(n)
, nchr: intGte(0)
) : intGte(0) = let
in
//
if
n > 0
then let
  val i = lexbuf_get_char (buf)
in
//
if i <= 0
  then nchr
  else let
    val c = int2char0(i)
    val () = position_incby_char (pos, c)
  in
    if c != lit.head
      then let
        val np = sz2i(n0 - n)
        val () = position_decby (pos, np)
        val () = lexbuf_incby_nback (buf, np)
      in
        loop (buf, pos, lit0, n0, succ(nchr))
      end // end of [then]
      else (
        loop (buf, pos, lit.tail, pred(n), succ(nchr))
      ) (* end of [else] *)
  end // end of [else]
//
end // end of [then]
else nchr // end of [else]
//
end // end of [loop]
//
in
  loop (buf, pos, lit0, n0, 0)
end // end of [testing_until_literal]

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

implement
lexing_SLASHSTAR
  (buf) = let
//
var pos: position
val () = lexbuf_get_position (buf, pos)
val () = position_incby (pos, 2)
//
#define STARSLASH "*/"
//
val nchr =
  testing_until_literal (buf, pos, STARSLASH)
//
val () = lexbuf_remove (buf, nchr + 2)
val loc = lexbufpos_get_location (buf, pos)
val ((*void*)) = lexbuf_set_position (buf, pos)
//
in
  token_make (loc, T_COMMENT_block)
end // end of [lexing_SLASHSTAR]

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

implement
lexing_SLASHSLASH
  (buf) = let
//
val nchr =
ftesting_seq0 (buf, lam i => i != EOL)
val () = lexbuf_remove_all (buf)
val loc = lexbuf_getincby_location (buf, nchr)
//
in
  token_make (loc, T_COMMENT_line)
end // end of [lexing_SLASHSLASH]

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

implement
lexbuf_get_token
  (buf) = let
//
var res: int
val k0 = skip_blankseq0 (buf)
val () = lexbuf_set_nspace (buf, k0)
//
val i0 = lexbuf_get_char (buf)
//
in
//
if
i0 > 0
then let
//
val c0 = $UN.cast{charNZ}(i0)
//
in
//
case+ 0 of
//
| _ when
    IDENTFST_test (i0) => lexing_IDENT_alp (buf)
//
| _ when DIGIT_test (i0) => lexing_INTEGER_dec (buf)
//
| _ when i0 = COMMA => lexing_litchar (buf, T_COMMA)
| _ when i0 = COLON => lexing_litchar (buf, T_COLON)
| _ when i0 = SEMICOLON => lexing_litchar (buf, T_SEMICOLON)
//
| _ when i0 = LPAREN => lexing_litchar (buf, T_LPAREN)
| _ when i0 = RPAREN => lexing_litchar (buf, T_RPAREN)
| _ when i0 = LBRACE => lexing_litchar (buf, T_LBRACE)
| _ when i0 = RBRACE => lexing_litchar (buf, T_RBRACE)
| _ when i0 = LBRACKET => lexing_litchar (buf, T_LBRACKET)
| _ when i0 = RBRACKET => lexing_litchar (buf, T_RBRACKET)
//
| _ when c0 = SHARP => lexing_SHARP (buf)
//
| _ when i0 = SLASH => lexing_SLASH (buf)
//
| _ (*rest-of-char*) => let
//
// HX: skipping the unrecognized char
//
    val () =
    println! ("Unrecognized char: c0 = ", c0)
//
    val () = lexbuf_remove_all (buf)
    val loc = lexbuf_getincby_location (buf, 1)
//
    val err =
      lexerr_make (loc, LEXERR_UNSUPPORTED_char(c0))
    val () = the_lexerrlst_insert (err)
  in
    lexbuf_get_token (buf)
  end // end of [rest-of-char]
//
end // end of [then]
else let
  val loc =
    lexbuf_getincby_location (buf, 0) in token_make (loc, T_EOF)
  // end of [val]
end // end of [else]
//
end // end of [lexing_get_token]

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

(* end of [atsparemit_lexing.dats] *)


Refactoring

Refactoring

#include "config.hats"
#include "{$TOP}/avr_prelude/kernel_staload.hats"

staload "{$TOP}/SATS/i2c.sats"

//staload UN = "prelude/SATS/unsafe.sats"
staload "prelude/SATS/unsafe.sats"

macdef i8(x) = cast{int8}(,(x))
macdef u8(x) = cast{uint8}(,(x))
macdef u16(x) = cast{uint16}(,(x))

macdef
ifnerr(x, err, ec, t) =
(
if
(,(err) = ,(t)(0))
then let
  val () = ,(err) := ,(x)
in
  if ,(err) != ,(t)(0) then ,(err) := ,(t)(,(ec))
end // end of [then]
)

macdef err (z, t) = ,(t)(,(z))

fun wa (addr:uint8) : uint8 = addr << 1
fun ra (addr:uint8) : uint8 = (addr << 1) + u8(1)

implement i2c_start () = u8(i2c_start_p())
implement i2c_repeated_start () = u8(i2c_repeated_start_p())
implement i2c_write (b) = u8(i2c_write_p(b))
implement i2c_read (b) = i2c_read_p(i8(b))

implement i2c_read_byte(address: uint8): (uint8, uint8) = let
  var err: uint8 =                       err (0, u8)
  val () = ifnerr(i2c_start(),           err, 1, u8)
  val () = ifnerr(i2c_write(wa address), err, 2, u8)
  val b  =        i2c_read(u8(WITH_NACK))
  val () =        i2c_stop()
  in (err, b) end

implement i2c_write_byte(address: uint8, data: uint8): uint8 = let
  var err: uint8 =                       err (0, u8)
  val () = ifnerr(i2c_start(),           err, 1, u8)
  val () = ifnerr(i2c_write(wa address), err, 2, u8)
  val () = ifnerr(i2c_write(data),       err, 3, u8)
  val () =        i2c_stop()
  in err end

implement i2c_read_byte_data(address: uint8, command: uint8): (uint8, uint8) = let
  var err: uint8 =                       err (0, u8)
  val () = ifnerr(i2c_start(),           err, 1, u8)
  val () = ifnerr(i2c_write(wa address), err, 2, u8)
  val () = ifnerr(i2c_write(command),    err, 3, u8)
  val () = ifnerr(i2c_start(),           err, 4, u8)
  val () = ifnerr(i2c_write(ra address), err, 5, u8)
  val b  =        i2c_read(u8(WITH_NACK))
  val () =        i2c_stop()
  in (err, b) end

implement i2c_write_byte_data(address: uint8, command: uint8, data: uint8): uint8 = let
  var err: uint8 =                       err (0, u8)
  val () = ifnerr(i2c_start(),           err, 1, u8)
  val () = ifnerr(i2c_write(wa address), err, 2, u8)
  val () = ifnerr(i2c_write(command),    err, 3, u8)
  val () = ifnerr(i2c_write(data),       err, 4, u8)
  val () =        i2c_stop()
  in err end

implement i2c_read_word_data(address: uint8, command: uint8): (uint8, uint16) = let
  var err: uint8 =                       err (0, u8)
  val () = ifnerr(i2c_start(),           err, 1, u8)
  val () = ifnerr(i2c_write(wa address), err, 2, u8)
  val () = ifnerr(i2c_write(command),    err, 3, u8)
  val () = ifnerr(i2c_start(),           err, 4, u8)
  val () = ifnerr(i2c_write(ra address), err, 5, u8)
  val b1 =        i2c_read(u8(WITH_ACK))
  val b0 =        i2c_read(u8(WITH_NACK))
  val () =        i2c_stop()
  val w  = (u16(b1) << 8) + u16(b0)
  in (err, w) end

  implement i2c_write_word_data(address: uint8, command: uint8, data: uint16): uint8 = let
  var err: uint8 =                                          err (0, u8)
  val () = ifnerr(i2c_start(),                              err, 1, u8)
  val () = ifnerr(i2c_write(wa address),                    err, 2, u8)
  val () = ifnerr(i2c_write(command),                       err, 3, u8)
  val () = ifnerr(i2c_write(u8(data >> 8)),                 err, 4, u8)
  val () = ifnerr(i2c_write(u8(data - ((data >> 8) << 8))), err, 5, u8)
  val () =        i2c_stop()
  in err end

#include "config.hats"
#include "{$TOP}/avr_prelude/kernel_staload.hats"

staload "{$TOP}/SATS/i2c.sats"

//staload UN = "prelude/SATS/unsafe.sats"
staload "prelude/SATS/unsafe.sats"

macdef i8(x) = cast{int8}(,(x))
macdef u8(x) = cast{uint8}(,(x))
macdef u16(x) = cast{uint16}(,(x))

fun wa (addr:uint8) : uint8 = addr << 1
fun ra (addr:uint8) : uint8 = (addr << 1) + u8(1)

implement i2c_start () = u8(i2c_start_p())
implement i2c_repeated_start () = u8(i2c_repeated_start_p())
implement i2c_write (b) = u8(i2c_write_p(b))
implement i2c_read (b) = i2c_read_p(i8(b))

implement i2c_read_byte(address: uint8): (uint8, uint8) = let
  var r: uint8                              = i2c_start()
  val () = if r = u8(0) then r := r + u8(2) * i2c_write(wa address)
  val b  =                                    i2c_read(u8(WITH_NACK))
  val () =                                    i2c_stop()
  in (r, b) end

implement i2c_write_byte(address: uint8, data: uint8): uint8 = let
  var r: uint8                              = i2c_start()
  val () = if r = u8(0) then r := r + u8(2) * i2c_write(wa address)
  val () = if r = u8(0) then r := r + u8(3) * i2c_write(data)
  val () =                                    i2c_stop()
  in r end

implement i2c_read_byte_data(address: uint8, command: uint8): (uint8, uint8) = let
  var r: uint8                              = i2c_start()
  val () = if r = u8(0) then r := r + u8(2) * i2c_write(wa address)
  val () = if r = u8(0) then r := r + u8(3) * i2c_write(command)
  val () = if r = u8(0) then r := r + u8(4) * i2c_start()
  val () = if r = u8(0) then r := r + u8(5) * i2c_write(ra address)
  val b  =                                    i2c_read(u8(WITH_NACK))
  val () =                                    i2c_stop()
  in (r, b) end

implement i2c_write_byte_data(address: uint8, command: uint8, data: uint8): uint8 = let
  var r: uint8                              = i2c_start()
  val () = if r = u8(0) then r := r + u8(2) * i2c_write(wa address)
  val () = if r = u8(0) then r := r + u8(3) * i2c_write(command)
  val () = if r = u8(0) then r := r + u8(4) * i2c_write(data)
  val () =                                    i2c_stop()
  in r end

implement i2c_read_word_data(address: uint8, command: uint8): (uint8, uint16) = let
  var r: uint8                              = i2c_start()
  val () = if r = u8(0) then r := r + u8(2) * i2c_write(wa address)
  val () = if r = u8(0) then r := r + u8(3) * i2c_write(command)
  val () = if r = u8(0) then r := r + u8(4) * i2c_start()
  val () = if r = u8(0) then r := r + u8(5) * i2c_write(ra address)
  val b1 =                                    i2c_read(u8(WITH_ACK))
  val b0 =                                    i2c_read(u8(WITH_NACK))
  val () =                                    i2c_stop()
  val w  = (u16(b1) << 8) + u16(b0)
  in (r, w) end

  implement i2c_write_word_data(address: uint8, command: uint8, data: uint16): uint8 = let
  var r: uint8                              = i2c_start()
  val () = if r = u8(0) then r := r + u8(2) * i2c_write(wa address)
  val () = if r = u8(0) then r := r + u8(3) * i2c_write(command)
  val () = if r = u8(0) then r := r + u8(4) * i2c_write(u8(data >> 8))
  val () = if r = u8(0) then r := r + u8(5) * i2c_write(u8(data - ((data >> 8) << 8)))
  val () =                                    i2c_stop()
  in r end


Delete Bit.hats, because it is not used.

#include "share/atspre_define.hats"
#include "share/atspre_staload.hats"

prfn {n:int} le_plus_1 ():[n <= n + 1] void = ()
prfn {n:int} le_refl   ():[n <= n]     void = ()
prfn {n:int} plus_0    ():[n == n + 0] void = ()

prfun le_plus_nat {n,m:int | n <= m}{p:nat} .<p>. ():[n <= m+p] void =
  sif 0 < p then let
      prval () = le_plus_nat {n,m}{p-1} ()
    in le_plus_1<n> () end
  else let
      prval () = plus_0<m> ()
    in (* nothing *) end

dataprop POW2 (int,int) =
 | POW2_0 (0,1) of ()
 | {n,v:int} POW2_N (n+1,v+v) of POW2 (n,v)

prfun pow2_total {n:nat} .<n>. ():[npow:int] POW2 (n,npow) =
  sif 0 < n then POW2_N (pow2_total {n-1} ())
            else POW2_0 ()

extern praxi pow2_domain_nat {n,npow:int} (POW2 (n,npow)):[0 <= n] void

prfun pow2_range_lte_1 {n:nat}{npow:int} .<n>. (pow:POW2 (n,npow)):[1 <= npow] void
 = case+ pow of
   | POW2_0 ()        => () // 1 <= 1
   | POW2_N (pow_ind) => let
       prval () = pow2_domain_nat (pow_ind)
       prval () = pow2_range_lte_1 (pow_ind)
     in  end // 1 <= npow_ind -> 1 <= npow_ind+npow_ind

prfn pow2_lte {n,npow:int} (pow2:POW2 (n,npow)):[0 <= n][1 <= npow] void
 = let
     prval () = pow2_domain_nat (pow2)
     prval () = pow2_range_lte_1 (pow2)
   in end

prfun pow2_injective {n,npow1,npow2:nat} .<n>. (pow1:POW2 (n,npow1), pow2:POW2 (n,npow2)):[npow1==npow2] void
 = sif 0 < n then let
       prval POW2_N (pow1') = pow1
       prval POW2_N (pow2') = pow2
     in pow2_injective (pow1',pow2') end
   else case+ (pow1,pow2) of
        | (POW2_0 (), POW2_0 ()) => () // 0 == 0
        | (POW2_N (pow_ind), _) =/=> let prval () = pow2_lte (pow_ind) in end // 0 == n && 0 <= n-1
        | (_, POW2_N (pow_ind)) =/=> let prval () = pow2_lte (pow_ind) in end // 0 == n && 0 <= n-1

prfn npow_lte_int31 {npow:nat}
      (pow2:POW2 (31,npow)): [npow <= 2147483648] void
 = let
    prfn npow_double {n,npow,nmax:nat | npow <= nmax/2}
      (pow2:POW2 (n,npow)):[npow+npow <= nmax] POW2 (n+1,npow+npow)
     = POW2_N pow2
    prval pow2' = npow_double {30,1073741824,2147483648}(npow_double {29,536870912,1073741824}(
                  npow_double {28,268435456,536870912}(npow_double {27,134217728,268435456}(
                  npow_double {26,67108864,134217728}(npow_double {25,33554432,67108864}(
                  npow_double {24,16777216,33554432}(npow_double {23,8388608,16777216}(
                  npow_double {22,4194304,8388608}(npow_double {21,2097152,4194304}(
                  npow_double {20,1048576,2097152}(npow_double {19,524288,1048576}(
                  npow_double {18,262144,524288}(npow_double {17,131072,262144}(
                  npow_double {16,65536,131072}(npow_double {15,32768,65536}(
                  npow_double {14,16384,32768}(npow_double {13,8192,16384}(
                  npow_double {12,4096,8192}(npow_double {11,2048,4096}(
                  npow_double {10,1024,2048}(npow_double {9,512,1024}(
                  npow_double {8,256,512}(npow_double {7,128,256}(
                  npow_double {6,64,128}(npow_double {5,32,64}(
                  npow_double {4,16,32}(npow_double {3,8,16}(
                  npow_double {2,4,8}(npow_double {1,2,4}(
                  npow_double {0,1,2}(POW2_0 (
                  ))))))))))))))))))))))))))))))))
    prval () = pow2_injective(pow2,pow2')
 in  end

prfun npow_monotonically_increasing {n,m,npow,mpow:nat | n < m}
      .<m>. (pow2_n:POW2 (n,npow),pow2_m:POW2 (m,mpow)):[npow < mpow] void
 = case+ pow2_m of
   | POW2_0 ()           =/=> () // (n < m) && (0 = m)
   | POW2_N (pow2_m_ind) =>   let
       prval () = pow2_lte (pow2_m_ind)
     in case+ pow2_n of
        | POW2_0 ()           => () // (0 = n) && (0 <= m-1)
        | POW2_N (pow2_n_ind) => let
            prval () = pow2_lte (pow2_n_ind)
          in npow_monotonically_increasing (pow2_n_ind, pow2_m_ind) end
     end

prfun npow_intmax {n,npow,m:nat | n < INTBITS; m < npow}
      .<INTBITS - n>. (pow2:POW2 (n,npow)): [m <= INTMAX] void
 = sif (31 == n) then npow_lte_int31 (pow2)
   else let
        prval () = pow2_lte (POW2_N (pow2))
        prval () = npow_intmax{n+1,npow+npow,m+m} (POW2_N (pow2))
   in npow_monotonically_increasing (pow2,POW2_N (pow2)) end

prfn beqint_is_nat {n,v:int}{bs:bits}
  (beqint_fst:BITSEQINT (n,bs,v)):[0 <= v] void =
let
  prfun aux {n,v:int}{bs:bits} .<bs>. (beqint:BITSEQINT (n,bs,v)):[0 <= v] void =
    case+ beqint of
    | BEQNIL   ()       => le_refl ()   // 0 <= 0
    | BEQCONS (beqind,B0EQ0 ()) => aux (beqind) // (0 <= n) -> (0 <= n+0)
    | BEQCONS (beqind,B1EQ1 ()) => aux (beqind) // (0 <= n) -> (0 <= n+1)
in aux (beqint_fst) end

dataprop NAT_EVEN (int) =
 | NEVENbas (0) of ()
 | {n:nat} NEVENind (n+2) of NAT_EVEN (n)

dataprop NAT_ODD (int) =
 | NODDbas (1) of ()
 | {n:nat} NODDind (n+2) of NAT_ODD (n)

prfn {n:int} neven_nat (ev:NAT_EVEN (n)):[0 <= n] void
 = case+ ev of
   | NEVENbas ()       => le_refl ()
   | NEVENind {n'} (_) => le_plus_nat {0,n'}{2} ()

prfn {n:int} nodd_gte_1 (odd:NAT_ODD (n)):[1 <= n] void
 = sif 1 <= n then ()
       else case+ odd of
       | NODDbas ()       =/=> () // 1 < 1
       | NODDind {n'} (_) =/=> () // 0 <= n' && n'+2 < 1

prfun nodd_prev_is_even {n:nat} .<n>. (odd:NAT_ODD (n)):NAT_EVEN (n-1)
 = case+ odd of
   | NODDbas ()       => NEVENbas ()
   | NODDind (oddind) => let
       prval () = nodd_gte_1 (oddind)
     in NEVENind (nodd_prev_is_even (oddind)) end

datasort oddity = EVEN | ODD

dataprop NAT_ODDITY (int,oddity) =
 | {n:int} NATeven (n,EVEN) of NAT_EVEN (n)
 | {n:int} NATodd  (n,ODD)  of NAT_ODD  (n)

prfun natoddity_total {n:nat} .<n>. ():[o:oddity] NAT_ODDITY (n,o)
 = sif      n == 0 then NATeven (NEVENbas ())
   else sif n == 1 then NATodd  (NODDbas  ())
   else     case+ natoddity_total {n-2} () of
            | NATeven (ev)  => NATeven (NEVENind (ev))
            | NATodd  (odd) => let prval () = nodd_gte_1 (odd)
                               in NATodd  (NODDind  (odd)) end

prfun nat_half {n:nat} .<n>. (ev:NAT_EVEN (n)):[h:nat | h+h == n] int h
 = case+ ev of
   | NEVENbas ()   => 0 // 0+0 == 0
   | NEVENind {n'} (ev) => let prval () = neven_nat<n'> (ev)
                           in nat_half {n'} (ev) + 1 (* h+h == n' -> h+1 + h+1 == n'+2 *) end

prfn double_v_lt_2pow_succ__v_lt_2pow {v,n,npow_succ,npow:nat | v+v < npow_succ}
                                      (pow2:POW2(n,npow),pow2succ:POW2 (n+1,npow_succ)):[v < npow] void
 = let
     prval () = pow2_injective (POW2_N (pow2), pow2succ)// npow_succ == npow+npow
   in end // v+v < npow+npow -> v < npow

prfun nat_eq_bits {n,npow,v:nat | v < npow}{v <= INTMAX} .<n>.
  (pow2:POW2 (n,npow)):[bs:bits] BITSEQINT (n,bs,v) =
  sif 0 < n then let
      prval POW2_N {n',npow'} (pow2ind) = pow2
      prval () = pow2_lte (pow2ind)
    in case+ natoddity_total {v} () of
       | NATeven (ev) => let
           prval [h:int](_) = nat_half {v} (ev)
           prval () = double_v_lt_2pow_succ__v_lt_2pow {h,n',npow,npow'} (pow2ind,pow2) // h < npow'
         in BEQCONS (nat_eq_bits {n',npow',h} (pow2ind),B0EQ0) end
       | NATodd  (odd) => let
           prval (ev) = nodd_prev_is_even (odd)
           prval () = nodd_gte_1 (odd)
           prval [h:int](_) = nat_half {v-1} (ev)
           prval () = double_v_lt_2pow_succ__v_lt_2pow {h,n',npow,npow'} (pow2ind,pow2) // h < npow'
         in BEQCONS (nat_eq_bits {n',npow',h} (pow2ind),B1EQ1) end
    end
  else let
      prval () = pow2_injective (pow2, POW2_0 ())
    in BEQNIL () end


Updating: very minorly improving

Updating: very minorly improving

(* ****** ****** *)
//
// HX-2015-03-20:
//
// Animating a variant of
// the Dining Philosophers problem
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "my_dynload"

(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
staload
"{$LIBATSCC2JS}/SATS/HTML/canvas-2d/canvas2d.sats"
//
(* ****** ****** *)
//
#define NPHIL 5
typedef nphil = natLt(NPHIL)
//
(* ****** ****** *)
//
extern
fun theCtx2d_get(): canvas2d = "mac#"
//
(* ****** ****** *)
//
extern
fun
cloref_app
(
  fwork: () -<cloref1> void
) : void = "mac#" // endfun
//
implement cloref_app(fwork) = fwork()
//
extern
fun
setTimeout_cloref
(
  fwork: () -<cloref1> void, ntime: double
) : void = "mac#" // end-of-function
//
(* ****** ****** *)
//
fun
rand_int2
(
  x0: int, len: intGte(0)
) : double =
(
  x0 + len * JSmath_random()
)
//
(* ****** ****** *)

extern
fun
phil_draw(id: nphil): void = "mac#"

(* ****** ****** *)
//
extern
fun
phil_pick_lfork(id: nphil): int = "mac#"
and
phil_pick_rfork(id: nphil): int = "mac#"
//
extern
fun
phil_return_lfork(id: nphil): void = "mac#"
and
phil_return_rfork(id: nphil): void = "mac#"
//
(* ****** ****** *)
//
extern
fun
phil_loop (id: nphil): void = "mac#"
//
extern
fun phil_think_beg (id: nphil): void
and phil_think_end (id: nphil): void
//
extern
fun phil_dine_start (id: nphil): void
and phil_dine_lfork (id: nphil): void
and phil_dine_rfork (id: nphil): void
and phil_dine_finish (id: nphil): void
//
(* ****** ****** *)
//
implement
phil_loop(id) =
  (phil_draw(id); phil_think_beg (id))
//
(* ****** ****** *)
//
implement
phil_think_beg
  (id) = let
//
val ntime = rand_int2(500, 2500)
//
in
//
setTimeout_cloref(lam() => phil_think_end(id), ntime)
//
end // end of [phil_think_beg]
//
implement phil_think_end(id) = phil_dine_start(id)
//
(* ****** ****** *)
//
implement
phil_dine_start
  (id) = phil_dine_lfork(id)
//
implement
phil_dine_lfork
  (id) = let
//
val ntime =
  rand_int2(250, 1000)
//
val lfork = phil_pick_lfork(id)
val ((*void*)) = if lfork > 0 then phil_draw(id)
//
in
//
if
lfork = 0
then setTimeout_cloref(lam() => phil_dine_lfork(id), ntime)
else setTimeout_cloref(lam() => phil_dine_rfork(id), ntime)
//
end // end of [phil_dine_lfork]
//
implement
phil_dine_rfork(id) = let
//
val ntime =
  rand_int2(250, 1000)
//
val rfork = phil_pick_rfork(id)
val ((*void*)) = if rfork > 0 then phil_draw(id)
//
in
//
if
rfork = 0
then setTimeout_cloref(lam() => phil_dine_rfork(id), ntime)
else setTimeout_cloref(lam() => phil_dine_finish(id), ntime)
//
end // end of [phil_dine_rfork]

implement
phil_dine_finish(id) =
(
  phil_return_lfork(id); phil_return_rfork(id); phil_loop(id)
)
//
(* ****** ****** *)

%{$
//
var
mycanvas =
document.getElementById
  ("Patsoptaas-Evaluate-canvas");
//
var
myctx2d0 = mycanvas.getContext( '2d' );
//
var theFks = [1, 1, 1, 1, 1]
//
var Ph0 = { lfork: 0, rfork: 0 }
var Ph1 = { lfork: 0, rfork: 0 }
var Ph2 = { lfork: 0, rfork: 0 }
var Ph3 = { lfork: 0, rfork: 0 }
var Ph4 = { lfork: 0, rfork: 0 }
var thePhs = [Ph0, Ph1, Ph2, Ph3, Ph4]
//
function
phil_pick_lfork
  (id0)
{
//
var
lf0 =
theFks[id0];
if(lf0 > 0)
{
  theFks[id0] = 0;
  thePhs[id0].lfork = 1;
}
return (lf0);
//
} // phil_pick_lfork
//
function
phil_pick_rfork
  (id0)
{
//
var id1 = (id0+1)%5;
var rf1 = theFks[id1];
if(rf1 > 0)
{
  theFks[id1] = 0;
  thePhs[id0].rfork = 1;
}
return (rf1);
//
} // phil_pick_rfork
//
function
phil_return_lfork
  (id0)
{
  var ph = thePhs[id0];
  ph.lfork = 0; theFks[id0] = 1; return;
}
function
phil_return_rfork
  (id0)
{
  var ph = thePhs[id0];
  var id1 = (id0+1)%5
  ph.rfork = 0; theFks[id1] = 1; return;
}
//
function
theCx_get() { return mycanvas.width/2; }
function
theCy_get() { return mycanvas.height/2; }
function
theRadius1_get() { return Math.min(mycanvas.width, mycanvas.height)/2; }
function
theRadius2_get() { return theRadius1_get() / 5; }
//
function
phil_Cx(id)
{
  var r1 = theRadius1_get();
  var r2 = theRadius2_get();
  var theta = Math.PI/2 - id*(2*Math.PI/5);
  return theCx_get() + (r1-r2) * Math.cos(theta);
}
function
phil_Cy(id)
{
  var r1 = theRadius1_get();
  var r2 = theRadius2_get();
  var theta = Math.PI/2 - id*(2*Math.PI/5);
  return theCy_get() - (r1-r2) * Math.sin(theta);
}
//
function
phil_draw(id)
{
  var ph = thePhs[id];
  var Cx = phil_Cx(id);
  var r2 = theRadius2_get();
  var Cy = phil_Cy(id) + 2*r2/5;
  var fg_color = "#000000"; // black
  var bg_color = "#ffffff"; // white
//
  var PI = Math.PI
  var rot = id*(2*PI/5)+PI/2
//
  myctx2d0.beginPath();
  myctx2d0.arc(Cx, Cy, r2, 0, 2*PI, true);
  myctx2d0.closePath();
  myctx2d0.fillStyle = bg_color; myctx2d0.fill();
//
  if (ph.lfork > 0)
  {
    myctx2d0.beginPath();
    myctx2d0.arc(Cx, Cy, r2, rot, rot+PI, true);
    myctx2d0.closePath();
    myctx2d0.fillStyle = fg_color; myctx2d0.fill();
  }
  if (ph.rfork > 0)
  {
    myctx2d0.beginPath();
    myctx2d0.arc(Cx, Cy, r2, rot+PI, rot+2*PI, true);
    myctx2d0.closePath();
    myctx2d0.fillStyle = fg_color; myctx2d0.fill();
  }
//
  return;
}
//
function
DininingPhil_initize()
{
  phil_loop(0);
  phil_loop(1);
  phil_loop(2);
  phil_loop(3);
  phil_loop(4); return;
}
/*
function
DininingPhil_initize() { alert("DininingPhil_initize"); }
*/
//
function
setTimeout_cloref(fwork, ntime)
{
  setTimeout(function(){cloref_app(fwork);return;}, ntime); return;
}
//
jQuery(document).ready(function(){DininingPhil_initize();});
//
%} // end of [%{$]

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

(* end of [DiningPhil.php] *)

(* ****** ****** *)
//
// HX-2015-03-20:
//
// Animating a variant of
// the Dining Philosophers problem
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "my_dynload"

(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
staload
"{$LIBATSCC2JS}/SATS/HTML/canvas-2d/canvas2d.sats"
//
(* ****** ****** *)
//
#define NPHIL 5
typedef nphil = natLt(NPHIL)
//
(* ****** ****** *)
//
extern
fun theCtx2d_get(): canvas2d = "mac#"
//
(* ****** ****** *)
//
extern
fun
cloref_app
(
  fwork: () -<cloref1> void
) : void = "mac#" // endfun
//
implement cloref_app(fwork) = fwork()
//
extern
fun
setTimeout_cloref
(
  fwork: () -<cloref1> void, ntime: double
) : void = "mac#" // end-of-function
//
(* ****** ****** *)
//
fun
rand_int2
(
  x0: int, len: intGte(0)
) : double =
(
  x0 + len * JSmath_random()
)
//
(* ****** ****** *)

extern
fun
phil_draw(id: nphil): void = "mac#"

(* ****** ****** *)
//
extern
fun
phil_pick_lfork(id: nphil): int = "mac#"
and
phil_pick_rfork(id: nphil): int = "mac#"
//
extern
fun
phil_return_lfork(id: nphil): void = "mac#"
and
phil_return_rfork(id: nphil): void = "mac#"
//
(* ****** ****** *)
//
extern
fun
phil_loop (id: nphil): void = "mac#"
//
extern
fun phil_think_beg (id: nphil): void
and phil_think_end (id: nphil): void
//
extern
fun phil_dine_start (id: nphil): void
and phil_dine_lfork (id: nphil): void
and phil_dine_rfork (id: nphil): void
and phil_dine_finish (id: nphil): void
//
(* ****** ****** *)
//
implement
phil_loop(id) =
  (phil_draw(id); phil_think_beg (id))
//
(* ****** ****** *)
//
implement
phil_think_beg
  (id) = let
//
val ntime = rand_int2(500, 2500)
//
in
//
setTimeout_cloref(lam() => phil_think_end(id), ntime)
//
end // end of [phil_think_beg]
//
implement phil_think_end(id) = phil_dine_start(id)
//
(* ****** ****** *)
//
implement
phil_dine_start
  (id) = phil_dine_lfork(id)
//
implement
phil_dine_lfork
  (id) = let
//
val ntime =
  rand_int2(250, 1000)
//
val lfork = phil_pick_lfork(id)
val ((*void*)) = if lfork > 0 then phil_draw(id)
//
in
//
if
lfork = 0
then setTimeout_cloref(lam() => phil_dine_lfork(id), ntime)
else setTimeout_cloref(lam() => phil_dine_rfork(id), ntime)
//
end // end of [phil_dine_lfork]
//
implement
phil_dine_rfork(id) = let
//
val ntime =
  rand_int2(250, 1000)
//
val rfork = phil_pick_rfork(id)
val ((*void*)) = if rfork > 0 then phil_draw(id)
//
in
//
if
rfork = 0
then setTimeout_cloref(lam() => phil_dine_rfork(id), ntime)
else setTimeout_cloref(lam() => phil_dine_finish(id), ntime)
//
end // end of [phil_dine_rfork]

implement
phil_dine_finish(id) =
(
  phil_return_lfork(id); phil_return_rfork(id); phil_loop(id)
)
//
(* ****** ****** *)

%{$
//
var
mycanvas =
document.getElementById
  ("Patsoptaas-Evaluate-canvas");
//
var
myctx2d0 = mycanvas.getContext( '2d' );
//
var theFks = [1, 1, 1, 1, 1]
//
var Ph0 = { lfork: 0, rfork: 0 }
var Ph1 = { lfork: 0, rfork: 0 }
var Ph2 = { lfork: 0, rfork: 0 }
var Ph3 = { lfork: 0, rfork: 0 }
var Ph4 = { lfork: 0, rfork: 0 }
var thePhs = [Ph0, Ph1, Ph2, Ph3, Ph4]
//
function
phil_pick_lfork
  (id0)
{
//
var
lf0 =
theFks[id0];
if(lf0 > 0)
{
  theFks[id0] = 0;
  thePhs[id0].lfork = 1;
}
return (lf0);
//
} // phil_pick_lfork
//
function
phil_pick_rfork
  (id0)
{
//
var id1 = (id0+1)%5;
var rf1 = theFks[id1];
if(rf1 > 0)
{
  theFks[id1] = 0;
  thePhs[id0].rfork = 1;
}
return (rf1);
//
} // phil_pick_rfork
//
function
phil_return_lfork
  (id0)
{
  var ph = thePhs[id0];
  ph.lfork = 0; theFks[id0] = 1; return;
}
function
phil_return_rfork
  (id0)
{
  var ph = thePhs[id0];
  var id1 = (id0+1)%5
  ph.rfork = 0; theFks[id1] = 1; return;
}
//
function
theCx_get() { return mycanvas.width/2; }
function
theCy_get() { return mycanvas.height/2; }
function
theRadius1_get() { return Math.min(mycanvas.width, mycanvas.height)/2; }
function
theRadius2_get() { return theRadius1_get() / 5; }
//
function
phil_Cx(id)
{
  var r1 = theRadius1_get();
  var r2 = theRadius2_get();
  var theta = Math.PI/2 - id*(2*Math.PI/5);
  return theCx_get() + (r1-r2) * Math.cos(theta);
}
function
phil_Cy(id)
{
  var r1 = theRadius1_get();
  var r2 = theRadius2_get();
  var theta = Math.PI/2 - id*(2*Math.PI/5);
  return theCy_get() - (r1-r2) * Math.sin(theta);
}
//
function
phil_draw(id)
{
  var ph = thePhs[id];
  var Cx = phil_Cx(id);
  var r2 = theRadius2_get();
  var Cy = phil_Cy(id) + 2*r2/5;
  var fg_color = "#000000"; // black
  var bg_color = "#ffffff"; // white
//
  var PI = Math.PI
//
  myctx2d0.beginPath();
  myctx2d0.arc(Cx, Cy, r2, 0, 2*PI, true);
  myctx2d0.closePath();
  myctx2d0.fillStyle = bg_color; myctx2d0.fill();
//
  if (ph.lfork > 0)
  {
    myctx2d0.beginPath();
    myctx2d0.arc(Cx, Cy, r2, 3*PI/2, 1*PI/2, true);
    myctx2d0.closePath();
    myctx2d0.fillStyle = fg_color; myctx2d0.fill();
  }
  if (ph.rfork > 0)
  {
    myctx2d0.beginPath();
    myctx2d0.arc(Cx, Cy, r2, 1*PI/2, 3*PI/2, true);
    myctx2d0.closePath();
    myctx2d0.fillStyle = fg_color; myctx2d0.fill();
  }
//
  return;
}
//
function
DininingPhil_initize()
{
  phil_loop(0);
  phil_loop(1);
  phil_loop(2);
  phil_loop(3);
  phil_loop(4); return;
}
/*
function
DininingPhil_initize() { alert("DininingPhil_initize"); }
*/
//
function
setTimeout_cloref(fwork, ntime)
{
  setTimeout(function(){cloref_app(fwork);return;}, ntime); return;
}
//
jQuery(document).ready(function(){DininingPhil_initize();});
//
%} // end of [%{$]

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

(* end of [DiningPhil.php] *)


Updating: improving on libatscc

Updating: improving on libatscc

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

(* ****** ****** *)
//
// HX: prefix for external names
//
#define ATS_EXTERN_PREFIX "ats2jspre_"
//
(* ****** ****** *)
//
fun double2int (x: double): int = "mac#%"
fun int_of_double (x: double): int = "mac#%"
//
fun int2double (x: int): double = "mac#%"
fun double_of_int (x: int): double = "mac#%"
//
(* ****** ****** *)
//
fun
abs_double
  : double -> double = "mac#%"
overload abs with abs_double of 100
//
(* ****** ****** *)
//
fun
neg_double
  : double -> double = "mac#%"
overload ~ with neg_double of 100
overload neg with neg_double of 100
//
(* ****** ****** *)
//
fun succ_double : double -> double = "mac#%"
fun pred_double : double -> double = "mac#%"
//
overload succ with succ_double of 100
overload pred with pred_double of 100
//
(* ****** ****** *)
//
fun add_int_double
  : (int, double) -> double = "mac#%"
fun add_double_int
  : (double, int) -> double = "mac#%"
//
fun sub_int_double
  : (int, double) -> double = "mac#%"
fun sub_double_int
  : (double, int) -> double = "mac#%"
//
fun mul_int_double
  : (int, double) -> double = "mac#%"
fun mul_double_int
  : (double, int) -> double = "mac#%"
//
fun div_int_double
  : (int, double) -> double = "mac#%"
fun div_double_int
  : (double, int) -> double = "mac#%"
//
(* ****** ****** *)

overload + with add_int_double of 100
overload + with add_double_int of 100
overload - with sub_int_double of 100
overload - with sub_double_int of 100
overload * with mul_int_double of 100
overload * with mul_double_int of 100
overload / with div_int_double of 100
overload / with div_double_int of 100

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

typedef
float_aop_type = (double, double) -> double

(* ****** ****** *)
//
fun add_double_double: float_aop_type = "mac#%"
fun sub_double_double : float_aop_type = "mac#%"
fun mul_double_double : float_aop_type = "mac#%"
fun div_double_double : float_aop_type = "mac#%"
//
(* ****** ****** *)
//
overload + with add_double_double of 100
overload - with sub_double_double of 100
overload * with mul_double_double of 100
overload / with div_double_double of 100
//
(* ****** ****** *)
//
fun lt_int_double
  : (int, double) -> bool = "mac#%"
fun lt_double_int
  : (double, int) -> bool = "mac#%"
//
fun lte_int_double
  : (int, double) -> bool = "mac#%"
fun lte_double_int
  : (double, int) -> bool = "mac#%"
//
fun gt_int_double
  : (int, double) -> bool = "mac#%"
fun gt_double_int
  : (double, int) -> bool = "mac#%"
//
fun gte_int_double
  : (int, double) -> bool = "mac#%"
fun gte_double_int
  : (double, int) -> bool = "mac#%"
//
(* ****** ****** *)

typedef
float_cmp_type = (double, double) -> bool

(* ****** ****** *)
//
fun lt_double_double: float_cmp_type = "mac#%"
fun lte_double_double: float_cmp_type = "mac#%"
fun gt_double_double: float_cmp_type = "mac#%"
fun gte_double_double: float_cmp_type = "mac#%"
//
fun eq_double_double: float_cmp_type = "mac#%"
fun neq_double_double: float_cmp_type = "mac#%"
//
(* ****** ****** *)
//
overload < with lt_double_double of 100
overload <= with lte_double_double of 100
overload > with gt_double_double of 100
overload >= with gte_double_double of 100
overload = with eq_double_double of 100
overload != with neq_double_double of 100
overload <> with neq_double_double of 100
//
(* ****** ****** *)
//
fun
compare_double_double
  (x1: double, x2: double): Sgn = "mac#%"
//
overload compare with compare_double_double of 100
//
(* ****** ****** *)

(* end of [float.sats] *)

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

(* ****** ****** *)
//
// HX: prefix for external names
//
#define ATS_EXTERN_PREFIX "ats2jspre_"
//
(* ****** ****** *)
//
fun double2int (x: double): int = "mac#%"
fun int_of_double (x: double): int = "mac#%"
//
fun int2double (x: int): double = "mac#%"
fun double_of_int (x: int): double = "mac#%"
//
(* ****** ****** *)
//
fun
abs_double
  : double -> double = "mac#%"
overload abs with abs_double of 100
//
(* ****** ****** *)
//
fun
neg_double
  : double -> double = "mac#%"
overload ~ with neg_double of 100
overload neg with neg_double of 100
//
(* ****** ****** *)
//
fun succ_double : double -> double = "mac#%"
fun pred_double : double -> double = "mac#%"
//
overload succ with succ_double of 100
overload pred with pred_double of 100
//
(* ****** ****** *)
//
fun add_int_double
  : (int, double) -> double = "mac#%"
fun add_double_int
  : (double, int) -> double = "mac#%"
//
fun sub_int_double
  : (int, double) -> double = "mac#%"
fun sub_double_int
  : (double, int) -> double = "mac#%"
//
fun mul_int_double
  : (int, double) -> double = "mac#%"
fun mul_double_int
  : (double, int) -> double = "mac#%"
//
fun div_int_double
  : (int, double) -> double = "mac#%"
fun div_double_int
  : (double, int) -> double = "mac#%"
//
(* ****** ****** *)

overload + with add_int_double of 100
overload + with add_double_int of 100
overload - with sub_int_double of 100
overload - with sub_double_int of 100
overload * with mul_int_double of 100
overload * with mul_double_int of 100
overload / with div_int_double of 100
overload / with div_double_int of 100

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

typedef
float_aop_type = (double, double) -> double

(* ****** ****** *)
//
fun add_double_double: float_aop_type = "mac#%"
fun sub_double_double : float_aop_type = "mac#%"
fun mul_double_double : float_aop_type = "mac#%"
fun div_double_double : float_aop_type = "mac#%"
//
(* ****** ****** *)
//
overload + with add_double_double of 100
overload - with sub_double_double of 100
overload * with mul_double_double of 100
overload / with div_double_double of 100
//
(* ****** ****** *)
//
fun lt_int_double
  : (int, double) -> bool = "mac#%"
fun lt_double_int
  : (double, int) -> bool = "mac#%"
//
fun lte_int_double
  : (int, double) -> bool = "mac#%"
fun lte_double_int
  : (double, int) -> bool = "mac#%"
//
fun gt_int_double
  : (int, double) -> bool = "mac#%"
fun gt_double_int
  : (double, int) -> bool = "mac#%"
//
fun gte_int_double
  : (int, double) -> bool = "mac#%"
fun gte_double_int
  : (double, int) -> bool = "mac#%"
//
(* ****** ****** *)

typedef
float_cmp_type = (double, double) -> bool

(* ****** ****** *)
//
fun lt_double_double: float_cmp_type = "mac#%"
fun lte_double_double: float_cmp_type = "mac#%"
fun gt_double_double: float_cmp_type = "mac#%"
fun gte_double_double: float_cmp_type = "mac#%"
//
fun eq_double_double: float_cmp_type = "mac#%"
fun neq_double_double: float_cmp_type = "mac#%"
//
(* ****** ****** *)
//
overload < with lt_double_double of 100
overload <= with lte_double_double of 100
overload > with gt_double_double of 100
overload >= with gte_double_double of 100
overload = with eq_double_double of 100
overload != with neq_double_double of 100
overload <> with neq_double_double of 100
//
(* ****** ****** *)
//
fun
compare_double_double
  (x1: double, x2: double) -> Sgn = "mac#%"
//
overload compare with compare_double_double of 100
//
(* ****** ****** *)

(* end of [float.sats] *)


Updating: very minorly improving

Updating: very minorly improving

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

(*
** Copyright (C) 2013 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-2013-11:
// An array-based channel
//
(* ****** ****** *)

staload
UN = "prelude/SATS/unsafe.sats"

(* ****** ****** *)
//
staload "libats/SATS/athread.sats"
//
staload "libats/SATS/deqarray.sats"
//
(* ****** ****** *)

staload "./../SATS/channel.sats"

(* ****** ****** *)
//
datatype
channel = {
l1,l2,l3:agz
} CHANNEL of
(
  ptr(*buf*)
, size_t(*cap*)
, mutex(l1), condvar(l2), condvar(l3)
) (* end of [channel] *)
//
(* ****** ****** *)

assume channel_type (a:vt0p) = channel

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

implement{a}
channel_create_exn (cap) = let
//
val mut = mutex_create_exn ()
val CVisnil = condvar_create_exn ()
val CVisful = condvar_create_exn ()
val deq = deqarray_make_cap<a> (cap)
val deq = $UN.castvwtp0{ptr}(deq)
//
in
  CHANNEL (deq, cap, mut, CVisnil, CVisful)
end // end of [channel_create_exn]

(* ****** ****** *)
//
implement{}
channel_get_capacity (chan) =
  let val+CHANNEL(ptr, cap, _, _, _) = chan in cap end
//
(* ****** ****** *)
//
extern
fun{a:vt0p}
channel_insert2 (channel(a), !deqarray(a) >> _, a): void
extern
fun{a:vt0p}
channel_takeout2 (chan: channel(a), !deqarray(a) >> _): (a)
//
(* ****** ****** *)

implement{a}
channel_insert
  (chan, x0) = let
//
val+CHANNEL{l1,l2,l3}
  (deq, cap, mut, CVisnil, CVisful) = chan
val (pfmut | ()) = mutex_lock (mut)
val deq =
  $UN.castvwtp0{deqarray(a)}((pfmut | deq))
val ((*void*)) = channel_insert2<a> (chan, deq, x0)
prval pfmut = $UN.castview0{locked_v(l1)}(deq)
val ((*void*)) = mutex_unlock (pfmut | mut)
//
in
  // nothing
end // end of [channel_insert]

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

implement{a}
channel_insert2
  (chan, deq, x0) = let
//
val+CHANNEL{l1,l2,l3}
  (ptr, cap, mut, CVisnil, CVisful) = chan
//
val isnot = deqarray_isnot_full (deq)
prval ((*void*)) = lemma_deqarray_param (deq)
//
in
//
if
isnot
then let
  val isnil = deqarray_is_nil (deq)
  val ((*void*)) =
    deqarray_insert_atend (deq, x0)
  val ((*void*)) =
    if isnil then condvar_signal (CVisnil)
  // end of [val]
in
  // nothing
end // end of [then]
else let
  prval
  (pfmut, fpf) = __assert () where
  {
    extern
    praxi __assert (): vtakeout0(locked_v(l1))
  }
  val ((*void*)) = condvar_wait (pfmut | CVisful, mut)
  prval ((*void*)) = fpf (pfmut)
in
  channel_insert2 (chan, deq, x0)
end // end of [else]
//
end // end of [channel_insert2]

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

implement{a}
channel_takeout
  (chan) = x0 where
{
//
val+CHANNEL{l1,l2,l3}
  (deq, cap, mut, CVisnil, CVisful) = chan
val (pfmut | ()) = mutex_lock (mut)
val deq =
  $UN.castvwtp0{deqarray(a)}((pfmut | deq))
val x0 = channel_takeout2<a> (chan, deq)
prval pfmut = $UN.castview0{locked_v(l1)}(deq)
val ((*void*)) = mutex_unlock (pfmut | mut)
//
} // end of [channel_takeout2]

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

implement{a}
channel_takeout2
  (chan, deq) = let
//
val+CHANNEL{l1,l2,l3}
  (ptr, cap, mut, CVisnil, CVisful) = chan
//
val isnot = deqarray_isnot_nil (deq)
prval ((*void*)) = lemma_deqarray_param (deq)
//
in
//
if
isnot
then let
  val isful = deqarray_is_full (deq)
  val x0_out = deqarray_takeout_atbeg (deq)
  val ((*void*)) =
    if isful then condvar_signal (CVisful)
  // end of [val]
in
  x0_out
end // end of [then]
else let
  prval (pfmut, fpf) = __assert () where
  {
    extern
    praxi __assert (): vtakeout0(locked_v(l1))
  }
  val ((*void*)) = condvar_wait (pfmut | CVisnil, mut)
  prval ((*void*)) = fpf (pfmut)
in
  channel_takeout2 (chan, deq)
end // end of [else]
//
end // end of [channel_takeout2]

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

(* end of [channel.dats] *)

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

(*
** Copyright (C) 2013 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-2013-11:
// An array-based channel
//
(* ****** ****** *)

staload
UN = "prelude/SATS/unsafe.sats"

(* ****** ****** *)
//
staload "libats/SATS/athread.sats"
//
staload "libats/SATS/deqarray.sats"
//
(* ****** ****** *)

staload "./../SATS/channel.sats"

(* ****** ****** *)
//
datatype
channel = {
l1,l2,l3:agz
} CHANNEL of
(
  ptr(*buf*)
, size_t(*cap*)
, mutex(l1), condvar(l2), condvar(l3)
) (* end of [channel] *)
//
(* ****** ****** *)

assume channel_type (a:vt0p) = channel

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

implement{a}
channel_create_exn (cap) = let
//
val mut = mutex_create_exn ()
val CVisnil = condvar_create_exn ()
val CVisful = condvar_create_exn ()
val deq = deqarray_make_cap<a> (cap)
val deq = $UN.castvwtp0{ptr}(deq)
//
in
  CHANNEL (deq, cap, mut, CVisnil, CVisful)
end // end of [channel_create_exn]

(* ****** ****** *)
//
implement{}
channel_get_capacity (chan) =
  let val+CHANNEL(ptr, cap, _, _, _) = chan in cap end
//
(* ****** ****** *)

extern
fun{a:vt0p}
channel_insert2 (channel(a), !deqarray(a) >> _, a): void

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

implement{a}
channel_insert
  (chan, x0) = let
//
val+CHANNEL{l1,l2,l3}
  (deq, cap, mut, CVisnil, CVisful) = chan
val (pfmut | ()) = mutex_lock (mut)
val deq =
  $UN.castvwtp0{deqarray(a)}((pfmut | deq))
val ((*void*)) = channel_insert2<a> (chan, deq, x0)
prval pfmut = $UN.castview0{locked_v(l1)}(deq)
val ((*void*)) = mutex_unlock (pfmut | mut)
//
in
  // nothing
end // end of [channel_insert]

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

implement{a}
channel_insert2
  (chan, deq, x0) = let
//
val+CHANNEL{l1,l2,l3}
  (ptr, cap, mut, CVisnil, CVisful) = chan
//
val isnot = deqarray_isnot_full (deq)
prval ((*void*)) = lemma_deqarray_param (deq)
//
in
//
if
isnot
then let
  val isnil = deqarray_is_nil (deq)
  val ((*void*)) = deqarray_insert_atend (deq, x0)
  val ((*void*)) = if isnil then condvar_signal (CVisnil)
in
  // nothing
end // end of [then]
else let
  prval (pfmut, fpf) = __assert () where
  {
    extern praxi __assert (): vtakeout0(locked_v(l1))
  }
  val ((*void*)) = condvar_wait (pfmut | CVisful, mut)
  prval ((*void*)) = fpf (pfmut)
in
  channel_insert2 (chan, deq, x0)
end // end of [else]
//
end // end of [channel_insert2]

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

extern
fun{a:vt0p}
channel_takeout2 (channel(a), !deqarray(a) >> _): (a)

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

implement{a}
channel_takeout
  (chan) = x0 where
{
//
val+CHANNEL{l1,l2,l3}
  (deq, cap, mut, CVisnil, CVisful) = chan
val (pfmut | ()) = mutex_lock (mut)
val deq =
  $UN.castvwtp0{deqarray(a)}((pfmut | deq))
val x0 = channel_takeout2<a> (chan, deq)
prval pfmut = $UN.castview0{locked_v(l1)}(deq)
val ((*void*)) = mutex_unlock (pfmut | mut)
//
} // end of [channel_takeout2]

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

implement{a}
channel_takeout2
  (chan, deq) = let
//
val+CHANNEL{l1,l2,l3}
  (ptr, cap, mut, CVisnil, CVisful) = chan
//
val isnot = deqarray_isnot_nil (deq)
prval ((*void*)) = lemma_deqarray_param (deq)
//
in
//
if
isnot
then let
  val isful = deqarray_is_full (deq)
  val x0 = deqarray_takeout_atbeg (deq)
  val ((*void*)) = if isful then condvar_signal (CVisful)
in
  x0
end // end of [then]
else let
  prval (pfmut, fpf) = __assert () where
  {
    extern praxi __assert (): vtakeout0(locked_v(l1))
}
  val ((*void*)) = condvar_wait (pfmut | CVisnil, mut)
  prval ((*void*)) = fpf (pfmut)
in
  channel_takeout2 (chan, deq)
end // end of [else]
//
end // end of [channel_takeout2]

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

(* end of [channel.dats] *)