Updating: very very minorly

Updating: very very minorly

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

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

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
// HX-2014-08:
// prefix for external names
//
#define
ATS_EXTERN_PREFIX "ats2jspre_ML_"
#define
ATS_STATIC_PREFIX "_ats2jspre_ML_list0_"
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload "./../../basics_js.sats"
//
(* ****** ****** *)
//
staload "./../../SATS/integer.sats"
//
(* ****** ****** *)
//
staload "./../../SATS/print.sats"
staload "./../../SATS/filebas.sats"
//
(* ****** ****** *)
//
staload "./../../SATS/list.sats"
staload "./../../SATS/ML/list0.sats"
//
(* ****** ****** *)
//
#include "{$LIBATSCC}/DATS/ML/list0.dats"
//
(* ****** ****** *)
//
implement
list0_head_exn
  {a}(xs) =
(
case+ xs of
| list0_cons
    (x, _) => (x)
  // list0_cons
| list0_nil() =>
  (
    $extfcall(a, "ats2jspre_ListSubscriptExn_throw")
  ) (* list0_nil *)
) (* end of [list0_head_exn] *)
//
(* ****** ****** *)
//
implement
list0_tail_exn
  {a}(xs) =
(
case+ xs of
| list0_cons
    (_, xs) => (xs)
  // list0_cons
| list0_nil() =>
  (
    $extfcall
      (list0(a), "ats2jspre_ListSubscriptExn_throw")
    // $extfcall
  ) (* list0_nil *)
) (* end of [list0_tail_exn] *)
//
(* ****** ****** *)

implement
list0_get_at_exn
  {a}(xs, n) =
(
  case+ xs of
  | list0_nil() =>
    (
      $extfcall(a, "ats2jspre_ListSubscriptExn_throw")
    ) (* list0_nil *)
  | list0_cons(x, xs) =>
      if n > 0 then list0_get_at_exn(xs, n-1) else (x)
    // end of [list0_cons]
) (* end of [list0_get_at_exn] *)
//
(* ****** ****** *)

implement
list0_insert_at_exn
  {a}
(
  xs, i0, x0
) = aux(xs, i0) where
{
//
fun
aux
(
  xs: list0(a), i0: intGte(0)
) : list0(a) =
(
if
i0 > 0
then
(
case+ xs of
| list0_nil() =>
  $extfcall
    (list0(a), "ats2jspre_ListSubscriptExn_throw")
  // (* list0_nil *)
| list0_cons(x, xs) => list0_cons(x, aux(xs, i0-1))
)
else list0_cons(x0, xs)
) (* end of [aux] *)
//
} (* end of [list0_insert_at_exn] *)

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

implement
list0_remove_at_exn
  {a}
(
  xs, i0
) = aux(xs, i0) where
{
//
fun
aux
(
  xs: list0(a), i0: intGte(0)
) : list0(a) =
(
case+ xs of
| list0_nil() =>
  $extfcall
    (list0(a), "ats2jspre_ListSubscriptExn_throw")
  // (* list0_nil *)
| list0_cons(x, xs) =>
  if i0 > 0 then list0_cons(x, aux(xs, i0-1)) else xs
)
//
} (* end of [list0_remove_at_exn] *)

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

(* end of [list0.dats] *)

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

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

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
// HX-2014-08:
// prefix for external names
//
#define
ATS_EXTERN_PREFIX "ats2jspre_ML_"
#define
ATS_STATIC_PREFIX "_ats2jspre_ML_list0_"
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload "./../../basics_js.sats"
//
(* ****** ****** *)
//
staload "./../../SATS/integer.sats"
//
(* ****** ****** *)
//
staload "./../../SATS/print.sats"
staload "./../../SATS/filebas.sats"
//
(* ****** ****** *)
//
staload "./../../SATS/list.sats"
staload "./../../SATS/ML/list0.sats"
//
(* ****** ****** *)
//
#include "{$LIBATSCC}/DATS/ML/list0.dats"
//
(* ****** ****** *)
//
implement
list0_head_exn
  {a}(xs) =
(
case+ xs of
| list0_cons
    (x, _) => (x)
  // list0_cons
| list0_nil() =>
  (
    $extfcall(a, "ats2jspre_ListSubscriptExn_throw")
  ) (* list0_nil *)
) (* end of [list0_head_exn] *)
//
(* ****** ****** *)
//
implement
list0_tail_exn
  {a}(xs) =
(
case+ xs of
| list0_cons
    (_, xs) => (xs)
  // list0_cons
| list0_nil() =>
  (
    $extfcall(list0(a), "ats2jspre_ListSubscriptExn_throw")
  ) (* list0_nil *)
) (* end of [list0_tail_exn] *)
//
(* ****** ****** *)

implement
list0_get_at_exn
  {a}(xs, n) =
(
  case+ xs of
  | list0_nil() =>
    (
      $extfcall(a, "ats2jspre_ListSubscriptExn_throw")
    ) (* list0_nil *)
  | list0_cons(x, xs) =>
      if n > 0 then list0_get_at_exn(xs, n-1) else (x)
    // end of [list0_cons]
) (* end of [list0_get_at_exn] *)
//
(* ****** ****** *)

implement
list0_insert_at_exn
  {a}
(
  xs, i0, x0
) = aux(xs, i0) where
{
//
fun
aux
(
  xs: list0(a), i0: intGte(0)
) : list0(a) =
(
if
i0 > 0
then
(
case+ xs of
| list0_nil() =>
  $extfcall
    (list0(a), "ats2jspre_ListSubscriptExn_throw")
  // (* list0_nil *)
| list0_cons(x, xs) => list0_cons(x, aux(xs, i0-1))
)
else list0_cons(x0, xs)
) (* end of [aux] *)
//
} (* end of [list0_insert_at_exn] *)

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

implement
list0_remove_at_exn
  {a}
(
  xs, i0
) = aux(xs, i0) where
{
//
fun
aux
(
  xs: list0(a), i0: intGte(0)
) : list0(a) =
(
case+ xs of
| list0_nil() =>
  $extfcall
    (list0(a), "ats2jspre_ListSubscriptExn_throw")
  // (* list0_nil *)
| list0_cons(x, xs) =>
  if i0 > 0 then list0_cons(x, aux(xs, i0-1)) else xs
)
//
} (* end of [list0_remove_at_exn] *)

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

(* end of [list0.dats] *)


Use sequence expression

Use sequence expression

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

staload "{$TOP}/SATS/arduino.sats"
staload UN = "prelude/SATS/unsafe.sats"

#define LED 9
#define DELAY_MS 10.0

fun int_foreach_clo
  (n: natLt(256), f: &natLt(256) -<clo1> void): void =
  (f n; if n > 0 then int_foreach_clo (n - 1, f))

implement main () = {
  fun fadein() = let
    var fwork = lam@ (n: natLt(256)) =>
      (analogWrite (LED, n); delay_ms(DELAY_MS))
  in
    int_foreach_clo(255, fwork)
  end // end of [fadein]
  (* val () = init () *)
  val () = pinMode (LED, OUTPUT)
  val () = (fix f(): void => (fadein(); f()))()
}

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

staload "{$TOP}/SATS/arduino.sats"
staload UN = "prelude/SATS/unsafe.sats"

#define LED 9
#define DELAY_MS 10.0

fun int_foreach_clo
  (n: natLt(256), f: &natLt(256) -<clo1> void): void = {
  val () = f n
  val () = if n > 0 then int_foreach_clo (n - 1, f)
}

implement main () = {
  fun fadein() = let
    var fwork = lam@ (n: natLt(256)) => {
      val () = analogWrite (LED, n)
      val () = delay_ms(DELAY_MS)
    }
  in
    int_foreach_clo(255, fwork)
  end // end of [fadein]
  (* val () = init () *)
  val () = pinMode (LED, OUTPUT)
  val () = (fix f(): void => (fadein(); f()))()
}


Updating: a minor fix

Updating: a minor fix

(*
** The M-N-K-game
*)

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload "./game.sats"

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

assume
board_type = mtrxszref (int)

(* ****** ****** *)
//
implement
board_make (m, n) =
  mtrxszref_make_elt<int> (i2sz(m), i2sz(n), 0)
//
(* ****** ****** *)

fun
pid2char (id: int): char =
(
case+ id of
| 0 => ' ' | 1 => 'X' | 2 => 'O' | _ => '#'
) (* end of [pid2char] *)

(* ****** ****** *)
//
implement
fprint_board
  (out, board) = let
//
implement
fprint_val<int>
  (out, id) = fprint (out, pid2char(id))
//
val () = fprint (out, "|")
val () = fprint_mtrxszref_sep (out, board, "|", "|\n|")
val () = fprint (out, "|")
//
in
  // nothing
end // end of [fprint_board]
//
(* ****** ****** *)

// (*
val () = // testing code
{
//
val () =
println! ("TESTING(game_board):")
//
val () =
println! ("TESTING(fprint_board): beg")
val board = board_make (3, 3)
val ((*void*)) = fprint_board (stdout_ref, board)
val ((*void*)) = fprint_newline (stdout_ref)
val () =
println! ("TESTING(fprint_board): end")
} (* end of [val] *)
// *)

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

(* end of [game_board.dats] *)

(*
** The M-N-K-game
*)

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload "./game.sats"

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

assume
board_type = mtrxszref (int)

(* ****** ****** *)
//
implement
board_make (m, n) =
  mtrxszref_make_elt<int> (i2sz(m), i2sz(n), 0)
//
(* ****** ****** *)

fun
pid2char (id: int): char =
(
case+ id of
| 0 => ' ' | 1 => 'X' | 2 => 'O' | _ => '#'
) (* end of [pid2char] *)

(* ****** ****** *)
//
implement
fprint_board (out, board) =
  fprint_mtrxszref_sep (out, board, "|", "\n")
//
(* ****** ****** *)

// (*
val () = // testing code
{
//
val () =
println! ("TESTING(game_board):")
//
val () =
println! ("TESTING(fprint_board): beg")
val board = board_make (3, 3)
val ((*void*)) = fprint_board (stdout_ref, board)
val ((*void*)) = fprint_newline (stdout_ref)
val () =
println! ("TESTING(fprint_board): end")
} (* end of [val] *)
// *)

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

