diff options
-rw-r--r-- | mu.arc | 59 | ||||
-rw-r--r-- | mu.arc.t | 172 |
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*) |