Beginnings of using word tables

doc/Emitting.markdown

@@ -168,6 +168,66 @@ Copy command: immediate -> word
     = .data
     = .space position 2
 
+Copy command: word -> word
+
+    | reserve word position1
+    | reserve word position2
+    | routine main {
+    |     copy position1 position2
+    | }
+    = main:
+    =   lda position1
+    =   sta position2
+    =   lda position1+1
+    =   sta position2+1
+    =   rts
+    = 
+    = .data
+    = .space position1 2
+    = .space position2 2
+
+Copy command: word -> word indexed
+
+    | reserve word loc
+    | reserve word[4] locs
+    | routine main {
+    |     ldy #0
+    |     copy loc locs, y
+    | }
+    = main:
+    =   ldy #0
+    =   lda loc
+    =   sta locs_lo, y
+    =   lda loc+1
+    =   sta locs_hi, y
+    =   rts
+    = 
+    = .data
+    = .space loc 2
+    = .space locs_lo 4
+    = .space locs_hi 4
+
+Copy command: word INDEXED -> word
+
+    | reserve word loc
+    | reserve word[4] locs
+    | routine main {
+    |     ldx #0
+    |     copy locs, x loc
+    | }
+    = main:
+    =   ldx #0
+    =   lda locs_lo, x
+    =   sta loc
+    =   lda locs_hi, x
+    =   sta loc+1
+    =   rts
+    = 
+    = .data
+    = .space loc 2
+    = .space locs_lo 4
+    = .space locs_hi 4
+
 `main` is always emitted first.
 
     | reserve word position 

eg/game.60p

@@ -26,8 +26,7 @@ reserve word delta
 reserve byte value
 reserve word compare_target
 
-reserve byte[16] actor_pos_hi
+reserve word[16] actor_pos
-reserve byte[16] actor_pos_lo
 
 reserve vector dispatch_state
 reserve vector dispatch_logic