(* end of [game_board.dats] *)


Minor tweaks

Minor tweaks

(* ****** ****** *)
//
// chip8-sdl.dats
// Main file to run chip8 with an SDL frontend.
//
(* ****** ****** *)

%{^
typedef struct audio_queue_struct {
  unsigned int seconds;
  int first;
  struct audio_queue_struct *next;
} audio_queue;

audio_queue *aq_head = NULL;
audio_queue *aq_tail = NULL;

void audio_callback(void* userdata, unsigned char *stream, int len) {
  short* target = (short *) stream;

  while (len > 0 && aq_head != NULL) {
    audio_queue *data = aq_head;
    for (; len && data->first; target += 2, len -= 4, data->first -= 1)
      target[0] = target[1] = data->seconds * 300 * ((len & 128) - 64);
    if (!data->first) {
      aq_head = aq_head->next;
      if (aq_head == NULL) aq_tail = NULL;
    }
  }
}

SDL_AudioSpec *init_desired() {
  SDL_AudioSpec *desired = (SDL_AudioSpec *) malloc(sizeof(SDL_AudioSpec));
  desired->freq = 44100;
  desired->format = AUDIO_S16SYS;
  desired->channels = 2;
  desired->samples = desired->freq / 20;
  desired->callback = audio_callback;

  return desired;
}

SDL_AudioSpec *init_obtained() {
  SDL_AudioSpec *obtained = (SDL_AudioSpec *) malloc(sizeof(SDL_AudioSpec));

  return obtained;
}

void free_spec(SDL_AudioSpec *spec) { free(spec); }

int get_freq(SDL_AudioSpec *spec) { return spec->freq; }

void aq_enqueue(unsigned int seconds, int first) {
  if (aq_head == NULL) {
    aq_head = malloc(sizeof(audio_queue));
    aq_head->seconds = seconds;
    aq_head->first = first;
    aq_head->next = NULL;
    aq_tail = aq_head;
  } else {
    aq_tail->next = malloc(sizeof(audio_queue));
    aq_tail->next->seconds = seconds;
    aq_tail->next->first = first;
    aq_tail->next->next = NULL;
    aq_tail = aq_tail->next;
  }
}
%}

#include "./../mydepies.hats"
#include "./../staloadall.hats"

#define CHIP8_MAIN 1

local #include "./chip8-base.dats" in end
local #include "./chip8-mem.dats" in end
local #include "./chip8-font.dats" in end
local #include "./chip8-regs.dats" in end
local #include "./chip8-time.dats" in end
local #include "./chip8-stack.dats" in end
local #include "./chip8-scr.dats" in end
local #include "./chip8-inp.dats" in end
local #include "./chip8-loop.dats" in end

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

exception SDLException of (string)

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

local
  assume display_type = $SDL2.SDL_Window_ptr1
in
  implement init_display() = dpy where {
    val () = if $SDL2.SDL_Init($SDL2.SDL_INIT_EVERYTHING) > 0
      then $raise SDLException($SDL2.SDL_GetError())
    val dpy = $SDL2.SDL_CreateWindow(
          "Chip8",
          $SDL2.SDL_WINDOWPOS_UNDEFINED, $SDL2.SDL_WINDOWPOS_UNDEFINED,
          SCR_WIDTH * SCALE, SCR_HEIGHT * SCALE,
          $SDL2.SDL_WINDOW_SHOWN
        )
    val () = if $SDL2.ptrcast(dpy) = 0
      then $raise SDLException($SDL2.SDL_GetError())
    val () = assertloc($SDL2.ptrcast(dpy) > 0)
    val () = update_display(dpy)
  }

  implement close_display(dpy) = (
    $SDL2.SDL_DestroyWindow(dpy);
    $SDL2.SDL_Quit()
  )

  implement update_display(dpy) = () where {
    fun draw_x(surf: !$SDL2.SDL_Surface_ptr1, x: scr_x, y: scr_y): void =
      let
        var pix : $SDL2.SDL_Rect
        val () = pix.x := x * SCALE and () = pix.y := y * SCALE
        val () = pix.w := SCALE and () = pix.h := SCALE
        val color = if Scr(x, y) = b_0x1 then i2u(0xFFFFFF) else i2u(0x000000)
        val () = if $SDL2e.SDL_FillRect(surf, cptr_rvar(pix), color) > 0
          then $raise SDLException($SDL2.SDL_GetError())
      in
        if succ(x) < SCR_WIDTH then draw_x(surf, succ(x), y)
      end

    fun draw_y(surf: !$SDL2.SDL_Surface_ptr1, y: scr_y): void = (
      draw_x(surf, 0, y);
      if succ(y) < SCR_HEIGHT then draw_y(surf, succ(y))
    )

    val (fpf | surf) = $SDL2.SDL_GetWindowSurface(dpy)
    val () = if $SDL2.ptrcast(surf) = 0 then
      $raise SDLException($SDL2.SDL_GetError())
    val () = assertloc($SDL2.ptrcast(surf) > 0)
    val () = draw_y(surf, 0)
    prval () = fpf(surf)
    val () =  if $SDL2.SDL_UpdateWindowSurface(dpy) > 0 then
      $raise SDLException($SDL2.SDL_GetError())
  }
end

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

implement poll_kb() =
  let
    overload = with $SDL2.SDL_EventType_equal
    var event : $SDL2.SDL_Event?
    val res = $SDL2.SDL_PollEvent(event)
    prval () = if res > 0 then opt_unsome(event) else opt_unnone(event)
    val event = $UN.cast{$SDL2.SDL_Event}(event)
    val evtp = event.type
  in
    if evtp = $SDL2.SDL_QUIT then quit()
    else if evtp = $SDL2.SDL_KEYUP || evtp = $SDL2.SDL_KEYDOWN then
      let
        val key_sym = $SDL2e.GetKeysym(event)
        val key = (
          ifcase
            | key_sym = $SDL2e.SDLK_ESCAPE => 0x10
            | key_sym = $SDL2e.SDLK_1 => 0x1
            | key_sym = $SDL2e.SDLK_2 => 0x2
            | key_sym = $SDL2e.SDLK_3 => 0x3
            | key_sym = $SDL2e.SDLK_4 => 0xF
            | key_sym = $SDL2e.SDLK_q => 0x4
            | key_sym = $SDL2e.SDLK_w => 0x5
            | key_sym = $SDL2e.SDLK_e => 0x6
            | key_sym = $SDL2e.SDLK_r => 0xE
            | key_sym = $SDL2e.SDLK_a => 0x7
            | key_sym = $SDL2e.SDLK_s => 0x8
            | key_sym = $SDL2e.SDLK_d => 0x9
            | key_sym = $SDL2e.SDLK_f => 0xD
            | key_sym = $SDL2e.SDLK_z => 0xA
            | key_sym = $SDL2e.SDLK_x => 0x0
            | key_sym = $SDL2e.SDLK_c => 0xB
            | key_sym = $SDL2e.SDLK_v => 0xC
            | _                => ~1
          ) : int
      in
        if key = ~1 then ()
        else if key = 0x10 then quit()
        else
          let
              val key = $UN.cast{nkey}(key)
          in
            if evtp = $SDL2.SDL_KEYUP then release_key(key)
            else press_key(key)
          end
    end
end

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

local
  absvtype mixer_ptr(l:addr) = ptr(l)
  vtypedef mixer_ptr0 = [l:agez] mixer_ptr(l)
  vtypedef mixer_ptr1 = [l:addr | l > null] mixer_ptr(l)
  assume mixer_type = mixer_ptr1

  extern fun queue_audio(uint, bool): void = "mac#aq_enqueue"
in
  implement init_mixer() = obtained where {
    extern fun init_desired(): mixer = "mac#init_desired"
    extern fun init_obtained(): mixer = "mac#init_obtained"
    extern fun SDL_OpenAudio(mixer, !mixer): int = "mac#SDL_OpenAudio"

    val desired = init_desired()
    val obtained = init_obtained()
    val () = if SDL_OpenAudio(desired, obtained) > 0 then
      fprintln!(stderr_ref, "Failed to open SDL2 audio.")
    val () = $SDL2e.SDL_PauseAudio(0)
  }

  implement close_mixer(mxr) = free_spec(mxr) where {
    extern fun free_spec(mixer): void = "mac#free_spec"
  }

  implement update_mixer(mxr, frames) = () where {
    extern fun get_freq(!mixer): int = "mac#get_freq"

    val freq = g0i2u(get_freq(mxr))
    val () = $SDL2e.SDL_LockAudio()
    val () = queue_audio(freq * g0i2u(b2i(ST.get())) / i2u(60), true)
    val () = queue_audio(freq * g0i2u(frames - b2i(ST.get())) / i2u(60), false)
    val () = $SDL2e.SDL_UnlockAudio()
  }
end
(* ****** ****** *)

local
  assume game_info_type = string
in
  implement load_game(info) =
    let
      fun loop(data: stream_vt(char), n: imem): void =
        case+ !data of
        | ~stream_vt_nil() => ()
        | ~stream_vt_cons(c, rest) => (
            Mem(n, c2b(c));
            if succ(n) < MEM_SIZE then loop(rest, succ(n))
            else (stream_vt_free(rest); $raise GameTooLarge())
          )

      val data = fileref_open_opt(info, file_mode_r)
    in
      case+ data of
        | ~None_vt() => $raise GameNotFound()
        | ~Some_vt(data) => loop(streamize_fileref_char(data), PC_START)
    end

  implement main0(argc, argv) = () where {
    val () = if argc != 2 then (
        if argc = 1 then fprintln!(stderr_ref, "chip8: no game specified")
        else fprintln!(stderr_ref, "chip8: Unknown arguments");
        exit(1)
    )

    val () = assertloc(argc = 2)
    val () = load_font()
    val () = load_game(argv[1])
    val () = PC.set(i2w(PC_START))
    val () = init_clock()
    val dpy = init_display()
    val mxr = init_mixer()
    val () = game_loop(dpy, mxr)
    val () = close_display(dpy)
    val () = close_mixer(mxr)
  }
end

(* End of [chip8-sdl.dats] *)

(* ****** ****** *)
//
// chip8-sdl.dats
// Main file to run chip8 with an SDL frontend.
//
(* ****** ****** *)

