370 - unit tests for 'setm'

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