;; -*- Mode: Irken -*-

(require "lib/mtwist.scm")
(require "lib/time.scm")
(require "glulx/opcodes.scm")
(require "glulx/stack.scm")
(require "glulx/string.scm")

;; an idea for 'translating' the program, rather than nasty live bit-twiddling:
;; we convert a function to real data structures.
;; somehow we must deal with addresses.
;; it'd be nice if we could do some kind of table lookup to give us functions
;; from addresses.  A search tree is easy, but can we go faster?  For example,
;; could we generate a perfect hash table before starting the game up?
;; [answer: yes, see epmh.scm.  2095 addrs easily handled]

(define (read-file-contents path)
  (let ((f (file/open-read path))
        (blocks (list:nil)))
    (for block (make-file-generator f)
       (push! blocks block))
    (file/close f)
    (string-concat (reverse blocks))))

(define (run-game game-path read-line write-string)

  (let ((data (read-file-contents game-path))
        (magic "")
        (glulx-version 0)
        (RAMSTART 0)
        (EXTSTART 0)
        (ENDMEM 0)
        (stack-size 0)
        (start-addr 0)
        (decode-table 0)
        (string-table (stree:term))
        (running? #t)
        (pc 0)
        (insn-count 0)
        (stack (gstack:nil))
        (frame (make-frame #() (make-vstack)))
        ;; used for passing arguments to functions
        (argv (make-vector 32 #x0))
        ;; operand addressing mode:val
        (opmods (make-vector 32 (mode:constant0)))
        (opvals (make-vector 32 #x0))
        (input-event-thunk (lambda () (:tuple 0 0 0)))
        (RNG (mt19937 3141))
        )

    (defmacro writef
      (writef item ...) -> (write-string (format item ...))
      )

    (define (grow-mem extra)
      (let ((dlen (string-length data))
            (nlen (+ dlen extra))
            (data0 (make-string nlen)))
        (buffer-copy data 0 dlen data0 0)
        (for-range i extra
          (string-set! data0 (+ dlen i) #\nul))
        (set! data data0)
        ))

    (define (bump r n) ;; prog1 for old-school lispers
      (inc! pc n)
      r)

    (define (read@ n a) (substring data a (+ a n)))
    (define (read n) (bump (read@ n pc) n))

    (define (uNN@ n a)
      (let ((r 0))
        (for-range i n
          (set! r (logior (<< r 8) (u8@ a)))
          (inc! a))
        r))
    (define (uNN n) (bump (uNN@ n pc) n))

    (define (u8@ a)  (char->int (string-ref data a)))
    (define (u16@ a) (uNN@ 2 a))
    (define (u24@ a) (uNN@ 3 a))
    (define (u32@ a) (uNN@ 4 a))
    (define (u8)  (bump (u8@ pc) 1))
    (define (u16) (uNN 2))
    (define (u24) (uNN 3))
    (define (u32) (uNN 4))

    (define (tc n bit)
      (if (<0 n)
          (if (< n -2147483648)
              (raise (:HeyTooLow n))
              n)
          (if (= bit (logand bit n))
              (- 0 (- (<< bit 1) n))
              n)))

    (define (i8) (tc (u8) #x80))
    (define (i16) (tc (u16) #x8000))
    (define (i32) (tc (u32) #x80000000))

    (define (put8@ n a)
      (string-set! data a (int->char n)))
    (define (put16@ n a)
      (put8@ (logand #xff n) (+ a 1))
      (put8@ (logand #xff (>> n 8)) a))
    (define (put32@ n a)
      (put16@ (logand #xffff n) (+ a 2))
      (put16@ (logand #xffff (>> n 16)) a))

    (define (write@ s a)
      ;; (printf "write@ " (string s) " @ " (int a) "\n")
      (let ((slen (string-length s)))
        (buffer-copy s 0 slen data a)))

    ;; encode `v` into `n` be-bytes
    (define (int->uNN n v)
      (let ((r (make-string n)))
        (for-range i n
          (string-set! r (- n i 1) (int->char (logand v #xff)))
          (set! v (>> v 8)))
        r))

    ;; ---------------------
    ;; string decoding table
    ;; ---------------------

    (define (read-string-decoding-table addr)
      (let ((tlen (u32@ addr))
            (num (u32@ (+ addr 4)))
            (root (u32@ (+ addr 8)))
            (count 0))

        (define (read-node addr)
          ;;(printf "read-node @ " (int addr) "\n")
          (inc! count)
          (let ((type (u8@ addr)))
            ;;(printf "  type " (int type) "\n")
            (match type with
              #x00 -> (let ((laddr (u32@ (+ addr 1)))
                            (raddr (u32@ (+ addr 5))))
                        (stree:node (read-node laddr) (read-node raddr)))
              #x01 -> (stree:term)
              #x02 -> (stree:char (int->char (u8@ (+ addr 1))))
              #x03 -> (let loop ((acc (list:nil))
                                 (addr0 (+ 1 addr)))
                        (match (u8@ addr0) with
                          0  -> (stree:cstr (list->string (reverse acc)))
                          ch -> (loop (list:cons (int->char ch) acc) (+ 1 addr0))
                          ))
              #x04 -> (stree:unichar (u32@ (+ addr 1)))
              _ -> (raise (:NotYet (format "string table type " (int type))))
              )))
        ;; (printf "table-len " (int tlen) "\n"
        ;;         "   #nodes " (int num) "\n"
        ;;         "     root " (int root) "\n")
        (read-node root)
        ))

    (define (read-c-string addr)
      (let loop ((n 0))
        (match (u8@ (+ n addr)) with
          0 -> (substring data addr (+ addr n))
          n -> (loop (+ n 1))
          )))

    (define (make-bit-generator addr)
      (makegen emit
        (let loop ((a addr) (b (u8@ addr)))
          (for-range i 8
            (emit (= 1 (logand b 1))) ;; #t or #f
            (set! b (>> b 1)))
          (loop (+ a 1) (u8@ (+ a 1))))))

    (define (read-huff-string addr)
      (let ((result (list:nil))
            (bitgen (make-bit-generator addr)))
        (define walk
          (stree:node l r)
          -> (match (bitgen) with
               (maybe:yes #t) -> (walk r)
               (maybe:yes #f) -> (walk l)
               (maybe:no)     -> (impossible))
          (stree:term)     -> (maybe:no)
          (stree:char ch)  -> (maybe:yes (char->utf8 ch))
          (stree:cstr s)   -> (maybe:yes s)
          _                -> (raise (:NotYet "other string table type"))
          )
        (let loop ()
          (match (walk string-table) with
            (maybe:yes s) -> (begin (push! result s) (loop))
            (maybe:no)    -> (string-concat (reverse result))
            ))))

    (define (read-uni-string addr)
      (let loop ((acc (list:nil))
                 (addr0 (+ addr 3))) ;; padding
        ;; consider just encoding these into utf8 right here.
        (match (u32@ addr0) with
          0 -> (list->string (reverse acc))
          n -> (loop (list:cons (int->char n) acc) (+ addr 4))
          )))

    (define (read-string addr)
      (let ((type (u8@ addr)))
        (match type with
          #xe0 -> (read-c-string (+ 1 addr))
          #xe1 -> (read-huff-string (+ 1 addr))
          #xe2 -> (read-uni-string (+ 1 addr))
          _    -> (raise (:UnknownStringType type))
          )))

    ;; ---------------------
    ;; search
    ;; ---------------------

    (define (get-key key size options)
      (if (bit-get options 0)
          (read@ size key)
          (int->uNN size key)))

    (define (binarysearch key ksize start ssize num koff options)

      (define (key-cmp index k0)
        (let ((loc (+ start (+ (* index ssize) koff)))
              (k1 (substring data loc (+ loc ksize))))
          (string-cmp k0 k1)))

      (let ((key0 (get-key key ksize options)))
        ;; (printf "key   = " (int key) "\n"
        ;;         "key0  = " (string->hex key0) "\n"
        ;;         "ksize   " (int ksize) "\n"
        ;;         "start   " (int start) "\n"
        ;;         "ssize   " (int ssize) "\n"
        ;;         "num     " (int num) "\n"
        ;;         "koff    " (int koff) "\n"
        ;;         "options " (int options) "\n")
        (let loop ((lo 0)
                   (hi num))
          (if (< lo hi)
              (let ((mid (/ (+ lo hi) 2)))
                (match (key-cmp mid key0) with
                  (cmp:<) -> (loop lo mid)
                  (cmp:=) -> (maybe:yes mid)
                  (cmp:>) -> (loop (+ mid 1) hi)
                  ))
              (maybe:no)))))

    ;; ---------------------
    ;; vm insns
    ;; ---------------------

    (define (read-locals-format)
      (let loop ((lforms (list:nil))
                 (ltype (u8))
                 (lcount (u8)))
        (match ltype lcount with
          0 0 -> (reverse lforms)
          _ _ -> (loop (list:cons (:tuple ltype lcount) lforms) (u8) (u8))
          )))

    (define (read-modes n)
      (let ((nbytes (/ (+ n 1) 2))
            (r (list:nil)))
        (for-range i nbytes
          (let ((b (u8)))
            (push! r (logand #xf b))
            (push! r (logand #xf (>> b 4)))))
        (map int->mode (take (reverse r) n))))

    (define (read-opval mode)
      (match mode with
        (mode:constant0) -> 0
        (mode:constant1) -> (i8)  ;; NOTE these three are read as signed.
        (mode:constant2) -> (i16)
        (mode:constant4) -> (i32)
        (mode:conaddr1)  -> (u8)  ;; read from memory
        (mode:conaddr2)  -> (u16)
        (mode:conaddr4)  -> (u32)
        (mode:stack0)    -> 0     ;; push/pop
        (mode:local1)    -> (u8)  ;; local variables
        (mode:local2)    -> (u16)
        (mode:local4)    -> (u32)
        (mode:ram1)      -> (u8)  ;; 'memory' (i.e. addr + RAMSTART)
        (mode:ram2)      -> (u16)
        (mode:ram4)      -> (u32)
        ))

    (define (read-opcode)
      ;;(printf (ansi green (int pc)) "\n")
      (let ((b (u8)))
        (match (logand #xc0 b) with
          #xc0 -> (logior (<< (logand b #xf) 24) (u24))
          #x80 -> (logior (<< (logand b #xf) 8) (u8))
          _    -> b
          )))

    ;; --------------------------------------------------------
    ;; let's think about how to pre-decode functions again.
    ;; there's so much overhead here, it'd be nice to do this
    ;; without mangling this otherwise readable code too much.
    ;;
    ;; theoretically branches can go to places in other functions,
    ;;   but I doubt this is ever actually used.
    ;; we could pre-decode entire functions (maybe on-the-fly?)
    ;; xxx another thing, might need to put each insn's code in
    ;;   a function and dump them all in a table.
    ;; xxx instead, each insn is translated into a function +
    ;;   the argmode data needed, then we don't even need a dispatch
    ;;   table, we just execute each function in turn.
    ;; --------------------------------------------------------

    (define (read-insn)
      (let ((raw (read-opcode))
            (opcode (int->opcode raw))
            (nargs arity-table[raw])
            (modes (read-modes nargs)))
        ;; (printf "insn " (ansi blue (sym (opcode->name opcode))) " ")
        (for-range i nargs
          (let ((mode (nth modes i))
                (val (read-opval mode)))
            (set! opmods[i] mode)
            (set! opvals[i] val)
            ;; (printf " " (sym (mode->name mode)) ":" (int val))
            ))
        ;; (printf "\n")
        opcode
        ))

    ;; I think it's pretty much always [4:N]
    (define (lforms->nlocals lforms)
      (define R
        count ()                  -> count
        count ((:tuple 4 n) . tl) -> (R (+ count n) tl)
        count ((:tuple t _) . tl) -> (raise (:UnsupportedLocalType t pc))
        )
      (R 0 lforms))

    (define (enter-function addr nargs)
      (set! pc addr)
      (let ((ftype (u8)) ;; check value
            (lforms (read-locals-format))
            (nlocals (lforms->nlocals lforms))
            (locals (make-vector nlocals #x0))
            (vstack (make-vstack))
            (frame0 (make-frame locals vstack)))
        ;; (printf " ---> " (hex ftype) " " (int addr) " nargs " (int nargs) " nlocals " (int nlocals) "\n")
        ;; push the new frame onto the machine stack.
        (set! stack (gstack:frame frame0 stack))
        (set! frame frame0)
        ;; arguments left out must be zeroed
        (when (< nargs nlocals)
          (for-range* i nargs nlocals
            (set! argv[i] 0)))
        (match ftype with
          #xc0 -> (begin
                    (for-range i nargs
                      (vstack/push! vstack argv[(- nargs i 1)]))
                    (vstack/push! vstack nargs))
          #xc1 -> (copy-locals lforms locals)
          b    -> (raise (:BadFunctionType b))
          )
        ))

    ;; note: one and two-byte locals are deprecated.  I have yet to
    ;; see a 0:count (ignore argument) example.  since '4' seems to be
    ;; the only viable choice, there's no need for multiple entries in
    ;; table, and realistically all we see are either no entries, or a
    ;; single entry of 4:count.
    (define (copy-locals lforms locals)
      (match lforms with
        () -> #u
        ((:tuple 4 count))
        -> (for-range i count
             (set! locals[i] argv[i]))
        _
        -> (raise (:UnexpectedLocalsFormat lforms))
        ))

    (define (getarg n)
      (match opmods[n] with
        (mode:constant0) -> 0
        (mode:constant1) -> opvals[n]
        (mode:constant2) -> opvals[n]
        (mode:constant4) -> opvals[n]
        (mode:conaddr1)  -> (u8@ opvals[n])
        (mode:conaddr2)  -> (u16@ opvals[n])
        (mode:conaddr4)  -> (u32@ opvals[n])
        (mode:stack0)    -> (vstack/pop! frame.vstack)
        (mode:local1)    -> frame.locals[(>> opvals[n] 2)]
        (mode:local2)    -> frame.locals[(>> opvals[n] 2)]
        (mode:local4)    -> frame.locals[(>> opvals[n] 2)]
        (mode:ram1)      -> (u32@ (+ opvals[n] RAMSTART))
        (mode:ram2)      -> (u32@ (+ opvals[n] RAMSTART))
        (mode:ram4)      -> (u32@ (+ opvals[n] RAMSTART))
        ))

    (define (famode n)
      (format (sym (mode->name opmods[n])) ":" (int opvals[n])))

    (define (putdst val n)
      ;; (printf "putdst " (sym (mode->name opmods[n])) " " (int opvals[n]) " = " (int val) "\n")
      (store! (clamp val) opmods[n] opvals[n] put32@))

    (define (putdst16 val n)
      (store! (clamp val) opmods[n] opvals[n] put16@))

    (define (putdst8 val n)
      (store! (clamp val) opmods[n] opvals[n] put8@))

    (define (store! val opmode opval put@)
      (match opmode with
        (mode:constant0) -> #u ;; discard
        (mode:conaddr4)  -> (put@ val opval)
        (mode:stack0)    -> (vstack/push! frame.vstack val)
        (mode:local1)    -> (set! frame.locals[(>> opval 2)] val)
        (mode:local2)    -> (set! frame.locals[(>> opval 2)] val)
        (mode:local4)    -> (set! frame.locals[(>> opval 2)] val)
        (mode:ram1)      -> (put@ val (+ opval RAMSTART))
        (mode:ram2)      -> (put@ val (+ opval RAMSTART))
        (mode:ram4)      -> (put@ val (+ opval RAMSTART))
        other            -> (raise (:UnsupportedAddressingMode pc (mode->name other)))
        ))

    (define (op-call) ;; call L1 L2 S1 | call addr argcount -> dst
      (let ((addr (getarg 0))
            (count (getarg 1))
            (stack0 (gstack:save opmods[2] opvals[2] pc stack)))
        ;; (printf "call stack = [" (join int->string " " frame.vstack.val) "]\n")
        (for-range i count
          (set! argv[i] (vstack/pop! frame.vstack)))
        (set! stack stack0)
        (enter-function addr count)
        ))

    (define (op-callf) ;; call L1 S1 | call addr -> dst
      (let ((addr (getarg 0))
            (stack0 (gstack:save opmods[1] opvals[1] pc stack)))
        (set! stack stack0)
        (enter-function addr 0)
        ))

    (define (op-callfi) ;; call L1 L2 S1 | call addr arg0 -> dst
      (let ((addr (getarg 0))
            (arg0 (getarg 1))
            (stack0 (gstack:save opmods[2] opvals[2] pc stack)))
        (set! argv[0] arg0)
        (set! stack stack0)
        (enter-function addr 1)
        ))

    (define (op-callfii) ;; call L1 L2 L3 S1 | call addr arg0 arg1 -> dst
      (let ((addr (getarg 0))
            (arg0 (getarg 1))
            (arg1 (getarg 2))
            (stack0 (gstack:save opmods[3] opvals[3] pc stack)))
        (set! argv[0] arg0)
        (set! argv[1] arg1)
        (set! stack stack0)
        (enter-function addr 2)
        ))

    (define (op-callfiii) ;; call L1 L2 L3 L4 S1 | call addr arg0 arg1 arg2 -> dst
      (let ((addr (getarg 0))
            (arg0 (getarg 1))
            (arg1 (getarg 2))
            (arg2 (getarg 3))
            (stack0 (gstack:save opmods[4] opvals[4] pc stack)))
        (set! argv[0] arg0)
        (set! argv[1] arg1)
        (set! argv[2] arg2)
        (set! stack stack0)
        (enter-function addr 3)
        ))

    ;; rval is an argument because op-return is also called (sometimes) by branch insns.
    (define (op-return rval)
      (match stack with
        (gstack:frame _ (gstack:save dest-mode addr pc0 next))
        -> (begin
             (set! stack next)
             (match stack with
               (gstack:frame f _) -> (set! frame f)
               _ -> #u)
             ;; (printf " <--- pc=" (int pc0)
             ;;         " store " (sym (mode->name dest-mode))
             ;;         ":" (int addr) " = " (int rval) "\n")
             (store! rval dest-mode addr put32@)
             (set! pc pc0)
             )
        (gstack:frame _ (gstack:nil))
        -> (set! running? #f)
        other
        -> (raise (:ReturnExpectedSave))
        ))

    (define (op-tailcall)
      (let ((addr (getarg 0))
            (count (getarg 1)))
        (for-range i count
          (set! argv[i] (vstack/pop! frame.vstack)))
        ;; XXX
        (match stack with
          (gstack:frame _ save)
          -> (set! stack save)
          _
          -> (raise (:BadJuJu))
          )
        (enter-function addr count)
        ))

    (define (op-setiosys)
      (match (getarg 0) (getarg 1) with
        2  0  -> #u ;; GLK system
        l1 l2 -> (raise (:UnsupportedIOSys l1 l2))
        ))

    (define (op-copy)
      (let ((val (getarg 0)))
        ;; (printf " copy " (int val) " " (sym (mode->name opmods[1])) " " (int opvals[1]) "\n")
        (putdst val 1)))

    (define (op-copyb)
      (putdst8 (logand #xff (getarg 0)) 1))

    (define (op-copys)
      ;; (printf "copys " (famode 0) " => " (famode 1) "\n")
      (putdst16 (logand #xffff (getarg 0)) 1))

    (define (op-astore)
      (let ((l1 (getarg 0))
            (l2 (tc32 (getarg 1)))
            (l3 (getarg 2)))
        (put32@ l3 (+ l1 (* l2 4)))
        ))

    (define (op-astoreb)
      (let ((l1 (getarg 0))
            (l2 (tc32 (getarg 1)))
            (l3 (getarg 2)))
        (put8@ (logand #xff l3) (+ l1 l2))
        ))

    (define (op-astores)
      (let ((l1 (getarg 0))
            (l2 (tc32 (getarg 1)))
            (l3 (getarg 2)))
        (put16@ (logand #xffff l3) (+ l1 (* l2 2)))
        ))

    (define (op-aload)
      (let ((l1 (getarg 0))
            (l2 (tc32 (getarg 1))))
        (putdst (u32@ (+ l1 (* l2 4))) 2)))

    (define (op-aloadb)
      (let ((l1 (getarg 0))
            (l2 (tc32 (getarg 1))))
        (putdst (u8@ (+ l1 l2)) 2)))

    (define (op-aloads)
      (let ((l1 (getarg 0))
            (l2 (tc32 (getarg 1))))
        (putdst (u16@ (+ l1 (* 2 l2))) 2)))

    (define (op-aloadbit)
      (let ((addr (getarg 0))
            (bitnum (tc32 (getarg 1)))
            (byte (if (< bitnum 0)
                      (u8@ (- addr (+ 1 (>> (- -1 bitnum) 3))))
                      (u8@ (+ addr (>> bitnum 3)))))
            (bit (logand #x7 bitnum)))
        (putdst
         (if (bit-get byte bit) 1 0)
         2)))

    (define (op-astorebit)
      (let ((addr (getarg 0))
            (bitnum (tc32 (getarg 1)))
            (clear? (if (zero? (getarg 2)) #t #f))
            (byte-addr (if (< bitnum 0)
                           (- addr (+ 1 (>> (- -1 bitnum) 3)))
                           (+ addr (>> bitnum 3))))
            (byte (u8@ byte-addr))
            (bit (logand #x7 bitnum))
            (byte0 (if clear?
                       (logand (lognot (<< 1 bit)) byte)
                       (logior (<< 1 bit) byte))))
        (put8@ byte0 byte-addr)
        ))

    (define (op-streamchar)
      (let ((l1 (getarg 0)))
        ;;(printf (ansi green (char (int->char l1))))
        (writef (char (int->char l1)))
        (flush)
        #u
        ))

    (define (op-streamstr)
      (let ((l1 (getarg 0))
            (s (read-string l1)))
        ;;(printf (ansi green s))
        (writef s)
        (flush)
        #u
        ))

    (define (op-streamnum)
      (let ((v (tc32 (getarg 0))))
        (writef (int v))
        (flush)
        #u))

    (define (op-branch1 op)
      (let ((v0 (getarg 0))
            (v1 (getarg 1)))
        (if (op v0)
            (jump v1))))

    (define (op-branch1-neg op)
      (let ((v0 (getarg 0))
            (v1 (getarg 1)))
        (if (not (op v0))
            (jump v1))))

    (define (op-branch2 op signed?)
      (let ((v0 (getarg 0))
            (v1 (getarg 1))
            (v2 (getarg 2)))
        (if (op (if signed? (tc32 v0) v0) (if signed? (tc32 v1) v1))
            (jump v2))
        ))

    (define (jump v)
      (if (or (= v 0) (= v 1))
          (op-return v)
          (set! pc (+ pc (- v 2)))))

    (define (op-bin op)
      (let ((a (getarg 0))
            (b (getarg 1)))
        ;; (printf "op-bin " (hex a) " " (hex b) "\n")
        (putdst (op a b) 2)))

    (define (op-binarysearch)
      (let ((key (getarg 0))
            (ksize (getarg 1))
            (start (getarg 2))
            (ssize (getarg 3))
            (num (getarg 4))
            (koff (getarg 5))
            (options (getarg 6))
            (return-index (bit-get options 2)))
        (let ((r
               (match (binarysearch key ksize start ssize num koff options) with
                 (maybe:yes index) -> (if return-index index (+ start (* index ssize))) ;; NO koff
                 (maybe:no) -> (if return-index -1 0)
                 )))
          ;; (printf "binarysearch -> " (int r) "\n")
          (putdst r 7))))

    (define (op-stkcopy)
      (vstack/stkcopy! frame.vstack (getarg 0)))

    (define (op-stkswap)
      (let ((v0 (vstack/pop! frame.vstack))
            (v1 (vstack/pop! frame.vstack)))
        (vstack/push! frame.vstack v0)
        (vstack/push! frame.vstack v1)))

    (define (op-stkpeek)
      (let ((n (getarg 0)))
        (putdst (nth frame.vstack.val n) 1)))

    (define (op-gestalt)
      (let ((l1 (getarg 0))
            (l2 (getarg 1)))
        (putdst
         (match l1 with
           0  -> glulx-version
           1  -> #x010101
           2  -> 1 ;; resizemem
           3  -> 0 ;; undo
           4  -> (match l2 with
                   0 -> 1
                   1 -> 1
                   2 -> 1
                   _ -> 0) ;; iosystem null, filter, glk for now
           5  -> 1 ;; unicode, sure.
           6  -> 1 ;; memcopy
           7  -> 0 ;; malloc nyi
           8  -> 0 ;; mallocheap nyi
           9  -> 0 ;; accel unlikely
           10 -> 0 ;; ''
           11 -> 0 ;; float no
           12 -> 0 ;; extundo no
           13 -> 0 ;; double no
           _  -> 0 ;;
           )
         2)))

    (define (glk-null-iterate args)
      (match args with
        (0 rock) -> 0 ;; end of list
        _ -> 0
        ))

    (define (glk-window-iterate args)
      (match args with
        (0 rock) -> 0 ;; no windows yet
        _ -> 0
        ))

    (define (glk-stream-iterate args)
      (match args with
        (0 rock) -> 0 ;; no streams yet
        _ -> 0
        ))

    (define (glk-window-open args)
      (match args with
        ;; first window by advent:
        ;; (0 0 0 3 201) -> 1
        (0 0 0 3 rock) -> 1
        ;; second window by advent:
        ;; (1 18 1 4 202)
        (_ _ _ 4 rock) -> 0 ;; was '2', but creating multiple windows doesn't look easy.
        _
        -> (raise (:GLKError "unhandled window open args"))
        ))

    (define (glk-window-move-cursor args)
      (match args with
        (win x y) -> (writef "\x1b[" (int (+ 1 x)) ";" (int (+ 1 y)) "H")
        _ -> #u
        )
      0
      )

    (define (glk-set-window args)
      (match args with
        (1) -> 0
        (2) -> 0
        _ -> (raise (:GLKError "set window to unknown id"))
        ))

    ;; format macro doesn't quite work because it wants to bracket things.
    (define (glk-set-style args)
      ;; (printf (bold "GLK set style [" (join int->string " " args) "]\n"))
      (match args with
        (3) -> (writef "\x1b[1;37m") ;; header: bold on
        (4) -> (writef "\x1b[37m")   ;; sub-header just white
        (5) -> (writef "\x1b[31m")   ;; alert
        (6) -> (writef "\x1b[36m")   ;; note ('score just went up')
        (0) -> (writef "\x1b[0;32m") ;; normal: styles off
        (n) -> (writef (bold "GLK Style ? " (int n)))
        _   -> (impossible)
        )
      0
      )

    (define (get-line)
      (match (read-line) with
        (maybe:yes line) -> line
        (maybe:no)       -> (begin (set! running? #f) "")
        ))

    ;; this is repeated for each line.
    ;; evtype for lineinput is 3
    (define (glk-request-line-event args)
      (match args with
        (win buf maxlen initlen)
        -> (begin
             (writef "\x1b[0m") ;; input style
             (flush)
             (set! input-event-thunk
                   (lambda ()
                     (let ((line (get-line))
                           (llen (string-length line)))
                       ;; (printf "read line = " (string line) "\n")
                       (if (<= llen maxlen)
                           (write@ line buf)
                           (raise (:GLKError "input line too long")))
                       (:tuple win llen 3)
                       )))
             )
        _ -> (raise (:GLKError "bad args to request-line-event")))
      0)

    (define (glk-select args)
      ;; fake it til you make it
      (let (((win len type) (input-event-thunk)))
        (writef "\x1b[0;32m") ;; input style off
        (match args with
          (ev-addr)
          -> (begin
               (put32@ 3   (+ ev-addr 0)) ;; event type line-input
               (put32@ win (+ ev-addr 4))
               (put32@ len (+ ev-addr 8))
               (put32@ 0   (+ ev-addr 12)))
          _
          -> (raise (:GLKError "bad args to glk-select"))
          )
        0))

    (define (glk-window-get-size args)
      (match args with
        (win waddr haddr)
        -> (begin ;; fake it: over ssh we'll have this info
             (put32@ 132 waddr)
             (put32@  80 haddr)
             0)
        _
        -> (raise (:GLKError "bad args to glk-window-get-size"))
        ))

    (define (glk-note name args)
      (writef (ansi blue "(" (string name) " " (join int->string " " args) ")"))
      0)

    (define (glk-gestalt args)
      ;; we know NOTHING
      0)

    (define (glk-unknown id args)
      (writef (ansi blue "(glk #x" (hex id) " " (join int->string " " args) ")"))
      0
      )

    (define (glk-window-clear args)
      (match args with
        (id) -> (writef "\x1b[2J")
        _ -> #u
        )
      0
      )

    (define (glk-ignore args)
      0)

    (define (op-glk)
      (let ((id (getarg 0))
            (argcount (getarg 1))
            (args frame.vstack.val))
        ;; (printf "glk: id = " (hex id) " argcount = "  (int argcount) "\n")
        ;; (printf "     stack " (join int->string ", " frame.vstack.val) "\n")
        (putdst
         (match id with
           #x04 -> (glk-gestalt args)
           #x20 -> (glk-null-iterate args)
           #x40 -> (glk-window-iterate args)
           #x64 -> (glk-null-iterate args)
           #x23 -> (glk-window-open args)
           #x25 -> (glk-window-get-size args)
           #x2a -> (glk-window-clear args)
           #x2b -> (glk-window-move-cursor args)
           #x2f -> (glk-set-window args)
           #x43 -> (glk-ignore args) ;; stream-open-memory
           #x48 -> (glk-ignore args) ;; stream-get-current
           #x86 -> (glk-set-style args)
           #xd0 -> (glk-request-line-event args)
           #xc0 -> (glk-select args)
           #xa0 -> (char->int (tolower (int->char (first args)))) ;; char_tolower
           _    -> (glk-unknown id args)
           )
         2)))

    (define (op-quit)
      (writef (ansi red "quit") "\n")
      (set! running? #f))

    (define (op-shift signed? right?)
      (let ((val0 (getarg 0))
            (val1 (if signed? (tc32 val0) (clamp val0))))
        (match right? with
          #t -> (putdst (>> val1 (getarg 1)) 2)
          #f -> (putdst (<< val1 (getarg 1)) 2)
          )))

    (define (setrandom seed)
      (if (zero? seed)
          (let ((t (gettime/monotonic)))
            (set! RNG (mt19937 t.nsec)))
          (set! RNG (mt19937 seed))))

    (define (op-random)
      (let ((n (tc32 (getarg 0)))
            (r (RNG)))
        (putdst
         (match (int-cmp n 0) with
          (cmp:=) -> r
          (cmp:>) -> (mod r n)
          (cmp:<) -> (- (mod r (- n)))
           )
         1)))

    (define (op-setrandom)
      (setrandom (getarg 0)))

    (define (op-mzero)
      (let ((l1 (getarg 0))
            (l2 (getarg 1)))
        (for-range i l1
          (put8@ #x00 (+ l2 i)))
        ))

    (define (op-mcopy)
      (let ((l1 (getarg 0))
            (l2 (getarg 1))
            (l3 (getarg 2)))
        (if (< l3 l2)
            (for-range i l1
              (put8@ (u8@ (+ l2 i)) (+ l3 i)))
            (for-range-rev i l1
              (put8@ (u8@ (+ l2 i)) (+ l3 i))))
        ))

    (define (op-setmemsize)
      (let ((l1 (getarg 0))
            (dlen (string-length data)))
        (putdst
         (if (< l1 ENDMEM)
             1 ;; fail
             (if (< l1 dlen)
                 (begin (set! data (substring data 0 l1)) 0)
                 (begin (grow-mem (- l1 dlen)) 0)))
         1)))

    ;; this is equivalent to a cast to 'glsi32'.
    ;; (which can be undone with `clamp`)
    (define (tc32 n)
      (tc n #x80000000))

    ;; here we are taking a number that's potentially out of the range
    ;; of i32 and pushing it back into that range (while still representing
    ;; it as i63 within irken).

    (define (clamp n)
      (logand #xffffffff n))

    (define (<> a b)
      (not (= a b)))

    (define (nonzero? a)
      (not (zero? a)))

    (define (add32 a b)
      (clamp (+ a b)))

    (define (sub32 a b)
      (clamp (- a b)))

    (define (mul32 a b)
      (clamp (* a b)))

    ;; these are not defined in lib/core.scm
    (define (div-truncated n d)
      (let (((q r) (divmod-truncated n d)))
        q))

    (define (mod-truncated n d)
      (let (((q r) (divmod-truncated n d)))
        r))

    (define (div32 a b)
      (div-truncated (tc32 a) (tc32 b)))

    (define (mod32 a b)
      (mod-truncated (tc32 a) (tc32 b)))

    (define (neg32 a)
      (clamp (- (tc32 a))))

    (define (start addr)
      (set! pc addr)
      (enter-function addr 0)
      (while running?
        (inc! insn-count)
        ;; (printf  (lpad 8 (int insn-count)) " " (ansi green (lpad 8 (int pc))) " ["
        ;;         (join int->string " " frame.vstack.val) "]\n")
        (let ((insn (read-insn)))
          (match insn with
            (opcode:nop)          -> #u
            (opcode:call)         -> (op-call)
            (opcode:callf)        -> (op-callf)
            (opcode:callfi)       -> (op-callfi)
            (opcode:callfii)      -> (op-callfii)
            (opcode:callfiii)     -> (op-callfiii)
            (opcode:tailcall)     -> (op-tailcall)
            (opcode:return)       -> (op-return (getarg 0))
            (opcode:setiosys)     -> (op-setiosys)
            (opcode:copy)         -> (op-copy)
            (opcode:copyb)        -> (op-copyb)
            (opcode:copys)        -> (op-copys)
            (opcode:add)          -> (putdst (add32 (getarg 0) (getarg 1)) 2)
            (opcode:sub)          -> (putdst (sub32 (getarg 0) (getarg 1)) 2)
            (opcode:mul)          -> (putdst (mul32 (getarg 0) (getarg 1)) 2)
            (opcode:div)          -> (putdst (div32 (getarg 0) (getarg 1)) 2)
            (opcode:mod)          -> (putdst (mod32 (getarg 0) (getarg 1)) 2)
            (opcode:neg)          -> (putdst (neg32 (getarg 0)) 1)
            (opcode:shiftl)       -> (op-shift #f #f)
            (opcode:ushiftr)      -> (op-shift #f #t)
            (opcode:sshiftr)      -> (op-shift #t #t)
            (opcode:glk)          -> (op-glk)
            (opcode:astore)       -> (op-astore)
            (opcode:astoreb)      -> (op-astoreb)
            (opcode:astores)      -> (op-astores)
            (opcode:aload)        -> (op-aload)
            (opcode:aloadb)       -> (op-aloadb)
            (opcode:aloads)       -> (op-aloads)
            (opcode:aloadbit)     -> (op-aloadbit)
            (opcode:astorebit)    -> (op-astorebit)
            (opcode:streamchar)   -> (op-streamchar)
            (opcode:streamstr)    -> (op-streamstr)
            (opcode:streamnum)    -> (op-streamnum)
            (opcode:jump)         -> (jump (getarg 0))
            (opcode:jumpabs)      -> (set! pc (getarg 0))
            (opcode:jlt)          -> (op-branch2 < #t)
            (opcode:jltu)         -> (op-branch2 < #f)
            (opcode:jle)          -> (op-branch2 <= #t)
            (opcode:jleu)         -> (op-branch2 <= #f)
            (opcode:jne)          -> (op-branch2 <> #t)
            (opcode:jeq)          -> (op-branch2 = #t)
            (opcode:jge)          -> (op-branch2 >= #t)
            (opcode:jgeu)         -> (op-branch2 >= #f)
            (opcode:jgt)          -> (op-branch2 > #t)
            (opcode:jgtu)         -> (op-branch2 > #f)
            (opcode:jz)           -> (op-branch1 zero?)
            (opcode:jnz)          -> (op-branch1 nonzero?)
            (opcode:sexb)         -> (putdst (tc (logand #xff (getarg 0)) #x80) 1)
            (opcode:sexs)         -> (putdst (tc (logand #xffff (getarg 0)) #x8000) 1)
            (opcode:getmemsize)   -> (putdst (string-length data) 0)
            (opcode:setmemsize)   -> (op-setmemsize)
            (opcode:mzero)        -> (op-mzero)
            (opcode:mcopy)        -> (op-mcopy)
            (opcode:bitand)       -> (op-bin logand)
            (opcode:bitor)        -> (op-bin logior)
            (opcode:bitxor)       -> (op-bin logxor)
            (opcode:bitnot)       -> (putdst (lognot (getarg 0)) 1)
            (opcode:binarysearch) -> (op-binarysearch)
            (opcode:random)       -> (op-random)
            (opcode:setrandom)    -> (op-setrandom)
            (opcode:stkcopy)      -> (op-stkcopy)
            (opcode:stkswap)      -> (op-stkswap)
            (opcode:stkpeek)      -> (op-stkpeek)
            (opcode:stkcount)     -> (putdst frame.vstack.len 0)
            (opcode:gestalt)      -> (op-gestalt)
            (opcode:saveundo)     -> (putdst 1 0) ;; fail
            (opcode:quit)         -> (op-quit)
            _ -> (raise (:NotYet (format "insn " (sym (opcode->name insn)))))
            ))))

    ;; magic
    (set! magic (read 4))
    (assert (string=? magic "Glul"))
    (set! glulx-version (u32))
    (set! RAMSTART (u32))
    (set! EXTSTART (u32))
    (set! ENDMEM (u32))
    (set! stack-size (u32))
    (set! start-addr (u32))
    (set! decode-table (u32))

    (set! string-table (read-string-decoding-table decode-table))
    (setrandom 0)

    (when (< (string-length data) ENDMEM)
      (grow-mem (- ENDMEM (string-length data))))

    (printf "magic      = " (string magic) "\n"
            "version    = " (hex glulx-version) "\n"
            "ramstart   = " (hex RAMSTART) "\n"
            "extstart   = " (hex EXTSTART) "\n"
            "end-mem    = " (hex ENDMEM) "\n"
            "stack-size = " (hex stack-size) "\n"
            "start-addr = " (hex start-addr) "\n"
            "decode-tbl = " (hex decode-table) "\n"
            "chksum     = " (hex (u32)) "\n"
            "len(data)  = " (hex (string-length data)) "\n"
            )

    ;;(pp (stree->sexp string-table) 80)
    (start start-addr)
    ))