%{^
typedef struct audio_queue_struct {
  unsigned int seconds;
  int first;
  struct audio_queue_struct *next;
} audio_queue;

audio_queue *aq_head = NULL;
audio_queue *aq_tail = NULL;

void audio_callback(void* userdata, unsigned char *stream, int len) {
  short* target = (short *) stream;

  while (len > 0 && aq_head != NULL) {
    audio_queue *data = aq_head;
    for (; len && data->first; target += 2, len -= 4, data->first -= 1)
      target[0] = target[1] = data->seconds * 300 * ((len & 128) - 64);
    if (!data->first) {
      aq_head = aq_head->next;
      if (aq_head == NULL) aq_tail = NULL;
    }
  }
}

SDL_AudioSpec *init_desired() {
  SDL_AudioSpec *desired = (SDL_AudioSpec *) malloc(sizeof(SDL_AudioSpec));
  desired->freq = 44100;
  desired->format = AUDIO_S16SYS;
  desired->channels = 2;
  desired->samples = desired->freq / 20;
  desired->callback = audio_callback;

  return desired;
}

SDL_AudioSpec *init_obtained() {
  SDL_AudioSpec *obtained = (SDL_AudioSpec *) malloc(sizeof(SDL_AudioSpec));

  return obtained;
}

void free_spec(SDL_AudioSpec *spec) { free(spec); }

int get_freq(SDL_AudioSpec *spec) { return spec->freq; }

void aq_enqueue(unsigned int seconds, int first) {
  if (aq_head == NULL) {
    aq_head = malloc(sizeof(audio_queue));
    aq_head->seconds = seconds;
    aq_head->first = first;
    aq_head->next = NULL;
    aq_tail = aq_head;
  } else {
    aq_tail->next = malloc(sizeof(audio_queue));
    aq_tail->next->seconds = seconds;
    aq_tail->next->first = first;
    aq_tail->next->next = NULL;
    aq_tail = aq_tail->next;
  }
}
%}

#include "./../mydepies.hats"
#include "./../staloadall.hats"

#define CHIP8_MAIN 1

local #include "./chip8-base.dats" in end
local #include "./chip8-mem.dats" in end
local #include "./chip8-font.dats" in end
local #include "./chip8-regs.dats" in end
local #include "./chip8-time.dats" in end
local #include "./chip8-stack.dats" in end
local #include "./chip8-scr.dats" in end
local #include "./chip8-inp.dats" in end
local #include "./chip8-loop.dats" in end

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

exception SDLException of (string)

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

local
  assume display_type = $SDL2.SDL_Window_ptr1
in
  implement init_display() = dpy where {
    val () = if $SDL2.SDL_Init($SDL2.SDL_INIT_EVERYTHING) > 0
      then $raise SDLException($SDL2.SDL_GetError())
    val dpy = $SDL2.SDL_CreateWindow(
          "Chip8",
          $SDL2.SDL_WINDOWPOS_UNDEFINED, $SDL2.SDL_WINDOWPOS_UNDEFINED,
          SCR_WIDTH * SCALE, SCR_HEIGHT * SCALE,
          $SDL2.SDL_WINDOW_SHOWN
        )
    val () = if $SDL2.ptrcast(dpy) = 0
      then $raise SDLException($SDL2.SDL_GetError())
    val () = assertloc($SDL2.ptrcast(dpy) > 0)
    val () = update_display(dpy)
  }

  implement close_display(dpy) = (
    $SDL2.SDL_DestroyWindow(dpy);
    $SDL2.SDL_Quit()
  )

  implement update_display(dpy) = () where {
    fun draw_x(surf: !$SDL2.SDL_Surface_ptr1, x: scr_x, y: scr_y): void =
      let
        var pix : $SDL2.SDL_Rect
        val () = pix.x := x * SCALE and () = pix.y := y * SCALE
        val () = pix.w := SCALE and () = pix.h := SCALE
        val color = if Scr(x, y) = b_0x1 then i2u(0xFFFFFF) else i2u(0x000000)
        val () = if $SDL2e.SDL_FillRect(surf, cptr_rvar(pix), color) > 0
          then $raise SDLException($SDL2.SDL_GetError())
      in
        if succ(x) < SCR_WIDTH then draw_x(surf, succ(x), y)
      end

    fun draw_y(surf: !$SDL2.SDL_Surface_ptr1, y: scr_y): void = (
      draw_x(surf, 0, y);
      if succ(y) < SCR_HEIGHT then draw_y(surf, succ(y))
    )

    val (fpf | surf) = $SDL2.SDL_GetWindowSurface(dpy)
    val () = if $SDL2.ptrcast(surf) = 0 then
      $raise SDLException($SDL2.SDL_GetError())
    val () = assertloc($SDL2.ptrcast(surf) > 0)
    val () = draw_y(surf, 0)
    prval () = fpf(surf)
    val () =  if $SDL2.SDL_UpdateWindowSurface(dpy) > 0 then
      $raise SDLException($SDL2.SDL_GetError())
  }
end

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

implement poll_kb() =
  let
    overload = with $SDL2.SDL_EventType_equal
    var event : $SDL2.SDL_Event?
    val res = $SDL2.SDL_PollEvent(event)
    prval () = if res > 0 then opt_unsome(event) else opt_unnone(event)
    val event = $UN.cast{$SDL2.SDL_Event}(event)
    val evtp = event.type
  in
    if evtp = $SDL2.SDL_QUIT then quit()
    else if evtp = $SDL2.SDL_KEYUP || evtp = $SDL2.SDL_KEYDOWN then
      let
        val key_sym = $SDL2e.GetKeysym(event)
        val key = (
          ifcase
            | key_sym = $SDL2e.SDLK_ESCAPE => 0x10
            | key_sym = $SDL2e.SDLK_1 => 0x1
            | key_sym = $SDL2e.SDLK_2 => 0x2
            | key_sym = $SDL2e.SDLK_3 => 0x3
            | key_sym = $SDL2e.SDLK_4 => 0xF
            | key_sym = $SDL2e.SDLK_q => 0x4
            | key_sym = $SDL2e.SDLK_w => 0x5
            | key_sym = $SDL2e.SDLK_e => 0x6
            | key_sym = $SDL2e.SDLK_r => 0xE
            | key_sym = $SDL2e.SDLK_a => 0x7
            | key_sym = $SDL2e.SDLK_s => 0x8
            | key_sym = $SDL2e.SDLK_d => 0x9
            | key_sym = $SDL2e.SDLK_f => 0xD
            | key_sym = $SDL2e.SDLK_z => 0xA
            | key_sym = $SDL2e.SDLK_x => 0x0
            | key_sym = $SDL2e.SDLK_c => 0xB
            | key_sym = $SDL2e.SDLK_v => 0xC
            | _                => ~1
          ) : int
      in
        if key = ~1 then ()
        else if key = 0x10 then quit()
        else
          let
              val key = $UN.cast{nkey}(key)
          in
            if evtp = $SDL2.SDL_KEYUP then release_key(key)
            else press_key(key)
          end
    end
end

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

local
  absvtype mixer_ptr(l:addr) = ptr(l)
  vtypedef mixer_ptr0 = [l:agez] mixer_ptr(l)
  vtypedef mixer_ptr1 = [l:addr | l > null] mixer_ptr(l)
  assume mixer_type = mixer_ptr1

  extern fun queue_audio(uint, bool): void = "mac#aq_enqueue"
in
  implement init_mixer() = obtained where {
    extern fun init_desired(): mixer = "mac#init_desired"
    extern fun init_obtained(): mixer = "mac#init_obtained"
    extern fun SDL_OpenAudio(mixer, !mixer): int = "mac#SDL_OpenAudio"

    val desired = init_desired()
    val obtained = init_obtained()
    val () = if SDL_OpenAudio(desired, obtained) > 0 then
      fprintln!(stderr_ref, "Failed to open SDL2 audio.")
    val () = $SDL2e.SDL_PauseAudio(0)
  }

  implement close_mixer(mxr) = free_spec(mxr) where {
    extern fun free_spec(mixer): void = "mac#free_spec"
  }

  implement update_mixer(mxr, frames) = () where {
    extern fun get_freq(!mixer): int = "mac#get_freq"

    val freq = g0i2u(get_freq(mxr))
    val () = $SDL2e.SDL_LockAudio()
    val () = queue_audio(freq * g0i2u(b2i(ST.get())) / i2u(60), true)
    val () = queue_audio(freq * g0i2u(frames - b2i(ST.get())) / i2u(60), false)
    val () = $SDL2e.SDL_UnlockAudio()
  }
end
(* ****** ****** *)

local
  assume game_info_type = string
in
  fun load_game(info) =
    let
      fun loop(data: stream_vt(char), n: imem): void =
        case+ !data of
        | ~stream_vt_nil() => ()
        | ~stream_vt_cons(c, rest) => (
            Mem(n, c2b(c));
            if succ(n) < MEM_SIZE then loop(rest, succ(n))
            else (stream_vt_free(rest); $raise GameTooLarge())
          )

      val data = fileref_open_opt(info, file_mode_r)
    in
      case+ data of
        | ~None_vt() => $raise GameNotFound()
        | ~Some_vt(data) => loop(streamize_fileref_char(data), PC_START)
    end
end

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

implement main0(argc, argv) = () where {
  val () = if argc != 2 then (
      if argc = 1 then fprintln!(stderr_ref, "chip8: no game specified")
      else fprintln!(stderr_ref, "chip8: Unknown arguments");
      exit(1)
  )

  val () = assertloc(argc = 2)
  val () = load_font()
  val () = load_game(argv[1])
  val () = PC.set(i2w(PC_START))
  val () = init_clock()
  val dpy = init_display()
  val mxr = init_mixer()
  val () = game_loop(dpy, mxr)
  val () = close_display(dpy)
  val () = close_mixer(mxr)
}

(* End of [chip8-sdl.dats] *)


More Hongwei comment into github issue

More Hongwei comment into github issue

#include "share/atspre_staload.hats"

%{^
// #include <avr/io.h>
#include <util/delay.h>
%}

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

