199 - fix 'index' like 'get' in 190

2 files changed, 101 insertions, 33 deletions

diff --git a/mu.arc b/mu.arc
index 7746d668..b7eeb7ab 100644
--- a/mu.arc
+++ b/mu.arc
@@ -41,6 +41,7 @@
               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-address (obj size 1  address t  elem 'integer)  ; pointer to int
               ; records consist of a series of elems, corresponding to a list of types
               integer-boolean-pair (obj size 2  record t  elems '(integer boolean))
@@ -227,21 +228,26 @@
     (list (+ base (apply + (map sz (firstn idx basetype!elems))))
           basetype!elems.idx)))
 
-(def array-ref-addr (operand idx)
-  (assert typeinfo.operand!array "aref-addr: not an array @operand")
-  (unless (< -1 idx (array-len operand))
-    (die "aref-addr: out of bounds index @idx for @operand of size @array-len.operand"))
-  (withs (elem  typeinfo.operand!elem
-          offset  (+ 1 (* idx sz.elem)))
-    (+ v.operand offset)))
-
-(def array-ref (operand idx)
-  (assert typeinfo.operand!array "aref: not an array @operand")
-  (unless (< -1 idx (array-len operand))
-    (die "aref: out of bounds index @idx for @operand of size @array-len.operand"))
-  (withs (elem  typeinfo.operand!elem
-          offset  (+ 1 (* idx sz.elem)))
-    (m `(,(+ v.operand offset) ,elem))))
+(def array-info (operand offset)
+  (with (base  addr.operand
+         basetype  typeinfo.operand
+         idx  (m offset))
+;?     (prn operand ": " base " " basetype)
+    (when (pos 'deref metadata.operand)
+      (assert basetype!address "@operand requests deref, but it's not an address of an array")
+      (= basetype (types* basetype!elem))
+;?       (prn "=> " basetype)
+      )
+;?     (prn "AAA")
+    (assert basetype!array "index on non-array @operand")
+;?     (prn "AAA " idx)
+    (unless (< -1 idx array-len.operand)
+      (die "@idx is out of bounds of array @operand"))
+;?     (prn "AAA")
+    (list (+ base
+             1  ; for array size
+             (* idx (sz basetype!elem)))
+          basetype!elem)))
 
 ; data structure: routine
 ; runtime state for a serial thread of execution
@@ -403,29 +409,18 @@
                   (m arg.0)
                 get
                   (let (addr type)  (record-info arg.0 arg.1)
+;?                     (prn addr " " type)
                     (m `(,addr ,type global)))
                 get-address
                   (let (addr _)  (record-info arg.0 arg.1)
                     addr)
                 index
-                  (with (base arg.0  ; integer (non-symbol) memory location including metadata
-                         idx (m arg.1))
-;?                     (prn "processing index: @base @idx")
-                    (when typeinfo.base!address
-                      (assert (pos 'deref metadata.base) "index: array has deref but isn't an address @base")
-                      (= base (list (memory* v.base) typeinfo.base!elem)))
-;?                     (prn "after maybe deref: @base @idx")
-;?                     (prn Memory-in-use-until ": " memory*)
-                    (assert typeinfo.base!array "index on invalid type @arg.0 => @base")
-                    (array-ref base idx))
+                  (let (addr type)  (array-info arg.0 arg.1)
+;?                     (prn arg.0 " " arg.1 " => " addr " " type)
+                    (m `(,addr ,type global)))
                 index-address
-                  (with (base arg.0
-                         idx (m arg.1))
-                    (when typeinfo.base!address
-                      (assert (pos 'deref metadata.base) "index-addr: array has deref but isn't an address @base")
-                      (= base (list (memory* v.base) typeinfo.base!elem)))
-                    (assert typeinfo.base!array "index-addr on invalid type @arg.0 => @base")
-                    (array-ref-addr base idx))
+                  (let (addr _)  (array-info arg.0 arg.1)
+                    addr)
                 new
                   (let type (v arg.0)
                     (assert (is 'literal (ty arg.0)) "new: second arg @arg.0 must be literal")
diff --git a/mu.arc.t b/mu.arc.t
index 5da21e91..d123b4e1 100644
--- a/mu.arc.t
+++ b/mu.arc.t
@@ -372,7 +372,7 @@
 (new-trace "indirect-addressing")
 (add-fns
   '((main
-      ((1 integer-address) <- copy (2 literal))
+      ((1 integer-address) <- copy (2 literal))  ; unsafe; can't do this in general
       ((2 integer) <- copy (34 literal))
       ((3 integer) <- copy (1 integer-address deref)))))
 (run 'main)
@@ -488,6 +488,7 @@
 ;? (prn memory*)
 (if (~iso memory* (obj 1 2  2 23 3 nil  4 24 5 t  6 24 7 t))
   (prn "F - 'index' accesses indices of arrays"))
+;? (quit)
 
 (reset)
 (new-trace "index-direct")
@@ -504,6 +505,27 @@
 ;? (prn memory*)
 (if (~iso memory* (obj 1 2  2 23 3 nil  4 24 5 t  6 1  7 24 8 t))
   (prn "F - 'index' accesses indices of arrays"))
+;? (quit)
+
+(reset)
+(new-trace "index-indirect")
+(add-fns
+  '((main
+      ((1 integer) <- copy (2 literal))
+      ((2 integer) <- copy (23 literal))
+      ((3 boolean) <- copy (nil literal))
+      ((4 integer) <- copy (24 literal))
+      ((5 boolean) <- copy (t literal))
+      ((6 integer) <- copy (1 literal))
+      ((7 integer-boolean-pair-array-address) <- copy (1 literal))
+      ((8 integer-boolean-pair) <- index (7 integer-boolean-pair-array-address deref) (6 integer)))))
+;? (= dump-trace* (obj blacklist '("sz" "m" "setm" "addr" "cvt0" "cvt1")))
+;? (set dump-trace*)
+(run 'main)
+;? (prn memory*)
+(if (~iso memory* (obj 1 2  2 23 3 nil  4 24 5 t  6 1  7 1  8 24 9 t))
+  (prn "F - 'index' accesses indices of array address"))
+;? (quit)
 
 (reset)
 (new-trace "index-address")
@@ -521,6 +543,23 @@
 (if (~iso memory* (obj 1 2  2 23 3 nil  4 24 5 t  6 1  7 4))
   (prn "F - 'index-address' returns addresses of indices of arrays"))
 
+(reset)
+(new-trace "index-address-indirect")
+(add-fns
+  '((main
+      ((1 integer) <- copy (2 literal))
+      ((2 integer) <- copy (23 literal))
+      ((3 boolean) <- copy (nil literal))
+      ((4 integer) <- copy (24 literal))
+      ((5 boolean) <- copy (t literal))
+      ((6 integer) <- copy (1 literal))
+      ((7 integer-boolean-pair-array-address) <- copy (1 literal))
+      ((8 integer-boolean-pair-address) <- index-address (7 integer-boolean-pair-array-address deref) (6 integer)))))
+(run 'main)
+;? (prn memory*)
+(if (~iso memory* (obj 1 2  2 23 3 nil  4 24 5 t  6 1  7 1  8 4))
+  (prn "F - 'index-address' returns addresses of indices of array addresses"))
+
 ; Array values know their length. Record lengths are saved in the types table.
 
 (reset)
@@ -1492,6 +1531,40 @@
     (prn "F - default-scope checks bounds")))
 
 (reset)
+(new-trace "default-scope-and-get-indirect")
+(add-fns
+  '((main
+      ((default-scope scope-address) <- new (scope literal) (5 literal))
+      ((1 integer-boolean-pair-address) <- new (integer-boolean-pair literal))
+      ((2 integer-address) <- get-address (1 integer-boolean-pair-address deref) (0 offset))
+      ((2 integer-address deref) <- copy (34 literal))
+      ((3 integer global) <- get (1 integer-boolean-pair-address deref) (0 offset)))))
+;? (= dump-trace* (obj blacklist '("sz" "m" "setm" "addr" "cvt0" "cvt1")))
+(run 'main)
+;? (prn memory*)
+;? (prn (as cons completed-routines*))
+(if (~is 34 memory*.3)
+  (prn "F - indirect 'get' works in the presence of default-scope"))
+;? (quit)
+
+(reset)
+(new-trace "default-scope-and-index-indirect")
+(add-fns
+  '((main
+      ((default-scope scope-address) <- new (scope literal) (5 literal))
+      ((1 integer-array-address) <- new (integer-array literal) (4 literal))
+      ((2 integer-address) <- index-address (1 integer-array-address deref) (2 offset))
+      ((2 integer-address deref) <- copy (34 literal))
+      ((3 integer global) <- index (1 integer-array-address deref) (2 offset)))))
+;? (= dump-trace* (obj blacklist '("sz" "m" "setm" "addr" "cvt0" "cvt1")))
+(run 'main)
+;? (prn memory*)
+;? (prn (as cons completed-routines*))
+(if (~is 34 memory*.3)
+  (prn "F - indirect 'index' works in the presence of default-scope"))
+;? (quit)
+
+(reset)
 (new-trace "convert-names-default-scope")
 (if (~iso (convert-names
             '(((x integer) <- copy (4 literal))