@@ -141,12 +140,13 @@ routine init_game {
     ldy #0
     repeat bne {
         lda #$04
-        sta actor_pos_hi, y
+        // *** this is broken ***
+        sta >actor_pos, y
         tya
         clc
         asl .a
         asl .a
-        sta actor_pos_lo, y
+        sta <actor_pos, y
         iny
         cpy #8
     }
@@ -214,10 +214,7 @@ routine state_play_game {
     repeat bne {
         stx save_x
 
-        lda actor_pos_hi, x
+        copy actor_pos, x position
-        sta >position
-        lda actor_pos_lo, x
-        sta <position
 
         cpx #0
         if beq {
@@ -228,10 +225,8 @@ routine state_play_game {
         jsr indirect_jsr_logic
 
         ldx save_x
-        lda >position
+        copy position actor_pos, x
-        sta actor_pos_hi, x
+
-        lda <position
-        sta actor_pos_lo, x
         inx
         cpx #8
     }

src/SixtyPical/Checker.hs

@@ -31,8 +31,8 @@ noIndexedAccessOfNonTables p@(Program decls routines) =
     where
         checkInstr j@(COPY _ (Indexed (NamedLocation sz g) reg)) =
             case lookupDecl p g of
-                Just (Assign _ (Table Byte _) _) -> j
+                Just (Assign _ (Table _ _) _) -> j
-                Just (Reserve _ (Table Byte _) _) -> j
+                Just (Reserve _ (Table _ _) _) -> j
                 Just _ -> (COPY A A)
                 Nothing -> (COPY A A)
         checkInstr other = other

src/SixtyPical/Emitter.hs

@@ -40,6 +40,10 @@ emitDecl p (Reserve name (Table Byte size) vals) =
         showList [val] = show val
         showList (val:vals) = (show val) ++ ", " ++ (showList vals)
 
+emitDecl p (Reserve name (Table Word size) []) =
+    ".space " ++ name ++ "_lo " ++ (show size) ++ "\n" ++
+    ".space " ++ name ++ "_hi " ++ (show size)
+
 emitDecl p (Reserve name typ [])
     | typ == Byte = ".space " ++ name ++ " 1"
     | typ == Word = ".space " ++ name ++ " 2"
@@ -98,6 +102,28 @@ emitInstr p r (COPY A (Indexed (NamedLocation (Just (Table Byte _)) label) Y)) =
 emitInstr p r (COPY (Indexed (NamedLocation (Just (Table Byte _)) label) X) A) = "lda " ++ label ++ ", x"
 emitInstr p r (COPY (Indexed (NamedLocation (Just (Table Byte _)) label) Y) A) = "lda " ++ label ++ ", y"
 
+emitInstr p r (COPY (NamedLocation (Just st1) src) (Indexed (NamedLocation (Just (Table st2 _)) dst) reg))
+  | (st1 == Vector && st2 == Vector) || (st1 == Word && st2 == Word) =
+    "lda " ++ src ++ "\n" ++
+    "  sta " ++ dst ++ "_lo, " ++ r ++ "\n" ++
+    "  lda " ++ src ++ "+1\n" ++
+    "  sta " ++ dst ++ "_hi, " ++ r
+  where
+    r = case reg of
+         X -> "x"
+         Y -> "y"
+
+emitInstr p r (COPY (Indexed (NamedLocation (Just (Table st1 _)) src) reg) (NamedLocation (Just st2) dst))
+  | (st1 == Vector && st2 == Vector) || (st1 == Word && st2 == Word) =
+    "lda " ++ src ++ "_lo, " ++ r ++ "\n" ++
+    "  sta " ++ dst ++ "\n" ++
+    "  lda " ++ src ++ "_hi, " ++ r ++ "\n" ++
+    "  sta " ++ dst ++ "+1"
+  where
+    r = case reg of
+         X -> "x"
+         Y -> "y"
+
 emitInstr p r (COPY A (IndirectIndexed (NamedLocation st label) Y)) = "sta (" ++ label ++ "), y"
 emitInstr p r (COPY (IndirectIndexed (NamedLocation st label) Y) A) = "lda (" ++ label ++ "), y"
 

src/SixtyPical/Parser.hs

@@ -575,13 +575,21 @@ copy_general_statement :: Parser Instruction
 copy_general_statement = do
     string "copy"
     nspaces
+
     src <- (try immediate <|> try direct_location)
+    srcI <- many index    
+    lhs <- return $ case (src, srcI) of
+        ((Immediately s), []) -> (Immediate s)
+        ((Directly s), []) -> (NamedLocation Nothing s)
+        ((Directly s), [reg]) -> (Indexed (NamedLocation Nothing s) reg)
+
     dst <- direct_location
-    return $ case (src, dst) of
+    dstI <- many index    
-        (Immediately s, Directly d) ->
+    rhs <- return $ case (dst, dstI) of
-            (COPY (Immediate s) (NamedLocation Nothing d))
+        ((Directly d), []) -> (NamedLocation Nothing d)
-        (Directly s, Directly d) ->
+        ((Directly d), [reg]) -> (Indexed (NamedLocation Nothing d) reg)
-            (COPY (NamedLocation Nothing s) (NamedLocation Nothing d))
+
+    return $ COPY lhs rhs
 
 copy_routine_statement :: Parser Instruction
 copy_routine_statement = do

src/SixtyPical/Transformer.hs

@@ -112,8 +112,10 @@ fillOutNamedLocationTypes p@(Program decls routines) =
         getType A = Byte
         getType X = Byte
         getType Y = Byte
-        getType (Immediate x) =
+        getType (Immediate x) =   -- TODO! allow promotion!
             if x > 255 then Word else Byte
+        getType (Indexed t _) =
+            getType t
         getType _ = Byte
         typeMatch x y constructor =
             let
@@ -126,7 +128,10 @@ fillOutNamedLocationTypes p@(Program decls routines) =
                     (True, _, _) -> constructor rx ry
                     (_, Byte, (Table Byte _)) -> constructor rx ry
                     (_, (Table Byte _), Byte) -> constructor rx ry                    
-                    _ -> error ("incompatible types '" ++ (show typeRx) ++ "' and '" ++ (show typeRy) ++ "'")
+                    (_, Word, (Table Word _)) -> constructor rx ry
+                    (_, (Table Word _), Word) -> constructor rx ry                    
+                    _ -> error ("incompatible types '" ++ (show typeRx) ++ "' and '" ++ (show typeRy) ++ "'" ++
+                                "  " ++ (show rx) ++ "," ++ (show ry))
         resolve (NamedLocation Nothing name) =
             case lookupDecl p name of
                 Just decl ->