#define DDRB_OUT       int2char0 0xff
#define PORTB_LEDON    int2char0 0xff
#define PORTB_LEDOFF   int2char0 0x00
#define BLINK_DELAY_MS 500.0

macdef DDRB_PTR  = $extval(ptr, "(0x04 + 0x20)") (* Only for Arduino Mega 2560 *)
macdef PORTB_PTR = $extval(ptr, "(0x05 + 0x20)") (* Only for Arduino Mega 2560 *)

extern fun c_delay_ms (ms: double): void = "mac#_delay_ms"

implement main0 () = {
  fun loop (): void = {
    val () = $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDON)
    val () = c_delay_ms (BLINK_DELAY_MS)
    val () = $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDOFF)
    val () = c_delay_ms (BLINK_DELAY_MS)
    val () = loop ()
  }
  val () = $UN.ptr0_set<char> (DDRB_PTR, DDRB_OUT)
  val () = loop ()
}

#include "share/atspre_staload.hats"

%{^
// #include <avr/io.h>
#include <util/delay.h>
%}

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

#define DDRB_OUT       int2char0 0xff
#define PORTB_LEDON    int2char0 0xff
#define PORTB_LEDOFF   int2char0 0x00
#define BLINK_DELAY_MS 500.0

macdef DDRB_PTR  = $extval(ptr, "(0x04 + 0x20)") (* Only for Arduino Mega 2560 *)
macdef PORTB_PTR = $extval(ptr, "(0x05 + 0x20)") (* Only for Arduino Mega 2560 *)

(*
xxx Hongwei comment xxx

https://github.com/githwxi/ATS-Postiats/issues/3#issuecomment-42682765

Maybe it makes sense to introduce an abstract type here:

abstype PORTBval_t = int8
macdef PORTB_LEDON = $extval(PORTBval_t, "0xff")
macdef PORTB_LEDOFF = $extval(PORTBval_t, "0xff")

PORTB_get and PORTB_set can be implemented as templates:

extern
fun{} PORTB_get (): PORTBval_t
extern
fun{} PORTB_set (v: PORTBval_t): void

This will allow you to re-implement them for different chip models.
*)

extern fun c_delay_ms (ms: double): void = "mac#_delay_ms"

implement main0 () = {
  fun loop (): void = {
    val () = $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDON)
    val () = c_delay_ms (BLINK_DELAY_MS)
    val () = $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDOFF)
    val () = c_delay_ms (BLINK_DELAY_MS)
    val () = loop ()
  }
  val () = $UN.ptr0_set<char> (DDRB_PTR, DDRB_OUT)
  val () = loop ()
}


Updating: very minorly improving

Updating: very minorly improving

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: February, 2016
//
(* ****** ****** *)

(*
proctype
Agent(chan listen; chan talk)
{
    do
    :: talk!hold(listen)
    :: talk!deny(listen) -> break
    :: talk!grant(listen) ->
        wait:
        listen?return0; break
    od;
    server!return0(listen)
}
*)

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

abstype channel

(* ****** ****** *)
//
extern
fun
channel_recv{a:type}(channel): a
extern
fun
channel_send{a:type}(channel, a): void
//
extern
fun
channel_create(cap: intGte(0)): channel
//
(* ****** ****** *)
//
datatype
AgentReply =
| DENY of (channel)
| HOLD of (channel)
| GRANT of (channel)
//
datatype ClientReply = RETURN0 of ()
datatype ClientRequest = REQUEST0 of (channel)
//
(* ****** ****** *)
//
val
theServer = channel_create(0)
//
(* ****** ****** *)
//
extern
fun
Agent
(
  agent: channel, client: channel
) : void // end of [Agent]
//
(* ****** ****** *)

extern val RAND: int

(* ****** ****** *)
//
implement
Agent(agent, client) = (
//
case RAND of
| 0 => let
    val () =
    channel_send(client, HOLD(agent))
  in
    Agent(agent, client)
  end // end of [_]
| 1 =>
    channel_send(client, DENY(agent))
| _ => let
    val () =
    channel_send(client, GRANT(agent))
    val-RETURN0() =
      channel_recv{ClientReply}(agent)
    // end of [val]
  in
    // break
  end // end of [_]
//
) (* end of [Agent] *)
//
(* ****** ****** *)

(*
#define M 2
active [M] proctype Client()
{
    chan me = [0] of { mtype, chan };
    chan agent;
end:
    do
    :: timeout ->
        server!request(me);
        do
        :: me?hold(agent)
        :: me?deny(agent) -> break
        :: me?grant(agent) -> agent!return0; break
        od
    od
}
*)

(* ****** ****** *)
//
extern
fun Client(): void
//
(* ****** ****** *)
//
implement
Client() = let
//
fun
loop
(
  client: channel
) : void =
(
//
case+ RAND of
| _ => let
    val () =
    channel_send(theServer, REQUEST0(client))
  in
    loop2(client)
  end // end of [loop]
//
) (* end of [loop] *)
//
and
loop2
(
  client: channel
) : void = let
  val opt = channel_recv{AgentReply}(client)
in
//
case+ opt of
| DENY(agent) => ()
| HOLD(agent) => loop2(client)
| GRANT(agent) => channel_send(agent, RETURN0())
//
end // end of [loop2]
//
in
  loop(channel_create(0))
end // end of [Client]

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

(* end of [ClientServer-1.dats] *)

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: February, 2016
//
(* ****** ****** *)

(*
proctype
Agent(chan listen; chan talk)
{
    do
    :: talk!hold(listen)
    :: talk!deny(listen) -> break
    :: talk!grant(listen) ->
        wait:
        listen?return0; break
    od;
    server!return0(listen)
}
*)

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

abstype channel

(* ****** ****** *)
//
extern
fun
channel_recv{a:type}(channel): a
extern
fun
channel_send{a:type}(channel, a): void
//
extern
fun
channel_create(cap: intGte(0)): channel
//
(* ****** ****** *)
//
datatype
AgentReply =
| DENY of (channel)
| HOLD of (channel)
| GRANT of (channel)
//
datatype ClientReply = RETURN0 of ()
datatype ClientRequest = REQUEST0 of (channel)
//
(* ****** ****** *)
//
val
theServer = channel_create(0)
//
(* ****** ****** *)
//
extern
fun
Agent
(
  agent: channel, client: channel
) : void // end of [Agent]
//
(* ****** ****** *)

extern val RAND: int

(* ****** ****** *)
//
implement
Agent(agent, client) = (
//
case RAND of
| 0 => let
    val () =
    channel_send(client, HOLD(agent))
  in
    Agent(agent, client)
  end // end of [_]
| 1 =>
    channel_send(client, DENY(agent))
| _ => let
    val () =
    channel_send(client, GRANT(agent))
    val-RETURN0() =
      channel_recv{ClientReply}(agent)
    // end of [val]
  in
    // break
  end // end of [_]
//
) (* end of [Agent] *)
//
(* ****** ****** *)

(*
#define M 2
active [M] proctype Client()
{
    chan me = [0] of { mtype, chan };
    chan agent;
end:
    do
    :: timeout ->
        server!request(me);
        do
        :: me?hold(agent)
        :: me?deny(agent) -> break
        :: me?grant(agent) -> agent!return0; break
        od
    od
}
*)

(* ****** ****** *)
//
extern
fun Client(): void
//
(* ****** ****** *)
//
implement
Client() = let
//
val
client = channel_create(0)
//
fun
loop
(
  client: channel
) : void =
(
//
case+ RAND of
| _ => let
    val () =
    channel_send(theServer, REQUEST0(client))
  in
    loop2(client)
  end // end of [loop]
//
) (* end of [loop] *)
//
and
loop2
(
  client: channel
) : void = let
  val opt = channel_recv{AgentReply}(client)
in
//
case+ opt of
| DENY(agent) => ()
| HOLD(agent) => loop2(client)
| GRANT(agent) => channel_send(agent, RETURN0())
//
end // end of [loop2]
//
in
end // end of [Client]

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

(* end of [ClientServer-1.dats] *)


Updating: very very minorly

Updating: very very minorly

(*
** Tetris
*)

(* ****** ****** *)
//
#define
ATS_STATIC_PREFIX "tetris2_"
//
(* ****** ****** *)

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "tetris2_initize"

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
staload
"{$LIBATSCC2JS}/SATS/Bacon.js/baconjs.sats"
//
(* ****** ****** *)
//
staload (*opened*) "./tetris.sats"
//
(* ****** ****** *)
//
%{^
//
var
theKeyDowns =
  $(document).asEventStream("keydown")
//
var
theKeyDowns =
theKeyDowns.doAction(".preventDefault")
//
%} // end of ...
//
(* ****** ****** *)
//
%{^
//
var theStage = 0;
var theStageNP = 0;
//
function
theGame_tick(event)
{
  thePiece_handle_if();
  theStage.update(); theStageNP.update(); return;
}
//
function
theGame_initize()
{
  theStage = new createjs.Stage("theGameCanvas_main");
  theStageNP = new createjs.Stage("theGameCanvas_np"); // theNextPiece
  createjs.Ticker.addEventListener("tick", theGame_tick);
}
//
function
theScore_incby(delta)
{
    var
    score_well =
    document.getElementById("score_well");
    score_well.innerHTML =
    String(parseInt(score_well.innerHTML)+delta);
}
function
theScore_reset(score)
{
    document.getElementById("score_well").innerHTML = score;
}
//
%}
//
val () =
theGame_initize() where
  { extern fun theGame_initize(): void = "mac#" }
//
(* ****** ****** *)
//
%{^
//
function
theStage_addChild(x)
{
  theStage.addChild(x.createjs); return;
}
//
function
theStage_removeChild(x)
{
  theStage.removeChild(x.createjs); return;
}
//
function
theStageNP_addChild(x)
{
  theStageNP.addChild(x.createjs); return;
}
//
function
theStageNP_removeChild(x)
{
  theStageNP.removeChild(x.createjs); return;
}
//
%} // end of [%{^]
//
(* ****** ****** *)

local
//
val
theGameStatus = ref{int}(0)
//
in (* in-of-local *)

implement
theGameStatus_get() = theGameStatus[]
implement
theGameStatus_set(x) = theGameStatus[] := x

end // end of [local]

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

