mirror of
https://github.com/catseye/SixtyPical.git
synced 2025-02-15 09:30:49 +00:00
NamedLocation now includes the StorageType.
This commit is contained in:
Cat's Eye Technologies
parent
7fb454fb99
commit
c0676f9efa
@ -18,9 +18,9 @@ blockUsedLocations (instr:instrs) =
|
||||
(instrUsedLocations instr) ++ blockUsedLocations instrs
|
||||
|
||||
--instrUsedLocations (LOADIMM reg (NamedLocation loc)) = [loc]
|
||||
instrUsedLocations (COPY (NamedLocation loc) _) = [loc]
|
||||
instrUsedLocations (COPY _ (NamedLocation loc)) = [loc]
|
||||
instrUsedLocations (CMP reg (NamedLocation loc)) = [loc]
|
||||
instrUsedLocations (COPY (NamedLocation sz loc) _) = [loc]
|
||||
instrUsedLocations (COPY _ (NamedLocation sz loc)) = [loc]
|
||||
instrUsedLocations (CMP reg (NamedLocation sz loc)) = [loc]
|
||||
-- TODO: JSR...
|
||||
instrUsedLocations (IF _ branch b1 b2) =
|
||||
blockUsedLocations b1 ++ blockUsedLocations b2
|
||||
@ -55,7 +55,7 @@ noJmpsToNonVectors p@(Program decls routines) =
|
||||
in
|
||||
mappedProgram == p
|
||||
where
|
||||
checkInstr j@(JMPVECTOR (NamedLocation g)) =
|
||||
checkInstr j@(JMPVECTOR (NamedLocation sz g)) =
|
||||
case lookupDecl p g of
|
||||
Just (Assign _ Vector _) -> j
|
||||
Just (Reserve _ Vector) -> j
|
||||
@ -69,7 +69,7 @@ noIndexedAccessOfNonTables p@(Program decls routines) =
|
||||
in
|
||||
mappedProgram == p
|
||||
where
|
||||
checkInstr j@(COPY _ (Indexed (NamedLocation g) reg)) =
|
||||
checkInstr j@(COPY _ (Indexed (NamedLocation sz g) reg)) =
|
||||
case lookupDecl p g of
|
||||
Just (Assign _ ByteTable _) -> j
|
||||
Just (Reserve _ ByteTable) -> j
|
||||
@ -91,23 +91,7 @@ noUseOfUndeclaredRoutines p@(Program decls routines) =
|
||||
False -> (COPY A A)
|
||||
checkInstr other = other
|
||||
|
||||
-- -- --
|
||||
|
||||
checkAndTransformProgram :: Program -> Maybe Program
|
||||
checkAndTransformProgram program =
|
||||
if
|
||||
trueOrDie "missing 'main' routine" (routineDeclared "main" program) &&
|
||||
trueOrDie "undeclared location" (allUsedLocationsDeclared program) &&
|
||||
trueOrDie "duplicate location name" (noDuplicateDecls program) &&
|
||||
trueOrDie "duplicate routine name" (noDuplicateRoutines program) &&
|
||||
trueOrDie "jmp to non-vector" (noJmpsToNonVectors program) &&
|
||||
trueOrDie "undeclared routine" (noUseOfUndeclaredRoutines program) &&
|
||||
trueOrDie "indexed access of non-table" (noIndexedAccessOfNonTables program)
|
||||
then
|
||||
Just $ numberProgramLoops program
|
||||
else Nothing
|
||||
|
||||
-- - - - - - -
|
||||
-- -- -- -- -- --
|
||||
|
||||
-- in the following "number" means "assign a unique ID to" and "loop"
|
||||
-- means "REPEAT or IF" (because i'm in such a good mood)
|
||||
@ -161,3 +145,65 @@ numberInstruction (REPEAT _ branch blk) iid =
|
||||
in
|
||||
(newInstr, newIid)
|
||||
numberInstruction i iid = (i, iid)
|
||||
|
||||
-- -- --
|
||||
|
||||
fillOutNamedLocationTypes p@(Program decls routines) =
|
||||
mapProgramRoutines (xform) p
|
||||
where
|
||||
xform j@(COPY src dest) =
|
||||
COPY (resolve src) (resolve dest)
|
||||
xform j@(CMP dest other) =
|
||||
CMP (resolve dest) (resolve other)
|
||||
xform j@(ADD dest other) =
|
||||
ADD (resolve dest) (resolve other)
|
||||
xform j@(AND dest other) =
|
||||
AND (resolve dest) (resolve other)
|
||||
xform j@(SUB dest other) =
|
||||
SUB (resolve dest) (resolve other)
|
||||
xform j@(OR dest other) =
|
||||
OR (resolve dest) (resolve other)
|
||||
xform j@(JMPVECTOR dest) =
|
||||
JMPVECTOR (resolve dest)
|
||||
xform j@(IF iid branch b1 b2) =
|
||||
IF iid branch (mapBlock xform b1) (mapBlock xform b2)
|
||||
xform j@(REPEAT iid branch blk) =
|
||||
REPEAT iid branch (mapBlock xform blk)
|
||||
xform j@(DELTA dest val) =
|
||||
DELTA (resolve dest) val
|
||||
xform j@(SEI blk) =
|
||||
SEI (mapBlock xform blk)
|
||||
xform j@(COPYVECTOR src dest) =
|
||||
COPYVECTOR (resolve src) (resolve dest)
|
||||
xform j@(COPYROUTINE name dest) =
|
||||
COPYROUTINE name (resolve dest)
|
||||
xform other =
|
||||
other
|
||||
resolve (NamedLocation Nothing name) =
|
||||
case lookupDecl p name of
|
||||
Just decl ->
|
||||
(NamedLocation (Just $ getDeclLocationType decl) name)
|
||||
_ ->
|
||||
error ("undeclared location '" ++ name ++ "'")
|
||||
resolve other =
|
||||
other
|
||||
|
||||
checkAndTransformProgram :: Program -> Maybe Program
|
||||
checkAndTransformProgram program =
|
||||
if
|
||||
trueOrDie "missing 'main' routine" (routineDeclared "main" program) &&
|
||||
trueOrDie "undeclared location" (allUsedLocationsDeclared program) &&
|
||||
trueOrDie "duplicate location name" (noDuplicateDecls program) &&
|
||||
trueOrDie "duplicate routine name" (noDuplicateRoutines program) &&
|
||||
trueOrDie "jmp to non-vector" (noJmpsToNonVectors program) &&
|
||||
trueOrDie "undeclared routine" (noUseOfUndeclaredRoutines program) &&
|
||||
trueOrDie "indexed access of non-table" (noIndexedAccessOfNonTables program)
|
||||
then
|
||||
let
|
||||
program' = numberProgramLoops program
|
||||
program'' = fillOutNamedLocationTypes program'
|
||||
in
|
||||
Just program''
|
||||
else Nothing
|
||||
|
||||
-- - - - - - -
|
||||
|
||||
@ -42,52 +42,52 @@ emitInstr p r (COPY (Immediate 0) FlagV) = "clv"
|
||||
emitInstr p r (COPY (Immediate 1) FlagC) = "sec"
|
||||
emitInstr p r (COPY (Immediate 1) FlagD) = "sed"
|
||||
|
||||
emitInstr p r (COPY A (NamedLocation label)) = "sta " ++ label
|
||||
emitInstr p r (COPY X (NamedLocation label)) = "stx " ++ label
|
||||
emitInstr p r (COPY Y (NamedLocation label)) = "sty " ++ label
|
||||
emitInstr p r (COPY (NamedLocation label) A) = "lda " ++ label
|
||||
emitInstr p r (COPY (NamedLocation label) X) = "ldx " ++ label
|
||||
emitInstr p r (COPY (NamedLocation label) Y) = "ldy " ++ label
|
||||
emitInstr p r (COPY A (NamedLocation st label)) = "sta " ++ label
|
||||
emitInstr p r (COPY X (NamedLocation st label)) = "stx " ++ label
|
||||
emitInstr p r (COPY Y (NamedLocation st label)) = "sty " ++ label
|
||||
emitInstr p r (COPY (NamedLocation st label) A) = "lda " ++ label
|
||||
emitInstr p r (COPY (NamedLocation st label) X) = "ldx " ++ label
|
||||
emitInstr p r (COPY (NamedLocation st label) Y) = "ldy " ++ label
|
||||
|
||||
emitInstr p r (COPY A X) = "tax"
|
||||
emitInstr p r (COPY A Y) = "tay"
|
||||
emitInstr p r (COPY X A) = "txa"
|
||||
emitInstr p r (COPY Y A) = "tya"
|
||||
|
||||
emitInstr p r (COPY A (Indexed (NamedLocation label) X)) = "sta " ++ label ++ ", x"
|
||||
emitInstr p r (COPY A (Indexed (NamedLocation label) Y)) = "sta " ++ label ++ ", y"
|
||||
emitInstr p r (COPY A (Indexed (NamedLocation st label) X)) = "sta " ++ label ++ ", x"
|
||||
emitInstr p r (COPY A (Indexed (NamedLocation st label) Y)) = "sta " ++ label ++ ", y"
|
||||
|
||||
emitInstr p r (COPY (Indexed (NamedLocation label) X) A) = "lda " ++ label ++ ", x"
|
||||
emitInstr p r (COPY (Indexed (NamedLocation label) Y) A) = "lda " ++ label ++ ", y"
|
||||
emitInstr p r (COPY (Indexed (NamedLocation st label) X) A) = "lda " ++ label ++ ", x"
|
||||
emitInstr p r (COPY (Indexed (NamedLocation st label) Y) A) = "lda " ++ label ++ ", y"
|
||||
|
||||
emitInstr p r (COPY A (IndirectIndexed (NamedLocation label) Y)) = "sta (" ++ label ++ "), y"
|
||||
emitInstr p r (COPY A (IndirectIndexed (NamedLocation st label) Y)) = "sta (" ++ label ++ "), y"
|
||||
|
||||
emitInstr p r (CMP A (NamedLocation label)) = "cmp " ++ label
|
||||
emitInstr p r (CMP X (NamedLocation label)) = "cpx " ++ label
|
||||
emitInstr p r (CMP Y (NamedLocation label)) = "cpy " ++ label
|
||||
emitInstr p r (CMP A (NamedLocation st label)) = "cmp " ++ label
|
||||
emitInstr p r (CMP X (NamedLocation st label)) = "cpx " ++ label
|
||||
emitInstr p r (CMP Y (NamedLocation st label)) = "cpy " ++ label
|
||||
|
||||
emitInstr p r (CMP A (Immediate val)) = "cmp #" ++ (show val)
|
||||
emitInstr p r (CMP X (Immediate val)) = "cpx #" ++ (show val)
|
||||
emitInstr p r (CMP Y (Immediate val)) = "cpy #" ++ (show val)
|
||||
|
||||
emitInstr p r (ADD A (NamedLocation label)) = "adc " ++ label
|
||||
emitInstr p r (ADD A (NamedLocation st label)) = "adc " ++ label
|
||||
emitInstr p r (ADD A (Immediate val)) = "adc #" ++ (show val)
|
||||
|
||||
emitInstr p r (AND A (NamedLocation label)) = "and " ++ label
|
||||
emitInstr p r (AND A (NamedLocation st label)) = "and " ++ label
|
||||
emitInstr p r (AND A (Immediate val)) = "and #" ++ (show val)
|
||||
|
||||
emitInstr p r (SUB A (NamedLocation label)) = "sbc " ++ label
|
||||
emitInstr p r (SUB A (NamedLocation st label)) = "sbc " ++ label
|
||||
emitInstr p r (SUB A (Immediate val)) = "sbc #" ++ (show val)
|
||||
|
||||
emitInstr p r (OR A (NamedLocation label)) = "ora " ++ label
|
||||
emitInstr p r (OR A (NamedLocation st label)) = "ora " ++ label
|
||||
emitInstr p r (OR A (Immediate val)) = "ora #" ++ (show val)
|
||||
|
||||
emitInstr p r (DELTA X 1) = "inx"
|
||||
emitInstr p r (DELTA X (-1)) = "dex"
|
||||
emitInstr p r (DELTA Y 1) = "iny"
|
||||
emitInstr p r (DELTA Y (-1)) = "dey"
|
||||
emitInstr p r (DELTA (NamedLocation label) 1) = "inc " ++ label
|
||||
emitInstr p r (DELTA (NamedLocation label) (-1)) = "dec " ++ label
|
||||
emitInstr p r (DELTA (NamedLocation st label) 1) = "inc " ++ label
|
||||
emitInstr p r (DELTA (NamedLocation st label) (-1)) = "dec " ++ label
|
||||
|
||||
emitInstr p r (IF iid branch b1 b2) =
|
||||
(show branch) ++ " _label_" ++ (show iid) ++ "\n" ++
|
||||
@ -107,19 +107,19 @@ emitInstr p r (SEI blk) =
|
||||
emitInstrs p r blk ++
|
||||
" cli"
|
||||
|
||||
emitInstr p r (COPYVECTOR (NamedLocation src) (NamedLocation dst)) =
|
||||
emitInstr p r (COPYVECTOR (NamedLocation (Just Vector) src) (NamedLocation (Just Vector) dst)) =
|
||||
"lda " ++ src ++ "\n" ++
|
||||
" sta " ++ dst ++ "\n" ++
|
||||
" lda " ++ src ++ "+1\n" ++
|
||||
" sta " ++ dst ++ "+1"
|
||||
|
||||
emitInstr p r (COPYROUTINE src (NamedLocation dst)) =
|
||||
emitInstr p r (COPYROUTINE src (NamedLocation (Just Vector) dst)) =
|
||||
"lda #<" ++ src ++ "\n" ++
|
||||
" sta " ++ dst ++ "\n" ++
|
||||
" lda #>" ++ src ++ "\n" ++
|
||||
" sta " ++ dst ++ "+1"
|
||||
|
||||
emitInstr p r (JMPVECTOR (NamedLocation dst)) =
|
||||
emitInstr p r (JMPVECTOR (NamedLocation (Just Vector) dst)) =
|
||||
"jmp (" ++ dst ++ ")"
|
||||
|
||||
emitInstr p r (JSR routineName) =
|
||||
|
||||
@ -20,6 +20,12 @@ type LocationName = String
|
||||
-- One of these should never refer to the program code. We can only police
|
||||
-- this up to a point.
|
||||
|
||||
data StorageType = Byte
|
||||
| Word
|
||||
| Vector
|
||||
| ByteTable
|
||||
deriving (Show, Ord, Eq)
|
||||
|
||||
data StorageLocation = A
|
||||
| Y
|
||||
| X
|
||||
@ -32,7 +38,7 @@ data StorageLocation = A
|
||||
| Indirect StorageLocation
|
||||
| Indexed StorageLocation StorageLocation
|
||||
| IndirectIndexed StorageLocation StorageLocation
|
||||
| NamedLocation LocationName
|
||||
| NamedLocation (Maybe StorageType) LocationName
|
||||
deriving (Show, Ord, Eq)
|
||||
|
||||
-- this is bunk, man. if a location does not appear in an analysis
|
||||
@ -42,12 +48,6 @@ allRegisters = [A, X, Y, FlagN, FlagV, FlagD, FlagZ, FlagC]
|
||||
|
||||
-- -- -- -- program model -- -- -- --
|
||||
|
||||
data StorageType = Byte
|
||||
| Word
|
||||
| Vector
|
||||
| ByteTable
|
||||
deriving (Show, Ord, Eq)
|
||||
|
||||
data Decl = Assign LocationName StorageType Address -- .alias
|
||||
| Reserve LocationName StorageType -- .word, .byte
|
||||
| External RoutineName Address
|
||||
@ -89,6 +89,9 @@ getRoutineName (Routine name _) = name
|
||||
getDeclLocationName (Assign name _ _) = name
|
||||
getDeclLocationName (Reserve name _) = name
|
||||
|
||||
getDeclLocationType (Assign _ t _) = t
|
||||
getDeclLocationType (Reserve _ t) = t
|
||||
|
||||
isLocationDecl (Assign _ _ _) = True
|
||||
isLocationDecl (Reserve _ _) = True
|
||||
isLocationDecl _ = False
|
||||
@ -125,9 +128,6 @@ mapRoutines f (rout:routs) =
|
||||
mapProgramRoutines :: (Instruction -> Instruction) -> Program -> Program
|
||||
mapProgramRoutines f (Program decls routs) = Program decls $ mapRoutines f routs
|
||||
|
||||
|
||||
|
||||
|
||||
lookupDecl (Program [] _) _ = Nothing
|
||||
lookupDecl (Program (decl:decls) routs) name =
|
||||
if
|
||||
|
||||
@ -252,63 +252,63 @@ inc = do
|
||||
string "inc"
|
||||
spaces
|
||||
l <- locationName
|
||||
return (DELTA (NamedLocation l) 1)
|
||||
return (DELTA (NamedLocation Nothing l) 1)
|
||||
|
||||
dec :: Parser Instruction
|
||||
dec = do
|
||||
string "dec"
|
||||
spaces
|
||||
l <- locationName
|
||||
return (DELTA (NamedLocation l) (-1))
|
||||
return (DELTA (NamedLocation Nothing l) (-1))
|
||||
|
||||
cmp :: Parser Instruction
|
||||
cmp = do
|
||||
string "cmp"
|
||||
spaces
|
||||
(try $ immediate (\v -> CMP A (Immediate v)) <|>
|
||||
absolute (\l -> CMP A (NamedLocation l)))
|
||||
absolute (\l -> CMP A (NamedLocation Nothing l)))
|
||||
|
||||
cpx :: Parser Instruction
|
||||
cpx = do
|
||||
string "cpx"
|
||||
spaces
|
||||
(try $ immediate (\v -> CMP X (Immediate v)) <|>
|
||||
absolute (\l -> CMP X (NamedLocation l)))
|
||||
absolute (\l -> CMP X (NamedLocation Nothing l)))
|
||||
|
||||
cpy :: Parser Instruction
|
||||
cpy = do
|
||||
string "cpy"
|
||||
spaces
|
||||
(try $ immediate (\v -> CMP Y (Immediate v)) <|>
|
||||
absolute (\l -> CMP Y (NamedLocation l)))
|
||||
absolute (\l -> CMP Y (NamedLocation Nothing l)))
|
||||
|
||||
adc :: Parser Instruction
|
||||
adc = do
|
||||
string "adc"
|
||||
spaces
|
||||
(try $ immediate (\v -> ADD A (Immediate v)) <|>
|
||||
absolute (\l -> ADD A (NamedLocation l)))
|
||||
absolute (\l -> ADD A (NamedLocation Nothing l)))
|
||||
|
||||
sbc :: Parser Instruction
|
||||
sbc = do
|
||||
string "sbc"
|
||||
spaces
|
||||
(try $ immediate (\v -> SUB A (Immediate v)) <|>
|
||||
absolute (\l -> SUB A (NamedLocation l)))
|
||||
absolute (\l -> SUB A (NamedLocation Nothing l)))
|
||||
|
||||
and :: Parser Instruction
|
||||
and = do
|
||||
string "and"
|
||||
spaces
|
||||
(try $ immediate (\v -> AND A (Immediate v)) <|>
|
||||
absolute (\l -> AND A (NamedLocation l)))
|
||||
absolute (\l -> AND A (NamedLocation Nothing l)))
|
||||
|
||||
ora :: Parser Instruction
|
||||
ora = do
|
||||
string "ora"
|
||||
spaces
|
||||
(try $ immediate (\v -> OR A (Immediate v)) <|>
|
||||
absolute (\l -> OR A (NamedLocation l)))
|
||||
absolute (\l -> OR A (NamedLocation Nothing l)))
|
||||
|
||||
lda :: Parser Instruction
|
||||
lda = do
|
||||
@ -316,22 +316,22 @@ lda = do
|
||||
spaces
|
||||
(try $ immediate (\v -> COPY (Immediate v) A) <|> absolute_indexed gen)
|
||||
where
|
||||
gen l [] = COPY (NamedLocation l) A
|
||||
gen l [reg] = COPY (Indexed (NamedLocation l) reg) A
|
||||
gen l [] = COPY (NamedLocation Nothing l) A
|
||||
gen l [reg] = COPY (Indexed (NamedLocation Nothing l) reg) A
|
||||
|
||||
ldx :: Parser Instruction
|
||||
ldx = do
|
||||
string "ldx"
|
||||
spaces
|
||||
(try $ immediate (\v -> COPY (Immediate v) X) <|>
|
||||
absolute (\l -> COPY (NamedLocation l) X))
|
||||
absolute (\l -> COPY (NamedLocation Nothing l) X))
|
||||
|
||||
ldy :: Parser Instruction
|
||||
ldy = do
|
||||
string "ldy"
|
||||
spaces
|
||||
(try $ immediate (\v -> COPY (Immediate v) Y) <|>
|
||||
absolute (\l -> COPY (NamedLocation l) Y))
|
||||
absolute (\l -> COPY (NamedLocation Nothing l) Y))
|
||||
|
||||
sta :: Parser Instruction
|
||||
sta = do
|
||||
@ -339,23 +339,23 @@ sta = do
|
||||
spaces
|
||||
indirect_indexed gen
|
||||
where
|
||||
gen (Directly l) [] = COPY A (NamedLocation l)
|
||||
gen (Directly l) [reg] = COPY A (Indexed (NamedLocation l) reg)
|
||||
gen (Indirectly l) [reg] = COPY A (IndirectIndexed (NamedLocation l) reg)
|
||||
gen (Directly l) [] = COPY A (NamedLocation Nothing l)
|
||||
gen (Directly l) [reg] = COPY A (Indexed (NamedLocation Nothing l) reg)
|
||||
gen (Indirectly l) [reg] = COPY A (IndirectIndexed (NamedLocation Nothing l) reg)
|
||||
|
||||
stx :: Parser Instruction
|
||||
stx = do
|
||||
string "stx"
|
||||
spaces
|
||||
l <- locationName
|
||||
return (COPY X (NamedLocation l))
|
||||
return (COPY X (NamedLocation Nothing l))
|
||||
|
||||
sty :: Parser Instruction
|
||||
sty = do
|
||||
string "sty"
|
||||
spaces
|
||||
l <- locationName
|
||||
return (COPY Y (NamedLocation l))
|
||||
return (COPY Y (NamedLocation Nothing l))
|
||||
|
||||
txa :: Parser Instruction
|
||||
txa = do
|
||||
@ -393,7 +393,7 @@ jmp = do
|
||||
string "jmp"
|
||||
spaces
|
||||
l <- locationName
|
||||
return $ JMPVECTOR (NamedLocation l)
|
||||
return $ JMPVECTOR (NamedLocation Nothing l)
|
||||
|
||||
jsr :: Parser Instruction
|
||||
jsr = do
|
||||
@ -431,7 +431,7 @@ copy_vector_statement = do
|
||||
string "to"
|
||||
spaces
|
||||
dst <- locationName
|
||||
return (COPYVECTOR (NamedLocation src) (NamedLocation dst))
|
||||
return (COPYVECTOR (NamedLocation Nothing src) (NamedLocation Nothing dst))
|
||||
|
||||
copy_routine_statement :: Parser Instruction
|
||||
copy_routine_statement = do
|
||||
@ -443,7 +443,7 @@ copy_routine_statement = do
|
||||
string "to"
|
||||
spaces
|
||||
dst <- locationName
|
||||
return (COPYROUTINE src (NamedLocation dst))
|
||||
return (COPYROUTINE src (NamedLocation Nothing dst))
|
||||
|
||||
branch :: Parser Branch
|
||||
branch = try (b "bcc" BCC) <|> try (b "bcs" BCS) <|> try (b "beq" BEQ) <|>
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user