;; what happens when our virtual machine starts up
(= initialization-fns* (queue))
(def reset ()
  (each f (as cons initialization-fns*)
    (f)))

(mac on-init body
  `(enq (fn () ,@body)
        initialization-fns*))

;; persisting and checking traces for each test
(= traces* (queue))
(= trace-dir* ".traces/")
(ensure-dir trace-dir*)
(= curr-trace-file* nil)
(on-init
  (awhen curr-trace-file*
    (tofile (+ trace-dir* it)
      (each (label trace) (as cons traces*)
        (pr label ": " trace))))
  (= curr-trace-file* nil)
  (= traces* (queue)))

(def new-trace (filename)
  (prn "== @filename")
;?   )
  (= curr-trace-file* filename))

(= dump-trace* nil)
(def trace (label . args)
  (when (or (is dump-trace* t)
            (and dump-trace* (is label "-"))
            (and dump-trace* (pos label dump-trace*!whitelist))
            (and dump-trace* (no dump-trace*!whitelist) (~pos label dump-trace*!blacklist)))
    (apply prn label ": " args))
  (enq (list label (apply tostring:prn args))
       traces*))

(redef tr args  ; why am I still returning to prn when debugging? Will this help?
  (do1 nil
       (apply trace "-" args)))

(def tr2 (msg arg)
  (tr msg arg)
  arg)

(def check-trace-contents (msg expected-contents)
  (unless (trace-contents-match expected-contents)
    (prn "F - " msg)
    (prn "  trace contents")
    (print-trace-contents-mismatch expected-contents)))

(def trace-contents-match (expected-contents)
  (each (label msg) (as cons traces*)
    (when (and expected-contents
               (is label expected-contents.0.0)
               (posmatch expected-contents.0.1 msg))
      (pop expected-contents)))
  (no expected-contents))

(def print-trace-contents-mismatch (expected-contents)
  (each (label msg) (as cons traces*)
    (whenlet (expected-label expected-msg)  expected-contents.0
      (if (and (is label expected-label)
               (posmatch expected-msg msg))
        (do (pr "  * ")
            (pop expected-contents))
        (pr "    "))
      (pr label ": " msg)))
  (prn "  couldn't find")
  (each (expected-label expected-msg)  expected-contents
    (prn "  ! " expected-label ": " expected-msg)))

;; virtual machine state

; things that a future assembler will need separate memory for:
;   code; types; args channel
(def clear ()
  (= type* (table))
  (= memory* (table))
  (= function* (table))
  )
(enq clear initialization-fns*)

(on-init
  (= type* (obj
              ; Each type must be scalar or array, sum or product or primitive
              type (obj size 1)  ; implicitly scalar and primitive
              type-address (obj size 1  address t  elem '(type))
              type-array (obj array t  elem '(type))
              type-array-address (obj size 1  address t  elem '(type-array))
              location (obj size 1  address t  elem '(location))  ; assume it points to an atom
              integer (obj size 1)
              boolean (obj size 1)
              boolean-address (obj size 1  address t  elem '(boolean))
              byte (obj size 1)
              byte-address (obj  size 1  address t  elem '(byte))
              string (obj array t  elem '(byte))  ; inspired by Go
              string-address (obj size 1  address t  elem '(string))
              string-address-address (obj size 1  address t  elem '(string-address))
              string-address-array (obj array t  elem '(string-address))
              string-address-array-address (obj size 1  address t  elem '(string-address-array))
              character (obj size 1)  ; int32 like a Go rune
              character-address (obj size 1  address t  elem '(character))
              ; isolating function calls
              scope  (obj array t  elem '(location))  ; by convention index 0 points to outer scope
              scope-address  (obj size 1  address t  elem '(scope))
              ; arrays consist of an integer length followed by the right number of elems
              integer-array (obj array t  elem '(integer))
              integer-array-address (obj size 1  address t  elem '(integer-array))
              integer-array-address-address (obj size 1  address t  elem '(integer-array-address))
              integer-address (obj size 1  address t  elem '(integer))  ; pointer to int
              integer-address-address (obj size 1  address t  elem '(integer-address))
              ; and-records consist of a series of elems, corresponding to a list of types
              integer-boolean-pair (obj size 2  and-record t  elems '((integer) (boolean))  fields '(int bool))
              integer-boolean-pair-address (obj size 1  address t  elem '(integer-boolean-pair))
              integer-boolean-pair-array (obj array t  elem '(integer-boolean-pair))
              integer-boolean-pair-array-address (obj size 1  address t  elem '(integer-boolean-pair-array))
              integer-integer-pair (obj size 2  and-record t  elems '((integer) (integer)))
              integer-point-pair (obj size 2  and-record t  elems '((integer) (integer-integer-pair)))
              integer-point-pair-address (obj size 1  address t  elem '(integer-point-pair))
              integer-point-pair-address-address (obj size 1  address t  elem '(integer-point-pair-address))
              ; tagged-values are the foundation of dynamic types
              tagged-value (obj size 2  and-record t  elems '((type) (location))  fields '(type payload))
              tagged-value-address (obj size 1  address t  elem '(tagged-value))
              tagged-value-array (obj array t  elem '(tagged-value))
              tagged-value-array-address (obj size 1  address t  elem '(tagged-value-array))
              tagged-value-array-address-address (obj size 1  address t  elem '(tagged-value-array-address))
              ; heterogeneous lists
              list (obj size 2  and-record t  elems '((tagged-value) (list-address))  fields '(car cdr))
              list-address (obj size 1  address t  elem '(list))
              list-address-address (obj size 1  address t  elem '(list-address))
              ; parallel routines use channels to synchronize
              channel (obj size 3  and-record t  elems '((integer) (integer) (tagged-value-array-address))  fields '(first-full first-free circular-buffer))
              channel-address (obj size 1  address t  elem '(channel))
              ; editor
              line (obj array t  elem '(character))
              line-address (obj size 1  address t  elem '(line))
              line-address-address (obj size 1  address t  elem '(line-address))
              screen (obj array t  elem '(line-address))
              screen-address (obj size 1  address t  elem '(screen))
              )))

;; managing concurrent routines

; routine = runtime state for a serial thread of execution
(def make-routine (fn-name . args)
  (annotate 'routine (obj alloc 1000  call-stack (list
      (obj fn-name fn-name  pc 0  args args  caller-arg-idx 0)))))

(defextend empty (x)  (isa x 'routine)
  (no rep.x!call-stack))

(def stack (routine)
  ((rep routine) 'call-stack))

(mac push-stack (routine op)
  `(push (obj fn-name ,op  pc 0  caller-arg-idx 0)
         ((rep ,routine) 'call-stack)))

(mac pop-stack (routine)
  `(pop ((rep ,routine) 'call-stack)))

(def top (routine)
  stack.routine.0)

(def body (routine (o idx 0))
  (function* stack.routine.idx!fn-name))

(mac pc (routine (o idx 0))  ; assignable
  `((((rep ,routine) 'call-stack) ,idx) 'pc))

(mac caller-arg-idx (routine (o idx 0))  ; assignable
  `((((rep ,routine) 'call-stack) ,idx) 'caller-arg-idx))

(mac caller-args (routine)  ; assignable
  `((((rep ,routine) 'call-stack) 0) 'args))
(mac caller-operands (routine)  ; assignable
  `((((rep ,routine) 'call-stack) 0) 'caller-operands))
(mac caller-results (routine)  ; assignable
  `((((rep ,routine) 'call-stack) 0) 'caller-results))

(mac results (routine)  ; assignable
  `((((rep ,routine) 'call-stack) 0) 'results))

(def waiting-for-exact-cycle? (routine)
  (is 'literal rep.routine!sleep.1))

(def ready-to-wake-up (routine)
  (assert no.routine*)
  (if (is 'literal rep.routine!sleep.1)
    (> curr-cycle* rep.routine!sleep.0)
    (~is rep.routine!sleep.1 (memory* rep.routine!sleep.0))))

(on-init
  (= running-routines* (queue))  ; simple round-robin scheduler
  ; set of sleeping routines; don't modify routines while they're in this table
  (= sleeping-routines* (table))
  (= completed-routines* nil)  ; audit trail
  (= routine* nil)
  (= abort-routine* (parameter nil))
  (= curr-cycle* 0)
  (= scheduling-interval* 500)
  (= scheduler-switch-table* nil)  ; hook into scheduler for tests
  )

; like arc's 'point' but you can also call ((abort-routine*)) in nested calls
(mac routine-mark body
  (w/uniq (g p)
    `(ccc (fn (,g)
            (parameterize abort-routine* (fn ((o ,p)) (,g ,p))
              ,@body)))))

(def run fn-names
  (freeze-functions)
  (= traces* (queue))
  (each it fn-names
    (enq make-routine.it running-routines*))
  (while (~empty running-routines*)
    (= routine* deq.running-routines*)
    (trace "schedule" top.routine*!fn-name)
    (routine-mark
      (run-for-time-slice scheduling-interval*))
    (update-scheduler-state)
;?     (tr "after run iter " running-routines*)
;?     (tr "after run iter " empty.running-routines*)
    ))

; prepare next iteration of round-robin scheduler
;
; state before: routine* running-routines* sleeping-routines*
; state after: running-routines* (with next routine to run at head) sleeping-routines*
;
; responsibilities:
;   add routine* to either running-routines* or sleeping-routines* or completed-routines*
;   wake up any necessary sleeping routines (either by time or on a location)
;   detect deadlock: kill all sleeping routines when none can be woken
(def update-scheduler-state ()
;?   (trace "schedule" curr-cycle*)
  (when routine*
    (if
        rep.routine*!sleep
          (do (trace "schedule" "pushing " top.routine*!fn-name " to sleep queue")
              (set sleeping-routines*.routine*))
        (~empty routine*)
          (do (trace "schedule" "scheduling " top.routine*!fn-name " for further processing")
              (enq routine* running-routines*))
        :else
          (do (trace "schedule" "done with routine")
              (push routine* completed-routines*)))
    (= routine* nil))
;?   (tr 111)
  (each (routine _) canon.sleeping-routines*
    (when (ready-to-wake-up routine)
      (trace "schedule" "waking up " top.routine!fn-name)
      (wipe sleeping-routines*.routine)  ; do this before modifying routine
      (wipe rep.routine!sleep)
      (++ pc.routine)
      (enq routine running-routines*)))
;?   (tr 112)
  (when (empty running-routines*)
    (whenlet exact-sleeping-routines (keep waiting-for-exact-cycle? keys.sleeping-routines*)
      (let next-wakeup-cycle (apply min (map [rep._!sleep 0] exact-sleeping-routines))
        (= curr-cycle* (+ 1 next-wakeup-cycle))
        (trace "schedule" "skipping to cycle " curr-cycle*)
        (update-scheduler-state))))
;?   (tr 113)
  (detect-deadlock)
;?   (tr 114)
  )

(def detect-deadlock ()
  (when (and (empty running-routines*)
             (~empty sleeping-routines*)
             (~some 'literal (map (fn(_) rep._!sleep.1)
                                  keys.sleeping-routines*)))
    (each (routine _) sleeping-routines*
      (wipe sleeping-routines*.routine)
      (= rep.routine!error "deadlock detected")
      (push routine completed-routines*))))

(def die (msg)
  (tr "die: " msg)
  (= rep.routine*!error msg)
  (= rep.routine*!stack-trace rep.routine*!call-stack)
  (wipe rep.routine*!call-stack)
  (iflet abort-continuation (abort-routine*)
    (abort-continuation)))

;; running a single routine

; value of an arg or oarg, stripping away all metadata
; wish I could have this flag an error when arg is incorrectly formed
(mac v (operand)  ; for value
  `((,operand 0) 0))

; routines consist of instrs
; instrs consist of oargs, op and args
(def parse-instr (instr)
  (iflet delim (pos '<- instr)
    (list (cut instr 0 delim)  ; oargs
          (v (instr (+ delim 1)))  ; op
          (cut instr (+ delim 2)))  ; args
    (list nil (v car.instr) cdr.instr)))

(def metadata (operand)
  cdr.operand)

(def ty (operand)
  (cdr operand.0))

(def typeinfo (operand)
  (or (type* ty.operand.0)
      (err "unknown type @(tostring prn.operand)")))

; operand accessors
(def nondummy (operand)  ; precondition for helpers below
  (~is '_ operand))

; just for convenience, 'new' instruction sometimes takes a raw string and
; allocates just enough space to store it
(def not-raw-string (operand)
  (~isa operand 'string))

(def address? (operand)
  (or (is ty.operand.0 'location)
      typeinfo.operand!address))

($:require "charterm/main.rkt")
($:require graphics/graphics)
(= Viewport nil)

; run instructions from 'routine*' for 'time-slice'
(def run-for-time-slice (time-slice)
  (point return
    (for ninstrs 0 (< ninstrs time-slice) (++ ninstrs)
      (if (empty body.routine*) (err "@stack.routine*.0!fn-name not defined"))
      ; falling out of end of function = implicit reply
      (while (>= pc.routine* (len body.routine*))
        (pop-stack routine*)
        (if empty.routine* (return ninstrs))
        (++ pc.routine*))
      (++ curr-cycle*)
      (trace "run" "-- " int-canon.memory*)
      (trace "run" curr-cycle* " " top.routine*!fn-name " " pc.routine* ": " (body.routine* pc.routine*))
;?       (trace "run" routine*)
      (when (atom (body.routine* pc.routine*))  ; label
        (when (aand scheduler-switch-table*
                    (alref it (body.routine* pc.routine*)))
          (++ pc.routine*)
          (trace "run" "context-switch forced " abort-routine*)
          ((abort-routine*)))
        (++ pc.routine*)
        (continue))
      (let (oarg op arg)  (parse-instr (body.routine* pc.routine*))
        (let results
              (case op
                ; arithmetic
                add
                  (do (trace "add" (m arg.0) " " (m arg.1))
                  (+ (m arg.0) (m arg.1))
                  )
                subtract
                  (- (m arg.0) (m arg.1))
                multiply
                  (* (m arg.0) (m arg.1))
                divide
                  (/ (real (m arg.0)) (m arg.1))
                divide-with-remainder
                  (list (trunc:/ (m arg.0) (m arg.1))
                        (mod (m arg.0) (m arg.1)))

                ; boolean
                and
                  (and (m arg.0) (m arg.1))
                or
                  (or (m arg.0) (m arg.1))
                not
                  (not (m arg.0))

                ; comparison
                equal
                  (is (m arg.0) (m arg.1))
                not-equal
                  (do (trace "neq" (m arg.0) " " (m arg.1))
                  (~is (m arg.0) (m arg.1))
                  )
                less-than
                  (< (m arg.0) (m arg.1))
                greater-than
                  (> (m arg.0) (m arg.1))
                lesser-or-equal
                  (<= (m arg.0) (m arg.1))
                greater-or-equal
                  (>= (m arg.0) (m arg.1))

                ; control flow
                jump
                  (do (= pc.routine* (+ 1 pc.routine* (v arg.0)))
                      (trace "jump" "jumping to " pc.routine*)
                      (continue))
                jump-if
                  (let flag (m arg.0)
                    (trace "jump" "checking that " flag " is t")
                    (when (is t flag)
                      (= pc.routine* (+ 1 pc.routine* (v arg.1)))
                      (trace "jump" "jumping to " pc.routine*)
                      (continue)))
                jump-unless  ; convenient helper
                  (let flag (m arg.0)
                    (trace "jump" "checking that " flag " is not t")
                    (unless (is t flag)
                      (= pc.routine* (+ 1 pc.routine* (v arg.1)))
                      (trace "jump" "jumping to " pc.routine*)
                      (continue)))

                ; data management: scalars, arrays, and-records (structs)
                copy
                  (m arg.0)
                get
                  (with (operand  (canonize arg.0)
                         idx  (v arg.1))
                    (assert (iso '(offset) (ty arg.1)) "record index @arg.1 must have type 'offset'")
                    (assert (< -1 idx (len typeinfo.operand!elems)) "@idx is out of bounds of record @operand")
                    (m `((,(apply + v.operand
                                    (map (fn(x) (sizeof `((_ ,@x))))
                                         (firstn idx typeinfo.operand!elems)))
                          ,@typeinfo.operand!elems.idx)
                         (global))))
                get-address
                  (with (operand  (canonize arg.0)
                         idx  (v arg.1))
                    (assert (iso '(offset) (ty arg.1)) "record index @arg.1 must have type 'offset'")
                    (assert (< -1 idx (len typeinfo.operand!elems)) "@idx is out of bounds of record @operand")
                    (apply + v.operand
                             (map (fn(x) (sizeof `((_ ,@x))))
                                  (firstn idx typeinfo.operand!elems))))
                index
                  (withs (operand  (canonize arg.0)
                          elemtype  typeinfo.operand!elem
                          idx  (m arg.1))
                    (unless (< -1 idx array-len.operand)
                      (die "@idx is out of bounds of array @operand"))
                    (m `((,(+ v.operand
                              1  ; for array size
                              (* idx (sizeof `((_ ,@elemtype)))))
                           ,@elemtype)
                         (global))))
                index-address
                  (withs (operand  (canonize arg.0)
                          elemtype  typeinfo.operand!elem
                          idx  (m arg.1))
                    (unless (< -1 idx array-len.operand)
                      (die "@idx is out of bounds of array @operand"))
                    (+ v.operand
                       1  ; for array size
                       (* idx (sizeof `((_ ,@elemtype))))))
                new
                  (if (isa arg.0 'string)
                    ; special-case: allocate space for a literal string
                    (new-string arg.0)
                    (let type (v arg.0)
                      (assert (iso '(literal) (ty arg.0)) "new: second arg @arg.0 must be literal")
                      (if (no type*.type)  (err "no such type @type"))
                      ; todo: initialize memory. currently racket does it for us
                      (if type*.type!array
                        (new-array type (m arg.1))
                        (new-scalar type))))
                sizeof
                  (sizeof `((_ ,(m arg.0))))
                length
                  (let base arg.0
                    (if (or typeinfo.base!array address?.base)
                      array-len.base
                      -1))

                ; tagged-values require one primitive
                save-type
                  (annotate 'record `(,((ty arg.0) 0) ,(m arg.0)))

                ; multiprocessing
                run
                  (run (v arg.0))
                fork
                  (let routine (apply make-routine (v car.arg) (map m cdr.arg))
;?                     (tr "before: " rep.routine*!alloc)
                    (= rep.routine!alloc rep.routine*!alloc)
                    (++ rep.routine*!alloc 1000)
;?                     (tr "after: " rep.routine*!alloc " " rep.routine!alloc)
                    (enq routine running-routines*))
                ; todo: errors should stall a process and let its parent
                ; inspect it
                assert
                  (assert (m arg.0))
                sleep
                  (let operand arg.0
;?                     (tr "sleep " operand)
                    ; store sleep as either (<cycle number> literal) or (<location> <current value>)
                    (if (is ty.operand.0 'literal)
                      (let delay v.operand
                        (trace "run" "sleeping until " (+ curr-cycle* delay))
                        (= rep.routine*!sleep `(,(+ curr-cycle* delay) literal)))
                      (do
;?                         (tr "blocking on " operand " -> " (addr operand))
                        (= rep.routine*!sleep `(,addr.operand ,m.operand))))
                    ((abort-routine*)))

                ; text interaction
                clear-screen
                  (do1 nil ($.charterm-clear-screen))
                clear-line
                  (do1 nil ($.charterm-clear-line))
                cursor
                  (do1 nil ($.charterm-cursor (m arg.0) (m arg.1)))
                print-primitive
                  (do1 nil ((if ($.current-charterm) $.charterm-display pr) (m arg.0)))
                read-key
                  (and ($.charterm-byte-ready?) ($.charterm-read-key))
                bold-mode
                  (do1 nil ($.charterm-bold))
                non-bold-mode
                  (do1 nil ($.charterm-normal))
                console-on
                  (do1 nil (if (no ($.current-charterm)) ($.open-charterm)))
                console-off
                  (do1 nil (if ($.current-charterm) ($.close-charterm)))

                ; graphics
                graphics-on
                  (do1 nil
                    ($.open-graphics)
                    (= Viewport ($.open-viewport "practice" 300 300)))
                graphics-off
                  (do1 nil
                    ($.close-graphics)
                    (= Viewport nil))
                mouse-position
                  (aif ($.ready-mouse-click Viewport)
                    (let posn ($.mouse-click-posn it)
                      (list (annotate 'record (list ($.posn-x posn) ($.posn-y posn))) t))
                    (list nil nil))

                ; user-defined functions
                next-input
                  (let idx caller-arg-idx.routine*
                    (++ caller-arg-idx.routine*)
                    (trace "arg" arg " " idx " " caller-args.routine*)
                    (if (len> caller-args.routine* idx)
                      (list caller-args.routine*.idx t)
                      (list nil nil)))
                input
                  (do (assert (iso '(literal) (ty arg.0)))
                      (= caller-arg-idx.routine* (v arg.0))
                      (let idx caller-arg-idx.routine*
                        (++ caller-arg-idx.routine*)
                        (trace "arg" arg " " idx " " caller-args.routine*)
                        (if (len> caller-args.routine* idx)
                          (list caller-args.routine*.idx t)
                          (list nil nil))))
                ; type and otype won't always easily compile. be careful.
                type
                  (ty (caller-operands.routine* (v arg.0)))
                otype
                  (ty (caller-results.routine* (v arg.0)))
                prepare-reply
                  (prepare-reply arg)
                reply
                  (do (when arg
                        (prepare-reply arg))
                      (let results results.routine*
                        (pop-stack routine*)
                        (if empty.routine* (return ninstrs))
                        (let (caller-oargs _ _)  (parse-instr (body.routine* pc.routine*))
                          (trace "reply" arg " " caller-oargs)
                          (each (dest val)  (zip caller-oargs results)
                            (when nondummy.dest
                              (trace "reply" val " => " dest)
                              (setm dest val))))
                        (++ pc.routine*)
                        (while (>= pc.routine* (len body.routine*))
                          (pop-stack routine*)
                          (when empty.routine* (return ninstrs))
                          (++ pc.routine*))
                        (continue)))
                ; else try to call as a user-defined function
                  (do (if function*.op
                        (with (callee-args (accum yield
                                             (each a arg
                                               (yield (m a))))
                               callee-operands (accum yield
                                                 (each a arg
                                                   (yield a)))
                               callee-results (accum yield
                                                (each a oarg
                                                  (yield a))))
                          (push-stack routine* op)
                          (= caller-args.routine* callee-args)
                          (= caller-operands.routine* callee-operands)
                          (= caller-results.routine* callee-results))
                        (err "no such op @op"))
                      (continue))
                )
              ; opcode generated some 'results'
              ; copy to output args
              (if (acons results)
                (each (dest val) (zip oarg results)
                  (unless (is dest '_)
                    (trace "run" val " => " dest)
                    (setm dest val)))
                (when oarg  ; must be a list
                  (trace "run" results " => " oarg.0)
                  (setm oarg.0 results)))
              )
        (++ pc.routine*)))
    (return time-slice)))

(def prepare-reply (args)
  (= results.routine*
     (accum yield
       (each a args
         (yield (m a))))))

; helpers for memory access respecting
;   immediate addressing - 'literal' and 'offset'
;   direct addressing - default
;   indirect addressing - 'deref'
;   relative addressing - if routine* has 'default-scope'

(def m (loc)  ; read memory, respecting metadata
  (point return
    (if (in ty.loc.0 'literal 'offset)
      (return v.loc))
    (when (is v.loc 'default-scope)
      (return rep.routine*!call-stack.0!default-scope))
    (trace "m" loc)
    (assert (isa v.loc 'int) "addresses must be numeric (problem in convert-names?) @loc")
    (with (n  sizeof.loc
           addr  addr.loc)
;?       (trace "m" "reading " n " locations starting at " addr)
      (if (is 1 n)
            memory*.addr
          :else
            (annotate 'record
                      (map memory* (addrs addr n)))))))

(def setm (loc val)  ; set memory, respecting metadata
  (point return
    (when (is v.loc 'default-scope)
      (assert (is 1 sizeof.loc) "can't store compounds in default-scope @loc")
      (= rep.routine*!call-stack.0!default-scope val)
      (return))
    (assert (isa v.loc 'int) "can't store to non-numeric address (problem in convert-names?)")
    (trace "setm" loc " <= " val)
    (with (n  (if (isa val 'record) (len rep.val) 1)
           addr  addr.loc
           typ  typeof.loc)
      (trace "setm" "size of " loc " is " n)
      (assert n "setm: can't compute type of @loc")
      (assert addr "setm: null pointer @loc")
      (if (is 1 n)
        (do (assert (~isa val 'record) "setm: record of size 1 @(tostring prn.val)")
            (trace "setm" loc ": setting " addr " to " val)
            (= memory*.addr val))
        (do (if type*.typ!array
              ; size check for arrays
              (when (~is n
                         (+ 1  ; array length
                            (* rep.val.0 (sizeof `((_ ,@type*.typ!elem))))))
                (die "writing invalid array @(tostring prn.val)"))
              ; size check for non-arrays
              (when (~is sizeof.loc n)
                (die "writing to incorrect size @(tostring prn.val) => @loc")))
            (let addrs (addrs addr n)
              (each (dest src) (zip addrs rep.val)
                (trace "setm" loc ": setting " dest " to " src)
                (= memory*.dest src))))))))

(def typeof (operand)
  (let loc absolutize.operand
    (while (pos '(deref) metadata.loc)
      (zap deref loc))
    ty.loc.0))

(def addr (operand)
;?   (prn 211 " " operand)
  (let loc absolutize.operand
;?     (prn 212 " " loc)
    (while (pos '(deref) metadata.loc)
;?       (prn 213 " " loc)
      (zap deref loc))
;?     (prn 214 " " loc)
    v.loc))

(def addrs (n sz)
  (accum yield
    (repeat sz
      (yield n)
      (++ n))))

(def canonize (operand)
  (ret operand
    (zap absolutize operand)
    (while (pos '(deref) metadata.operand)
      (zap deref operand))))

(def array-len (operand)
  (trace "array-len" operand)
  (zap canonize operand)
  (if typeinfo.operand!array
        (m `((,v.operand integer) ,@metadata.operand))
      :else
        (err "can't take len of non-array @operand")))

(def sizeof (x)
  (trace "sizeof" x)
  (assert acons.x)
  (zap canonize x)
  (point return
;?   (tr "sizeof: checking @x for array")
  (when typeinfo.x!array
;?     (tr "sizeof: @x is an array")
    (assert (~is '_ v.x) "sizeof: arrays require a specific variable")
    (return (+ 1 (* array-len.x (sizeof `((_ ,@typeinfo.x!elem)))))))
;?   (tr "sizeof: not an array")
  (when typeinfo.x!and-record
;?     (tr "sizeof: @x is an and-record")
    (return (sum idfn
                 (accum yield
                   (each elem typeinfo.x!elems
                     (yield (sizeof `((_ ,@elem)))))))))
;?   (tr "sizeof: @x is a primitive")
  (return typeinfo.x!size)))

(def absolutize (operand)
  (if (no routine*)
        operand
      (is '_ v.operand)
        operand
      (pos '(global) metadata.operand)
        operand
      :else
        (iflet base rep.routine*!call-stack.0!default-scope
;?                (do (prn 313 " " operand " " base)
          (if (< v.operand memory*.base)
            `((,(+ v.operand base) ,@(cdr operand.0))
              ,@metadata.operand
              (global))
            (die "no room for var @operand in routine of size @memory*.base"))
;?                 )
          operand)))

(def deref (operand)
  (assert (pos '(deref) metadata.operand))
  (assert address?.operand)
  (cons `(,(memory* v.operand) ,@typeinfo.operand!elem)
        (drop-one '(deref) metadata.operand)))

(def drop-one (f x)
  (when acons.x  ; proper lists only
    (if (testify.f car.x)
      cdr.x
      (cons car.x (drop-one f cdr.x)))))

; memory allocation

(def new-scalar (type)
;?   (tr "new scalar: @type")
  (ret result rep.routine*!alloc
    (++ rep.routine*!alloc (sizeof `((_ ,type))))))

(def new-array (type size)
;?   (tr "new array: @type @size")
  (ret result rep.routine*!alloc
    (++ rep.routine*!alloc (+ 1 (* (sizeof `((_ ,@type*.type!elem))) size)))
    (= memory*.result size)))

(def new-string (literal-string)
;?   (tr "new string: @literal-string")
  (ret result rep.routine*!alloc
    (= (memory* rep.routine*!alloc) len.literal-string)
    (++ rep.routine*!alloc)
    (each c literal-string
      (= (memory* rep.routine*!alloc) c)
      (++ rep.routine*!alloc))))

;; desugar structured assembly based on blocks

(def convert-braces (instrs)
;?   (prn "convert-braces " instrs)
  (let locs ()  ; list of information on each brace: (open/close pc)
    (let pc 0
      (loop (instrs instrs)
        (each instr instrs
;?           (tr instr)
          (if (or atom.instr (~is 'begin instr.0))  ; label or regular instruction
                (do
                  (trace "c{0" pc " " instr " -- " locs)
                  (++ pc))
                ; hack: racket replaces braces with parens, so we need the
                ; keyword 'begin' to delimit blocks.
                ; ultimately there'll be no nesting and braces will just be
                ; in an instr by themselves.
              :else  ; brace
                (do
                  (push `(open ,pc) locs)
                  (recur cdr.instr)
                  (push `(close ,pc) locs))))))
    (zap rev locs)
;?     (tr "-")
    (with (pc  0
           stack  ())  ; elems are pcs
      (accum yield
        (loop (instrs instrs)
          (each instr instrs
;?             (tr "- " instr)
            (point continue
            (when (atom instr)  ; label
              (yield instr)
              (++ pc)
              (continue))
            (when (is car.instr 'begin)
              (push pc stack)
              (recur cdr.instr)
              (pop stack)
              (continue))
            (let (oarg op arg)  (parse-instr instr)
              (trace "c{1" pc " " op " " oarg)
              (case op
                break
                  (do
                    (assert (is oarg nil) "break: can't take oarg in @instr")
                    (yield `(((jump)) ((,(close-offset pc locs (and arg (v arg.0))) offset)))))
                break-if
                  (do
                    (assert (is oarg nil) "break-if: can't take oarg in @instr")
                    (yield `(((jump-if)) ,arg.0 ((,(close-offset pc locs (and cdr.arg (v arg.1))) offset)))))
                break-unless
                  (do
                    (assert (is oarg nil) "break-unless: can't take oarg in @instr")
                    (yield `(((jump-unless)) ,arg.0 ((,(close-offset pc locs (and cdr.arg (v arg.1))) offset)))))
                loop
                  (do
                    (assert (is oarg nil) "loop: can't take oarg in @instr")
                    (yield `(((jump)) ((,(open-offset pc stack (and arg (v arg.0))) offset)))))
                loop-if
                  (do
                    (trace "cvt0" "loop-if: " instr " => " (- stack.0 1))
                    (assert (is oarg nil) "loop-if: can't take oarg in @instr")
                    (yield `(((jump-if)) ,arg.0 ((,(open-offset pc stack (and cdr.arg (v arg.1))) offset)))))
                loop-unless
                  (do
                    (trace "cvt0" "loop-if: " instr " => " (- stack.0 1))
                    (assert (is oarg nil) "loop-unless: can't take oarg in @instr")
                    (yield `(((jump-unless)) ,arg.0 ((,(open-offset pc stack (and cdr.arg (v arg.1))) offset)))))
                ;else
                  (yield instr)))
            (++ pc))))))))

(def close-offset (pc locs nblocks)
  (or= nblocks 1)
;?   (tr nblocks)
  (point return
;?   (tr "close " pc " " locs)
  (let stacksize 0
    (each (state loc) locs
      (point continue
;?       (tr stacksize "/" done " " state " " loc)
      (when (<= loc pc)
        (continue))
;?       (tr "process " stacksize loc)
      (if (is 'open state) (++ stacksize) (-- stacksize))
      ; last time
;?       (tr "process2 " stacksize loc)
      (when (is stacksize (* -1 nblocks))
;?         (tr "close now " loc)
        (return (- loc pc 1))))))))

(def open-offset (pc stack nblocks)
  (or= nblocks 1)
  (- (stack (- nblocks 1)) 1 pc))

;; convert jump targets to offsets

(def convert-labels (instrs)
;?   (tr "convert-labels " instrs)
  (let labels (table)
    (let pc 0
      (each instr instrs
        (when (~acons instr)
;?           (tr "label " pc)
          (= labels.instr pc))
        (++ pc)))
    (let pc 0
      (each instr instrs
        (when (and acons.instr
                   (acons car.instr)
                   (in (v car.instr) 'jump 'jump-if 'jump-unless))
          (each arg cdr.instr
;?             (tr "trying " arg " " ty.arg ": " v.arg " => " (labels v.arg))
            (when (and (is ty.arg.0 'offset)
                       (isa v.arg 'sym)
                       (labels v.arg))
              (= v.arg (- (labels v.arg) pc 1)))))
        (++ pc))))
  instrs)

;; convert symbolic names to raw memory locations

(def convert-names (instrs)
;?   (tr "convert-names " instrs)
  (with (location  (table)
         isa-field  (table))
    (let idx 1
      (each instr instrs
        (point continue
        (when atom.instr
          (continue))
        (trace "cn0" instr " " canon.location " " canon.isa-field)
        (let (oargs op args)  (parse-instr instr)
;?           (tr "about to rename args")
          ; rename args
          (if (in op 'get 'get-address)
            (with (basetype  (typeof args.0)
                   field  (v args.1))
              (assert type*.basetype!and-record "get on non-record @args.0")
              (trace "cn0" "field-access @field in @args.0 of type @basetype")
              (when (isa field 'sym)
                (assert (or (~location field) isa-field.field) "field @args.1 is also a variable")
                (when (~location field)
                  (trace "cn0" "new field; computing location")
;?                   (tr "aa " type*.basetype)
                  (assert type*.basetype!fields "no field names available for @instr")
;?                   (tr "bb")
                  (iflet idx (pos field type*.basetype!fields)
                    (do (set isa-field.field)
                        (trace "cn0" "field location @idx")
                        (= location.field idx))
                    (assert nil "couldn't find field in @instr")))))
            (each arg args
              (when (and nondummy.arg not-raw-string.arg)
                (assert (~isa-field v.arg) "arg @arg is also a field name")
                (when (maybe-add arg location idx)
                  (err "use before set: @arg")))))
;?           (tr "about to rename oargs")
          ; rename oargs
          (each arg oargs
            (trace "cn0" "checking " arg)
            (when (and nondummy.arg not-raw-string.arg)
              (assert (~isa-field v.arg) "oarg @arg is also a field name")
              (when (maybe-add arg location idx)
                (trace "cn0" "location for arg " arg ": " idx)
                ; todo: can't allocate arrays on the stack
                (++ idx (sizeof `((_ ,@ty.arg)))))))))))
    (trace "cn1" "update names " canon.location " " canon.isa-field)
    (each instr instrs
      (when (acons instr)
        (let (oargs op args)  (parse-instr instr)
          (each arg args
            (when (and nondummy.arg not-raw-string.arg (location v.arg))
              (zap location v.arg)))
          (each arg oargs
            (when (and nondummy.arg not-raw-string.arg (location v.arg))
              (zap location v.arg))))))
    instrs))

(def maybe-add (arg location idx)
  (trace "maybe-add" arg)
  (when (and nondummy.arg
             (~in ty.arg.0 'literal 'offset 'fn)
             (~location v.arg)
             (isa v.arg 'sym)
             (~in v.arg 'nil 'default-scope)
             (~pos '(global) metadata.arg))
    (= (location v.arg) idx)))

;; literate tangling system for reordering code

(def convert-quotes (instrs)
  (let deferred (queue)
    (each instr instrs
      (when (acons instr)
        (case instr.0
          defer
            (let (q qinstrs)  instr.1
              (assert (is 'make-br-fn q) "defer: first arg must be [quoted]")
              (each qinstr qinstrs
                (enq qinstr deferred))))))
    (accum yield
      (each instr instrs
        (if atom.instr  ; label
              (yield instr)
            (is instr.0 'defer)
              nil  ; skip
            (is instr.0 'reply)
              (do
                (when cdr.instr  ; return values
                  (= instr.0 'prepare-reply)
                  (yield instr))
                (each instr (as cons deferred)
                  (yield instr))
                (yield '(reply)))
            :else
              (yield instr)))
      (each instr (as cons deferred)
        (yield instr)))))

(on-init
  (= before* (table))  ; label -> queue of fragments
  (= after* (table)))  ; label -> list of fragments

; see add-code below for adding to before* and after*

(def insert-code (instrs (o name))
;?   (tr "insert-code " instrs)
  (loop (instrs instrs)
    (accum yield
      (each instr instrs
        (if (and (acons instr) (~is 'begin car.instr))
              ; simple instruction
              (yield instr)
            (and (acons instr) (is 'begin car.instr))
              ; block
              (yield `{begin ,@(recur cdr.instr)})
            (atom instr)
              ; label
              (do
;?                 (prn "tangling " instr)
                (each fragment (as cons (or (and name (before* (sym:string name '/ instr)))
                                            before*.instr))
                  (each instr fragment
                    (yield instr)))
                (yield instr)
                (each fragment (or (and name (after* (sym:string name '/ instr)))
                                   after*.instr)
                  (each instr fragment
                    (yield instr)))))))))

;; loading code into the virtual machine

(def add-code (forms)
  (each (op . rest)  forms
    (case op
      ; function <name> [ <instructions> ]
      ; don't apply our lightweight tools just yet
      function!
        (let (name (_make-br-fn body))  rest
          (assert (is 'make-br-fn _make-br-fn))
          (= function*.name body))
      function
        (let (name (_make-br-fn body))  rest
          (assert (is 'make-br-fn _make-br-fn))
          (= function*.name (join body function*.name)))

      ; and-record <type> [ <name:types> ]
      and-record
        (let (name (_make-br-fn fields))  rest
          (assert (is 'make-br-fn _make-br-fn))
          (let fields (map tokenize-arg fields)
            (= type*.name (obj size len.fields
                               and-record t
                               ; dump all metadata for now except field name and type
                               elems (map cdar fields)
                               fields (map caar fields)))))

      ; before <label> [ <instructions> ]
      ;
      ; multiple before directives => code in order
      before
        (let (label (_make-br-fn fragment))  rest
          (assert (is 'make-br-fn _make-br-fn))
          (or= before*.label (queue))
          (enq fragment before*.label))

      ; after <label> [ <instructions> ]
      ;
      ; multiple after directives => code in *reverse* order
      ; (if initialization order in a function is A B, corresponding
      ; finalization order should be B A)
      after
        (let (label (_make-br-fn fragment))  rest
          (assert (is 'make-br-fn _make-br-fn))
          (push fragment after*.label))
      )))

(def freeze-functions ()
;?   (prn "freeze")
  (each (name body)  canon.function*
;?     (tr name)
;?     (prn keys.before* " -- " keys.after*)
;?     (= function*.name (convert-names:convert-labels:convert-braces:prn:insert-code body)))
    (= function*.name (convert-names:convert-labels:convert-braces:tokenize-args:insert-code body name))))

(def tokenize-arg (arg)
;?   (tr "tokenize-arg " arg)
  (if (in arg '<- '_)
        arg
      (isa arg 'sym)
        (map [map [fromstring _ (read)] _]
             (map [tokens _ #\:]
                  (tokens string.arg #\/)))
      :else
        arg))

(def tokenize-args (instrs)
;?   (tr "tokenize-args " instrs)
;?   (prn2 "@(tostring prn.instrs) => "
  (accum yield
    (each instr instrs
      (if atom.instr
            (yield instr)
          (is 'begin instr.0)
            (yield `{begin ,@(tokenize-args cdr.instr)})
          :else
            (yield (map tokenize-arg instr))))))
;?   )

(def prn2 (msg . args)
  (pr msg)
  (apply prn args))

(def canon (table)
  (sort (compare < [tostring (prn:car _)]) (as cons table)))

(def int-canon (table)
  (sort (compare < car) (as cons table)))

;; test helpers

(def memory-contains (addr value)
;?   (prn "Looking for @value starting at @addr")
  (loop (addr addr
         idx  0)
;?     (prn "@idx vs @addr")
    (if (>= idx len.value)
          t
        (~is memory*.addr value.idx)
          (do1 nil
               (prn "@addr should contain @value.idx but contains @memory*.addr"))
        :else
          (recur (+ addr 1) (+ idx 1)))))

(def memory-contains-array (addr value)
;?   (prn "Looking for @value starting at @addr, size @memory*.addr vs @len.value")
  (and (>= memory*.addr len.value)
       (loop (addr (+ addr 1)
              idx  0)
;?          (prn "comparing @memory*.addr and @value.idx")
         (if (>= idx len.value)
               t
             (~is memory*.addr value.idx)
               (do1 nil
                    (prn "@addr should contain @value.idx but contains @memory*.addr"))
             :else
               (recur (+ addr 1) (+ idx 1))))))

;; system software
; create once, load before every test

(reset)
(= system-function* (table))

(mac init-fn (name . body)
  `(= (system-function* ',name) 
      (convert-names:convert-labels:convert-braces:tokenize-args:insert-code ',body ',name)))

(on-init
  (each (name f) system-function*
    (= (function* name)
       (system-function* name))))

(section 100

(init-fn maybe-coerce
  (default-scope:scope-address <- new scope:literal 30:literal)
  (x:tagged-value-address <- new tagged-value:literal)
  (x:tagged-value-address/deref <- next-input)
  (p:type <- next-input)
  (xtype:type <- get x:tagged-value-address/deref 0:offset)
  (match?:boolean <- equal xtype:type p:type)
  { begin
    (break-if match?:boolean)
    (reply 0:literal nil:literal)
  }
  (xvalue:location <- get x:tagged-value-address/deref 1:offset)
  (reply xvalue:location match?:boolean))

(init-fn new-tagged-value
  (default-scope:scope-address <- new scope:literal 30:literal)
  ; assert sizeof:arg.0 == 1
  (xtype:type <- next-input)
  (xtypesize:integer <- sizeof xtype:type)
  (xcheck:boolean <- equal xtypesize:integer 1:literal)
  (assert xcheck:boolean)
  ; todo: check that arg 0 matches the type? or is that for the future typechecker?
  (result:tagged-value-address <- new tagged-value:literal)
  ; result->type = arg 0
  (resulttype:location <- get-address result:tagged-value-address/deref type:offset)
  (resulttype:location/deref <- copy xtype:type)
  ; result->payload = arg 1
  (locaddr:location <- get-address result:tagged-value-address/deref payload:offset)
  (locaddr:location/deref <- next-input)
  (reply result:tagged-value-address))

(init-fn list-next  ; list-address -> list-address
  (default-scope:scope-address <- new scope:literal 30:literal)
  (base:list-address <- next-input)
  (result:list-address <- get base:list-address/deref cdr:offset)
  (reply result:list-address))

(init-fn list-value-address  ; list-address -> tagged-value-address
  (default-scope:scope-address <- new scope:literal 30:literal)
  (base:list-address <- next-input)
  (result:tagged-value-address <- get-address base:list-address/deref car:offset)
  (reply result:tagged-value-address))

(init-fn new-list
  (default-scope:scope-address <- new scope:literal 30:literal)
  ; new-list = curr = new list
  (new-list-result:list-address <- new list:literal)
  (curr:list-address <- copy new-list-result:list-address)
  { begin
    ; while read curr-value
    (curr-value:integer exists?:boolean <- next-input)
    (break-unless exists?:boolean)
    ; curr.cdr = new list
    (next:list-address-address <- get-address curr:list-address/deref cdr:offset)
    (next:list-address-address/deref <- new list:literal)
    ; curr = curr.cdr
    (curr:list-address <- list-next curr:list-address)
    ; curr.car = type:curr-value
    (dest:tagged-value-address <- list-value-address curr:list-address)
    (dest:tagged-value-address/deref <- save-type curr-value:integer)
    (loop)
  }
  ; return new-list.cdr
  (new-list-result:list-address <- list-next new-list-result:list-address)  ; memory leak
  (reply new-list-result:list-address))

(init-fn new-channel
  (default-scope:scope-address <- new scope:literal 30:literal)
  ; result = new channel
  (result:channel-address <- new channel:literal)
  ; result.first-full = 0
  (full:integer-address <- get-address result:channel-address/deref first-full:offset)
  (full:integer-address/deref <- copy 0:literal)
  ; result.first-free = 0
  (free:integer-address <- get-address result:channel-address/deref first-free:offset)
  (free:integer-address/deref <- copy 0:literal)
  ; result.circular-buffer = new tagged-value[arg+1]
  (capacity:integer <- next-input)
  (capacity:integer <- add capacity:integer 1:literal)  ; unused slot for full? below
  (channel-buffer-address:tagged-value-array-address-address <- get-address result:channel-address/deref circular-buffer:offset)
  (channel-buffer-address:tagged-value-array-address-address/deref <- new tagged-value-array:literal capacity:integer)
  (reply result:channel-address))

(init-fn capacity
  (default-scope:scope-address <- new scope:literal 30:literal)
  (chan:channel <- next-input)
  (q:tagged-value-array-address <- get chan:channel circular-buffer:offset)
  (qlen:integer <- length q:tagged-value-array-address/deref)
  (reply qlen:integer))

(init-fn write
  (default-scope:scope-address <- new scope:literal 30:literal)
  (chan:channel-address <- next-input)
  (val:tagged-value <- next-input)
  { begin
    ; block if chan is full
    (full:boolean <- full? chan:channel-address/deref)
    (break-unless full:boolean)
    (full-address:integer-address <- get-address chan:channel-address/deref first-full:offset)
    (sleep full-address:integer-address/deref)
  }
  ; store val
  (q:tagged-value-array-address <- get chan:channel-address/deref circular-buffer:offset)
  (free:integer-address <- get-address chan:channel-address/deref first-free:offset)
  (dest:tagged-value-address <- index-address q:tagged-value-array-address/deref free:integer-address/deref)
  (dest:tagged-value-address/deref <- copy val:tagged-value)
  ; increment free
  (free:integer-address/deref <- add free:integer-address/deref 1:literal)
  { begin
    ; wrap free around to 0 if necessary
    (qlen:integer <- length q:tagged-value-array-address/deref)
    (remaining?:boolean <- less-than free:integer-address/deref qlen:integer)
    (break-if remaining?:boolean)
    (free:integer-address/deref <- copy 0:literal)
  }
  reply:chan:channel-address/deref)

(init-fn read
  (default-scope:scope-address <- new scope:literal 30:literal)
  (chan:channel-address <- next-input)
  { begin
    ; block if chan is empty
    (empty:boolean <- empty? chan:channel-address/deref)
    (break-unless empty:boolean)
    (free-address:integer-address <- get-address chan:channel-address/deref first-free:offset)
    (sleep free-address:integer-address/deref)
  }
  ; read result
  (full:integer-address <- get-address chan:channel-address/deref first-full:offset)
  (q:tagged-value-array-address <- get chan:channel-address/deref circular-buffer:offset)
  (result:tagged-value <- index q:tagged-value-array-address/deref full:integer-address/deref)
  ; increment full
  (full:integer-address/deref <- add full:integer-address/deref 1:literal)
  { begin
    ; wrap full around to 0 if necessary
    (qlen:integer <- length q:tagged-value-array-address/deref)
    (remaining?:boolean <- less-than full:integer-address/deref qlen:integer)
    (break-if remaining?:boolean)
    (full:integer-address/deref <- copy 0:literal)
  }
  (reply result:tagged-value chan:channel-address/deref))

; An empty channel has first-empty and first-full both at the same value.
(init-fn empty?
  (default-scope:scope-address <- new scope:literal 30:literal)
  ; return arg.first-full == arg.first-free
  (chan:channel <- next-input)
  (full:integer <- get chan:channel first-full:offset)
  (free:integer <- get chan:channel first-free:offset)
  (result:boolean <- equal full:integer free:integer)
  (reply result:boolean))

; A full channel has first-empty just before first-full, wasting one slot.
; (Other alternatives: https://en.wikipedia.org/wiki/Circular_buffer#Full_.2F_Empty_Buffer_Distinction)
(init-fn full?
  (default-scope:scope-address <- new scope:literal 30:literal)
  (chan:channel <- next-input)
  ; curr = chan.first-free + 1
  (curr:integer <- get chan:channel first-free:offset)
  (curr:integer <- add curr:integer 1:literal)
  { begin
    ; if (curr == chan.capacity) curr = 0
    (qlen:integer <- capacity chan:channel)
    (remaining?:boolean <- less-than curr:integer qlen:integer)
    (break-if remaining?:boolean)
    (curr:integer <- copy 0:literal)
  }
  ; return chan.first-full == curr
  (full:integer <- get chan:channel first-full:offset)
  (result:boolean <- equal full:integer curr:integer)
  (reply result:boolean))

(init-fn strcat
  (default-scope:scope-address <- new scope:literal 30:literal)
  ; result = new string[a.length + b.length]
  (a:string-address <- next-input)
  (a-len:integer <- length a:string-address/deref)
  (b:string-address <- next-input)
  (b-len:integer <- length b:string-address/deref)
  (result-len:integer <- add a-len:integer b-len:integer)
  (result:string-address <- new string:literal result-len:integer)
  ; copy a into result
  (result-idx:integer <- copy 0:literal)
  (i:integer <- copy 0:literal)
  { begin
    ; while (i < a.length)
    (a-done?:boolean <- less-than i:integer a-len:integer)
    (break-unless a-done?:boolean)
    ; result[result-idx] = a[i]
    (out:byte-address <- index-address result:string-address/deref result-idx:integer)
    (in:byte <- index a:string-address/deref i:integer)
    (out:byte-address/deref <- copy in:byte)
    ; ++i
    (i:integer <- add i:integer 1:literal)
    ; ++result-idx
    (result-idx:integer <- add result-idx:integer 1:literal)
    (loop)
  }
  ; copy b into result
  (i:integer <- copy 0:literal)
  { begin
    ; while (i < b.length)
    (b-done?:boolean <- less-than i:integer b-len:integer)
    (break-unless b-done?:boolean)
    ; result[result-idx] = a[i]
    (out:byte-address <- index-address result:string-address/deref result-idx:integer)
    (in:byte <- index b:string-address/deref i:integer)
    (out:byte-address/deref <- copy in:byte)
    ; ++i
    (i:integer <- add i:integer 1:literal)
    ; ++result-idx
    (result-idx:integer <- add result-idx:integer 1:literal)
    (loop)
  }
  (reply result:string-address))

; replace underscores in first with remaining args
(init-fn interpolate  ; string-address template, string-address a..
  (default-scope:scope-address <- new scope:literal 60:literal)
  (template:string-address <- next-input)
  ; compute result-len, space to allocate for result
  (tem-len:integer <- length template:string-address/deref)
  (result-len:integer <- copy tem-len:integer)
  { begin
    ; while arg received
    (a:string-address arg-received?:boolean <- next-input)
    (break-unless arg-received?:boolean)
;?     (print-primitive ("arg now: " literal))
;?     (print-primitive a:string-address)
;?     (print-primitive "@":literal)
;?     print-primitive:a:string-address/deref  ; todo: test (m on scoped array)
;?     (print-primitive "\n":literal)
;? ;?     (assert nil:literal)
    ; result-len = result-len + arg.length - 1 (for the 'underscore' being replaced)
    (a-len:integer <- length a:string-address/deref)
    (result-len:integer <- add result-len:integer a-len:integer)
    (result-len:integer <- subtract result-len:integer 1:literal)
;?     (print-primitive ("result-len now: " literal))
;?     (print-primitive result-len:integer)
;?     (print-primitive "\n":literal)
    (loop)
  }
  ; rewind to start of non-template args
  (_ <- input 0:literal)
  ; result = new string[result-len]
  (result:string-address <- new string:literal result-len:integer)
  ; repeatedly copy sections of template and 'holes' into result
  (result-idx:integer <- copy 0:literal)
  (i:integer <- copy 0:literal)
  { begin
    ; while arg received
    (a:string-address arg-received?:boolean <- next-input)
    (break-unless arg-received?:boolean)
    ; copy template into result until '_'
    { begin
      ; while (i < template.length)
      (tem-done?:boolean <- less-than i:integer tem-len:integer)
      (break-unless tem-done?:boolean 2:blocks)
      ; while template[i] != '_'
      (in:byte <- index template:string-address/deref i:integer)
      (underscore?:boolean <- equal in:byte ((#\_ literal)))
      (break-if underscore?:boolean)
      ; result[result-idx] = template[i]
      (out:byte-address <- index-address result:string-address/deref result-idx:integer)
      (out:byte-address/deref <- copy in:byte)
      ; ++i
      (i:integer <- add i:integer 1:literal)
      ; ++result-idx
      (result-idx:integer <- add result-idx:integer 1:literal)
      (loop)
    }
;?     (print-primitive ("i now: " literal))
;?     (print-primitive i:integer)
;?     (print-primitive "\n":literal)
    ; copy 'a' into result
    (j:integer <- copy 0:literal)
    { begin
      ; while (j < a.length)
      (arg-done?:boolean <- less-than j:integer a-len:integer)
      (break-unless arg-done?:boolean)
      ; result[result-idx] = a[j]
      (in:byte <- index a:string-address/deref j:integer)
;?       (print-primitive ("copying: " literal))
;?       (print-primitive in:byte)
;?       (print-primitive (" at: " literal))
;?       (print-primitive result-idx:integer)
;?       (print-primitive "\n":literal)
      (out:byte-address <- index-address result:string-address/deref result-idx:integer)
      (out:byte-address/deref <- copy in:byte)
      ; ++j
      (j:integer <- add j:integer 1:literal)
      ; ++result-idx
      (result-idx:integer <- add result-idx:integer 1:literal)
      (loop)
    }
    ; skip '_' in template
    (i:integer <- add i:integer 1:literal)
;?     (print-primitive ("i now: " literal))
;?     (print-primitive i:integer)
;?     (print-primitive "\n":literal)
    (loop)  ; interpolate next arg
  }
  ; done with holes; copy rest of template directly into result
  { begin
    ; while (i < template.length)
    (tem-done?:boolean <- less-than i:integer tem-len:integer)
    (break-unless tem-done?:boolean)
    ; result[result-idx] = template[i]
    (in:byte <- index template:string-address/deref i:integer)
;?     (print-primitive ("copying: " literal))
;?     (print-primitive in:byte)
;?     (print-primitive (" at: " literal))
;?     (print-primitive result-idx:integer)
;?     (print-primitive "\n":literal)
    (out:byte-address <- index-address result:string-address/deref result-idx:integer)
    (out:byte-address/deref <- copy in:byte)
    ; ++i
    (i:integer <- add i:integer 1:literal)
    ; ++result-idx
    (result-idx:integer <- add result-idx:integer 1:literal)
    (loop)
  }
  (reply result:string-address))

(init-fn find-next  ; string, character, index -> next index
  (s:string-address <- next-input)
  (needle:character <- next-input)  ; todo: unicode chars
  (idx:integer <- next-input)
  (len:integer <- length s:string-address/deref)
  { begin
    (eof?:boolean <- greater-or-equal idx:integer len:integer)
    (break-if eof?:boolean)
    (curr:byte <- index s:string-address/deref idx:integer)
    (found?:boolean <- equal curr:byte needle:character)
    (break-if found?:boolean)
    (idx:integer <- add idx:integer 1:literal)
    (loop)
  }
  (reply idx:integer))

(init-fn split  ; string, character -> string-address-array-address
  (default-scope:scope-address <- new scope:literal 30:literal)
  (s:string-address <- next-input)
  (delim:character <- next-input)  ; todo: unicode chars
  ; empty string? return empty array
  (len:integer <- length s:string-address/deref)
  { begin
    (empty?:boolean <- equal len:integer 0:literal)
    (break-unless empty?:boolean)
    (result:string-address-array-address <- new string-address-array:literal 0:literal)
    (reply result:string-address-array-address)
  }
  ; count #pieces we need room for
  (count:integer <- copy 1:literal)  ; n delimiters = n+1 pieces
  (idx:integer <- copy 0:literal)
  { begin
    (idx:integer <- find-next s:string-address delim:character idx:integer)
    (done?:boolean <- greater-or-equal idx:integer len:integer)
    (break-if done?:boolean)
    (idx:integer <- add idx:integer 1:literal)
    (count:integer <- add count:integer 1:literal)
    (loop)
  }
  ; allocate space
;?   (print-primitive (("alloc: " literal)))
;?   (print-primitive count:integer)
;?   (print-primitive (("\n" literal)))
  (result:string-address-array-address <- new string-address-array:literal count:integer)
  ; repeatedly copy slices (start..end) until delimiter into result[curr-result]
  (curr-result:integer <- copy 0:literal)
  (start:integer <- copy 0:literal)
  { begin
    ; while next delim exists
    (done?:boolean <- greater-or-equal start:integer len:integer)
    (break-if done?:boolean)
    (end:integer <- find-next s:string-address delim:character start:integer)
;?     (print-primitive (("i: " literal)))
;?     (print-primitive start:integer)
;?     (print-primitive (("-" literal)))
;?     (print-primitive end:integer)
;?     (print-primitive ((" => " literal)))
;?     (print-primitive curr-result:integer)
;?     (print-primitive (("\n" literal)))
    ; compute length of slice
    (slice-len:integer <- subtract end:integer start:integer)
    ; allocate result[curr-result]
    (dest:string-address-address <- index-address result:string-address-array-address/deref curr-result:integer)
    (dest:string-address-address/deref <- new string:literal slice-len:integer)
    ; copy start..end into result[curr-result]
    (src-idx:integer <- copy start:integer)
    (dest-idx:integer <- copy 0:literal)
    { begin
      (end-copy?:boolean <- greater-or-equal src-idx:integer end:integer)
      (break-if end-copy?:boolean)
      (src:character <- index s:string-address/deref src-idx:integer)
      (tmp:character-address <- index-address dest:string-address-address/deref/deref dest-idx:integer)
      (tmp:character-address/deref <- copy src:character)
      (src-idx:integer <- add src-idx:integer 1:literal)
      (dest-idx:integer <- add dest-idx:integer 1:literal)
      (loop)
    }
    ; slide over to next slice
    (start:integer <- add end:integer 1:literal)
    (curr-result:integer <- add curr-result:integer 1:literal)
    (loop)
  }
  (reply result:string-address-array-address)
)

)  ; section 100 for system software

;; load all provided files and start at 'main'
(reset)
(awhen (pos "--" argv)
  (map add-code:readfile (cut argv (+ it 1)))
;?   (= dump-trace* (obj whitelist '("run" "schedule" "add")))
;?   (freeze-functions)
;?   (prn function*!factorial)
  (run 'main)
  (if ($.current-charterm) ($.close-charterm))
  (prn "\nmemory: " memory*)
;?   (prn completed-routines*)
)