local
//
val
theGameTQuota0 = ref{double}(100.0)
val
theGameTQuota_left = ref{double}(100.0)
val
theGameTQuota_delta0 = ref{double}(15.0)
val
theGameTQuota_delta1 = ref{double}(15.0)
//
in
//
implement
theGameTQuota_get() = theGameTQuota_left[]
//
implement
theGameTQuota_reset
  ((*void*)) =
{
  val () = theGameTQuota_left[] := theGameTQuota0[]
}
implement
theGameTQuota_update
  ((*void*)) = let
  val left = theGameTQuota_left[]
in
  theGameTQuota_left[] := left - theGameTQuota_delta1[]
end // end of [theGameTQuota_update]
//
implement
theGameTQuota_delta_space
  ((*void*)) =
{
  val () = theGameTQuota_delta1[] := 101.0
}
implement
theGameTQuota_delta_reset
  ((*void*)) =
{
  val () = theGameTQuota_delta1[] := theGameTQuota_delta0[]
}
//
end // end of [local]

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

local

val nprev = ref{int}(0)

in (* in-of-local *)

fun
theScore_getinc_delta
  ((*void*)): int = let
  val np = nprev[]
  val () = nprev[] := np + 1
in
  case+ np of
  | 1 => 20 | 2 => 40 | 3 => 80 | _ => 10
end // end-of-function

fun theScore_reset_delta(): void = nprev[] := 0

end // end of [local]

(* ****** ****** *)
//
extern
fun
thePiece_handle(): void = "mac#"
implement
thePiece_handle() = let
//
val P0 = thePiece_get()
//
val moved = Piece_ymove_dn(P0)
//
val () = if not(moved) then Piece_dump_blocks(P0)
val () = if not(moved) then theGameTQuota_delta_reset()
val () = if not(moved) then thePiece_theNextPiece_update()
//
in
  // nothing
end // end of [thePiece_handle]
//
extern
fun
thePiece_handle_if(): void = "mac#"
implement
thePiece_handle_if() =
(
//
if
theGameStatus_get() > 0
then let
  val rowdel = theGameBoard_rowdel_one()
in
//
if
(rowdel)
then let
  val delta = theScore_getinc_delta()
in
  $extfcall(void, "theScore_incby", delta)
end // end of [then]
else let
  val () =
    theScore_reset_delta()
  // end of [val]
  val () =
    theGameTQuota_update()
  // end of [val]
  val tq = theGameTQuota_get()
in
//
if
tq > 0.0
then ((*void*))
else (theGameTQuota_reset(); thePiece_handle())
//
end // end of [else]
//
end // end of [then]
//
) (* end of [thePiece_handle_if] *)
//
(* ****** ****** *)
//
implement
theGame_play() =
if
(theGameStatus_get() = 0)
then
{
//
  val () = theGameBoard_clear()
  val () = theGameStatus_set(1)
//
  val () = thePiece_theNextPiece_update()
//
  val () = theScore_reset_delta()
//
  val () = $extfcall(void, "theScore_reset", 0)
//
}
//
(* ****** ****** *)
//
implement
theGame_stop() =
{
  val () = theGameStatus_set(0)
  val () = thePiece_dump_blocks()
  val () = theGameTQuota_reset()
}
//
(* ****** ****** *)
//
local
#include "./tetris2_block.dats"
in (*nothing*) end
//
local
#include "./tetris2_piece.dats"
in (*nothing*) end
//
local
#include "./tetris2_keyboard.dats"
in (*nothing*) end
//
local
#include "./tetris2_gameboard.dats"
in (*nothing*) end
//
(* ****** ****** *)

(* end of [tetris2.dats] *)

(*
** Tetris
*)

(* ****** ****** *)
//
#define
ATS_STATIC_PREFIX "tetris2_"
//
(* ****** ****** *)

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "tetris2_initize"

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
staload (*opened*) "./tetris.sats"
//
(* ****** ****** *)
//
#include "{$LIBATSCC2JS}/staloadall.hats"
//
staload
"{$LIBATSCC2JS}/SATS/Bacon.js/baconjs.sats"
//
(* ****** ****** *)
//
%{^
//
var
theKeyDowns =
  $(document).asEventStream("keydown")
//
var
theKeyDowns =
theKeyDowns.doAction(".preventDefault")
//
%} // end of ...
//
(* ****** ****** *)
//
%{^
//
var theStage = 0;
var theStageNP = 0;
//
function
theGame_tick(event)
{
  thePiece_handle_if();
  theStage.update(); theStageNP.update(); return;
}
//
function
theGame_initize()
{
  theStage = new createjs.Stage("theGameCanvas_main");
  theStageNP = new createjs.Stage("theGameCanvas_np"); // theNextPiece
  createjs.Ticker.addEventListener("tick", theGame_tick);
}
//
function
theScore_incby(delta)
{
    var
    score_well =
    document.getElementById("score_well");
    score_well.innerHTML =
    String(parseInt(score_well.innerHTML)+delta);
}
function
theScore_reset(score)
{
    document.getElementById("score_well").innerHTML = score;
}
//
%}
//
val () =
theGame_initize() where
  { extern fun theGame_initize(): void = "mac#" }
//
(* ****** ****** *)
//
%{^
//
function
theStage_addChild(x)
{
  theStage.addChild(x.createjs); return;
}
//
function
theStage_removeChild(x)
{
  theStage.removeChild(x.createjs); return;
}
//
function
theStageNP_addChild(x)
{
  theStageNP.addChild(x.createjs); return;
}
//
function
theStageNP_removeChild(x)
{
  theStageNP.removeChild(x.createjs); return;
}
//
%} // end of [%{^]
//
(* ****** ****** *)

local
//
val
theGameStatus = ref{int}(0)
//
in (* in-of-local *)

implement
theGameStatus_get() = theGameStatus[]
implement
theGameStatus_set(x) = theGameStatus[] := x

end // end of [local]

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

local
//
val
theGameTQuota0 = ref{double}(100.0)
val
theGameTQuota_left = ref{double}(100.0)
val
theGameTQuota_delta0 = ref{double}(15.0)
val
theGameTQuota_delta1 = ref{double}(15.0)
//
in
//
implement
theGameTQuota_get() = theGameTQuota_left[]
//
implement
theGameTQuota_reset
  ((*void*)) =
{
  val () = theGameTQuota_left[] := theGameTQuota0[]
}
implement
theGameTQuota_update
  ((*void*)) = let
  val left = theGameTQuota_left[]
in
  theGameTQuota_left[] := left - theGameTQuota_delta1[]
end // end of [theGameTQuota_update]
//
implement
theGameTQuota_delta_space
  ((*void*)) =
{
  val () = theGameTQuota_delta1[] := 101.0
}
implement
theGameTQuota_delta_reset
  ((*void*)) =
{
  val () = theGameTQuota_delta1[] := theGameTQuota_delta0[]
}
//
end // end of [local]

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

local

val nprev = ref{int}(0)

in (* in-of-local *)

fun
theScore_getinc_delta
  ((*void*)): int = let
  val np = nprev[]
  val () = nprev[] := np + 1
in
  case+ np of
  | 1 => 20 | 2 => 40 | 3 => 80 | _ => 10
end // end-of-function

fun theScore_reset_delta(): void = nprev[] := 0

end // end of [local]

(* ****** ****** *)
//
extern
fun
thePiece_handle(): void = "mac#"
implement
thePiece_handle() = let
//
val P0 = thePiece_get()
//
val moved = Piece_ymove_dn(P0)
//
val () = if not(moved) then Piece_dump_blocks(P0)
val () = if not(moved) then theGameTQuota_delta_reset()
val () = if not(moved) then thePiece_theNextPiece_update()
//
in
  // nothing
end // end of [thePiece_handle]
//
extern
fun
thePiece_handle_if(): void = "mac#"
implement
thePiece_handle_if() =
(
//
if
theGameStatus_get() > 0
then let
  val rowdel = theGameBoard_rowdel_one()
in
//
if
(rowdel)
then let
  val delta = theScore_getinc_delta()
in
  $extfcall(void, "theScore_incby", delta)
end // end of [then]
else let
  val () =
    theScore_reset_delta()
  // end of [val]
  val () =
    theGameTQuota_update()
  // end of [val]
  val tq = theGameTQuota_get()
in
//
if
tq > 0.0
then ((*void*))
else (theGameTQuota_reset(); thePiece_handle())
//
end // end of [else]
//
end // end of [then]
//
) (* end of [thePiece_handle_if] *)
//
(* ****** ****** *)
//
implement
theGame_play() =
if
(theGameStatus_get() = 0)
then
{
//
  val () = theGameBoard_clear()
  val () = theGameStatus_set(1)
//
  val () = thePiece_theNextPiece_update()
//
  val () = theScore_reset_delta()
//
  val () = $extfcall(void, "theScore_reset", 0)
//
}
//
(* ****** ****** *)
//
implement
theGame_stop() =
{
  val () = theGameStatus_set(0)
  val () = thePiece_dump_blocks()
  val () = theGameTQuota_reset()
}
//
(* ****** ****** *)
//
local
#include "./tetris2_block.dats"
in (*nothing*) end
//
local
#include "./tetris2_piece.dats"
in (*nothing*) end
//
local
#include "./tetris2_keyboard.dats"
in (*nothing*) end
//
local
#include "./tetris2_gameboard.dats"
in (*nothing*) end
//
(* ****** ****** *)

