;;;; An assignment is all of the new value or none of it, never a seam.
;;;;
;;;; A condition can be signalled from inside the value being assigned — the
;;;; third element of an array literal, one field of a struct, the call whose
;;;; result the whole thing is. If a handler answers that by abandoning the
;;;; frame, the assignment never finishes, and the question this file asks is
;;;; what the variable holds afterwards. The answer has to be: exactly what it
;;;; held before. A variable that is half its old value and half its new one
;;;; is not a state any program can be written against.
;;;;
;;;; That is easy on a backend that builds a whole struct as one value and
;;;; stores it once, and it is not free on one that has no registers to hold a
;;;; struct in: there, the obvious lowering writes each element straight into
;;;; the destination as it is computed, and the destination is the variable.
;;;; So this file is here for the x86-64 backend, where every row below used
;;;; to come back wrong, and it runs on both so that the two keep answering
;;;; the same thing.
;;;;
;;;; Every row is a different *destination* — a global, a local, a field, an
;;;; array element, a place behind a pointer — crossed with a different
;;;; right-hand side: an array literal, a struct literal, a union case, a call
;;;; that returns the aggregate. The last row is the scalar, which was never
;;;; broken and is here so that a regression in one is not read as the other.

(defstruct Boom [why i32])

(defstruct Pair [a u32  b u32])
(defstruct Box  [tag u32  inner [4 u32]])
(defdata Shape [Nothing (Circle [r u32  fill u32])])

;;; Old values, distinct from every new one, so a survivor is recognisable
;;; and a seam is too.
(defonce colors [4 u32] [9 9 9 9])
(defonce pair   Pair    (Pair {.a 8 .b 8}))
(defonce box    Box     (Box {.tag 8 .inner [8 8 8 8]}))
(defonce shape  Shape   (Shape.Circle {.r 8 .fill 8}))
(defonce rows   [2 [4 u32]] [[9 9 9 9] [9 9 9 9]])
(defonce scalar u32 7)

(defonce skipped i64)
;;; Larger than any u32, so converting it signals rather than answering.
(defonce huge f64 1e30)

;;; The signal, and nothing else. It is a function so that it can stand in the
;;; middle of a literal, which is where the damage used to happen.
(defn blow [] u32
  (error (Boom {.why 1}))
  0)

;;; The same value, returned rather than written: an aggregate comes back
;;; through a pointer the caller supplies, and that pointer used to be the
;;; destination itself.
(defn wreck [] [4 u32]
  [(u32 1) (u32 1) (blow) (u32 1)])

(defn show-arr [xs [4 u32]] ()
  (print (at xs 0)) (print " ")
  (print (at xs 1)) (print " ")
  (print (at xs 2)) (print " ")
  (print (at xs 3)) (println ""))

;;; One frame per row, each offering `continue` — sand.flan's shape, and the
;;; one a game uses: abandon this frame, keep the program.
(defn global-literal [] ()
  (restart-case
    (set colors [(u32 1) (u32 1) (blow) (u32 1)])
    (continue [] (set skipped (+ skipped 1)))))

(defn global-call [] ()
  (restart-case
    (set colors (wreck))
    (continue [] (set skipped (+ skipped 1)))))

;;; The other way an assignment stops part-way, and the one the backend's cast
;;; rule is about. A float narrowed to an integer is range-checked, because the
;;; instruction answers a fixed number rather than an answer for a value out of
;;; range — so that conversion signals and the assignment has to be built aside
;;; first. Every other conversion is a move or a widen and can go nowhere,
;;; which is what keeps `[(u32 1) (u32 2)]` — how an array of this language's
;;; literals is usually spelled — costing nothing.
(defn cast-literal [] ()
  (restart-case
    (set colors [(u32 1) (u32 1) (u32 huge) (u32 1)])
    (continue [] (set skipped (+ skipped 1)))))

(defn global-struct [] ()
  (restart-case
    (set pair (Pair {.a 1 .b (blow)}))
    (continue [] (set skipped (+ skipped 1)))))

;;; A union case is the sharpest of the lot: the payload is wider than any one
;;; case, so the destination is zeroed before the fields are written. Building
;;; one in place therefore wiped the variable before it damaged it.
(defn global-case [] ()
  (restart-case
    (set shape (Shape.Circle {.r 1 .fill (blow)}))
    (continue [] (set skipped (+ skipped 1)))))

;;; A field of a struct, and an element of an array of arrays: two ways to
;;; name a destination that is not a whole variable.
(defn field-place [] ()
  (restart-case
    (set (.inner box) (wreck))
    (continue [] (set skipped (+ skipped 1)))))

(defn index-place [] ()
  (restart-case
    (set (at rows 1) [(u32 1) (u32 1) (blow) (u32 1)])
    (continue [] (set skipped (+ skipped 1)))))

;;; A place behind a pointer, which is how a callee writes into a caller's
;;; storage and how sand.flan reaches a grid it was handed.
(defn through-ptr [p (Ptr [4 u32])] ()
  (restart-case
    (set (deref p) (wreck))
    (continue [] (set skipped (+ skipped 1)))))

;;; A local, and a local inside a loop.
;;;
;;; The loop is the case a running program cannot see for itself: the second
;;; turn's slot still holds the first turn's value, and a seam between them is
;;; only visible to something reading the frame from outside — which is the
;;; break loop, so that half is asserted in test_dev.ml and not here. What
;;; this row is worth is the other direction: the loop still prints the whole
;;; first-turn value, so the copy the second turn now pays for has not broken
;;; the ordinary path.
(defn local-place [] ()
  (let [v [(u32 1) (u32 1) (u32 1) (u32 1)]]
    (restart-case
      (set v (wreck))
      (continue [] (set skipped (+ skipped 1))))
    (show-arr v)))

(defn local-loop [] ()
  (restart-case
    (dotimes [i 2]
      (let [v [(u32 (+ i 1)) (u32 (+ i 1)) (if (= i 0) (u32 5) (blow))
               (u32 (+ i 1))]]
        (show-arr v)))
    (continue [] (set skipped (+ skipped 1)))))

;;; The control. A scalar has always been whole, because its store is one
;;; instruction and it happens after the check for a transfer.
(defn scalar-place [] ()
  (restart-case
    (set scalar (blow))
    (continue [] (set skipped (+ skipped 1)))))

(defn main [] i32
  (let [spare [(u32 1) (u32 1) (u32 1) (u32 1)]]
    (handler-bind
      [(Boom [_c] (invoke-restart 'continue))
       (ArithError [_c] (invoke-restart 'continue))]

      (global-literal)  (show-arr colors)
      (global-call)     (show-arr colors)
      (cast-literal)    (show-arr colors)

      (global-struct)
      (print (.a pair)) (print " ") (print (.b pair)) (println "")

      (global-case)
      (match shape
        (Circle r fill) (do (print r) (print " ") (print fill) (println ""))
        Nothing (println "nothing"))

      (field-place)     (show-arr (.inner box))
      (index-place)     (show-arr (at rows 1))
      (through-ptr (addr spare)) (show-arr spare)

      (local-place)
      (local-loop)

      (scalar-place)    (print scalar) (println "")))

  (print "skipped ") (print skipped) (println "")
  0)