diff options
-rw-r--r-- | mu.arc | 11 | ||||
-rw-r--r-- | mu.arc.t | 43 |
2 files changed, 50 insertions, 4 deletions
diff --git a/mu.arc b/mu.arc index f5a0c5c0..7bb44b8c 100644 --- a/mu.arc +++ b/mu.arc @@ -121,6 +121,7 @@ integer-integer-pair (obj size 2 record t elems '(integer integer)) integer-point-pair (obj size 2 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 record t elems '(type location) fields '(type payload)) tagged-value-address (obj size 1 address t elem 'tagged-value) @@ -576,10 +577,12 @@ (trace "setm" loc ": setting " addr " to " val) (= memory*.addr val)) (do (assert (isa val 'record) "setm: non-record of size >1 @val") - (each (dest src) (zip (addrs addr n) - (rep val)) - (trace "setm" loc ": setting " dest " to " src) - (= memory*.dest src))))))) + (let addrs (addrs addr n) + (when (~is len.addrs (len rep.val)) + (die "writing to incorrect size @(tostring prn.val) => @loc")) + (each (dest src) (zip addrs rep.val) + (trace "setm" loc ": setting " dest " to " src) + (= memory*.dest src)))))))) (def addr (operand) (let loc absolutize.operand diff --git a/mu.arc.t b/mu.arc.t index 81e4244b..f4e0b401 100644 --- a/mu.arc.t +++ b/mu.arc.t @@ -838,6 +838,49 @@ (if (~iso (annotate 'record '(2 35 36)) (m '(3 integer-array-address deref))) (prn "F - 'm' supports indirect access to arrays")) +; unit tests for 'setm' helper +(reset) +(setm '(4 integer) 34) +(if (~is 34 memory*.4) + (prn "F - 'setm' writes primitives to memory")) +(setm '(3 integer-address) 4) +(if (~is 4 memory*.3) + (prn "F - 'setm' writes addresses to memory")) +(setm '(3 integer-address deref) 35) +(if (~is 35 memory*.4) + (prn "F - 'setm' redirects writes")) +(= memory*.2 3) +(setm '(2 integer-address-address deref deref) 36) +(if (~is 36 memory*.4) + (prn "F - 'setm' multiply redirects writes")) +(setm '(4 integer-integer-pair) (annotate 'record '(23 24))) +(if (or (~is memory*.4 23) + (~is memory*.5 24)) + (prn "F - 'setm' writes compound records")) +(assert (is memory*.6 nil)) +(setm '(7 integer-point-pair) (annotate 'record '(23 24 25))) +(if (or (~is memory*.7 23) + (~is memory*.8 24) + (~is memory*.9 25)) + (prn "F - 'setm' writes records with compound fields")) +(= routine* make-routine!foo) +(setm '(4 integer-point-pair) (annotate 'record '(33 34))) +(if (~posmatch "incorrect size" rep.routine*!error) + (prn "F - 'setm' writes checks size of target")) +(wipe routine*) +(setm '(3 integer-point-pair-address deref) (annotate 'record '(43 44 45))) +(if (or (~is memory*.4 43) + (~is memory*.5 44) + (~is memory*.6 45)) + (prn "F - 'setm' supports indirect writes to records")) +(setm '(2 integer-point-pair-address-address deref deref) (annotate 'record '(53 54 55))) +(if (or (~is memory*.4 53) + (~is memory*.5 54) + (~is memory*.6 55)) + (prn "F - 'setm' supports multiply indirect writes to records")) + +; back to top level tests + (reset) (new-trace "copy-record") (add-code |