(* end of [tetris2.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(* ****** ****** *)
//
// CATS-parsemit
//
(* ****** ****** *)
//
// HX-2014-07-02: start
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload UN = $UNSAFE

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

staload "./../SATS/catsparse.sats"

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

macdef ENDL = char2int0('\n')

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

implement
token_get_loc (tok) = tok.token_loc

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

fun BLANK_test
  (i: int): bool = let
//
val c = int2char0 (i)
//
in
  case+ 0 of
  | _ when c = ' ' => true
  | _ when c = '\t' => true
  | _ (*rest-of-chars*) => false
end // end of [BLANK_test]

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

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
  | _ when c = '\'' => true
  | _ (*rest-of-char*) => false
end (* end of [IDENTRST_test] *)

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

local
//
#define
SYMBOLIC "%&+-./:=@~`^|*!$#?<>"
//
in (* in-of-local *)
//
fun
SYMBOLIC_test
  (c: int): bool =
  strchr (SYMBOLIC, int2char0(c)) >= 0
//
end // end of [local]

(* ****** ****** *)
//
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 SIGN_test
  (c: int): bool = let
//
val c = int2char0(c) in (c = '+' || c = '-')
//
end // end of [SIGN_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]
//
(* ****** ****** *)
//
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_opt
(
  buf: &lexbuf >> _, f: int -> bool
) : intGte(0) // end of [ftesting_opt]
//
implement
ftesting_opt
  (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_opt]
//
(* ****** ****** *)
//
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_blankseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, BLANK_test)
//
(* ****** ****** *)
//
fun
testing_identrstseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, IDENTRST_test)
//
(* ****** ****** *)
//
fun
testing_symbolicseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, SYMBOLIC_test)
//
(* ****** ****** *)
//
extern
fun
lexing_IDENT_alp
  (buf: &lexbuf): token
//
implement
lexing_IDENT_alp
  (buf) = let
//
val nchr =
  testing_identrstseq0(buf)
val nchr1 = succ(nchr)
val name = lexbuf_takeout(buf, nchr1)
val name = strptr2string(name)
//
val loc =
  lexbuf_getincby_location(buf, nchr1)
//
val kwd = keyword_search (name)
//
in
//
case+ kwd of
//
| KWORDnone () =>
    token_make (loc, T_IDENT_alp(name))
  // end of [KWORDnone]
| _ (*keyword*) => token_make (loc, T_KWORD(kwd))
//
end // end of [lexing_IDENT_alp]

(* ****** ****** *)
//
extern
fun
lexing_IDENT_sym
  (buf: &lexbuf): token
//
implement
lexing_IDENT_sym
  (buf) = let
//
val nchr =
  testing_symbolicseq0 (buf)
val nchr1 = succ(nchr)
val name = lexbuf_takeout (buf, nchr1)
val name = strptr2string (name)
//
val loc = lexbuf_getincby_location (buf, nchr1)
//
in
//
case+ name of
| "<" => token_make (loc, T_LT)
| ">" => token_make (loc, T_GT)
//
| "-" => token_make (loc, T_MINUS)
//
| ":" => token_make (loc, T_COLON)
//
| _ (*rest*) => token_make (loc, T_IDENT_sym(name))
//
end // end of [lexing_IDENT_sym]

(* ****** ****** *)
//
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)
//
(* ****** ****** *)

fun
testing_fexponent
(
  buf: &lexbuf
) : intGte(0) = let
//
val i = lexbuf_get_char (buf)
//
in
//
if
i > 0
then let
//
val c = int2char0(i)
//
in
//
if
eE_test(i)
then let
//
val k1 =
  ftesting_opt (buf, SIGN_test)
val k2 = testing_digitseq0 (buf) // err: k2 = 0
//
val () =
if k2 = 0 then
{
  val loc =
    lexbuf_getincby_location (buf, k1+1)
  val err =
    lexerr_make (loc, LEXERR_FEXPONENT_nil)
  val ((*void*)) = the_lexerrlst_insert (err)
} (* end of [if] *) // end of [val]
//
in
  k1+k2+1
end // end of [then]
else (
  lexbuf_incby_nback (buf, 1); 0
) (* end of [else] *)
//
end // end of [then]
else (0) // end of [else]
//
end // end of [testing_fexponent]

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

fun
testing_deciexp
(
  buf: &lexbuf
) : intGte(0) = let
//
val i = lexbuf_get_char (buf)
//
in
//
if
i > 0
then let
//
val c = int2char0(i)
//
in
//
if
c = '.'
then let
//
  val k1 = testing_digitseq0 (buf)
  val k2 = testing_fexponent (buf)
  val k12 = k1 + k2
//
in
  k12 + 1
end // end of [then]
else (
  lexbuf_incby_nback (buf, 1); 0
) (* end of [else] *)
//
end // end of [then]
else 0 // end of [else]
//
end // end of [testing_deciexp]

(* ****** ****** *)
//
extern
fun
lexing_INT_oct (buf: &lexbuf): token
//
extern
fun
lexing_INT_dec (buf: &lexbuf): token
//
extern
fun
lexing_FLOAT_deciexp (buf: &lexbuf): token
//
(* ****** ****** *)
//
implement
lexing_INT_oct
  (buf) = let
//
val k0 = testing_octalseq0 (buf)
//
in
//
if
k0 >= 2
then let
//
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_INT(base, intrep))
end // end of [then]
else lexing_INT_dec (buf)
//
end // end of [lexing_INT_oct]

(* ****** ****** *)
//
implement
lexing_INT_dec (buf) = let
//
val k0 =
  testing_digitseq0 (buf)
//
val k1 = testing_deciexp (buf)
//
in
//
if
k1 > 0
then let
//
  val nchr = succ(k0 + k1)
  val float = lexbuf_takeout (buf, nchr)
  val float = strptr2string (float)
//
  val loc = lexbuf_getincby_location (buf, nchr)
//
in
  token_make (loc, T_FLOAT(10(*base*), float))
end // end of [then]
else let
//
val k1 = testing_fexponent (buf)
//
in
//
if
k1 > 0
then let
//
  val nchr = succ(k0 + k1)
  val float = lexbuf_takeout (buf, nchr)
  val float = strptr2string (float)
//
  val loc = lexbuf_getincby_location (buf, nchr)
//
in
  token_make (loc, T_FLOAT(10(*base*), float))
end // end of [then]
else let
//
  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_INT(10(*base*), intrep))
end // end of [else]
//
end // end of [else]
//
end // end of [lexing_INT_dec]

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

extern
fun
lexing_INT_hex (buf: &lexbuf): token
//
implement
lexing_INT_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_INT(16(*base*), intrep))
end // end of [lexing_INT_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_SPACES
  (buf: &lexbuf): token
//
implement
lexing_SPACES
  (buf) = let
//
val nchr = testing_blankseq0 (buf)
val nchr1 = nchr + 1
val () = lexbuf_set_nspace (buf, nchr1)
val spaces = lexbuf_takeout (buf, nchr1)
val spaces = strptr2string (spaces)
val loc = lexbuf_getincby_location (buf, nchr1)
//
in
  token_make (loc, T_SPACES (spaces))
end // end of [lexing_SPACES]
//
(* ****** ****** *)
//
extern
fun
lexing_ENDL
  (buf: &lexbuf): token
//
implement
lexing_ENDL
  (buf) = let
//
val () = lexbuf_remove (buf, 1)
val loc = lexbuf_getbyrow_location (buf)
//
in
  token_make (loc, T_ENDL())
end // end of [lexing_ENDL]

(* ****** ****** *)
//
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 i = lexbuf_get_char (buf)
//
in
//
if
i > 0
then let
//
val c = int2char0(i)
//
in
//
case+ 0 of
| _ when
    IDENTFST_test(i) => let
    val nchr = testing_identrstseq0 (buf)
    val nchr2 = nchr + 2
    val name = lexbuf_takeout (buf, nchr2)
    val name = strptr2string (name)
    val loc = lexbuf_getincby_location (buf, nchr2)
    val kwd = keyword_search (name)
  in
    case+ kwd of
    | KWORDnone () =>
        token_make (loc, T_IDENT_srp(name))
      // end of [KWORDnone]
    | _(*keyword*) => token_make (loc, T_KWORD (kwd))
  end
