409 - new arg representation

Tests only passing at level 9:
  $ arc load.arc 9 mu.arc.t

2 files changed, 157 insertions, 74 deletions

diff --git a/mu.arc b/mu.arc
index b578db06..d302b462 100644
--- a/mu.arc
+++ b/mu.arc
@@ -302,16 +302,16 @@
   (~is '_ operand))
 
 (mac v (operand)  ; for value
-  `(,operand 0))
+  `((,operand 0) 0))
 
 (def metadata (operand)
   cdr.operand)
 
 (def ty (operand)
-  operand.1)  ; assume type is always first bit of metadata, and it's always present
+  (cdr operand.0))
 
 (def typeinfo (operand)
-  (or (types* ty.operand)
+  (or (types* ty.operand.0)
       (err "unknown type @(tostring prn.operand)")))
 
 ($:require "charterm/main.rkt")
@@ -582,7 +582,7 @@
 
 (def m (loc)  ; read memory, respecting metadata
   (point return
-    (if (in ty.loc 'literal 'offset)
+    (if (in ty.loc.0 'literal 'offset)
       (return v.loc))
     (when (is v.loc 'default-scope)
       (return rep.routine*!call-stack.0!default-scope))
@@ -630,14 +630,18 @@
 
 (def typeof (operand)
   (let loc absolutize.operand
-    (while (pos 'deref metadata.loc)
+    (while (pos '(deref) metadata.loc)
       (zap deref loc))
-    ty.loc))
+    ty.loc.0))
 
 (def addr (operand)
+;?   (prn 211 " " operand)
   (let loc absolutize.operand
-    (while (pos 'deref metadata.loc)
+;?     (prn 212 " " loc)
+    (while (pos '(deref) metadata.loc)
+;?       (prn 213 " " loc)
       (zap deref loc))
+;?     (prn 214 " " loc)
     v.loc))
 
 (def addrs (n sz)
@@ -649,14 +653,14 @@
 (def canonize (operand)
   (ret operand
     (zap absolutize operand)
-    (while (pos 'deref metadata.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 ,@(cut operand 2)))
+        (m `((,v.operand integer) ,@metadata.operand))
       :else
         (err "can't take len of non-array @operand")))
 
@@ -665,12 +669,15 @@
   (point return
   (when (acons x)
     (zap canonize x)
+;?     (tr "sizeof 1 @x")
     (when typeinfo.x!array
+;?       (tr "sizeof 2")
       (return (+ 1 (* array-len.x (sizeof typeinfo.x!elem))))))
-  (let type (if (and acons.x (pos 'deref metadata.x))
+;?   (tr "sizeof 3")
+  (let type (if (and acons.x (pos '(deref) metadata.x))
                   typeinfo.x!elem  ; deref pointer
                 acons.x
-                  ty.x
+                  ty.x.0
                 :else  ; naked type
                   x)
     (assert types*.type "sizeof: no such type @type")
@@ -687,21 +694,24 @@
 (def absolutize (operand)
   (if (no routine*)
         operand
-      (pos 'global metadata.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) ,@metadata.operand global)
+            `((,(+ 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 (pos '(deref) metadata.operand))
   (assert typeinfo.operand!address)
-  (apply list (memory* v.operand)
-              typeinfo.operand!elem
-              (drop-one 'deref (cut operand 2))))
+  (cons `(,(memory* v.operand) ,typeinfo.operand!elem)
+        (drop-one '(deref) metadata.operand)))
 
 (def drop-one (f x)
   (when acons.x  ; proper lists only
@@ -871,7 +881,7 @@
               (assert basetype "no such type @args.0")
               (trace "cn0" "field-access " field)
               ; todo: need to rename args.0 as well?
-              (when (pos 'deref (metadata args.0))
+              (when (pos '(deref) (metadata args.0))
                 (trace "cn0" "field-access deref")
                 (assert basetype!address "@args.0 requests deref, but it's not an address of a record")
                 (= basetype (types* basetype!elem)))
@@ -1359,6 +1369,19 @@
 ;?     (= function*.name (convert-names:convert-labels:convert-braces:prn:insert-code body)))
     (= function*.name (convert-names:convert-labels:convert-braces:insert-code body name))))
 
+(def tokenize-arg (arg)
+  (if (is arg '<-)
+    arg
+    (map [map [fromstring _ (read)] _]
+         (map [tokens _ #\:]
+              (tokens string.arg #\/)))))
+
+(def tokenize-args (instrs)
+  (map [if atom._
+         _
+         (map tokenize-arg _)]
+       instrs))
+
 ;; test helpers
 
 (def memory-contains (addr value)
diff --git a/mu.arc.t b/mu.arc.t
index 9124f98a..dabd522f 100644
--- a/mu.arc.t
+++ b/mu.arc.t
@@ -2789,6 +2789,8 @@
 
 )  ; section 100
 
+(section 9
+
 ;; Separating concerns
 ;
 ; Lightweight tools can also operate on quoted lists of statements surrounded
@@ -3184,6 +3186,8 @@
           '(((2 integer) <- copy (0 literal))))
   (prn "F - 'def!' clears all previous clauses"))
 
+)  ; section 9
+
 ;; ---
 
 (section 100  ; string utilities
@@ -3297,73 +3301,123 @@
 
 ;; unit tests for various helpers
 
+; tokenize-args
+(prn "tokenize-args")
+(assert:iso '((a b) (c d))
+            (tokenize-arg 'a:b/c:d))
+(assert:iso '((a b) (1 d))
+            (tokenize-arg 'a:b/1:d))
+(assert:iso '<-
+            (tokenize-arg '<-))
+
+(assert:iso '((((default-scope scope-address)) <- ((new)) ((scope literal)) ((30 literal)))
+              foo)
+            (tokenize-args
+              '((default-scope:scope-address <- new scope:literal 30:literal)
+                foo)))
+
 ; absolutize
+(prn "absolutize")
 (reset)
-(if (~iso '(4 integer) (absolutize '(4 integer)))
+(if (~iso '((4 integer)) (absolutize '((4 integer))))
   (prn "F - 'absolutize' works without routine"))
 (= routine* make-routine!foo)
-(if (~iso '(4 integer) (absolutize '(4 integer)))
+(if (~iso '((4 integer)) (absolutize '((4 integer))))
   (prn "F - 'absolutize' works without default-scope"))
 (= rep.routine*!call-stack.0!default-scope 10)
 (= memory*.10 5)  ; bounds check for default-scope
-(if (~iso '(14 integer global) (absolutize '(4 integer)))
+(if (~iso '((14 integer) (global))
+          (absolutize '((4 integer))))
   (prn "F - 'absolutize' works with default-scope"))
-(absolutize '(5 integer))
+(absolutize '((5 integer)))
 (if (~posmatch "no room" rep.routine*!error)
   (prn "F - 'absolutize' checks against default-scope bounds"))
 
 ; addr
+(prn "addr")
 (reset)
 (= routine* nil)
-(if (~is 4 (addr '(4 integer)))
+;? (prn 111)
+(if (~is 4 (addr '((4 integer))))
   (prn "F - directly addressed operands are their own address"))
-(if (~is 4 (addr '(4 integer-address)))
+;? (quit)
+(if (~is 4 (addr '((4 integer-address))))
   (prn "F - directly addressed operands are their own address - 2"))
-(if (~is 4 (addr '(4 literal)))
+(if (~is 4 (addr '((4 literal))))
   (prn "F - 'addr' doesn't understand literals"))
+;? (prn 201)
 (= memory*.4 23)
-(if (~is 23 (addr '(4 integer-address deref)))
+;? (prn 202)
+(if (~is 23 (addr '((4 integer-address) (deref))))
   (prn "F - 'addr' works with indirectly-addressed 'deref'"))
+;? (quit)
 (= memory*.3 4)
-(if (~is 23 (addr '(3 integer-address-address deref deref)))
+(if (~is 23 (addr '((3 integer-address-address) (deref) (deref))))
   (prn "F - 'addr' works with multiple 'deref'"))
 
 (= routine* make-routine!foo)
-(if (~is 4 (addr '(4 integer)))
+(if (~is 4 (addr '((4 integer))))
   (prn "F - directly addressed operands are their own address inside routines"))
-(if (~is 4 (addr '(4 integer-address)))
+(if (~is 4 (addr '((4 integer-address))))
   (prn "F - directly addressed operands are their own address inside routines - 2"))
-(if (~is 4 (addr '(4 literal)))
+(if (~is 4 (addr '((4 literal))))
   (prn "F - 'addr' doesn't understand literals inside routines"))
 (= memory*.4 23)
-(if (~is 23 (addr '(4 integer-address deref)))
+(if (~is 23 (addr '((4 integer-address) (deref))))
   (prn "F - 'addr' works with indirectly-addressed 'deref' inside routines"))
 
+;? (prn 301)
 (= rep.routine*!call-stack.0!default-scope 10)
+;? (prn 302)
 (= memory*.10 5)  ; bounds check for default-scope
-(if (~is 14 (addr '(4 integer)))
+;? (prn 303)
+(if (~is 14 (addr '((4 integer))))
   (prn "F - directly addressed operands in routines add default-scope"))
-(if (~is 14 (addr '(4 integer-address)))
+;? (quit)
+(if (~is 14 (addr '((4 integer-address))))
   (prn "F - directly addressed operands in routines add default-scope - 2"))
-(if (~is 14 (addr '(4 literal)))
+(if (~is 14 (addr '((4 literal))))
   (prn "F - 'addr' doesn't understand literals"))
 (= memory*.14 23)
-(if (~is 23 (addr '(4 integer-address deref)))
+(if (~is 23 (addr '((4 integer-address) (deref))))
   (prn "F - 'addr' adds default-scope before 'deref', not after"))
+;? (quit)
 
 ; deref
+(prn "deref")
 (reset)
 (= memory*.3 4)
-(if (~iso '(4 integer) (deref '(3 integer-address deref)))
+(if (~iso '((4 integer))
+          (deref '((3 integer-address)
+                   (deref))))
   (prn "F - 'deref' handles simple addresses"))
-(if (~iso '(4 integer deref) (deref '(3 integer-address deref deref)))
+(if (~iso '((4 integer) (deref))
+          (deref '((3 integer-address)
+                   (deref)
+                   (deref))))
   (prn "F - 'deref' deletes just one deref"))
 (= memory*.4 5)
-(if (~iso '(5 integer) (deref:deref '(3 integer-address-address deref deref)))
+(if (~iso '((5 integer))
+          (deref:deref '((3 integer-address-address)
+                         (deref)
+                         (deref))))
   (prn "F - 'deref' can be chained"))
 
+; array-len
+(prn "array-len")
+(reset)
+(= memory*.35 4)
+(if (~is 4 (array-len '((35 integer-boolean-pair-array))))
+  (prn "F - 'array-len'"))
+(= memory*.34 35)
+(if (~is 4 (array-len '((34 integer-boolean-pair-array-address) (deref))))
+  (prn "F - 'array-len'"))
+;? (quit)
+
 ; sizeof
+(prn "sizeof")
 (reset)
+;? (prn 401)
 (if (~is 1 sizeof!integer)
   (prn "F - 'sizeof' works on primitives"))
 (if (~is 1 sizeof!integer-address)
@@ -3373,126 +3427,132 @@
 (if (~is 3 sizeof!integer-point-pair)
   (prn "F - 'sizeof' works on records with record fields"))
 
-(if (~is 1 (sizeof '(34 integer)))
+;? (prn 410)
+(if (~is 1 (sizeof '((34 integer))))
   (prn "F - 'sizeof' works on primitive operands"))
-(if (~is 1 (sizeof '(34 integer-address)))
+(if (~is 1 (sizeof '((34 integer-address))))
   (prn "F - 'sizeof' works on address operands"))
-(if (~is 2 (sizeof '(34 integer-boolean-pair)))
+(if (~is 2 (sizeof '((34 integer-boolean-pair))))
   (prn "F - 'sizeof' works on record operands"))
-(if (~is 3 (sizeof '(34 integer-point-pair)))
+(if (~is 3 (sizeof '((34 integer-point-pair))))
   (prn "F - 'sizeof' works on record operands with record fields"))
-(if (~is 2 (sizeof '(34 integer-boolean-pair-address deref)))
+(if (~is 2 (sizeof '((34 integer-boolean-pair-address) (deref))))
   (prn "F - 'sizeof' works on pointers to records"))
 (= memory*.35 4)  ; size of array
 (= memory*.34 35)
-;? (= dump-trace* (obj whitelist '("sizeof")))
-(if (~is 9 (sizeof '(34 integer-boolean-pair-array-address deref)))
+;? (= dump-trace* (obj whitelist '("sizeof" "array-len")))
+(if (~is 9 (sizeof '((34 integer-boolean-pair-array-address) (deref))))
   (prn "F - 'sizeof' works on pointers to arrays"))
 ;? (quit)
 
+;? (prn 420)
 (= memory*.4 23)
-(if (~is 24 (sizeof '(4 integer-array)))
+(if (~is 24 (sizeof '((4 integer-array))))
   (prn "F - 'sizeof' reads array lengths from memory"))
 (= memory*.3 4)
-(if (~is 24 (sizeof '(3 integer-array-address deref)))
+(if (~is 24 (sizeof '((3 integer-array-address) (deref))))
   (prn "F - 'sizeof' handles pointers to arrays"))
 (= memory*.14 34)
 (= routine* make-routine!foo)
-(if (~is 24 (sizeof '(4 integer-array)))
+(if (~is 24 (sizeof '((4 integer-array))))
   (prn "F - 'sizeof' reads array lengths from memory inside routines"))
 (= rep.routine*!call-stack.0!default-scope 10)
 (= memory*.10 5)  ; bounds check for default-scope
-(if (~is 35 (sizeof '(4 integer-array)))
+(if (~is 35 (sizeof '((4 integer-array))))
   (prn "F - 'sizeof' reads array lengths from memory using default-scope"))
 (= memory*.35 4)  ; size of array
 (= memory*.14 35)
 ;? (= dump-trace* (obj whitelist '("sizeof")))
 (aif rep.routine*!error (prn "error - " it))
-(if (~is 9 (sizeof '(4 integer-boolean-pair-array-address deref)))
+(if (~is 9 (sizeof '((4 integer-boolean-pair-array-address) (deref))))
   (prn "F - 'sizeof' works on pointers to arrays using default-scope"))
 ;? (quit)
 
 ; m
+(prn "m")
 (reset)
-(if (~is 4 (m '(4 literal)))
+(if (~is 4 (m '((4 literal))))
   (prn "F - 'm' avoids reading memory for literals"))
-(if (~is 4 (m '(4 offset)))
+(if (~is 4 (m '((4 offset))))
   (prn "F - 'm' avoids reading memory for offsets"))
 (= memory*.4 34)
-(if (~is 34 (m '(4 integer)))
+(if (~is 34 (m '((4 integer))))
   (prn "F - 'm' reads memory for simple types"))
 (= memory*.3 4)
-(if (~is 34 (m '(3 integer-address deref)))
+(if (~is 34 (m '((3 integer-address) (deref))))
   (prn "F - 'm' redirects addresses"))
 (= memory*.2 3)
-(if (~is 34 (m '(2 integer-address-address deref deref)))
+(if (~is 34 (m '((2 integer-address-address) (deref) (deref))))
   (prn "F - 'm' multiply redirects addresses"))
-(if (~iso (annotate 'record '(34 nil)) (m '(4 integer-boolean-pair)))
+(if (~iso (annotate 'record '(34 nil)) (m '((4 integer-boolean-pair))))
   (prn "F - 'm' supports compound records"))
 (= memory*.5 35)
 (= memory*.6 36)
-(if (~iso (annotate 'record '(34 35 36)) (m '(4 integer-point-pair)))
+(if (~iso (annotate 'record '(34 35 36)) (m '((4 integer-point-pair))))
   (prn "F - 'm' supports records with compound fields"))
-(if (~iso (annotate 'record '(34 35 36)) (m '(3 integer-point-pair-address deref)))
+(if (~iso (annotate 'record '(34 35 36)) (m '((3 integer-point-pair-address) (deref))))
   (prn "F - 'm' supports indirect access to records"))
 (= memory*.4 2)
-(if (~iso (annotate 'record '(2 35 36)) (m '(4 integer-array)))
+(if (~iso (annotate 'record '(2 35 36)) (m '((4 integer-array))))
   (prn "F - 'm' supports access to arrays"))
-(if (~iso (annotate 'record '(2 35 36)) (m '(3 integer-array-address deref)))
+(if (~iso (annotate 'record '(2 35 36)) (m '((3 integer-array-address) (deref))))
   (prn "F - 'm' supports indirect access to arrays"))
 
 ; setm
+(prn "setm")
 (reset)
-(setm '(4 integer) 34)
+(setm '((4 integer)) 34)
 (if (~is 34 memory*.4)
   (prn "F - 'setm' writes primitives to memory"))
-(setm '(3 integer-address) 4)
+(setm '((3 integer-address)) 4)
 (if (~is 4 memory*.3)
   (prn "F - 'setm' writes addresses to memory"))
-(setm '(3 integer-address deref) 35)
+(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)
+(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)))
+;? (prn 505)
+(setm '((4 integer-integer-pair)) (annotate 'record '(23 24)))
 (if (~memory-contains 4 '(23 24))
   (prn "F - 'setm' writes compound records"))
 (assert (is memory*.7 nil))
-(setm '(7 integer-point-pair) (annotate 'record '(23 24 25)))
+;? (prn 506)
+(setm '((7 integer-point-pair)) (annotate 'record '(23 24 25)))
 (if (~memory-contains 7 '(23 24 25))
   (prn "F - 'setm' writes records with compound fields"))
 (= routine* make-routine!foo)
-(setm '(4 integer-point-pair) (annotate 'record '(33 34)))
+(setm '((4 integer-point-pair)) (annotate 'record '(33 34)))
 (if (~posmatch "incorrect size" rep.routine*!error)
   (prn "F - 'setm' checks size of target"))
 (wipe routine*)
-(setm '(3 integer-point-pair-address deref) (annotate 'record '(43 44 45)))
+(setm '((3 integer-point-pair-address) (deref)) (annotate 'record '(43 44 45)))
 (if (~memory-contains 4 '(43 44 45))
   (prn "F - 'setm' supports indirect writes to records"))
-(setm '(2 integer-point-pair-address-address deref deref) (annotate 'record '(53 54 55)))
+(setm '((2 integer-point-pair-address-address) (deref) (deref)) (annotate 'record '(53 54 55)))
 (if (~memory-contains 4 '(53 54 55))
   (prn "F - 'setm' supports multiply indirect writes to records"))
-(setm '(4 integer-array) (annotate 'record '(2 31 32)))
+(setm '((4 integer-array)) (annotate 'record '(2 31 32)))
 (if (~memory-contains 4 '(2 31 32))
   (prn "F - 'setm' writes arrays"))
-(setm '(3 integer-array-address deref) (annotate 'record '(2 41 42)))
+(setm '((3 integer-array-address) (deref)) (annotate 'record '(2 41 42)))
 (if (~memory-contains 4 '(2 41 42))
   (prn "F - 'setm' supports indirect writes to arrays"))
 (= routine* make-routine!foo)
-(setm '(4 integer-array) (annotate 'record '(2 31 32 33)))
+(setm '((4 integer-array)) (annotate 'record '(2 31 32 33)))
 (if (~posmatch "invalid array" rep.routine*!error)
   (prn "F - 'setm' checks that array written is well-formed"))
 (= routine* make-routine!foo)
 ;? (prn 111)
 ;? (= dump-trace* (obj whitelist '("sizeof" "setm")))
-(setm '(4 integer-boolean-pair-array) (annotate 'record '(2 31 nil 32 nil 33)))
+(setm '((4 integer-boolean-pair-array)) (annotate 'record '(2 31 nil 32 nil 33)))
 (if (~posmatch "invalid array" rep.routine*!error)
   (prn "F - 'setm' checks that array of records is well-formed"))
 (= routine* make-routine!foo)
 ;? (prn 222)
-(setm '(4 integer-boolean-pair-array) (annotate 'record '(2 31 nil 32 nil)))
+(setm '((4 integer-boolean-pair-array)) (annotate 'record '(2 31 nil 32 nil)))
 (if (posmatch "invalid array" rep.routine*!error)
   (prn "F - 'setm' checks that array of records is well-formed - 2"))
 (wipe routine*)