From cbeac87a73809c7824b246de2d94f4c9e28524c9 Mon Sep 17 00:00:00 2001 From: Cat's Eye Technologies Date: Sun, 13 Apr 2014 11:41:40 +0100 Subject: [PATCH] Beginnings of using word tables --- doc/Emitting.markdown | 60 +++++++++++++++++++++++++++++++++++ eg/game.60p | 19 ++++------- src/SixtyPical/Checker.hs | 4 +-- src/SixtyPical/Emitter.hs | 26 +++++++++++++++ src/SixtyPical/Parser.hs | 18 ++++++++--- src/SixtyPical/Transformer.hs | 9 ++++-- 6 files changed, 115 insertions(+), 21 deletions(-) diff --git a/doc/Emitting.markdown b/doc/Emitting.markdown index 543398b..0471c27 100644 --- a/doc/Emitting.markdown +++ b/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 diff --git a/eg/game.60p b/eg/game.60p index 70f5cc5..6252eeb 100644 --- a/eg/game.60p +++ b/eg/game.60p @@ -26,8 +26,7 @@ reserve word delta reserve byte value reserve word compare_target -reserve byte[16] actor_pos_hi -reserve byte[16] actor_pos_lo +reserve word[16] actor_pos 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 position - lda actor_pos_lo, x - sta position - sta actor_pos_hi, x - lda j - Just (Reserve _ (Table Byte _) _) -> j + Just (Assign _ (Table _ _) _) -> j + Just (Reserve _ (Table _ _) _) -> j Just _ -> (COPY A A) Nothing -> (COPY A A) checkInstr other = other diff --git a/src/SixtyPical/Emitter.hs b/src/SixtyPical/Emitter.hs index 5ec0074..28b3a0f 100644 --- a/src/SixtyPical/Emitter.hs +++ b/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" diff --git a/src/SixtyPical/Parser.hs b/src/SixtyPical/Parser.hs index 0f543cf..356ef76 100644 --- a/src/SixtyPical/Parser.hs +++ b/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 - (Immediately s, Directly d) -> - (COPY (Immediate s) (NamedLocation Nothing d)) - (Directly s, Directly d) -> - (COPY (NamedLocation Nothing s) (NamedLocation Nothing d)) + dstI <- many index + rhs <- return $ case (dst, dstI) of + ((Directly d), []) -> (NamedLocation Nothing d) + ((Directly d), [reg]) -> (Indexed (NamedLocation Nothing d) reg) + + return $ COPY lhs rhs copy_routine_statement :: Parser Instruction copy_routine_statement = do diff --git a/src/SixtyPical/Transformer.hs b/src/SixtyPical/Transformer.hs index 7e1f2f9..0591363 100644 --- a/src/SixtyPical/Transformer.hs +++ b/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 ->