| _ (* rest-of-char *) => let
    val nchr = testing_symbolicseq0 (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 // end of [then]
else let
  val () = lexbuf_remove (buf, 1)
  val loc = lexbuf_getincby_location (buf, 1)
in
  token_make (loc, T_SLASH((*void*)))
end // end of [else]
//
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 () = position_incby1 (pos)
val nchr = loop (buf, pos, 0(*nchr*))
val loc = lexbufpos_get_location (buf, pos)
val strp = lexbuf_takeout (buf, nchr+1)
val () = lexbuf_set_position (buf, pos)
//
(*
val () = println! ("lexing_quote: loc = ", loc)
val () = println! ("lexing_quote: nchr = ", nchr)
val () = println! ("lexing_quote: strp = ", strp)
*)
//
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 () =
        if (c != ENDL) then
        {
          val np = sz2i(n0 - n)
          val () = position_decby (pos, np)
          val () = lexbuf_incby_nback (buf, np)
        } (* end of [if] *)
      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 str = lexbuf_takeout (buf, nchr + 2)
val loc = lexbufpos_get_location (buf, pos)
val ((*void*)) = lexbuf_set_position (buf, pos)
//
in
  token_make (loc, T_COMMENT_block(strptr2string(str)))
end // end of [lexing_SLASHSTAR]

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

implement
lexing_SLASHSLASH
  (buf) = let
//
val
nchr =
ftesting_seq0
(
  buf, lam i => i != ENDL
) (* end of [val] *)
//
// HX: Note that ENDL is not included
//
val str = lexbuf_takeout (buf, nchr + 2)
val loc = lexbuf_getincby_location (buf, nchr + 2)
//
in
  token_make (loc, T_COMMENT_line(strptr2string(str)))
end // end of [lexing_SLASHSLASH]

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

local
//
fun
get_token_any
(
  buf: &lexbuf >> _
) : token = let
//
val i0 = lexbuf_get_char (buf)
//
in
//
if
i0 > 0
then let
//
val c0 = $UN.cast{charNZ}(i0)
//
in
//
case+ 0 of
//
| _ when
    BLANK_test (i0) => lexing_SPACES (buf)
//
| _ when
    IDENTFST_test (i0) => lexing_IDENT_alp (buf)
//
| _ when c0 = ENDL => lexing_ENDL (buf)
| _ when c0 = SHARP => lexing_SHARP (buf)
| _ when i0 = SLASH => lexing_SLASH (buf)
//
| _ when
    SYMBOLIC_test (i0) => lexing_IDENT_sym (buf)
//
| _ when DIGIT_test (i0) =>
  (
    if ZERO_test(i0)
      then let
        val k = ftesting_one (buf, xX_test)
      in
        if k = 0
          then lexing_INT_oct (buf) else lexing_INT_hex (buf)
        // end of [if]
      end // end of [then]
      else lexing_INT_dec (buf)
   )
//
| _ when i0 = COMMA => lexing_litchar (buf, T_COMMA)
| _ 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 i0 = QUOTE => lexing_QUOTE (buf)
| _ when i0 = DQUOTE => lexing_DQUOTE (buf)
//
| _ (*rest-of-char*) => let
//
// HX: skipping the unrecognized char
//
    val () = lexbuf_remove_all (buf)
//
    val loc = lexbuf_getincby_location (buf, 1)
    val err = lexerr_make (loc, LEXERR_UNSUPPORTED_char (c0))
    val ((*void*)) = prerrln! ("Warning(lex): ", err)
(*
    val ((*inserted*)) = the_lexerrlst_insert (err)
*)
//
  in
    lexbuf_get_token_any (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 [get_token_any]
//
in
//
implement
lexbuf_get_token_any
  (buf) = let
//
val tok = get_token_any (buf)
//
in
//
case+
tok.token_node of
//
| T_SPACES _ => tok
| _ (*non-SPACES*) => let
    val () = lexbuf_set_nspace (buf, 0) in tok
  end // end of [non-SPACES]
//
end // end of [lexbuf_get_token_any]
//
end // end of [local]

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

implement
lexbuf_get_token_skip
  (buf) = let
//
val tok = lexbuf_get_token_any (buf)
//
in
//
case+
tok.token_node of
| T_ENDL () => lexbuf_get_token_skip (buf)
| T_SPACES _ => lexbuf_get_token_skip (buf)
| T_COMMENT_line _ => lexbuf_get_token_skip (buf)
| T_COMMENT_block _ => lexbuf_get_token_skip (buf)
| _ (*non-skip-token*) => tok
//
end // end of [lexing_get_token_skip]

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

(* end of [catsparse_lexing.dats] *)

(* ****** ****** *)
//
// CATS-parsemit
//
(* ****** ****** *)
//
// HX-2014-07-02: start
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload UN = $UNSAFE

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

staload "./../SATS/catsparse.sats"

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

macdef ENDL = char2int0('\n')

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

implement
token_get_loc (tok) = tok.token_loc

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

fun BLANK_test
  (i: int): bool = let
//
val c = int2char0 (i)
//
in
  case+ 0 of
  | _ when c = ' ' => true
  | _ when c = '\t' => true
  | _ (*rest-of-chars*) => false
end // end of [BLANK_test]

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

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
  | _ when c = '\'' => true
  | _ (*rest-of-char*) => false
end (* end of [IDENTRST_test] *)

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

local
//
#define
SYMBOLIC "%&+-./:=@~`^|*!$#?<>"
//
in (* in-of-local *)
//
fun
SYMBOLIC_test
  (c: int): bool =
  strchr (SYMBOLIC, int2char0(c)) >= 0
//
end // end of [local]

(* ****** ****** *)
//
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 SIGN_test
  (c: int): bool = let
//
val c = int2char0(c) in (c = '+' || c = '-')
//
end // end of [SIGN_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]
//
(* ****** ****** *)
//
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_opt
(
  buf: &lexbuf >> _, f: int -> bool
) : intGte(0) // end of [ftesting_opt]
//
implement
ftesting_opt
  (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_opt]
//
(* ****** ****** *)
//
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_blankseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, BLANK_test)
//
(* ****** ****** *)
//
fun
testing_identrstseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, IDENTRST_test)
//
(* ****** ****** *)
//
fun
testing_symbolicseq0
  (buf: &lexbuf): intGte(0) =
  ftesting_seq0 (buf, SYMBOLIC_test)
//
(* ****** ****** *)
//
extern
fun
lexing_IDENT_alp (buf: &lexbuf): token
//
implement
lexing_IDENT_alp
  (buf) = let
//
val nchr =
  testing_identrstseq0 (buf)
val nchr1 = succ(nchr)
val name = lexbuf_takeout (buf, nchr1)
val name = strptr2string (name)
//
val loc = lexbuf_getincby_location (buf, nchr1)
//
val kwd = keyword_search (name)
//
in
//
case+ kwd of
//
| KWORDnone () =>
    token_make (loc, T_IDENT_alp(name))
  // end of [KWORDnone]
| _ (*keyword*) => token_make (loc, T_KWORD (kwd))
//
end // end of [lexing_IDENT_alp]

(* ****** ****** *)
//
extern
fun
lexing_IDENT_sym (buf: &lexbuf): token
//
implement
lexing_IDENT_sym
  (buf) = let
//
val nchr =
  testing_symbolicseq0 (buf)
val nchr1 = succ(nchr)
val name = lexbuf_takeout (buf, nchr1)
val name = strptr2string (name)
//
val loc = lexbuf_getincby_location (buf, nchr1)
//
in
//
case+ name of
| "<" => token_make (loc, T_LT)
| ">" => token_make (loc, T_GT)
//
| "-" => token_make (loc, T_MINUS)
//
| ":" => token_make (loc, T_COLON)
//
| _ (*rest*) => token_make (loc, T_IDENT_sym(name))
//
end // end of [lexing_IDENT_sym]

(* ****** ****** *)
//
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)
//
(* ****** ****** *)

fun
testing_fexponent
(
  buf: &lexbuf
) : intGte(0) = let
//
val i = lexbuf_get_char (buf)
//
in
//
if
i > 0
then let
//
val c = int2char0(i)
//
in
//
if
eE_test(i)
then let
//
val k1 =
  ftesting_opt (buf, SIGN_test)
val k2 = testing_digitseq0 (buf) // err: k2 = 0
//
val () =
if k2 = 0 then
{
  val loc =
    lexbuf_getincby_location (buf, k1+1)
  val err =
    lexerr_make (loc, LEXERR_FEXPONENT_nil)
  val ((*void*)) = the_lexerrlst_insert (err)
} (* end of [if] *) // end of [val]
//
in
  k1+k2+1
end // end of [then]
else (
  lexbuf_incby_nback (buf, 1); 0
) (* end of [else] *)
//
end // end of [then]
else (0) // end of [else]
//
end // end of [testing_fexponent]

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

fun
testing_deciexp
(
  buf: &lexbuf
) : intGte(0) = let
//
val i = lexbuf_get_char (buf)
//
in
//
if
i > 0
then let
//
val c = int2char0(i)
//
in
//
if
c = '.'
then let
//
  val k1 = testing_digitseq0 (buf)
  val k2 = testing_fexponent (buf)
  val k12 = k1 + k2
//
in
  k12 + 1
end // end of [then]
else (
  lexbuf_incby_nback (buf, 1); 0
) (* end of [else] *)
//
end // end of [then]
else 0 // end of [else]
//
end // end of [testing_deciexp]

(* ****** ****** *)
//
extern
fun
lexing_INT_oct (buf: &lexbuf): token
//
extern
fun
lexing_INT_dec (buf: &lexbuf): token
//
extern
fun
lexing_FLOAT_deciexp (buf: &lexbuf): token
//
(* ****** ****** *)
//
implement
lexing_INT_oct
  (buf) = let
//
val k0 = testing_octalseq0 (buf)
//
in
//
if
k0 >= 2
then let
//
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_INT(base, intrep))
end // end of [then]
else lexing_INT_dec (buf)
//
end // end of [lexing_INT_oct]

(* ****** ****** *)
//
implement
lexing_INT_dec (buf) = let
//
val k0 =
  testing_digitseq0 (buf)
//
val k1 = testing_deciexp (buf)
//
in
//
if
k1 > 0
then let
//
  val nchr = succ(k0 + k1)
  val float = lexbuf_takeout (buf, nchr)
  val float = strptr2string (float)
//
  val loc = lexbuf_getincby_location (buf, nchr)
//
in
  token_make (loc, T_FLOAT(10(*base*), float))
end // end of [then]
else let
//
val k1 = testing_fexponent (buf)
//
in
//
if
k1 > 0
then let
//
  val nchr = succ(k0 + k1)
  val float = lexbuf_takeout (buf, nchr)
  val float = strptr2string (float)
//
  val loc = lexbuf_getincby_location (buf, nchr)
//
in
  token_make (loc, T_FLOAT(10(*base*), float))
end // end of [then]
else let
//
  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_INT(10(*base*), intrep))
end // end of [else]
//
end // end of [else]
//
end // end of [lexing_INT_dec]

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

extern
fun
lexing_INT_hex (buf: &lexbuf): token
//
implement
lexing_INT_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_INT(16(*base*), intrep))
end // end of [lexing_INT_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_SPACES
  (buf: &lexbuf): token
//
implement
lexing_SPACES
  (buf) = let
//
val nchr = testing_blankseq0 (buf)
val nchr1 = nchr + 1
val () = lexbuf_set_nspace (buf, nchr1)
val spaces = lexbuf_takeout (buf, nchr1)
val spaces = strptr2string (spaces)
val loc = lexbuf_getincby_location (buf, nchr1)
//
in
  token_make (loc, T_SPACES (spaces))
end // end of [lexing_SPACES]
//
(* ****** ****** *)
//
extern
fun
lexing_ENDL
  (buf: &lexbuf): token
//
implement
lexing_ENDL
  (buf) = let
//
val () = lexbuf_remove (buf, 1)
val loc = lexbuf_getbyrow_location (buf)
//
in
  token_make (loc, T_ENDL())
end // end of [lexing_ENDL]

(* ****** ****** *)
//
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 i = lexbuf_get_char (buf)
//
in
//
if
i > 0
then let
//
val c = int2char0(i)
//
in
//
case+ 0 of
| _ when
    IDENTFST_test(i) => let
    val nchr = testing_identrstseq0 (buf)
    val nchr2 = nchr + 2
    val name = lexbuf_takeout (buf, nchr2)
    val name = strptr2string (name)
    val loc = lexbuf_getincby_location (buf, nchr2)
    val kwd = keyword_search (name)
  in
    case+ kwd of
    | KWORDnone () =>
        token_make (loc, T_IDENT_srp(name))
      // end of [KWORDnone]
    | _(*keyword*) => token_make (loc, T_KWORD (kwd))
  end
