mirror of
https://github.com/catseye/SixtyPical.git
synced 2024-09-27 11:54:45 +00:00
mergeRoutCtxs does not need to throw poisoning errors.
This commit is contained in:
Cat's Eye Technologies
parent
af7d65ee09
commit
8acde175ad
44
eg/game.60p
44
eg/game.60p
@ -26,11 +26,10 @@ reserve word delta
|
||||
reserve byte value
|
||||
reserve word compare_target
|
||||
|
||||
routine reset_position {
|
||||
copy #$0400 position
|
||||
}
|
||||
reserve byte[16] actor_pos_hi
|
||||
reserve byte[16] actor_pos_lo
|
||||
|
||||
routine advance_pos {
|
||||
routine calculate_new_position outputs (new_position) {
|
||||
clc
|
||||
lda <position
|
||||
adc <delta
|
||||
@ -40,10 +39,6 @@ routine advance_pos {
|
||||
sta >new_position
|
||||
}
|
||||
|
||||
routine install_new_position {
|
||||
copy new_position position
|
||||
}
|
||||
|
||||
routine compare_new_pos {
|
||||
lda >new_position
|
||||
cmp >compare_target
|
||||
@ -117,7 +112,6 @@ routine read_stick {
|
||||
if beq {
|
||||
lda #255 // -1
|
||||
sta <delta
|
||||
lda #255
|
||||
sta >delta
|
||||
} else {
|
||||
txa
|
||||
@ -132,19 +126,30 @@ routine read_stick {
|
||||
}
|
||||
|
||||
routine our_cinv {
|
||||
lda #32
|
||||
ldy #0
|
||||
sta (position), y
|
||||
lda actor_pos_hi, y
|
||||
sta >position
|
||||
lda actor_pos_lo, y
|
||||
sta <position
|
||||
|
||||
jsr read_stick
|
||||
jsr advance_pos
|
||||
jsr calculate_new_position
|
||||
jsr check_new_position_in_bounds
|
||||
if bcs {
|
||||
jsr install_new_position
|
||||
lda #32
|
||||
ldy #0
|
||||
sta (position), y
|
||||
copy new_position position
|
||||
lda #81
|
||||
ldy #0
|
||||
sta (position), y
|
||||
} else { }
|
||||
|
||||
lda #81
|
||||
ldy #0
|
||||
sta (position), y
|
||||
lda >position
|
||||
sta actor_pos_hi, y
|
||||
lda <position
|
||||
sta actor_pos_lo, y
|
||||
|
||||
jmp (save_cinv)
|
||||
}
|
||||
@ -154,7 +159,14 @@ routine main {
|
||||
sta vic_border
|
||||
lda #0
|
||||
sta vic_bg
|
||||
jsr reset_position
|
||||
// copy #$0400 position
|
||||
|
||||
ldy #0
|
||||
lda #$04
|
||||
sta actor_pos_hi, y
|
||||
lda #$00
|
||||
sta actor_pos_lo, y
|
||||
|
||||
jsr clear_screen
|
||||
with sei {
|
||||
copy cinv save_cinv
|
||||
|
||||
@ -37,20 +37,20 @@ analyzeProgram program@(Program decls routines) =
|
||||
-- -- -- -- -- -- -- -- -- -- -- --
|
||||
|
||||
checkInstr nm (COPY src dst) progCtx routCtx =
|
||||
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
||||
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
||||
checkInstr nm (DELTA dst val) progCtx routCtx =
|
||||
updateRoutCtx nm dst (UpdatedWith (Immediate val)) routCtx
|
||||
updateRoutCtxPoison nm dst (UpdatedWith (Immediate val)) routCtx
|
||||
checkInstr nm (ADD dst src) progCtx routCtx =
|
||||
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
||||
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
||||
checkInstr nm (SUB dst src) progCtx routCtx =
|
||||
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
||||
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
||||
|
||||
checkInstr nm (AND dst src) progCtx routCtx =
|
||||
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
||||
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
||||
checkInstr nm (OR dst src) progCtx routCtx =
|
||||
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
||||
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
||||
checkInstr nm (XOR dst src) progCtx routCtx =
|
||||
updateRoutCtx nm dst (UpdatedWith src) routCtx
|
||||
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx
|
||||
|
||||
checkInstr nm (JSR name) progCtx routCtx =
|
||||
case lookupRoutine program name of
|
||||
@ -77,7 +77,7 @@ analyzeProgram program@(Program decls routines) =
|
||||
mergeAlternateRoutCtxs nm routCtx1 routCtx2
|
||||
checkInstr nm (REPEAT _ branch blk) progCtx routCtx =
|
||||
-- we analyze the block twice, to simulate it being
|
||||
-- repeated. (see tests for a test case on this.
|
||||
-- repeated. (see tests for a test case on this.)
|
||||
let
|
||||
routCtx' = checkBlock nm blk progCtx routCtx
|
||||
routCtx'' = checkBlock nm blk progCtx routCtx'
|
||||
@ -89,15 +89,15 @@ analyzeProgram program@(Program decls routines) =
|
||||
checkBlock nm blk progCtx routCtx
|
||||
|
||||
checkInstr nm (BIT dst) progCtx routCtx =
|
||||
updateRoutCtx nm dst (UpdatedWith (Immediate 0)) routCtx
|
||||
updateRoutCtxPoison nm dst (UpdatedWith (Immediate 0)) routCtx
|
||||
|
||||
checkInstr nm (SHR dst flg) progCtx routCtx =
|
||||
updateRoutCtx nm dst (UpdatedWith flg) routCtx
|
||||
updateRoutCtxPoison nm dst (UpdatedWith flg) routCtx
|
||||
checkInstr nm (SHL dst flg) progCtx routCtx =
|
||||
updateRoutCtx nm dst (UpdatedWith flg) routCtx
|
||||
updateRoutCtxPoison nm dst (UpdatedWith flg) routCtx
|
||||
|
||||
checkInstr nm (COPYROUTINE name dst) progCtx routCtx =
|
||||
updateRoutCtx nm dst (UpdatedWith (Immediate 7)) routCtx
|
||||
updateRoutCtxPoison nm dst (UpdatedWith (Immediate 7)) routCtx
|
||||
|
||||
checkInstr nm (JMPVECTOR dst) progCtx routCtx =
|
||||
routCtx
|
||||
@ -115,6 +115,9 @@ analyzeProgram program@(Program decls routines) =
|
||||
-- JSR'ed to (immediately previously) -- and merge them to create a new
|
||||
-- context for the current routine.
|
||||
--
|
||||
-- This can't, by itself, cause a poisoning error.
|
||||
-- So we use a weaker version of updateRoutCtx to build the merged context.
|
||||
--
|
||||
mergeRoutCtxs nm routCtx calledRoutCtx calledRout@(Routine name outputs _) =
|
||||
let
|
||||
-- go through all the Usages in the calledRoutCtx
|
||||
@ -165,14 +168,3 @@ mergeAlternateRoutCtxs nm routCtx1 routCtx2 =
|
||||
updateRoutCtx nm location newUsage routCtxAccum
|
||||
in
|
||||
Map.foldrWithKey (poison) routCtx1 routCtx2
|
||||
where
|
||||
-- a weaker version of updateRoutCtx, which does not error if
|
||||
-- we access a poisoned source
|
||||
updateRoutCtx nm dst (UpdatedWith src) routCtx =
|
||||
let
|
||||
s = untypedLocation src
|
||||
d = untypedLocation dst
|
||||
in
|
||||
Map.insert d (UpdatedWith s) routCtx
|
||||
updateRoutCtx nm dst (PoisonedWith src) routCtx =
|
||||
Map.insert (untypedLocation dst) (PoisonedWith $ untypedLocation src) routCtx
|
||||
|
||||
@ -38,8 +38,8 @@ untypedLocation (NamedLocation _ name) =
|
||||
NamedLocation Nothing name
|
||||
untypedLocation x = x
|
||||
|
||||
updateRoutCtx :: String -> StorageLocation -> Usage -> RoutineContext -> RoutineContext
|
||||
updateRoutCtx nm dst (UpdatedWith src) routCtx =
|
||||
updateRoutCtxPoison :: String -> StorageLocation -> Usage -> RoutineContext -> RoutineContext
|
||||
updateRoutCtxPoison nm dst (UpdatedWith src) routCtx =
|
||||
let
|
||||
s = untypedLocation src
|
||||
d = untypedLocation dst
|
||||
@ -50,9 +50,18 @@ updateRoutCtx nm dst (UpdatedWith src) routCtx =
|
||||
(show s) ++ "' (in context: " ++ (show routCtx) ++ ")")
|
||||
_ ->
|
||||
Map.insert d (UpdatedWith s) routCtx
|
||||
updateRoutCtx nm dst (PoisonedWith src) routCtx =
|
||||
updateRoutCtxPoison nm dst (PoisonedWith src) routCtx =
|
||||
Map.insert (untypedLocation dst) (PoisonedWith $ untypedLocation src) routCtx
|
||||
|
||||
updateRoutCtx nm dst (UpdatedWith src) routCtx =
|
||||
let
|
||||
s = untypedLocation src
|
||||
d = untypedLocation dst
|
||||
in
|
||||
Map.insert d (UpdatedWith s) routCtx
|
||||
updateRoutCtx nm dst (PoisonedWith src) routCtx =
|
||||
Map.insert (untypedLocation dst) (PoisonedWith $ untypedLocation src) routCtx
|
||||
|
||||
-- pretty printing
|
||||
|
||||
ppAnalysis :: Program -> ProgramContext -> IO ()
|
||||
|
||||
Loading…
Reference in New Issue
Block a user