begin % virtual machine interpreter %
    % string literals %
    string(256) array stringValue  ( 0 :: 256 );
    integer     array stringLength ( 0 :: 256 );
    integer     MAX_STRINGS;
    % op codes %
    integer     oFetch, oStore, oPush
          ,     oAdd,   oSub,   oMul, oDiv, oMod, oLt, oGt,   oLe,   oGe,   oEq,   oNe
          ,     oAnd,   oOr,    oNeg, oNot, oJmp, oJz, oPrtc, oPrts, oPrti, oHalt
          ;
    string(6)   array opName       ( 1 :: 24 );
    integer     OP_MAX;
    % code %
    string(1)   array byteCode     ( 0 :: 4096 );
    integer     nextLocation, MAX_LOCATION;
    % data %
    integer     array data         ( 0 :: 4096 );
    integer     dataSize, MAX_DATA, MAX_STACK;
    % tracing %
    logical     trace;

    % reports an error and stops %
    procedure rtError( string(80) value message ); begin
        integer errorPos;
        write( s_w := 0, "**** Runtime error: " );
        errorPos := 0;
        while errorPos < 80 and message( errorPos // 1 ) not = "." do begin
            writeon( s_w := 0, message( errorPos // 1 ) );
            errorPos := errorPos + 1
        end while_not_at_end_of_message ;
        writeon( s_w := 0, "." );
        assert( false )
    end genError ;

    oFetch :=  1; opName( oFetch ) := "fetch"; oStore :=  2; opName( oStore ) := "store"; oPush :=  3; opName( oPush ) := "push";
    oAdd   :=  4; opName( oAdd   ) := "add";   oSub   :=  5; opName( oSub   ) := "sub";   oMul  :=  6; opName( oMul  ) := "mul";
    oDiv   :=  7; opName( oDiv   ) := "div";   oMod   :=  8; opName( oMod   ) := "mod";   oLt   :=  9; opName( oLt   ) := "lt";
    oGt    := 10; opName( oGt    ) := "gt";    oLe    := 11; opName( oLe    ) := "le";    oGe   := 12; opName( oGe   ) := "ge";
    oEq    := 13; opName( oEq    ) := "eq";    oNe    := 14; opName( oNe    ) := "ne";    oAnd  := 15; opName( oAnd  ) := "and";
    oOr    := 16; opName( oOr    ) := "or";    oNeg   := 17; opName( oNeg   ) := "neg";   oNot  := 18; opName( oNot  ) := "not";
    oJmp   := 19; opName( oJmp   ) := "jmp";   oJz    := 20; opName( oJz    ) := "jz";    oPrtc := 21; opName( oPrtc ) := "prtc";
    oPrts  := 22; opName( oPrts  ) := "prts";  oPrti  := 23; opName( oPrti  ) := "prti";  oHalt := 24; opName( oHalt ) := "halt";
    OP_MAX := oHalt;

    trace        := false;
    MAX_STACK    := 256;
    MAX_LOCATION := 4096;
    for pc := 0 until MAX_LOCATION do byteCode( pc ) := code( 0 );
    MAX_DATA := 4096;
    for dPos := 0 until MAX_DATA do data( dPos ) := 0;
    MAX_STRINGS := 256;
    for sPos := 0 until MAX_STRINGS do begin
        stringValue(  sPos ) := " ";
        stringLength( sPos ) := 0
    end for_sPos ;

    % load thge output from syntaxc analyser %
    begin % readCode %

        % skips spaces on the source line %
        procedure skipSpaces ; begin
            while line( lPos // 1 ) = " " do lPos := lPos + 1
        end skipSpaces ;

        % parses a string from line and stores it in the string literals table %
        procedure readString ( integer value stringNumber ) ; begin
            string(256) str;
            integer     sLen;
            str  := " ";
            sLen := 0;
            lPos := lPos + 1; % skip the opening double-quote %
            while lPos <= 255 and line( lPos // 1 ) not = """" do begin
                str( sLen // 1 ) := line( lPos // 1 );
                sLen := sLen + 1;
                lPos := lPos + 1
            end while_more_string ;
            if lPos > 255 then rtError( "Unterminated String." );
            % store the string %
            stringValue(  stringNumber ) := str;
            stringLength( stringNumber ) := sLen
        end readString ;

        % gets an integer from the line - checks for valid digits %
        integer procedure readInteger ; begin
            integer n;
            skipSpaces;
            n := 0;
            while line( lPos // 1 ) >= "0" and line( lPos // 1 ) <= "9" do begin
                n    := ( n * 10 ) + ( decode( line( lPos // 1 ) ) - decode( "0" ) );
                lPos := lPos + 1
            end while_not_end_of_integer ;
            n
        end readInteger ;

        % reads the next line from standard input %
        procedure readALine ; begin
            lPos := 0;
            readcard( line );
            if trace then write( s_w := 0, ">> ", line( 0 // 32 ) )
        end readALine ;

        % loads an instruction from the current source line %
        procedure loadCodeFromLine ; begin
            integer pc, opCode, operand, oPos;
            string(256) op;
            logical haveOperand;
            % get the code location %
            pc := readInteger;
            if pc > MAX_LOCATION then rtError( "Code too large." );
            % get the opCode %
            skipSpaces;
            oPos := 0;
            op := " ";
            while lPos <= 255 and line( lPos // 1 ) not = " " do begin
                op( oPos // 1 ) := line( lPos // 1 );
                oPos := oPos + 1;
                lPos := lPos + 1
            end while_more_opName ;
            % lookup the op code %
            opCode := 0;
            oPos   := 1;
            while oPos <= OP_MAX and opCode = 0 do begin
                if opName( oPos ) = op then opCode := oPos
                                       else oPos   := oPos + 1
            end while_op_not_found ;
            if opCode = 0 then rtError( "Unknown op code." );
            % get the operand if there is one %
            operand     := 0;
            haveOperand := false;
            if      opCode = oFetch or opCode = oStore then begin
                % fetch or store - operand is enclosed in square brackets %
                skipSpaces;
                if line( lPos // 1 ) not = "[" then rtError( """["" expected after fetch/store." );
                lPos        := lPos + 1;
                operand     := readInteger;
                if operand > dataSize then rtError( "fetch/store address out of range." );
                haveOperand := true
                end
            else if opCode = oPush then begin
                % push integer literal instruction %
                operand     := readInteger;
                haveOperand := true
                end
            else if opCode = oJmp or opCode = oJz then begin
                % jump - the operand is the relative address enclosed in parenthesis %
                % followed by the absolute address - we use the absolute address so  %
                % the opewrand will be >= 0 %
                skipSpaces;
                if line( lPos // 1 ) not = "(" then rtError( """("" expected after jmp/jz." );
                lPos        := lPos + 1;
                if line( lPos // 1 ) = "-" then % negative relative address % lPos := lPos + 1;
                operand     := readInteger;
                if line( lPos // 1 ) not = ")" then rtError( """)"" expected after jmp/jz." );
                lPos        := lPos + 1;
                operand     := readInteger;
                haveOperand := true
            end if_various_opcodes ;
            % store the code %
            byteCode( pc ) := code( opCode );
            if haveOperand then begin
                % have an operand for the op code %
                if ( pc + 4 ) > MAX_LOCATION then rtError( "Code too large." );
                for oPos := 1 until 4 do begin
                    pc := pc + 1;
                    byteCode( pc ) := code( operand rem 256 );
                    operand := operand div 256;
                end for_oPos
            end if_have_operand ;
        end loadCodeFromLine ;

        string(256) line;
        string(16)  name;
        integer     lPos, tPos, stringCount;

        % allow us to detect EOF %
        ENDFILE := EXCEPTION( false, 1, 0, false, "EOF" );

        % first line should be "Datasize: d Strings: s" where d = number variables %
        % and s = number of strings                                                %
        readALine;
        if line = "trace" then begin
            % extension - run in trace mode %
            trace := true;
            readALine
        end if_line_eq_trace ;
        if XCPNOTED(ENDFILE) then rtError( "Empty program file." );
        if line( 0 // 10 ) not = "Datasize: " then rtError( "Header line missing." );
        lPos := 10;
        dataSize := readInteger;
        if dataSize > MAX_DATA then rtError( "Datasize too large." );
        skipSpaces;
        if line( lPos // 9 ) not = "Strings: " then rtError( """Strings: "" missing on header line." );
        lPos := lPos + 9;
        stringCount := readInteger;
        if stringCount > MAX_STRINGS then rtError( "Too many strings." );
        % read the string table %
        for stringNumber := 0 until stringCount - 1 do begin
            string(256) str;
            integer     sLen, sPos;
            readALine;
            if XCPNOTED(ENDFILE) then rtError( "End-of-file in string table." );
            if line( lPos // 1 ) not = """" then rtError( "String literal expected." );
            str  := " ";
            sLen := 0;
            lPos := lPos + 1; % skip the opening double-quote %
            while lPos <= 255 and line( lPos // 1 ) not = """" do begin
                str( sLen // 1 ) := line( lPos // 1 );
                sLen := sLen + 1;
                lPos := lPos + 1
            end while_more_string ;
            if lPos > 255 then rtError( "Unterminated String." );
            % store the string %
            stringValue(  stringNumber ) := str;
            stringLength( stringNumber ) := sLen
        end for_sPos ;
        % read the code %
        readALine;
        while not XCPNOTED(ENDFILE) do begin
            if line not = " " then loadCodeFromLine;
            readALine
        end while_not_eof
    end;
    % run the program %
    begin
        integer pc, opCode, operand, sp;
        integer array st ( 0 :: MAX_STACK );
        logical halted;
        % prints a string from the string pool, escape sequences are interpreted %
        procedure writeOnString( integer value stringNumber ) ;
        begin
            integer     cPos, sLen;
            string(256) text;
            if stringNumber < 0 or stringNumber > MAX_STRINGS then rtError( "Invalid string number." );
            cPos := 0;
            sLen := stringLength( stringNumber );
            text := stringValue(  stringNumber );
            while cPos < stringLength( stringNumber ) do begin
                string(1) ch;
                ch := text( cPos // 1 );
                if ch not = "\" then writeon( s_w := 0, ch )
                else begin
                    % escaped character %
                    cPos := cPos + 1;
                    if cPos > sLen then rtError( "String terminates with ""\""." );
                    ch := text( cPos // 1 );
                    if ch = "n" then % newline % write()
                                else writeon( s_w := 0, ch )
                end;
                cPos := cPos + 1
            end while_not_end_of_string
        end writeOnString ;

        pc     := 0;
        sp     := -1;
        halted := false;
        while not halted do begin;
            % get the next op code and operand %
            opCode  := decode( byteCode( pc ) );
            pc      := pc + 1;
            operand := 0;
            if opCode = oFetch or opCode = oStore or opCode = oPush or opCode = oJmp or opCode = oJz then begin
                % this opCode has an operand %
                pc := pc + 4;
                for bPos := 1 until 4 do begin
                    operand := ( operand * 256 ) + decode( byteCode( pc - bPos ) );
                end for_bPos
            end if_opCode_with_an_operand ;
            if trace then begin
                write( i_w:= 1, s_w := 0, pc, " op(", opCode, "): ", opName( opCode ), " ", operand );
                write()
            end if_trace ;
            % interpret the instruction %
            if      opCode = oFetch then begin sp := sp + 1; st( sp ) := data( operand ) end
            else if opCode = oStore then begin data( operand ) := st( sp ); sp := sp - 1 end
            else if opCode = oPush  then begin sp := sp + 1; st( sp ) := operand         end
            else if opCode = oHalt  then halted := true
            else if opCode = oJmp   then pc     := operand
            else if oPCode = oJz    then begin
                if st( sp ) = 0 then pc := operand;
                sp := sp - 1
                end
            else if opCode = oPrtc  then begin writeon( i_w := 1, s_w := 0, code( st( sp ) ) ); sp := sp - 1 end
            else if opCode = oPrti  then begin writeon( i_w := 1, s_w := 0,       st( sp )   ); sp := sp - 1 end
            else if opCode = oPrts  then begin writeonString(                     st( sp )   ); sp := sp - 1 end
            else if opCode = oNeg   then st( sp ) := - st( sp )
            else if opCode = oNot   then st( sp ) := ( if st( sp ) = 0 then 1 else 0 )
            else begin
                operand := st( sp );
                sp      := sp - 1;
                if      opCode = oAdd   then st( sp ) :=    st( sp )    +  operand
                else if opCode = oSub   then st( sp ) :=    st( sp )    -  operand
                else if opCode = oMul   then st( sp ) :=    st( sp )    *  operand
                else if opCode = oDiv   then st( sp ) :=    st( sp )  div  operand
                else if opCode = oMod   then st( sp ) :=    st( sp )  rem  operand
                else if opCode = oLt    then st( sp ) := if st( sp )    <  operand then 1 else 0
                else if opCode = oGt    then st( sp ) := if st( sp )    >  operand then 1 else 0
                else if opCode = oLe    then st( sp ) := if st( sp )    <= operand then 1 else 0
                else if opCode = oGe    then st( sp ) := if st( sp )    >= operand then 1 else 0
                else if opCode = oEq    then st( sp ) := if st( sp )     = operand then 1 else 0
                else if opCode = oNe    then st( sp ) := if st( sp ) not = operand then 1 else 0
                else if opCode = oAnd   then st( sp ) := if st( sp ) not = 0 and operand not = 0 then 1 else 0
                else if opCode = oOr    then st( sp ) := if st( sp ) not = 0 or  operand not = 0 then 1 else 0
                else                         rtError( "Unknown opCode." )
            end if_various_opCodes
        end while_not_halted
    end
end.


(*
  Usage: vm [INPUTFILE [OUTPUTFILE]]
     If INPUTFILE or OUTPUTFILE is "-" or missing, then standard input
     or standard output is used, respectively.

  The Rosetta Code virtual machine task in ATS2 (also known as
  Postiats).

  Some implementation notes:

    * Values are stored as uint32, and it is checked that uint32
      really is 32 bits, two’s-complement. Addition and subtraction
      are allowed to roll around, and so can be done without casting
      to int32. (The C standard specifies that unsigned integer values
      will roll around, rather than signal an overflow.)

    * Where it matters, the uint32 are stored in little-endian
      order. I have *not* optimized the code for x86/AMD64 (which are
      little-endian and also can address unaligned data).

    * Here I am often writing out code instead of using some library
      function. Partly this is to improve code safety (proof at
      compile-time that buffers are not overrun, proof of loop
      termination, etc.). Partly this is because I do not feel like
      using the C library (or ATS interfaces to it) all that much.

    * I am using linear types and so forth, because I think it
      interesting to do so. It is unnecessary to use a garbage
      collector, because there (hopefully) are no memory leaks. (Not
      that we couldn’t simply let memory leak, for this little program
      with no REPL.)

*)

#define ATS_EXTERN_PREFIX "rosettacode_vm_"
#define ATS_DYNLOADFLAG 0       (* No initialization is needed. *)

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

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

#define NIL list_vt_nil ()
#define :: list_vt_cons

(* The stack has a fixed size but is very large. (Alternatively, one
could make the stack double in size whenever it overflows. Design
options such as using a linked list for the stack come with a
performance penalty.) *)
#define VMSTACK_SIZE 65536
macdef vmstack_size = (i2sz VMSTACK_SIZE)

(* In this program, exceptions are not meant to be caught, unless
   the catcher terminates the program. Linear types and
   general exception-catching do not go together well. *)
exception bad_vm of string
exception vm_runtime_error of string

(********************************************************************)
(*                                                                  *)
(* Some string functions that are safe against buffer overruns.     *)
(*                                                                  *)

fn
skip_whitespace {n, i : int | 0 <= i; i <= n}
                (s    : string n,
                 n    : size_t n,
                 i    : size_t i) :
    [j : int | i <= j; j <= n]
    size_t j =
  let
    fun
    loop {k : int | i <= k; k <= n} .<n - k>.
         (k : size_t k) :
        [j : int | i <= j; j <= n]
        size_t j =
      if k = n then
        k
      else if isspace (s[k]) then
        loop (succ k)
      else
        k
  in
    loop (i)
  end

fn
skip_non_whitespace {n, i : int | 0 <= i; i <= n}
                    (s    : string n,
                     n    : size_t n,
                     i    : size_t i) :
    [j : int | i <= j; j <= n]
    size_t j =
  let
    fun
    loop {k : int | i <= k; k <= n} .<n - k>.
         (k : size_t k) :
        [j : int | i <= j; j <= n]
        size_t j =
      if k = n then
        k
      else if isspace (s[k]) then
        k
      else
        loop (succ k)
  in
    loop (i)
  end

fn
substr_equal {n, i, j : int | 0 <= i; i <= j; j <= n}
             {m       : int | 0 <= m}
             (s       : string n,
              i       : size_t i,
              j       : size_t j,
              t       : string m) : bool =
  (* Is s[i .. j-1] equal to t? *)
  let
    val m = string_length t
  in
    if m <> j - i then
      false
    else
      let
        fun
        loop {k : int | 0 <= k; k <= m} .<m - k>.
             (k : size_t k) : bool =
          if k = m then
            true
          else if s[i + k] <> t[k] then
            false
          else
            loop (succ k)
      in
        loop (i2sz 0)
      end
  end

(********************************************************************)
(*                                                                  *)
(* vmint = 32-bit two’s-complement numbers.                         *)
(*                                                                  *)

stadef vmint_kind = uint32_kind
typedef vmint = uint32

extern castfn i2vm    : int -<> vmint
extern castfn u2vm    : uint -<> vmint
extern castfn byte2vm : byte -<> vmint

extern castfn vm2i    : vmint -<> int
extern castfn vm2sz   : vmint -<> size_t
extern castfn vm2byte : vmint -<> byte

%{^

/*
 * The ATS prelude might not have C implementations of all the
 * operations we would like to have, so here are some.
 */

typedef uint32_t vmint_t;

ATSinline() vmint_t
rosettacode_vm_g0uint_add_vmint (vmint_t x, vmint_t y)
{
  return (x + y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_sub_vmint (vmint_t x, vmint_t y)
{
  return (x - y);
}

ATSinline() int
rosettacode_vm_g0uint_eq_vmint (vmint_t x, vmint_t y)
{
  return (x == y);
}

ATSinline() int
rosettacode_vm_g0uint_neq_vmint (vmint_t x, vmint_t y)
{
  return (x != y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_equality_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) (x == y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_inequality_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) (x != y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_lt_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x < (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_gt_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x > (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_lte_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x <= (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_gte_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x >= (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_mul_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x * (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_div_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x / (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_signed_mod_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((int32_t) x % (int32_t) y);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_logical_not_vmint (vmint_t x)
{
  return (vmint_t) (!x);
}

ATSinline() vmint_t
rosettacode_vm_g0uint_logical_and_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) ((!!x) * (!!y));
}

ATSinline() vmint_t
rosettacode_vm_g0uint_logical_or_vmint (vmint_t x, vmint_t y)
{
  return (vmint_t) (1 - ((!x) * (!y)));
}

%}

extern fn g0uint_add_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn g0uint_sub_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn g0uint_eq_vmint (x : vmint, y : vmint) :<> bool = "mac#%"
extern fn g0uint_neq_vmint (x : vmint, y : vmint) :<> bool = "mac#%"

implement g0uint_add<vmint_kind> (x, y) = g0uint_add_vmint (x, y)
implement g0uint_sub<vmint_kind> (x, y) = g0uint_sub_vmint (x, y)
implement g0uint_eq<vmint_kind> (x, y) = g0uint_eq_vmint (x, y)
implement g0uint_neq<vmint_kind> (x, y) = g0uint_neq_vmint (x, y)

extern fn
g0uint_signed_mul_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_div_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_mod_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_equality_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_inequality_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_lt_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_gt_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_lte_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_signed_gte_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_logical_not_vmint (x : vmint) :<> vmint = "mac#%"
extern fn
g0uint_logical_and_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"
extern fn
g0uint_logical_or_vmint (x : vmint, y : vmint) :<> vmint = "mac#%"

overload signed_mul with g0uint_signed_mul_vmint
overload signed_div with g0uint_signed_div_vmint
overload signed_mod with g0uint_signed_mod_vmint
overload equality with g0uint_equality_vmint
overload inequality with g0uint_inequality_vmint
overload signed_lt with g0uint_signed_lt_vmint
overload signed_gt with g0uint_signed_gt_vmint
overload signed_lte with g0uint_signed_lte_vmint
overload signed_gte with g0uint_signed_gte_vmint
overload logical_not with g0uint_logical_not_vmint
overload logical_and with g0uint_logical_and_vmint
overload logical_or with g0uint_logical_or_vmint

fn {}
twos_complement (x : vmint) :<>
    vmint =
  (~x) + i2vm 1

fn
ensure_that_vmint_is_suitable () : void =
  {
    val _ = assertloc (u2vm (0xFFFFFFFFU) + u2vm 1U = u2vm 0U)
    val _ = assertloc (u2vm 0U - u2vm 1U = u2vm (0xFFFFFFFFU))
    val _ = assertloc (i2vm (~1234) = twos_complement (i2vm 1234))
  }

fn
parse_digits {n, i, j : int | 0 <= i; i <= j; j <= n}
             (s       : string n,
              i       : size_t i,
              j       : size_t j) :
    vmint =
  let
    val bad_integer = "Bad integer."
    fun
    loop {k : int | i <= k; k <= j} .<j - k>.
         (k : size_t k,
          x : vmint) : vmint =
      if k = j then
        x
      else if ~isdigit (s[k]) then
        $raise bad_vm (bad_integer)
      else
        (* The result is allowed to overflow freely. *)
        loop (succ k, (i2vm 10 * x) + i2vm (char2i s[k] - char2i '0'))
  in
    if j = i then
      $raise bad_vm (bad_integer)
    else
      loop (i, i2vm 0)
  end

fn
parse_integer {n, i, j : int | 0 <= i; i <= j; j <= n}
              (s       : string n,
               i       : size_t i,
               j       : size_t j) :
    vmint =
  let
    val bad_integer = "Bad integer."
  in
    if j = i then
      $raise bad_vm (bad_integer)
    else if j = succ i && ~isdigit (s[i]) then
      $raise bad_vm (bad_integer)
    else if s[i] <> '-' then
      parse_digits (s, i, j)
    else if succ i = j then
      $raise bad_vm (bad_integer)
    else
      twos_complement (parse_digits (s, succ i, j))
  end

(********************************************************************)
(*                                                                  *)
(* A linear array type for elements of vmint, byte, etc.            *)
(*                                                                  *)

vtypedef vmarray_vt (t : [email protected]+, n : int, p : addr) =
  @{
    pf = @[t][n] @ p,
    pfgc = mfree_gc_v p |
    n = size_t n,
    p = ptr p
  }
vtypedef vmarray_vt (t : [email protected]+, n : int) =
  [p : addr] vmarray_vt (t, n, p)

fn {t : [email protected]}
vmarray_vt_alloc {n    : int}
                 (n    : size_t n,
                  fill : t) :
    [p : addr | null < p]
    vmarray_vt (t, n, p) =
  let
    val @(pf, pfgc | p) = array_ptr_alloc<t> (n)
    val _ = array_initize_elt (!p, n, fill)
  in
    @{
      pf = pf,
      pfgc = pfgc |
      n = n,
      p = p
    }
  end

fn {t : [email protected]}
vmarray_vt_free {n   : int}
                {p   : addr}
                (arr : vmarray_vt (t, n, p)) :
    void =
  let
    val @{
          pf = pf,
          pfgc = pfgc |
          n = n,
          p = p
        } = arr
  in
    array_ptr_free (pf, pfgc | p)
  end

fn {t : [email protected]}
vmarray_vt_fill {n    : int}
                {p    : addr}
                (arr  : !vmarray_vt (t, n, p),
                 fill : t) :
    void =
  array_initize_elt (!(arr.p), (arr.n), fill)

fn {t  : [email protected]}
   {tk : tkind}
vmarray_vt_get_at_g1int {n, i : int | 0 <= i; i < n}
                        (arr  : !vmarray_vt (t, n),
                         i    : g1int (tk, i)) :
    t =
  array_get_at (!(arr.p), i)

fn {t  : [email protected]}
   {tk : tkind}
vmarray_vt_get_at_g1uint {n, i : int | 0 <= i; i < n}
                         (arr  : !vmarray_vt (t, n),
                          i    : g1uint (tk, i)) :
    t =
  array_get_at (!(arr.p), i)

overload [] with vmarray_vt_get_at_g1int
overload [] with vmarray_vt_get_at_g1uint

fn {t  : [email protected]}
   {tk : tkind}
vmarray_vt_set_at_g1int {n, i : int | 0 <= i; i < n}
                        (arr  : !vmarray_vt (t, n),
                         i    : g1int (tk, i),
                         x    : t) :
    void =
  array_set_at (!(arr.p), i, x)

fn {t  : [email protected]}
   {tk : tkind}
vmarray_vt_set_at_g1uint {n, i : int | 0 <= i; i < n}
                         (arr  : !vmarray_vt (t, n),
                          i    : g1uint (tk, i),
                          x    : t) :
    void =
  array_set_at (!(arr.p), i, x)

overload [] with vmarray_vt_set_at_g1int
overload [] with vmarray_vt_set_at_g1uint

fn {t : [email protected]}
vmarray_vt_length {n   : int}
                  (arr : !vmarray_vt (t, n)) :<>
    size_t n =
  arr.n

(********************************************************************)
(*                                                                  *)
(* Storage for the strings section.                                 *)
(*                                                                  *)

vtypedef vmstring_vt (n : int, p : addr) =
  @{
    (* A vmstring_vt is NUL-terminated, and thus there is [n + 1]
       instead of [n] in the following declaration. *)
    pf = @[char][n + 1] @ p,
    pfgc = mfree_gc_v p |
    length = size_t n,
    p = ptr p
  }
vtypedef vmstring_vt (n : int) = [p : addr] vmstring_vt (n, p)
vtypedef vmstring_vt = [n : int | 0 <= n] vmstring_vt (n)

vtypedef vmstrings_section_vt (n : int, p : addr) =
  @{
    pf = @[vmstring_vt][n] @ p,
    pfgc = mfree_gc_v p |
    n = size_t n,
    p = ptr p
  }
vtypedef vmstrings_section_vt (n : int) =
  [p : addr] vmstrings_section_vt (n, p)

fn {t : [email protected]}
vmstrings_section_vt_length {n   : int}
                            (arr : !vmstrings_section_vt (n)) :<>
    size_t n =
  arr.n

fn
vmstring_vt_free {n : int}
                 {p : addr}
                 (s : vmstring_vt (n, p)) :
    void =
  array_ptr_free (s.pf, s.pfgc | s.p)

fn
vmstrings_section_vt_free {n       : int}
                          {p       : addr}
                          (strings : vmstrings_section_vt (n, p)) :
    void =
  {
    fun
    free_the_strings {n  : int | 0 <= n}
                     {p  : addr} .<n>.
                     (pf : !(@[vmstring_vt][n] @ p) >>
                              @[vmstring_vt?][n] @ p |
                      n  : size_t n,
                      p  : ptr p) : void =
      if n = 0 then
        {
          prval _ = pf :=
            array_v_unnil_nil {vmstring_vt, vmstring_vt?} pf
        }
      else
        {
          prval @(pf_element, pf_rest) = array_v_uncons pf
          val _ = vmstring_vt_free (!p)
          val p_next = ptr_succ<vmstring_vt> (p)
          val _ = free_the_strings (pf_rest | pred n, p_next)
          prval _ = pf := array_v_cons (pf_element, pf_rest)
        }

    val @{
          pf = pf,
          pfgc = pfgc |
          n = n,
          p = p
        } = strings
    prval _ = lemma_g1uint_param n
    val _ = free_the_strings (pf | n, p)
    val _ = array_ptr_free (pf, pfgc | p)
  }

fn
quoted_string_length {n : int | 0 <= n}
                     (s : string n,
                      n : size_t n) :
    [m : int | 0 <= m; m <= n - 2]
    size_t m =
  let
    val bad_quoted_string = "Bad quoted string."

    fun
    loop {i : int | 1 <= i; i <= n - 1}
         {j : int | 0 <= j; j <= i - 1} .<n - i>.
         (i : size_t i,
          j : size_t j) :
        [k : int | 0 <= k; k <= n - 2]
        size_t k =
      if i = pred n then
        j
      else if s[i] <> '\\' then
        loop (succ i, succ j)
      else if succ i = pred n then
        $raise bad_vm (bad_quoted_string)
      else if s[succ i] = 'n' || s[succ i] = '\\' then
        loop (succ (succ i), succ j)
      else
        $raise bad_vm (bad_quoted_string)
  in
    if n < i2sz 2 then
      $raise bad_vm (bad_quoted_string)
    else if s[0] <> '"' then
      $raise bad_vm (bad_quoted_string)
    else if s[pred n] <> '"' then
      $raise bad_vm (bad_quoted_string)
    else
      loop (i2sz 1, i2sz 0)
  end

fn
dequote_string {m, n : int | 0 <= m; m <= n - 2}
               (s : string n,
                n : size_t n,
                t : !vmstring_vt m) :
    void =
  let
    fun
    loop {i : int | 1 <= i; i <= n - 1}
         {j : int | 0 <= j; j <= i - 1} .<n - i>.
         (t : !vmstring_vt m,
          i : size_t i,
          j : size_t j) : void =
      let
        macdef t_str = !(t.p)
      in
        if i = pred n then
          ()
        else if (t.length) < j then
          assertloc (false)
        else if s[i] <> '\\' then
          begin
            t_str[j] := s[i];
            loop (t, succ i, succ j)
          end
        else if succ i = pred n then
          assertloc (false)
        else if s[succ i] = 'n' then
          begin
            t_str[j] := '\n';
            loop (t, succ (succ i), succ j)
          end
        else
          begin
            t_str[j] := s[succ i];
            loop (t, succ (succ i), succ j)
          end
      end
  in
    loop (t, i2sz 1, i2sz 0)
  end

fn
read_vmstrings {strings_size : int}
               {strings_addr : addr}
               (pf_strings   :
                    !(@[vmstring_vt?][strings_size] @ strings_addr) >>
                        @[vmstring_vt][strings_size] @ strings_addr |
                f            : FILEref,
                strings_size : size_t strings_size,
                strings      : ptr strings_addr) :
    void =
  let
    prval _ = lemma_g1uint_param strings_size

    fun
    loop {k   : int | 0 <= k; k <= strings_size} .<strings_size - k>.
         (lst : list_vt (vmstring_vt, k),
          k   : size_t k) :
        list_vt (vmstring_vt, strings_size) =
      if k = strings_size then
        list_vt_reverse (lst)
      else
        let
          val bad_quoted_string = "Bad quoted string."
          val line = fileref_get_line_string (f)
          val s = $UN.strptr2string (line)
          val n = string_length s
              val str_length = quoted_string_length (s, n)
          val (pf, pfgc | p) =
            array_ptr_alloc<char> (succ str_length)
          val _ = array_initize_elt (!p, succ str_length, '\0')
          val vmstring =
            @{
              pf = pf,
              pfgc = pfgc |
              length = str_length,
              p = p
            }
        in
          dequote_string (s, n, vmstring);
          free line;
          loop (vmstring :: lst, succ k)
        end

    val lst = loop (NIL, i2sz 0)
  in
    array_initize_list_vt<vmstring_vt>
      (!strings, sz2i strings_size, lst)
  end

fn
vmstrings_section_vt_read {strings_size : int}
                          (f            : FILEref,
                           strings_size : size_t strings_size) :
    [p : addr]
    vmstrings_section_vt (strings_size, p) =
  let
    val @(pf, pfgc | p) = array_ptr_alloc<vmstring_vt> strings_size
    val _ = read_vmstrings (pf | f, strings_size, p)
  in
    @{
      pf = pf,
      pfgc = pfgc |
      n = strings_size,
      p = p
    }
  end

fn
vmstring_fprint {n, i    : int | i < n}
                (f       : FILEref,
                 strings : !vmstrings_section_vt n,
                 i       : size_t i) :
    void =
  {

    (*
     * The following code does some ‘unsafe’ tricks. For instance, it
     * is assumed each stored string is NUL-terminated.
     *)

    fn
    print_it (str : !vmstring_vt) : void =
      fileref_puts (f, $UN.cast{string} (str.p))

    prval _ = lemma_g1uint_param i
    val p_element = array_getref_at (!(strings.p), i)
    val @(pf_element | p_element) =
      $UN.castvwtp0
        {[n : int; p : addr] @(vmstring_vt @ p | ptr p)}
        (p_element)
    val _ = print_it (!p_element)
    prval _ = $UN.castview0{void} pf_element
  }

(********************************************************************)
(*                                                                  *)
(* vm_vt: the dataviewtype for a virtual machine.                   *)
(*                                                                  *)

datavtype instruction_vt =
| instruction_vt_1 of (byte)
| instruction_vt_5 of (byte, byte, byte, byte, byte)

#define OPCODE_COUNT 24

#define OP_HALT    0x0000  // 00000
#define OP_ADD     0x0001  // 00001
#define OP_SUB     0x0002  // 00010
#define OP_MUL     0x0003  // 00011
#define OP_DIV     0x0004  // 00100
#define OP_MOD     0x0005  // 00101
#define OP_LT      0x0006  // 00110
#define OP_GT      0x0007  // 00111
#define OP_LE      0x0008  // 01000
#define OP_GE      0x0009  // 01001
#define OP_EQ      0x000A  // 01010
#define OP_NE      0x000B  // 01011
#define OP_AND     0x000C  // 01100
#define OP_OR      0x000D  // 01101
#define OP_NEG     0x000E  // 01110
#define OP_NOT     0x000F  // 01111
#define OP_PRTC    0x0010  // 10000
#define OP_PRTI    0x0011  // 10001
#define OP_PRTS    0x0012  // 10010
#define OP_FETCH   0x0013  // 10011
#define OP_STORE   0x0014  // 10100
#define OP_PUSH    0x0015  // 10101
#define OP_JMP     0x0016  // 10110
#define OP_JZ      0x0017  // 10111

#define REGISTER_PC 0
#define REGISTER_SP 1
#define MAX_REGISTER REGISTER_SP

vtypedef vm_vt (strings_size : int,
                strings_addr : addr,
                code_size    : int,
                code_addr    : addr,
                data_size    : int,
                data_addr    : addr,
                stack_size   : int,
                stack_addr   : addr) =
  @{
    strings = vmstrings_section_vt (strings_size, strings_addr),
    code = vmarray_vt (byte, code_size, code_addr),
    data = vmarray_vt (vmint, data_size, data_addr),
    stack = vmarray_vt (vmint, stack_size, stack_addr),
    registers = vmarray_vt (vmint, MAX_REGISTER + 1)
  }

vtypedef vm_vt (strings_size : int,
                code_size    : int,
                data_size    : int,
                stack_size   : int) =
  [strings_addr : addr]
  [code_addr    : addr]
  [data_addr    : addr]
  [stack_addr   : addr]
  vm_vt (strings_size, strings_addr,
         code_size, code_addr,
         data_size, data_addr,
         stack_size, stack_addr)

vtypedef vm_vt =
  [strings_size : int]
  [code_size    : int]
  [data_size    : int]
  [stack_size   : int]
  vm_vt (strings_size, code_size, data_size, stack_size)

fn
vm_vt_free (vm : vm_vt) :
    void =
  let
    val @{
          strings = strings,
          code = code,
          data = data,
          stack = stack,
          registers = registers
        } = vm
  in
    vmstrings_section_vt_free strings;
    vmarray_vt_free<byte> code;
    vmarray_vt_free<vmint> data;
    vmarray_vt_free<vmint> stack;
    vmarray_vt_free<vmint> registers
  end

fn
opcode_name_to_byte {n, i, j : int | 0 <= i; i <= j; j <= n}
                    (arr : &(@[String0][OPCODE_COUNT]),
                     str : string n,
                     i   : size_t i,
                     j   : size_t j) :
    byte =
  let
    fun
    loop {k   : int | 0 <= k; k <= OPCODE_COUNT} .<OPCODE_COUNT - k>.
         (arr : &(@[String0][OPCODE_COUNT]),
          k   : int k) : byte =
      if k = OPCODE_COUNT then
        $raise bad_vm ("Unrecognized opcode name.")
      else if substr_equal (str, i, j, arr[k]) then
        i2byte k
      else
        loop (arr, succ k)
  in
    loop (arr, 0)
  end

fn {}
vmint_byte0 (i : vmint) :<>
    byte =
  vm2byte (i land (u2vm 0xFFU))

fn {}
vmint_byte1 (i : vmint) :<>
    byte =
  vm2byte ((i >> 8) land (u2vm 0xFFU))

fn {}
vmint_byte2 (i : vmint) :<>
    byte =
  vm2byte ((i >> 16) land (u2vm 0xFFU))

fn {}
vmint_byte3 (i : vmint) :<>
    byte =
  vm2byte (i >> 24)

fn
parse_instruction {n    : int | 0 <= n}
                  (arr  : &(@[String0][OPCODE_COUNT]),
                   line : string n) :
    instruction_vt =
  let
    val bad_instruction = "Bad VM instruction."
    val n = string_length (line)
    val i = skip_whitespace (line, n, i2sz 0)

    (* Skip the address field*)
    val i = skip_non_whitespace (line, n, i)

    val i = skip_whitespace (line, n, i)
    val j = skip_non_whitespace (line, n, i)
    val opcode = opcode_name_to_byte (arr, line, i, j)

    val start_of_argument = j

    fn
    finish_push () :
        instruction_vt =
      let
        val i1 = skip_whitespace (line, n, start_of_argument)
        val j1 = skip_non_whitespace (line, n, i1)
        val arg = parse_integer (line, i1, j1)
      in
        (* Little-endian storage. *)
        instruction_vt_5 (opcode, vmint_byte0 arg, vmint_byte1 arg,
                          vmint_byte2 arg, vmint_byte3 arg)
      end

    fn
    finish_fetch_or_store () :
        instruction_vt =
      let
        val i1 = skip_whitespace (line, n, start_of_argument)
        val j1 = skip_non_whitespace (line, n, i1)
      in
        if j1 - i1 < i2sz 3 then
          $raise bad_vm (bad_instruction)
        else if line[i1] <> '\[' || line[pred j1] <> ']' then
          $raise bad_vm (bad_instruction)
        else
          let
            val arg = parse_integer (line, succ i1, pred j1)
          in
            (* Little-endian storage. *)
            instruction_vt_5 (opcode, vmint_byte0 arg, vmint_byte1 arg,
                              vmint_byte2 arg, vmint_byte3 arg)
          end
      end

    fn
    finish_jmp_or_jz () :
        instruction_vt =
      let
        val i1 = skip_whitespace (line, n, start_of_argument)
        val j1 = skip_non_whitespace (line, n, i1)
      in
        if j1 - i1 < i2sz 3 then
          $raise bad_vm (bad_instruction)
        else if line[i1] <> '\(' || line[pred j1] <> ')' then
          $raise bad_vm (bad_instruction)
        else
          let
            val arg = parse_integer (line, succ i1, pred j1)
          in
            (* Little-endian storage. *)
            instruction_vt_5 (opcode, vmint_byte0 arg, vmint_byte1 arg,
                              vmint_byte2 arg, vmint_byte3 arg)
          end
      end
  in
    case+ byte2int0 opcode of
    | OP_PUSH => finish_push ()
    | OP_FETCH => finish_fetch_or_store ()
    | OP_STORE => finish_fetch_or_store ()
    | OP_JMP => finish_jmp_or_jz ()
    | OP_JZ => finish_jmp_or_jz ()
    | _ => instruction_vt_1 (opcode)
  end

fn
read_instructions (f   : FILEref,
                   arr : &(@[String0][OPCODE_COUNT])) :
    (List_vt (instruction_vt), Size_t) =
  (* Read the instructions from the input, producing a list of
     instruction_vt objects, and also calculating the total
     number of bytes in the instructions. *)
  let
    fun
    loop (arr          : &(@[String0][OPCODE_COUNT]),
          lst          : List_vt (instruction_vt),
          bytes_needed : Size_t) :
        @(List_vt (instruction_vt), Size_t) =
      if fileref_is_eof f then
        @(list_vt_reverse lst, bytes_needed)
      else
        let
          val line = fileref_get_line_string (f)
        in
          if fileref_is_eof f then
            begin
              free line;
              @(list_vt_reverse lst, bytes_needed)
            end
          else
            let
              val instruction =
                parse_instruction (arr, $UN.strptr2string line)
              val _ = free line
              prval _ = lemma_list_vt_param lst
            in
              case+ instruction of
              | instruction_vt_1 _ =>
                loop (arr, instruction :: lst, bytes_needed + i2sz 1)
              | instruction_vt_5 _ =>
                loop (arr, instruction :: lst, bytes_needed + i2sz 5)
            end
        end
  in
    loop (arr, NIL, i2sz 0)
  end

fn
list_of_instructions_to_code {bytes_needed : int}
                             (lst          : List_vt (instruction_vt),
                              bytes_needed : size_t bytes_needed) :
    [bytes_needed : int]
    vmarray_vt (byte, bytes_needed) =
  (* This routine consumes and destroys lst. *)
  let
    fun
    loop {n    : int | 0 <= n} .<n>.
         (code : &vmarray_vt (byte, bytes_needed),
          lst  : list_vt (instruction_vt, n),
          i    : Size_t) : void =
      case+ lst of
      | ~ NIL => ()
      | ~ head :: tail =>
        begin
          case head of
          | ~ instruction_vt_1 (byte1) =>
            let
              val _ = assertloc (i < bytes_needed)
            in
              code[i] := byte1;
              loop (code, tail, i + i2sz 1)
            end
          | ~ instruction_vt_5 (byte1, byte2, byte3, byte4, byte5) =>
            let
              val _ = assertloc (i + i2sz 4 < bytes_needed)
            in
              code[i] := byte1;
              code[i + i2sz 1] := byte2;
              code[i + i2sz 2] := byte3;
              code[i + i2sz 3] := byte4;
              code[i + i2sz 4] := byte5;
              loop (code, tail, i + i2sz 5)
            end
        end

    var code = vmarray_vt_alloc<byte> (bytes_needed, i2byte OP_HALT)

    prval _ = lemma_list_vt_param lst
    prval _ = lemma_g1uint_param bytes_needed
    val _ = loop (code, lst, i2sz 0)
  in
    code
  end

fn
read_and_parse_code (f   : FILEref,
                     arr : &(@[String0][OPCODE_COUNT])) :
    [bytes_needed : int]
    vmarray_vt (byte, bytes_needed) =
  let
    val @(instructions, bytes_needed) = read_instructions (f, arr)
  in
    list_of_instructions_to_code (instructions, bytes_needed)
  end

fn
parse_header_line {n    : int | 0 <= n}
                  (line : string n) :
    @(vmint, vmint) =
  let
    val bad_vm_header_line = "Bad VM header line."
    val n = string_length (line)
    val i = skip_whitespace (line, n, i2sz 0)
    val j = skip_non_whitespace (line, n, i)
    val _ = if ~substr_equal (line, i, j, "Datasize:") then
              $raise bad_vm (bad_vm_header_line)
    val i = skip_whitespace (line, n, j)
    val j = skip_non_whitespace (line, n, i)
    val data_size = parse_integer (line, i, j)
    val i = skip_whitespace (line, n, j)
    val j = skip_non_whitespace (line, n, i)
    val _ = if ~substr_equal (line, i, j, "Strings:") then
              $raise bad_vm (bad_vm_header_line)
    val i = skip_whitespace (line, n, j)
    val j = skip_non_whitespace (line, n, i)
    val strings_size = parse_integer (line, i, j)
  in
    @(data_size, strings_size)
  end

fn
read_vm (f                : FILEref,
         opcode_names_arr : &(@[String0][OPCODE_COUNT])) :
    vm_vt =
  let
    val line = fileref_get_line_string (f)

    val @(data_size, strings_size) =
      parse_header_line ($UN.strptr2string line)

    val _ = free line

    val [data_size : int] data_size =
      g1ofg0 (vm2sz data_size)
    val [strings_size : int] strings_size =
      g1ofg0 (vm2sz strings_size)

    prval _ = lemma_g1uint_param data_size
    prval _ = lemma_g1uint_param strings_size

    prval _ = prop_verify {0 <= data_size} ()
    prval _ = prop_verify {0 <= strings_size} ()

    val strings = vmstrings_section_vt_read (f, strings_size)
    val code = read_and_parse_code (f, opcode_names_arr)
    val data = vmarray_vt_alloc<vmint> (data_size, i2vm 0)
    val stack = vmarray_vt_alloc<vmint> (vmstack_size, i2vm 0)
    val registers = vmarray_vt_alloc<vmint> (i2sz (MAX_REGISTER + 1),
                                             i2vm 0)
  in
    @{
      strings = strings,
      code = code,
      data = data,
      stack = stack,
      registers = registers
    }
  end

fn {}
pop (vm : &vm_vt) :
    vmint =
  let
    macdef registers = vm.registers
    macdef stack = vm.stack
    val sp_before = registers[REGISTER_SP]
  in
    if sp_before = i2vm 0 then
      $raise vm_runtime_error ("Stack underflow.")
    else
      let
        val sp_after = sp_before - i2vm 1
        val _ = registers[REGISTER_SP] := sp_after
        val i = g1ofg0 (vm2sz sp_after)

        (* What follows is a runtime assertion that the upper stack
           boundary is not gone past, even though it certainly will
           not. This is necessary (assuming one does not use something
           such as $UN.prop_assert) because the stack pointer is a
           vmint, whose bounds cannot be proven at compile time.

           If you comment out the assertloc, the program will not pass
           typechecking.

           Compilers for many other languages will just insert such
           checks willy-nilly, leading programmers to turn off such
           instrumentation in the very code they provide to users.

           One might be tempted to use Size_t instead for the stack
           pointer, but what if the instruction set were later
           augmented with ways to read from or write into the stack
           pointer? *)
          val _ = assertloc (i < vmarray_vt_length stack)
      in
        stack[i]
      end
  end

fn {}
push (vm : &vm_vt,
      x  : vmint) :
    void =
  let
    macdef registers = vm.registers
    macdef stack = vm.stack
    val sp_before = registers[REGISTER_SP]
    val i = g1ofg0 (vm2sz sp_before)
  in
    if vmarray_vt_length stack <= i then
      $raise vm_runtime_error ("Stack overflow.")
    else
      let
        val sp_after = sp_before + i2vm 1
      in
        registers[REGISTER_SP] := sp_after;
        stack[i] := x
      end
  end

fn {}
fetch_data (vm    : &vm_vt,
            index : vmint) :
    vmint =
  let
    macdef data = vm.data
    val i = g1ofg0 (vm2sz index)
  in
    if vmarray_vt_length data <= i then
      $raise vm_runtime_error ("Fetch from outside the data section.")
    else
      data[i]
  end

fn {}
store_data (vm    : &vm_vt,
            index : vmint,
            x     : vmint) :
    void =
  let
    macdef data = vm.data
    val i = g1ofg0 (vm2sz index)
  in
    if vmarray_vt_length data <= i then
      $raise vm_runtime_error ("Store to outside the data section.")
    else
      data[i] := x
  end

fn {}
get_argument (vm : &vm_vt) :
    vmint =
  let
    macdef code = vm.code
    macdef registers = vm.registers
    val pc = registers[REGISTER_PC]
    val i = g1ofg0 (vm2sz pc)
  in
    if vmarray_vt_length code <= i + i2sz 4 then
      $raise (vm_runtime_error
                ("The program counter is out of bounds."))
    else
      let
        (* The data is stored little-endian. *)
        val byte0 = byte2vm code[i]
        val byte1 = byte2vm code[i + i2sz 1]
        val byte2 = byte2vm code[i + i2sz 2]
        val byte3 = byte2vm code[i + i2sz 3]
      in
        (byte0) lor (byte1 << 8) lor (byte2 << 16) lor (byte3 << 24)
      end
  end

fn {}
skip_argument (vm : &vm_vt) :
    void =
  let
    macdef registers = vm.registers
    val pc = registers[REGISTER_PC]
  in
    registers[REGISTER_PC] := pc + i2vm 4
  end

extern fun {}
unary_operation$inner : vmint -<> vmint
fn {}
unary_operation (vm : &vm_vt) :
    void =
  let
    macdef registers = vm.registers
    macdef stack = vm.stack
    val sp = registers[REGISTER_SP]
    val i = g1ofg0 (vm2sz (sp))
    prval _ = lemma_g1uint_param i
  in
    if i = i2sz 0 then
      $raise vm_runtime_error ("Stack underflow.")
    else
      let
        val _ = assertloc (i < vmarray_vt_length stack)

        (* The actual unary operation is inserted here during
           template expansion. *)
        val result = unary_operation$inner<> (stack[i - 1])
      in
        stack[i - 1] := result
      end
  end

extern fun {}
binary_operation$inner : (vmint, vmint) -<> vmint
fn {}
binary_operation (vm : &vm_vt) :
    void =
  let
    macdef registers = vm.registers
    macdef stack = vm.stack
    val sp_before = registers[REGISTER_SP]
    val i = g1ofg0 (vm2sz (sp_before))
    prval _ = lemma_g1uint_param i
  in
    if i <= i2sz 1 then
      $raise vm_runtime_error ("Stack underflow.")
    else
      let
        val _ = registers[REGISTER_SP] := sp_before - i2vm 1
        val _ = assertloc (i < vmarray_vt_length stack)

        (* The actual binary operation is inserted here during
           template expansion. *)
        val result =
          binary_operation$inner<> (stack[i - 2], stack[i - 1])
      in
        stack[i - 2] := result
      end
  end

fn {}
uop_neg (vm : &vm_vt) :
    void =
  let
    implement {}
    unary_operation$inner (x) =
      twos_complement x
  in
    unary_operation (vm)
  end

fn {}
uop_not (vm : &vm_vt) :
    void =
  let
    implement {}
    unary_operation$inner (x) =
      logical_not x
  in
    unary_operation (vm)
  end

fn {}
binop_add (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x + y
  in
    binary_operation (vm)
  end

fn {}
binop_sub (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x - y
  in
    binary_operation (vm)
  end

fn {}
binop_mul (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_mul y
  in
    binary_operation (vm)
  end

fn {}
binop_div (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_div y
  in
    binary_operation (vm)
  end

fn {}
binop_mod (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_mod y
  in
    binary_operation (vm)
  end

fn {}
binop_eq (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \equality y
  in
    binary_operation (vm)
  end

fn {}
binop_ne (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \inequality y
  in
    binary_operation (vm)
  end

fn {}
binop_lt (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_lt y
  in
    binary_operation (vm)
  end

fn {}
binop_gt (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_gt y
  in
    binary_operation (vm)
  end

fn {}
binop_le (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_lte y
  in
    binary_operation (vm)
  end

fn {}
binop_ge (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \signed_gte y
  in
    binary_operation (vm)
  end

fn {}
binop_and (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \logical_and y
  in
    binary_operation (vm)
  end

fn {}
binop_or (vm : &vm_vt) :
    void =
  let
    implement {}
    binary_operation$inner (x, y) =
      x \logical_or y
  in
    binary_operation (vm)
  end

fn {}
do_push (vm : &vm_vt) :
    void =
  let
    val arg = get_argument (vm)
  in
    push (vm, arg);
    skip_argument (vm)
  end

fn {}
do_fetch (vm : &vm_vt) :
    void =
  let
    val i = get_argument (vm)
    val x = fetch_data (vm, i)
  in
    push (vm, x);
    skip_argument (vm)
  end

fn {}
do_store (vm : &vm_vt) :
    void =
  let
    val i = get_argument (vm)
    val x = pop (vm)
  in
    store_data (vm, i, x);
    skip_argument (vm)
  end

fn {}
do_jmp (vm : &vm_vt) :
    void =
  let
    macdef registers = vm.registers
    val arg = get_argument (vm)
    val pc = registers[REGISTER_PC]
  in
    registers[REGISTER_PC] := pc + arg
  end

fn {}
do_jz (vm : &vm_vt) :
    void =
  let
    val x = pop (vm)
  in
    if x = i2vm 0 then
      do_jmp (vm)
    else
      skip_argument (vm)
  end

fn {}
do_prtc (f_output : FILEref,
         vm       : &vm_vt) :
    void =
  let
    val x = pop (vm)
  in
    fileref_putc (f_output, vm2i x)
  end

fn {}
do_prti (f_output : FILEref,
         vm       : &vm_vt) :
    void =
  let
    val x = pop (vm)
  in
    fprint! (f_output, vm2i x)
  end

fn {}
do_prts (f_output : FILEref,
         vm       : &vm_vt) :
    void =
  let
    val i = g1ofg0 (vm2sz (pop (vm)))
  in
    if vmstrings_section_vt_length (vm.strings) <= i then
      $raise vm_runtime_error ("String index out of bounds.")
    else
      vmstring_fprint (f_output, vm.strings, i)
  end

fn
vm_step (f_output     : FILEref,
         vm           : &vm_vt,
         machine_halt : &bool,
         bad_opcode   : &bool) :
    void =
  let
    macdef code = vm.code
    macdef registers = vm.registers

    val pc = registers[REGISTER_PC]

    val i = g1ofg0 (vm2sz (pc))
    prval _ = lemma_g1uint_param i
  in
    if vmarray_vt_length (code) <= i then
      $raise (vm_runtime_error
                ("The program counter is out of bounds."))
    else
      let
        val _ = registers[REGISTER_PC] := pc + i2vm 1

        val opcode = code[i]
        val u_opcode = byte2uint0 opcode
      in
        (* Dispatch by bifurcation on the bit pattern of the
           opcode. This method is logarithmic in the number
           of opcode values. *)
        machine_halt := false;
        bad_opcode := false;
        if (u_opcode land (~(0x1FU))) = 0U then
          begin
            if (u_opcode land 0x10U) = 0U then
              begin
                if (u_opcode land 0x08U) = 0U then
                  begin
                    if (u_opcode land 0x04U) = 0U then
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              (* OP_HALT *)
                              machine_halt := true
                            else
                              binop_add (vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_sub (vm)
                            else
                              binop_mul (vm)
                          end
                      end
                    else
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_div (vm)
                            else
                              binop_mod (vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_lt (vm)
                            else
                              binop_gt (vm)
                          end
                      end
                  end
                else
                  begin
                    if (u_opcode land 0x04U) = 0U then
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_le (vm)
                            else
                              binop_ge (vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_eq (vm)
                            else
                              binop_ne (vm)
                          end
                      end
                    else
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              binop_and (vm)
                            else
                              binop_or (vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              uop_neg (vm)
                            else
                              uop_not (vm)
                          end
                      end
                  end
              end
            else
              begin
                if (u_opcode land 0x08U) = 0U then
                  begin
                    if (u_opcode land 0x04U) = 0U then
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              do_prtc (f_output, vm)
                            else
                              do_prti (f_output, vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              do_prts (f_output, vm)
                            else
                              do_fetch (vm)
                          end
                      end
                    else
                      begin
                        if (u_opcode land 0x02U) = 0U then
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              do_store (vm)
                            else
                              do_push (vm)
                          end
                        else
                          begin
                            if (u_opcode land 0x01U) = 0U then
                              do_jmp (vm)
                            else
                              do_jz (vm)
                          end
                      end
                  end
                else
                  bad_opcode := true
              end
          end
        else
          bad_opcode := true
      end
  end

fn
vm_continue (f_output : FILEref,
             vm       : &vm_vt) :
    void =
  let
    fun
    loop (vm           : &vm_vt,
          machine_halt : &bool,
          bad_opcode   : &bool) : void =
      if ~machine_halt && ~bad_opcode then
        begin
          vm_step (f_output, vm, machine_halt, bad_opcode);
          loop (vm, machine_halt, bad_opcode)
        end

    var machine_halt : bool = false
    var bad_opcode : bool = false
  in
    loop (vm, machine_halt, bad_opcode);
    if bad_opcode then
      $raise vm_runtime_error ("Unrecognized opcode at runtime.")
  end

fn
vm_initialize (vm : &vm_vt) :
    void =
  let
    macdef data = vm.data
    macdef registers = vm.registers
  in
    vmarray_vt_fill (data, i2vm 0);
    registers[REGISTER_PC] := i2vm 0;
    registers[REGISTER_SP] := i2vm 0
  end

fn
vm_run (f_output : FILEref,
        vm       : &vm_vt) :
    void =
  begin
    vm_initialize (vm);
    vm_continue (f_output, vm)
  end

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

implement
main0 (argc, argv) =
  {
    val inpfname =
      if 2 <= argc then
        $UN.cast{string} argv[1]
      else
        "-"
    val outfname =
      if 3 <= argc then
        $UN.cast{string} argv[2]
      else
        "-"

    val inpf =
      if (inpfname : string) = "-" then
        stdin_ref
      else
        fileref_open_exn (inpfname, file_mode_r)

    val outf =
      if (outfname : string) = "-" then
        stdout_ref
      else
        fileref_open_exn (outfname, file_mode_w)

    (* The following order must match that established by
       OP_HALT, OP_ADD, OP_SUB, etc. *)
    var opcode_order =
      @[String0][OPCODE_COUNT] ("halt",  // 00000   bit pattern
                                "add",   // 00001
                                "sub",   // 00010
                                "mul",   // 00011
                                "div",   // 00100
                                "mod",   // 00101
                                "lt",    // 00110
                                "gt",    // 00111
                                "le",    // 01000
                                "ge",    // 01001
                                "eq",    // 01010
                                "ne",    // 01011
                                "and",   // 01100
                                "or",    // 01101
                                "neg",   // 01110
                                "not",   // 01111
                                "prtc",  // 10000
                                "prti",  // 10001
                                "prts",  // 10010
                                "fetch", // 10011
                                "store", // 10100
                                "push",  // 10101
                                "jmp",   // 10110
                                "jz")    // 10111

    val _ = ensure_that_vmint_is_suitable ()
    var vm = read_vm (inpf, opcode_order)
    val _ = vm_run (outf, vm)
    val _ = vm_vt_free vm
  }

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


function error(msg) {
  printf("%s\n", msg)
  exit(1)
}

function bytes_to_int(bstr,          i, sum) {
  sum = 0
  for (i=word_size-1; i>=0; i--) {
    sum *= 256
    sum += code[bstr+i]
  }
  return sum
}

function emit_byte(x) {
  code[next_free_code_index++] = x
}

function emit_word(x,       i) {
  for (i=0; i<word_size; i++) {
    emit_byte(int(x)%256);
    x = int(x/256)
  }
}

function run_vm(data_size) {
  sp = data_size + 1
  pc = 0
  while (1) {
    op = code[pc++]
    if (op == FETCH) {
      stack[sp++] = stack[bytes_to_int(pc)]
      pc += word_size
    } else if (op == STORE) {
      stack[bytes_to_int(pc)] = stack[--sp]
      pc += word_size
    } else if (op == PUSH) {
      stack[sp++] = bytes_to_int(pc)
      pc += word_size
    } else if (op == ADD ) { stack[sp-2] += stack[sp-1]; sp--
    } else if (op == SUB ) { stack[sp-2] -= stack[sp-1]; sp--
    } else if (op == MUL ) { stack[sp-2] *= stack[sp-1]; sp--
    } else if (op == DIV ) { stack[sp-2]  = int(stack[sp-2] / stack[sp-1]); sp--
    } else if (op == MOD ) { stack[sp-2] %= stack[sp-1]; sp--
    } else if (op == LT  ) { stack[sp-2] = stack[sp-2] <  stack[sp-1]; sp--
    } else if (op == GT  ) { stack[sp-2] = stack[sp-2] >  stack[sp-1]; sp--
    } else if (op == LE  ) { stack[sp-2] = stack[sp-2] <= stack[sp-1]; sp--
    } else if (op == GE  ) { stack[sp-2] = stack[sp-2] >= stack[sp-1]; sp--
    } else if (op == EQ  ) { stack[sp-2] = stack[sp-2] == stack[sp-1]; sp--
    } else if (op == NE  ) { stack[sp-2] = stack[sp-2] != stack[sp-1]; sp--
    } else if (op == AND ) { stack[sp-2] = stack[sp-2] && stack[sp-1]; sp--
    } else if (op == OR  ) { stack[sp-2] = stack[sp-2] || stack[sp-1]; sp--
    } else if (op == NEG ) { stack[sp-1] = - stack[sp-1]
    } else if (op == NOT ) { stack[sp-1] = ! stack[sp-1]
    } else if (op == JMP ) { pc += bytes_to_int(pc)
    } else if (op == JZ  ) { if (stack[--sp]) { pc += word_size } else { pc += bytes_to_int(pc) }
    } else if (op == PRTC) { printf("%c", stack[--sp])
    } else if (op == PRTS) { printf("%s", string_pool[stack[--sp]])
    } else if (op == PRTI) { printf("%d", stack[--sp])
    } else if (op == HALT) { break
    }
  } # while
}

function str_trans(srce,           dest, i) {
  dest = ""
  for (i=1; i <= length(srce); ) {
    if (substr(srce, i, 1) == "\\" && i < length(srce)) {
      if (substr(srce, i+1, 1) == "n") {
        dest = dest "\n"
        i += 2
      } else if (substr(srce, i+1, 1) == "\\") {
        dest = dest "\\"
        i += 2
      }
    } else {
      dest = dest substr(srce, i, 1)
      i += 1
    }
  }
  return dest
}

function load_code(            n, i) {
  getline line
  if (line ==  "")
    error("empty line")
  n=split(line, line_list)
  data_size = line_list[2]
  n_strings = line_list[4]
  for (i=0; i<n_strings; i++) {
    getline line
    gsub(/\n/, "", line)
    gsub(/"/ , "", line)
    string_pool[i] = str_trans(line)
  }
  while (getline) {
    offset = int($1)
    instr  = $2
    opcode = code_map[instr]
    if (opcode == "")
      error("Unknown instruction " instr " at " offset)
    emit_byte(opcode)
    if (opcode == JMP || opcode == JZ) {
      p = int($4)
      emit_word(p - (offset + 1))
    } else if (opcode == PUSH) {
      value = int($3)
      emit_word(value)
    } else if (opcode == FETCH || opcode == STORE) {
      gsub(/\[/, "", $3)
      gsub(/\]/, "", $3)
      value = int($3)
      emit_word(value)
    }
  }
  return data_size
}

BEGIN {
  code_map["fetch"] = FETCH =  1
  code_map["store"] = STORE =  2
  code_map["push" ] = PUSH  =  3
  code_map["add"  ] = ADD   =  4
  code_map["sub"  ] = SUB   =  5
  code_map["mul"  ] = MUL   =  6
  code_map["div"  ] = DIV   =  7
  code_map["mod"  ] = MOD   =  8
  code_map["lt"   ] = LT    =  9
  code_map["gt"   ] = GT    = 10
  code_map["le"   ] = LE    = 11
  code_map["ge"   ] = GE    = 12
  code_map["eq"   ] = EQ    = 13
  code_map["ne"   ] = NE    = 14
  code_map["and"  ] = AND   = 15
  code_map["or"   ] = OR    = 16
  code_map["neg"  ] = NEG   = 17
  code_map["not"  ] = NOT   = 18
  code_map["jmp"  ] = JMP   = 19
  code_map["jz"   ] = JZ    = 20
  code_map["prtc" ] = PRTC  = 21
  code_map["prts" ] = PRTS  = 22
  code_map["prti" ] = PRTI  = 23
  code_map["halt" ] = HALT  = 24

  next_free_node_index = 1
  next_free_code_index = 0
  word_size   = 4
  input_file = "-"
  if (ARGC > 1)
    input_file = ARGV[1]
  data_size = load_code()
  run_vm(data_size)
}


#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <stdint.h>
#include <ctype.h>

#define NELEMS(arr) (sizeof(arr) / sizeof(arr[0]))

#define da_dim(name, type)  type *name = NULL;          \
                            int _qy_ ## name ## _p = 0;  \
                            int _qy_ ## name ## _max = 0

#define da_redim(name)      do {if (_qy_ ## name ## _p >= _qy_ ## name ## _max) \
                                name = realloc(name, (_qy_ ## name ## _max += 32) * sizeof(name[0]));} while (0)

#define da_rewind(name)     _qy_ ## name ## _p = 0

#define da_append(name, x)  do {da_redim(name); name[_qy_ ## name ## _p++] = x;} while (0)

typedef unsigned char uchar;
typedef uchar code;

typedef enum { FETCH, STORE, PUSH, ADD, SUB, MUL, DIV, MOD, LT, GT, LE, GE, EQ, NE, AND,
    OR, NEG, NOT, JMP, JZ, PRTC, PRTS, PRTI, HALT
} Code_t;

typedef struct Code_map {
    char    *text;
    Code_t   op;
} Code_map;

Code_map code_map[] = {
    {"fetch",  FETCH},
    {"store",  STORE},
    {"push",   PUSH },
    {"add",    ADD  },
    {"sub",    SUB  },
    {"mul",    MUL  },
    {"div",    DIV  },
    {"mod",    MOD  },
    {"lt",     LT   },
    {"gt",     GT   },
    {"le",     LE   },
    {"ge",     GE   },
    {"eq",     EQ   },
    {"ne",     NE   },
    {"and",    AND  },
    {"or",     OR   },
    {"neg",    NEG  },
    {"not",    NOT  },
    {"jmp",    JMP  },
    {"jz",     JZ   },
    {"prtc",   PRTC },
    {"prts",   PRTS },
    {"prti",   PRTI },
    {"halt",   HALT },
};

FILE *source_fp;
da_dim(object, code);

void error(const char *fmt, ... ) {
    va_list ap;
    char buf[1000];

    va_start(ap, fmt);
    vsprintf(buf, fmt, ap);
    va_end(ap);
    printf("error: %s\n", buf);
    exit(1);
}

/*** Virtual Machine interpreter ***/
void run_vm(const code obj[], int32_t data[], int g_size, char **string_pool) {
    int32_t *sp = &data[g_size + 1];
    const code *pc = obj;

    again:
    switch (*pc++) {
        case FETCH: *sp++ = data[*(int32_t *)pc];  pc += sizeof(int32_t); goto again;
        case STORE: data[*(int32_t *)pc] = *--sp;  pc += sizeof(int32_t); goto again;
        case PUSH:  *sp++ = *(int32_t *)pc;        pc += sizeof(int32_t); goto again;
        case ADD:   sp[-2] += sp[-1]; --sp;                             goto again;
        case SUB:   sp[-2] -= sp[-1]; --sp;                             goto again;
        case MUL:   sp[-2] *= sp[-1]; --sp;                             goto again;
        case DIV:   sp[-2] /= sp[-1]; --sp;                             goto again;
        case MOD:   sp[-2] %= sp[-1]; --sp;                             goto again;
        case LT:    sp[-2] = sp[-2] <  sp[-1]; --sp;                    goto again;
        case GT:    sp[-2] = sp[-2] >  sp[-1]; --sp;                    goto again;
        case LE:    sp[-2] = sp[-2] <= sp[-1]; --sp;                    goto again;
        case GE:    sp[-2] = sp[-2] >= sp[-1]; --sp;                    goto again;
        case EQ:    sp[-2] = sp[-2] == sp[-1]; --sp;                    goto again;
        case NE:    sp[-2] = sp[-2] != sp[-1]; --sp;                    goto again;
        case AND:   sp[-2] = sp[-2] && sp[-1]; --sp;                    goto again;
        case OR:    sp[-2] = sp[-2] || sp[-1]; --sp;                    goto again;
        case NEG:   sp[-1] = -sp[-1];                                   goto again;
        case NOT:   sp[-1] = !sp[-1];                                   goto again;
        case JMP:   pc += *(int32_t *)pc;                               goto again;
        case JZ:    pc += (*--sp == 0) ? *(int32_t *)pc : (int32_t)sizeof(int32_t); goto again;
        case PRTC:  printf("%c", sp[-1]); --sp;                         goto again;
        case PRTS:  printf("%s", string_pool[sp[-1]]); --sp;            goto again;
        case PRTI:  printf("%d", sp[-1]); --sp;                         goto again;
        case HALT:                                                      break;
        default:    error("Unknown opcode %d\n", *(pc - 1));
    }
}

char *read_line(int *len) {
    static char *text = NULL;
    static int textmax = 0;

    for (*len = 0; ; (*len)++) {
        int ch = fgetc(source_fp);
        if (ch == EOF || ch == '\n') {
            if (*len == 0)
                return NULL;
            break;
        }
        if (*len + 1 >= textmax) {
            textmax = (textmax == 0 ? 128 : textmax * 2);
            text = realloc(text, textmax);
        }
        text[*len] = ch;
    }
    text[*len] = '\0';
    return text;
}

char *rtrim(char *text, int *len) {         // remove trailing spaces
    for (; *len > 0 && isspace(text[*len - 1]); --(*len))
        ;

    text[*len] = '\0';
    return text;
}

char *translate(char *st) {
    char *p, *q;
    if (st[0] == '"')                       // skip leading " if there
        ++st;
    p = q = st;

    while ((*p++ = *q++) != '\0') {
        if (q[-1] == '\\') {
            if (q[0] == 'n') {
                p[-1] = '\n';
                ++q;
            } else if (q[0] == '\\') {
                ++q;
            }
        }
        if (q[0] == '"' && q[1] == '\0')    // skip trialing " if there
            ++q;
    }

    return st;
}

/* convert an opcode string into its byte value */
int findit(const char text[], int offset) {
    for (size_t i = 0; i < sizeof(code_map) / sizeof(code_map[0]); i++) {
        if (strcmp(code_map[i].text, text) == 0)
            return code_map[i].op;
    }
    error("Unknown instruction %s at %d\n", text, offset);
    return -1;
}

void emit_byte(int c) {
    da_append(object, (uchar)c);
}

void emit_int(int32_t n) {
    union {
        int32_t n;
        unsigned char c[sizeof(int32_t)];
    } x;

    x.n = n;

    for (size_t i = 0; i < sizeof(x.n); ++i) {
        emit_byte(x.c[i]);
    }
}

/*
Datasize: 5 Strings: 3
" is prime\n"
"Total primes found: "
"\n"
 154 jmp    (-73) 82
 164 jz     (32) 197
 175 push  0
 159 fetch [4]
 149 store [3]
 */

/* Load code into global array object, return the string pool and data size */
char **load_code(int *ds) {
    int line_len, n_strings;
    char **string_pool;
    char *text = read_line(&line_len);
    text = rtrim(text, &line_len);

    strtok(text, " ");                      // skip "Datasize:"
    *ds = atoi(strtok(NULL, " "));          // get actual data_size
    strtok(NULL, " ");                      // skip "Strings:"
    n_strings = atoi(strtok(NULL, " "));    // get number of strings

    string_pool = malloc(n_strings * sizeof(char *));
    for (int i = 0; i < n_strings; ++i) {
        text = read_line(&line_len);
        text = rtrim(text, &line_len);
        text = translate(text);
        string_pool[i] = strdup(text);
    }

    for (;;) {
        int len;

        text = read_line(&line_len);
        if (text == NULL)
            break;
        text = rtrim(text, &line_len);

        int offset = atoi(strtok(text, " "));   // get the offset
        char *instr = strtok(NULL, " ");    // get the instruction
        int opcode = findit(instr, offset);
        emit_byte(opcode);
        char *operand = strtok(NULL, " ");

        switch (opcode) {
            case JMP: case JZ:
                operand++;                  // skip the '('
                len = strlen(operand);
                operand[len - 1] = '\0';    // remove the ')'
                emit_int(atoi(operand));
                break;
            case PUSH:
                emit_int(atoi(operand));
                break;
            case FETCH: case STORE:
                operand++;                  // skip the '['
                len = strlen(operand);
                operand[len - 1] = '\0';    // remove the ']'
                emit_int(atoi(operand));
                break;
        }
    }
    return string_pool;
}

void init_io(FILE **fp, FILE *std, const char mode[], const char fn[]) {
    if (fn[0] == '\0')
        *fp = std;
    else if ((*fp = fopen(fn, mode)) == NULL)
        error(0, 0, "Can't open %s\n", fn);
}

int main(int argc, char *argv[]) {
    init_io(&source_fp, stdin,  "r",  argc > 1 ? argv[1] : "");
    int data_size;
    char **string_pool = load_code(&data_size);
    int data[1000 + data_size];
    run_vm(object, data, data_size, string_pool);
}


        >>SOURCE FORMAT IS FREE
identification division.
*> this code is dedicated to the public domain
*> (GnuCOBOL) 2.3-dev.0
program-id. vminterpreter.
environment division.
configuration section.
repository.  function all intrinsic.
input-output section.
file-control.
    select input-file assign using input-name
        status is input-status
        organization is line sequential.
data division.

file section.
fd  input-file.
01  input-record pic x(64).

working-storage section.
01  program-name pic x(32).
01  input-name pic x(32).
01  input-status pic xx.

01  error-record pic x(64) value spaces global.

01  v-max pic 99.
01  parameters.
    03  offset pic 999.
    03  opcode pic x(8).
    03  parm0 pic x(16).
    03  parm1 pic x(16).
    03  parm2 pic x(16).

01  opcodes.
    03  opFETCH pic x value x'00'.
    03  opSTORE pic x value x'01'.
    03  opPUSH  pic x value x'02'.
    03  opADD   pic x value x'03'.
    03  opSUB   pic x value x'04'.
    03  opMUL   pic x value x'05'.
    03  opDIV   pic x value x'06'.
    03  opMOD   pic x value x'07'.
    03  opLT    pic x value x'08'.
    03  opGT    pic x value x'09'.
    03  opLE    pic x value x'0A'.
    03  opGE    pic x value x'0B'.
    03  opEQ    pic x value x'0C'.
    03  opNE    pic x value x'0D'.
    03  opAND   pic x value x'0E'.
    03  opOR    pic x value x'0F'.
    03  opNEG   pic x value x'10'.
    03  opNOT   pic x value x'11'.
    03  opJMP   pic x value x'13'.
    03  opJZ    pic x value x'14'.
    03  opPRTC  pic x value x'15'.
    03  opPRTS  pic x value x'16'.
    03  opPRTI  pic x value x'17'.
    03  opHALT  pic x value x'18'.

01  filler.
    03  s pic 99.
    03  s-max pic 99 value 0.
    03  s-lim pic 99 value 16.
    03  filler occurs 16.
        05  string-length pic 99.
        05  string-entry pic x(48).

01  filler.
    03  v pic 99.
    03  v-lim pic 99 value 16.
    03  variables occurs 16 usage binary-int.

01  generated-code global.
    03  c  pic 999 value 1.
    03  pc pic 999.
    03  c-lim pic 999 value 512.
    03  kode pic x(512).

01  filler.
    03  stack1 pic 999 value 2.
    03  stack2 pic 999 value 1.
    03  stack-lim pic 999 value 998.
    03  stack occurs 998 usage binary-int.

01  display-definitions global.
    03  ascii-character.
        05  numeric-value usage binary-char.
    03  display-integer pic -(9)9.
    03  word-x.
        05  word usage binary-int.
    03  word-length pic 9.
    03  string1 pic 99.
    03  length1 pic 99.
    03  count1 pic 99.
    03  display-pending pic x.

procedure division.
start-vminterpreter.
    display 1 upon command-line *> get arg(1)
    accept program-name from argument-value
    move length(word) to word-length
    perform load-code
    perform run-code
    stop run
    .
run-code.
    move 1 to pc
    perform until pc >= c
        evaluate kode(pc:1)
        when opFETCH
            perform push-stack
            move kode(pc + 1:word-length) to word-x
            add 1 to word *> convert offset to subscript
            move variables(word) to stack(stack1)
            add word-length to pc
        when opPUSH
            perform push-stack
            move kode(pc + 1:word-length) to word-x
            move word to stack(stack1)
            add word-length to pc
        when opNEG
            compute stack(stack1) = -stack(stack1)
        when opNOT
            if stack(stack1) = 0
                move 1 to stack(stack1)
            else
                move 0 to stack(stack1)
            end-if
        when opJMP
            move kode(pc + 1:word-length) to word-x
            move word to pc
        when opHALT
            if display-pending = 'Y'
                display space
            end-if
            exit perform
        when opJZ
            if stack(stack1) = 0
                move kode(pc + 1:word-length) to word-x
                move word to pc
            else
                add word-length to pc
            end-if
            perform pop-stack
        when opSTORE
            move kode(pc + 1:word-length) to word-x
            add 1 to word *> convert offset to subscript
            move stack(stack1) to variables(word)
            add word-length to pc
            perform pop-stack
        when opADD
            add stack(stack1) to stack(stack2)
            perform pop-stack
        when opSUB
            subtract stack(stack1) from stack(stack2)
            perform pop-stack
        when opMUL
            multiply stack(stack1) by stack(stack2)
                *>rounded mode nearest-toward-zero *> doesn't match python
            perform pop-stack
        when opDIV
            divide stack(stack1) into stack(stack2)
                *>rounded mode nearest-toward-zero *> doesn't match python
            perform pop-stack
        when opMOD
            move mod(stack(stack2),stack(stack1)) to stack(stack2)
            perform pop-stack
        when opLT
            if stack(stack2) <  stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opGT
            if stack(stack2) >  stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opLE
            if stack(stack2) <= stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opGE
            if stack(stack2) >= stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opEQ
            if stack(stack2) = stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opNE
            if stack(stack2) <> stack(stack1)
                move 1 to stack(stack2)
            else
                move 0 to stack(stack2)
            end-if
            perform pop-stack
        when opAND
            call "CBL_AND" using stack(stack1) stack(stack2) by value word-length
            perform pop-stack
        when opOR
            call "CBL_OR" using stack(stack1) stack(stack2) by value word-length
            perform pop-stack
        when opPRTC
            move stack(stack1) to numeric-value
            if numeric-value = 10
                display space
                move 'N' to display-pending
            else
                display ascii-character with no advancing
                move 'Y' to display-pending
            end-if
            perform pop-stack
        when opPRTS
            add 1 to word *> convert offset to subscript
            move 1 to string1
            move string-length(word) to length1
            perform until string1 > string-length(word)
                move 0 to count1
                inspect string-entry(word)(string1:length1)
                    tallying count1 for characters before initial '\'   *> ' workaround code highlighter problem
                evaluate true
                when string-entry(word)(string1 + count1 + 1:1) = 'n' *> \n
                    display string-entry(word)(string1:count1)
                    move 'N' to display-pending
                    compute string1 = string1 + 2 + count1
                    compute length1 = length1 - 2 - count1
                when string-entry(word)(string1 + count1 + 1:1) = '\' *> ' \\
                    display string-entry(word)(string1:count1 + 1) with no advancing
                    move 'Y' to display-pending
                    compute string1 = string1 + 2 + count1
                    compute length1 = length1 - 2 - count1
                when other
                    display string-entry(word)(string1:count1) with no advancing
                    move 'Y' to display-pending
                    add count1 to string1
                    subtract count1 from length1
                end-evaluate
            end-perform
            perform pop-stack
        when opPRTI
            move stack(stack1) to display-integer
            display trim(display-integer) with no advancing
            move 'Y' to display-pending
            perform pop-stack
        end-evaluate
        add 1 to pc
    end-perform
    .
push-stack.
    if stack1 >= stack-lim
        string 'in vminterpreter at ' pc ' stack overflow at ' stack-lim into error-record
        perform report-error
    end-if
    add 1 to stack1 stack2
    >>d display ' push at ' pc space stack1 space stack2
    .
pop-stack.
    if stack1 < 2
        string 'in vminterpreter at ' pc ' stack underflow' into error-record
        perform report-error
    end-if
    >>d display ' pop at ' pc space stack1 space stack2
    subtract 1 from stack1 stack2
    .
load-code.
    perform read-input
    if input-status <> '00'
        string 'in vminterpreter no input data' into error-record
        perform report-error
    end-if

    unstring input-record delimited by all spaces into parm1 v-max parm2 s-max
    if v-max > v-lim
        string 'in vminterpreter datasize exceeds ' v-lim into error-record
        perform report-error
    end-if
    if s-max > s-lim
        string 'in vminterpreter number of strings exceeds ' s-lim into error-record
        perform report-error
    end-if

    perform read-input
    perform varying s from 1 by 1 until s > s-max
    or input-status <> '00'
        compute string-length(s) string-length(word) = length(trim(input-record)) - 2
        move input-record(2:string-length(word)) to string-entry(s)
        perform read-input
    end-perform
    if s <= s-max
        string 'in vminterpreter not all strings found' into error-record
        perform report-error
    end-if

    perform until input-status <> '00'
        initialize parameters
        unstring input-record delimited by all spaces into
            parm0 offset opcode parm1 parm2
        evaluate opcode
        when 'fetch'
            call 'emitbyte' using opFETCH
            call 'emitword' using parm1
        when 'store'
            call 'emitbyte' using opSTORE
            call 'emitword' using parm1
        when 'push'
            call 'emitbyte' using opPUSH
            call 'emitword' using parm1
        when 'add' call 'emitbyte' using opADD
        when 'sub' call 'emitbyte' using opSUB
        when 'mul' call 'emitbyte' using opMUL
        when 'div' call 'emitbyte' using opDIV
        when 'mod' call 'emitbyte' using opMOD
        when 'lt'  call 'emitbyte' using opLT
        when 'gt'  call 'emitbyte' using opGT
        when 'le'  call 'emitbyte' using opLE
        when 'ge'  call 'emitbyte' using opGE
        when 'eq'  call 'emitbyte' using opEQ
        when 'ne'  call 'emitbyte' using opNE
        when 'and' call 'emitbyte' using opAND
        when 'or'  call 'emitbyte' using opOR
        when 'not' call 'emitbyte' using opNOT
        when 'neg' call 'emitbyte' using opNEG
        when 'jmp'
             call 'emitbyte' using opJMP
             call 'emitword' using parm2
        when 'jz'
             call 'emitbyte' using opJZ
             call 'emitword' using parm2
        when 'prtc' call 'emitbyte' using opPRTC
        when 'prts' call 'emitbyte' using opPRTS
        when 'prti' call 'emitbyte' using opPRTI
        when 'halt' call 'emitbyte' using opHALT
        when other
            string 'in vminterpreter unknown opcode ' trim(opcode) ' at ' offset into error-record
            perform report-error
        end-evaluate
        perform read-input
    end-perform
    .
read-input.
    if program-name = spaces
        move '00' to input-status
        accept input-record on exception move '10' to input-status end-accept
        exit paragraph
    end-if
    if input-name = spaces
        string program-name delimited by space '.gen' into input-name
        open input input-file
        if input-status <> '00'
            string 'in vminterpreter ' trim(input-name) ' file open status ' input-status
                into error-record
            perform report-error
        end-if
    end-if
    read input-file into input-record
    evaluate input-status
    when '00'
        continue
    when '10'
        close input-file
    when other
        string 'in vminterpreter unexpected input-status: ' input-status into error-record
        perform report-error
    end-evaluate
    .
report-error.
    display error-record upon syserr
    stop run with error status -1
    .
identification division.
program-id. emitbyte.
data division.
linkage section.
01  opcode pic x.
procedure division using opcode.
start-emitbyte.
    if c >= c-lim
        string 'in vminterpreter emitbyte c exceeds ' c-lim into error-record
        call 'reporterror'
    end-if
    move opcode to kode(c:1)
    add 1 to c
    .
end program emitbyte.

identification division.
program-id. emitword.
data division.
working-storage section.
01  word-temp pic x(8).
linkage section.
01  word-value any length.
procedure division using word-value.
start-emitword.
    if c + word-length >= c-lim
        string 'in vminterpreter emitword c exceeds ' c-lim into error-record
        call 'reporterror'
    end-if
    move word-value to word-temp
    inspect word-temp converting '[' to ' '
    inspect word-temp converting ']' to ' '
    move numval(trim(word-temp)) to word
    move word-x to kode(c:word-length)
    add word-length to c
    .
end program emitword.

end program vminterpreter.


; BUGGY - FIX

#Persistent
#SingleInstance OFF
SetBatchLines, -1
SortMethods := "Bogo,Bubble,Cocktail,Counting,Gnome,Insertion,Merge,Permutation,Quick,Selection,Shell,BuiltIn"
Gui, Add, Edit, vInput, numbers,separated,by,commas,without,spaces,afterwards
Loop, PARSE, SortMethods, `,
	Gui, Add, CheckBox, v%A_LoopField%, %A_LoopField% Sort
Gui, Add, Button, gTest, Test!
Gui, Show,, SortTest!
Return
Test:
SplashTextOn,,, Test Commencing
Sleep 2500
SplashTextOff
Gui, +OwnDialogs
Gui, Submit, NoHide
Loop, PARSE, SortMethods, `,
{
	If (%A_LoopField%)
	{
		DllCall("QueryPerformanceCounter", "Int64 *", %A_LoopField%Begin)
		%A_LoopField%Out := %A_LoopField%Sort(Input)
		DllCall("QueryPerformanceCounter", "Int64 *", %A_LoopField%Time)
		%A_LoopField%End := %A_LoopField%Begin + %A_LoopField%Time
		%A_LoopField%Time -= %A_LoopField%Begin
	}
}
Time := ""
Loop, PARSE, SortMethods, `,
	If (%A_LoopField%)
		Time .= A_LoopField . " Sort: " . %A_LoopField%Time . "`t`t" . %A_LoopField%Out . "`r`n"
MsgBox,, Results!, %Time%
Return

; Sorting funtions (Bogo, Bubble, Cocktail, Counting, Gnome, Insertion, Merge, Permutation, Quick, Selection, Shell, BuiltIn):

BogoSort(var)
{
	sorted := 1
	Loop, Parse, var
	{
		current := A_LoopField
		rest := SubStr(var, A_Index)
		Loop, Parse, rest
		{
			If (current > A_LoopField)
			sorted := 0
		}
	}
	While !sorted {
		sorted := 1
		Loop, Parse, var, `,
		{
			current := A_LoopField
			rest := SubStr(var, A_Index)
			Loop, Parse, rest, `,
			{
				If (current > A_LoopField)
				sorted := 0
			}
		}

		Sort, var, D`, Random
	}
	Return var
}

BubbleSort(var)
{
	StringSplit, array, var, `,
	hasChanged = 1
	size := array0
	While hasChanged
	{
		hasChanged = 0
		Loop, % (size - 1)
		{
			i := array%A_Index%
			aj := A_Index + 1
			j := array%aj%
			If (j < i)
			{
				temp := array%A_Index%
				array%A_Index% := array%aj%
				array%aj% := temp
				hasChanged = 1
			}
		}
	}
	Loop, % size
	sorted .= "," . array%A_Index%
	Return substr(sorted,2)
}

CocktailSort(var)
{
	StringSplit array, var, `,
	i0 := 1, i1 := array0
	Loop
	{
		Changed =
		Loop % i1-- -i0 {
			j := i0+A_Index, i := j-1
			If (array%j% < array%i%)
				t := array%i%, array%i% := array%j%, array%j% := t
				,Changed = 1
		}
		IfEqual Changed,, Break
		Loop % i1-i0++
		{
			i := i1-A_Index, j := i+1
			If (array%j% < array%i%)
			t := array%i%, array%i% := array%j%, array%j% := t
			,Changed = 1
		}
		IfEqual Changed,, Break
	}
	Loop % array0
		sorted .= "," . array%A_Index%
	Return SubStr(sorted,2)
}

CountingSort(var)
{
	max := min := substr(var, 1, instr(var, ","))
	Loop, parse, var, `,
	{
		If (A_LoopField > max)
			max := A_LoopField

		Else If (A_LoopField < min)
			min := A_LoopField
	}
	Loop % max-min+1
		i := A_Index-1, a%i% := 0
	Loop, Parse, var, `,
		i := A_LoopField-min, a%i%++
	Loop % max-min+1
	{
		i := A_Index-1, v := i+min
		Loop % a%i%
			t .= "," v
	}
	Return SubStr(t,2)
}

GnomeSort(var) {
	StringSplit, a, var, `,
	i := 2, j := 3
	While i <= a0 {
		u := i-1
		If (a%u% < a%i%)
			i := j, j := j+1
		Else {
			t := a%u%, a%u% := a%i%, a%i% := t
			If (--i = 1)
				i := j, j++
		}
	}
	Loop % a0
	sorted .= "," . a%A_Index%
	Return SubStr(sorted,2)
}

InsertionSort(var) {
	StringSplit, a, var, `,
	Loop % a0-1 {
		i := A_Index+1, v := a%i%, j := i-1
		While j>0 and a%j%>v
			u := j+1, a%u% := a%j%, j--
		u := j+1, a%u% := v
	}
	Loop % a0
	sorted .= "," . a%A_Index%
	Return SubStr(sorted,2)
}

MergeSort(var) {
	StringReplace, t, var, `,,, UseErrorLevel
	L := ((t = "") ? 0 : ErrorLevel+1)
	If (2 > L)
		Return var
	StringGetPos, p, var, `,, % "L" L//2
	list0 := MergeSort(SubStr(var,1,p))
	list1 := MergeSort(SubStr(var,p+2))
	If (list0 = "")
		Return list1
	Else If (list1 = "")
		Return list0
	list := list0
	i0 := (p0 := InStr(list,",",0,i:=p0+1)) ? SubStr(list,i,p0-i) : SubStr(list,i)
	list := list1
	i1 := (p1 := InStr(list,",",0,i:=p1+1)) ? SubStr(list,i,p1-i) : SubStr(list,i)
	Loop  {
		i := i0>i1
		list .= "," i%i%
		If (p%i%) {
			list := list%i%
			i%i% := (p%i% := InStr(list,",",0,i:=p%i%+1)) ? SubStr(list,i,p%i%-i) : SubStr(list,i)
		}
		Else {
			i ^= 1
			rtv := SubStr(list "," i%i% (p%i% ? "," SubStr(list%i%,p%i%+1) : ""), 2)
		}
	}
	Return rtv
}

PermutationSort(var) {
	static a:="a",v:="v"
	StringSplit, a, var, `,
	v0 := a0
	Loop %v0%
		v%A_Index% := A_Index
	unsorted := 0
	Loop % %a%0-1 {
		i := %v%%A_Index%, j := A_Index+1, j := %v%%j%
		If (%a%%i% > %a%%j%)
			unSorted := 1
	}
	While unSorted {
		i := %v%0, i1 := i-1
		While %v%%i1% >= %v%%i% {
			--i, --i1
			IfLess i1,1, Return 1
		}
		j := %v%0
		While %v%%j% <= %v%%i1%
			--j
		t := %v%%i1%, %v%%i1% := %v%%j%, %v%%j% := t,  j := %v%0
		While i < j
			t := %v%%i%, %v%%i% := %v%%j%, %v%%j% := t, ++i, --j
		unsorted := 0
		Loop % %a%0-1 {
			i := %v%%A_Index%, j := A_Index+1, j := %v%%j%
			If (%a%%i% > %a%%j%)
				unSorted := 1
		}
	}
	Loop % a0
		i := v%A_Index%, sorted .= "," . a%i%
	Return SubStr(sorted,2)
}

QuickSort(var)
{
	StringSplit, list, var, `,
	If (list0 <= 1)
		Return list
	pivot := list1
	Loop, Parse, var, `,
	{
		If (A_LoopField < pivot)
			less .= "," . A_LoopField
		Else If (A_LoopField > pivot)
			more .= "," . A_LoopField
		Else
			pivotlist .= "," . A_LoopField
	}
	less := QuickSort(substr(less,2))
	more := QuickSort(substr(more,2))
	Return substr(less,2) . pivotList . more
}

SelectionSort(var) {
	StringSplit, a, var, `,
	Loop % a0-1 {
		i := A_Index, mn := a%i%, j := m := i
		Loop % a0-i {
			j++
			If (a%j% < mn)
				mn := a%j%, m := j
		}
		t := a%i%, a%i% := a%m%, a%m% := t
	}
	Loop % a0
		sorted .= "," . a%A_Index%
	Return SubStr(sorted,2)
}

ShellSort(var) {
	StringSplit, a, var, `,
	inc := a0
	While inc:=round(inc/2.2)
		Loop % a0-inc {
			i := A_Index+inc, t := a%i%, j := i, k := j-inc
			While j > inc && a%k% > t
				a%j% := a%k%, j := k, k -= inc
			a%j% := t
		}
	Loop % a0
		s .= "," . a%A_Index%
	Return SubStr(s,2)
}

BuiltInSort(var) {
	Sort, var, N D`,
	Return var
}