| _ (* rest-of-char *) => let
    val nchr = testing_symbolicseq0 (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 // end of [then]
else let
  val () = lexbuf_remove (buf, 1)
  val loc = lexbuf_getincby_location (buf, 1)
in
  token_make (loc, T_SLASH((*void*)))
end // end of [else]
//
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 () = position_incby1 (pos)
val nchr = loop (buf, pos, 0(*nchr*))
val loc = lexbufpos_get_location (buf, pos)
val strp = lexbuf_takeout (buf, nchr+1)
val () = lexbuf_set_position (buf, pos)
//
(*
val () = println! ("lexing_quote: loc = ", loc)
val () = println! ("lexing_quote: nchr = ", nchr)
val () = println! ("lexing_quote: strp = ", strp)
*)
//
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 () =
        if (c != ENDL) then
        {
          val np = sz2i(n0 - n)
          val () = position_decby (pos, np)
          val () = lexbuf_incby_nback (buf, np)
        } (* end of [if] *)
      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 str = lexbuf_takeout (buf, nchr + 2)
val loc = lexbufpos_get_location (buf, pos)
val ((*void*)) = lexbuf_set_position (buf, pos)
//
in
  token_make (loc, T_COMMENT_block(strptr2string(str)))
end // end of [lexing_SLASHSTAR]

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

implement
lexing_SLASHSLASH
  (buf) = let
//
val
nchr =
ftesting_seq0
(
  buf, lam i => i != ENDL
) (* end of [val] *)
//
// HX: Note that ENDL is not included
//
val str = lexbuf_takeout (buf, nchr + 2)
val loc = lexbuf_getincby_location (buf, nchr + 2)
//
in
  token_make (loc, T_COMMENT_line(strptr2string(str)))
end // end of [lexing_SLASHSLASH]

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

local
//
fun
get_token_any
(
  buf: &lexbuf >> _
) : token = let
//
val i0 = lexbuf_get_char (buf)
//
in
//
if
i0 > 0
then let
//
val c0 = $UN.cast{charNZ}(i0)
//
in
//
case+ 0 of
//
| _ when
    BLANK_test (i0) => lexing_SPACES (buf)
//
| _ when
    IDENTFST_test (i0) => lexing_IDENT_alp (buf)
//
| _ when c0 = ENDL => lexing_ENDL (buf)
| _ when c0 = SHARP => lexing_SHARP (buf)
| _ when i0 = SLASH => lexing_SLASH (buf)
//
| _ when
    SYMBOLIC_test (i0) => lexing_IDENT_sym (buf)
//
| _ when DIGIT_test (i0) =>
  (
    if ZERO_test(i0)
      then let
        val k = ftesting_one (buf, xX_test)
      in
        if k = 0
          then lexing_INT_oct (buf) else lexing_INT_hex (buf)
        // end of [if]
      end // end of [then]
      else lexing_INT_dec (buf)
   )
//
| _ when i0 = COMMA => lexing_litchar (buf, T_COMMA)
| _ 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 i0 = QUOTE => lexing_QUOTE (buf)
| _ when i0 = DQUOTE => lexing_DQUOTE (buf)
//
| _ (*rest-of-char*) => let
//
// HX: skipping the unrecognized char
//
    val () = lexbuf_remove_all (buf)
//
    val loc = lexbuf_getincby_location (buf, 1)
    val err = lexerr_make (loc, LEXERR_UNSUPPORTED_char (c0))
    val ((*void*)) = prerrln! ("Warning(lex): ", err)
(*
    val ((*inserted*)) = the_lexerrlst_insert (err)
*)
//
  in
    lexbuf_get_token_any (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 [get_token_any]
//
in
//
implement
lexbuf_get_token_any
  (buf) = let
//
val tok = get_token_any (buf)
//
in
//
case+
tok.token_node of
//
| T_SPACES _ => tok
| _ (*non-SPACES*) => let
    val () = lexbuf_set_nspace (buf, 0) in tok
  end // end of [non-SPACES]
//
end // end of [lexbuf_get_token_any]
//
end // end of [local]

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

implement
lexbuf_get_token_skip
  (buf) = let
//
val tok = lexbuf_get_token_any (buf)
//
in
//
case+
tok.token_node of
| T_ENDL () => lexbuf_get_token_skip (buf)
| T_SPACES _ => lexbuf_get_token_skip (buf)
| T_COMMENT_line _ => lexbuf_get_token_skip (buf)
| T_COMMENT_block _ => lexbuf_get_token_skip (buf)
| _ (*non-skip-token*) => tok
//
end // end of [lexing_get_token_skip]

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

(* end of [catsparse_lexing.dats] *)


Updating: working on the tetris game

Updating: working on the tetris game

(*
** Tetris
*)

(* ****** ****** *)
//
#define
ATS_STATIC_PREFIX "tetris_piece__"
//
(* ****** ****** *)

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "tetris_piece_initize"

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
staload (*opened*) "./tetris.sats"
//
(* ****** ****** *)
//
#include "{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)

#define PDIM 4

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

(*
assume
Piece_type = $rec{
  x= int
, y= int
, vy= int // y-velocity
//
, mat1= matrixref(Block, PDIM, PDIM)
, mat2= matrixref(Block, PDIM, PDIM)
//
} (* end of [Piece_type] *)
*)

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

%{^
//
function
Piece_get_x(piece) { return piece.x; }
function
Piece_set_x(piece, x) { piece.x = x; return; }
//
function
Piece_get_y(piece) { return piece.y; }
function
Piece_set_y(piece, y) { piece.y = y; return; }
//
%} // end of [%{^]

(* ****** ****** *)
//
typedef
Piece_mat =
matrixref(Block, PDIM, PDIM)
//
extern
fun Piece_get_mat1 (Piece): Piece_mat
and Piece_set_mat1 (Piece, mat1: Piece_mat): void
//
overload .mat1 with Piece_get_mat1
overload .mat1 with Piece_set_mat1
//
extern
fun Piece_get_mat2 (Piece): Piece_mat
and Piece_set_mat2 (Piece, mat2: Piece_mat): void
//
overload .mat2 with Piece_get_mat2
overload .mat2 with Piece_set_mat2
//
(* ****** ****** *)
//
extern
fun
matrixref_lrotate_to
  {a:t@ype}{m,n:int}
(
  A: matrixref(a, m, n),
  B: matrixref(a, n, m), m: int(m), n: int(n)
) : void // end of [matrixref_lrotate_to]
//
implement
matrixref_lrotate_to
  {a}{m,n}(A, B, m, n) =
(
//
matrixref_foreach_cloref
(
  A, m, n
, lam(i, j) =>
  let val tmp = A[i,n,j] in
    A[i,n,j] := B[n-1-j,m,i]; B[n-1-j,m,i] := tmp
  end // end of [let] // end of [lam]
)
//
) (* end of [matrixref_lrotate_to] *)
//
(* ****** ****** *)

implement
Piece_lrotate
  (piece) =
{
//
val M1 = piece.mat1
val M2 = piece.mat2
//
val () =
  matrixref_lrotate_to(M1, M2, PDIM, PDIM)
//
val () = piece.mat1 := M2
val () = piece.mat2 := M1
//
} (* end of [Piece_lrotate] *)

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

(* end of [tetris_piece.dats] *)

(*
** Tetris
*)

(* ****** ****** *)
//
#define
ATS_STATIC_PREFIX "tetris_piece__"
//
(* ****** ****** *)

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "tetris_piece_initize"

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
staload (*opened*) "./tetris.sats"
//
(* ****** ****** *)
//
#include "{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)

#define PDIM 4

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

(*
assume
Piece_type = $rec{
  x= int
, y= int
, vy= int // y-velocity
//
, mat1= matrixref(Block, PDIM, PDIM)
, mat2= matrixref(Block, PDIM, PDIM)
//
} (* end of [Piece_type] *)
*)

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

%{^
//
function
Piece_get_x(piece) { return piece.x; }
function
Piece_set_x(piece, x) { piece.x = x; return; }
//
function
Piece_get_y(piece) { return piece.y; }
function
Piece_set_y(piece, y) { piece.y = y; return; }
//
%} // end of [%{^]

(* ****** ****** *)
//
typedef
Piece_mat =
matrixref(Block, PDIM, PDIM)
//
extern
fun Piece_get_mat1 (Piece): Piece_mat
and Piece_set_mat1 (Piece, mat1: Piece_mat): void
//
overload .mat1 with Piece_get_mat1
overload .mat1 with Piece_set_mat1
//
extern
fun Piece_get_mat2 (Piece): Piece_mat
and Piece_set_mat2 (Piece, mat2: Piece_mat): void
//
overload .mat2 with Piece_get_mat2
overload .mat2 with Piece_set_mat2
//
(* ****** ****** *)
//
extern
fun
matrixref_lrotate_to
  {a:t@ype}{m,n:int}
(
  A: matrixref(a, m, n),
  B: matrixref(a, n, m), m: int(m), n: int(n)
) : void // end of [matrixref_lrotate_to]
//
implement
matrixref_lrotate_to
  {a}{m,n}(A, B, m, n) =
(
//
matrixref_foreach_cloref
(
  A, m, n
, lam(i, j) =>
  let val tmp = A[i,n,j] in
    A[i,n,j] := B[n-1-j,m,i]; B[n-1-j,m,i] := tmp
  end // end of [let] // end of [lam]
)
//
) (* end of [matrixref_lrotate_to] *)
//
(* ****** ****** *)

implement
Piece_lrotate
  (piece) =
(
   matrixref_lrotate_to(piece.mat1, piece.mat2, PDIM, PDIM)
) // end of [Piece_lrotate]

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

(* end of [tetris_piece.dats] *)


small change to where libats-/wdblair is located

(**
  Use my own folder in contrib for now. This is needed for
  using my rough bindings for Z3 in ATS.
*)

#define
LIBATSWDBLAIR_sourceloc "$PATSHOMERELOC/contrib/libats-/wdblair"
#define
LIBATSWDBLAIR_targetloc "$PATSHOMERELOC/contrib/libats-/wdblair"

(**
  Use my own folder in contrib for now. This is needed for
  using my rough bindings for Z3 in ATS.
*)

#define
LIBATSWDBLAIR_sourceloc "$ATSLANGWEBLIB/contrib/libats-/wdblair"
#define
LIBATSWDBLAIR_targetloc "$PATSHOMERELOC/contrib/libats-/wdblair"