Routines can declare their outputs now.

doc/Analyzing.markdown

@@ -59,3 +59,43 @@ But if it does it can.
     = update_score
     =   X: UpdatedWith (Immediate 1)
     =   NamedLocation (Just Byte) "score": UpdatedWith X
+
+We can't expect to stay named variables to stay unmodified either.
+
+    | assign byte border_colour 4000
+    | reserve byte score
+    | routine update_score
+    | {
+    |   lda #8
+    |   sta score
+    | }
+    | routine main {
+    |   jsr update_score
+    |   ldx score
+    | }
+    ? routine does not preserve 'NamedLocation (Just Byte) "score"'
+
+What the solution to the above is to notate `update_score` as intentionally
+modifying score, as an "output" of the routine.
+
+    | assign byte border_colour 4000
+    | reserve byte score
+    | routine update_score outputs (score)
+    | {
+    |   lda #8
+    |   sta score
+    | }
+    | routine main {
+    |   ldx score
+    |   jsr update_score
+    |   ldx score
+    | }
+    = main
+    =   A: UpdatedWith (Immediate 4)
+    =   X: PoisonedWith (Immediate 1)
+    =   NamedLocation (Just Byte) "border_colour": UpdatedWith A
+    =   NamedLocation (Just Byte) "score": PoisonedWith X
+    = 
+    = update_score
+    =   X: UpdatedWith (Immediate 1)
+    =   NamedLocation (Just Byte) "score": UpdatedWith X

src/SixtyPical/Analyzer.hs

@@ -9,58 +9,78 @@ import SixtyPical.Context
 
 -- -- -- -- abstract interpreter -- -- -- --
 
-analyzeProgram (Program decls routines) =
+analyzeProgram program@(Program decls routines) =
     checkRoutines routines Map.empty
+    where
+      checkRoutines [] progCtx = progCtx
+      checkRoutines (rout@(Routine name outputs _) : routs) progCtx =
+          let
+              routCtx = Map.empty
+              routAnalysis = checkRoutine rout progCtx routCtx
+              progCtx' = Map.insert name routAnalysis progCtx
+          in
+              checkRoutines routs progCtx'
+      
+      checkRoutine (Routine name outputs instrs) progCtx routCtx =
+          checkBlock instrs progCtx routCtx
+      
+      checkBlock [] progCtx routCtx = routCtx
+      checkBlock (instr:instrs) progCtx routCtx =
+          let
+              routCtx' = checkInstr instr progCtx routCtx
+          in
+              checkBlock instrs progCtx routCtx'
+      
+      checkInstr (COPY src dst) progCtx routCtx =
+          case Map.lookup src routCtx of
+              Just (PoisonedWith _) ->
+                  error ("routine does not preserve '" ++ (show src) ++ "'")
+              _ ->
+                  Map.insert dst (UpdatedWith src) routCtx
+      checkInstr (DELTA dst val) progCtx routCtx =
+          -- TODO check that dst is not poisoned
+          Map.insert dst (UpdatedWith (Immediate val)) routCtx
+      checkInstr (JSR name) progCtx routCtx =
+          let
+              Just calledRout = lookupRoutine program name
+          in
+              case Map.lookup name progCtx of
+                  Just calledRoutCtx ->
+                      mergeRoutCtxs routCtx calledRoutCtx calledRout
+                  Nothing ->
+                      error ("can't call routine '" ++ name ++ "' before it is defined")
+      checkInstr (CMP reg addr) progCtx routCtx =
+          -- TODO: mark Carry bit as "touched" here
+          routCtx
+      checkInstr (IF _ branch b1 b2) progCtx routCtx =
+          -- TODO: oooh, this one's gonna be fun
+          --checkBlock b1 progCtx routCtx
+          --checkBlock b2 progCtx routCtx
+          routCtx
+      checkInstr (REPEAT _ branch blk) progCtx routCtx =
+          -- TODO: oooh, this one's gonna be fun too
+          --checkBlock blk progCtx routCtx
+          routCtx
+      checkInstr NOP progCtx routCtx =
+          routCtx
+      
+      checkInstr instr _ _ = error (
+          "Internal error: sixtypical doesn't know how to " ++
+          "analyze '" ++ (show instr) ++ "'")
 
-checkRoutines [] progCtx = progCtx
-checkRoutines (rout@(Routine name _) : routs) progCtx =
+--
+-- Utility function:
+-- Take 2 routine contexts -- the current routine and a routine that was just
+-- JSR'ed to (immediately previously) -- and merge them to create a new
+-- context for the current routine.
+--
+mergeRoutCtxs routCtx calledRoutCtx calledRout@(Routine name outputs _) =
     let
-        routCtx = Map.empty
-        routAnalysis = checkRoutine rout progCtx routCtx
-        progCtx' = Map.insert name routAnalysis progCtx
+        -- go through all the Usages in the calledRoutCtx
+        -- insert any that were updated, into routCtx
+        poison location usage routCtxAccum =
+            case usage of
+                UpdatedWith ulocation ->
+                    Map.insert location (PoisonedWith ulocation) routCtxAccum
     in
-        checkRoutines routs progCtx'
-
-checkRoutine (Routine name instrs) progCtx routCtx =
-    checkBlock instrs progCtx routCtx
-
-checkBlock [] progCtx routCtx = routCtx
-checkBlock (instr:instrs) progCtx routCtx =
-    let
-        routCtx' = checkInstr instr progCtx routCtx
-    in
-        checkBlock instrs progCtx routCtx'
-
-checkInstr (COPY src dst) progCtx routCtx =
-    case Map.lookup src routCtx of
-        Just (PoisonedWith _) ->
-            error ("routine does not preserve '" ++ (show src) ++ "'")
-        _ ->
-            Map.insert dst (UpdatedWith src) routCtx
-checkInstr (DELTA dst val) progCtx routCtx =
-    -- TODO check that dst is not poisoned
-    Map.insert dst (UpdatedWith (Immediate val)) routCtx
-checkInstr (JSR name) progCtx routCtx =
-    case Map.lookup name progCtx of
-        Just calledRoutCtx ->
-            mergeRoutCtxs routCtx calledRoutCtx
-        Nothing ->
-            error ("can't call routine '" ++ name ++ "' before it is defined")
-checkInstr (CMP reg addr) progCtx routCtx =
-    -- TODO: mark Carry bit as "touched" here
-    routCtx
-checkInstr (IF _ branch b1 b2) progCtx routCtx =
-    -- TODO: oooh, this one's gonna be fun
-    --checkBlock b1 progCtx routCtx
-    --checkBlock b2 progCtx routCtx
-    routCtx
-checkInstr (REPEAT _ branch blk) progCtx routCtx =
-    -- TODO: oooh, this one's gonna be fun too
-    --checkBlock blk progCtx routCtx
-    routCtx
-checkInstr NOP progCtx routCtx =
-    routCtx
-
-checkInstr instr _ _ = error (
-    "Internal error: sixtypical doesn't know how to " ++
-    "analyze '" ++ (show instr) ++ "'")
+        Map.foldrWithKey (poison) routCtx calledRoutCtx

src/SixtyPical/Checker.hs

@@ -72,11 +72,11 @@ numberRoutinesLoops (routine:routines) iid =
         ((routine':routines'), iid'')
 
 numberRoutineLoops :: Routine -> InternalID -> (Routine, InternalID)
-numberRoutineLoops (Routine name instrs) iid =
+numberRoutineLoops (Routine name outputs instrs) iid =
     let
         (instrs', iid') = numberBlockLoops instrs iid
     in
-        ((Routine name instrs'), iid')
+        ((Routine name outputs instrs'), iid')
 
 numberBlockLoops :: [Instruction] -> InternalID -> ([Instruction], InternalID)
 numberBlockLoops [] iid = ([], iid)

src/SixtyPical/Context.hs

@@ -26,24 +26,6 @@ type RoutineContext = Map.Map StorageLocation Usage
 
 type ProgramContext = Map.Map RoutineName RoutineContext
 
---
--- Utility function:
--- Take 2 routine contexts -- the current routine and a routine that was just
--- JSR'ed to (immediately previously) -- and merge them to create a new
--- context for the current routine.
---
-mergeRoutCtxs routCtx calledRoutCtx =
-    let
-        -- go through all the Usages in the calledRoutCtx
-        -- insert any that were updated, into routCtx
-        poison location usage routCtxAccum =
-            case usage of
-                UpdatedWith ulocation ->
-                    Map.insert location (PoisonedWith ulocation) routCtxAccum
-    in
-        Map.foldrWithKey (poison) routCtx calledRoutCtx
-
-
 ppAnalysis :: ProgramContext -> IO ()
 ppAnalysis progCtx =
     let

src/SixtyPical/Emitter.hs

@@ -27,7 +27,7 @@ emitRoutines _ [] = ""
 emitRoutines p (rout:routs) =
     emitRoutine p rout ++ "\n" ++ emitRoutines p routs
 
-emitRoutine p r@(Routine name instrs) =
+emitRoutine p r@(Routine name _ instrs) =
     name ++ ":\n" ++ emitInstrs p r instrs ++ "  rts\n"
 
 emitInstrs _ _ [] = ""

src/SixtyPical/Model.hs

@@ -78,7 +78,7 @@ data Instruction = COPY StorageLocation StorageLocation
                  | NOP
     deriving (Show, Ord, Eq)
 
-data Routine = Routine RoutineName [Instruction]
+data Routine = Routine RoutineName [StorageLocation] [Instruction]
     deriving (Show, Ord, Eq)
 
 data Program = Program [Decl] [Routine]
@@ -90,7 +90,7 @@ data Program = Program [Decl] [Routine]
 programSummary p@(Program decls routs) =
     show ((length $ show p) < 99999)
 
-getRoutineName (Routine name _) = name
+getRoutineName (Routine name _ _) = name
 
 getDeclLocationName (Assign name _ _) = name
 getDeclLocationName (Reserve name _) = name
@@ -126,7 +126,8 @@ mapBlock :: (Instruction -> Instruction) -> [Instruction] -> [Instruction]
 mapBlock = map
 
 mapRoutine :: (Instruction -> Instruction) -> Routine -> Routine
-mapRoutine f (Routine name instrs) = Routine name (mapBlock f instrs)
+mapRoutine f (Routine name outputs instrs) =
+    Routine name outputs (mapBlock f instrs)
 
 mapRoutines :: (Instruction -> Instruction) -> [Routine] -> [Routine]
 mapRoutines f [] = []
@@ -143,7 +144,7 @@ foldBlock :: (Instruction -> a -> a) -> a -> [Instruction] -> a
 foldBlock = foldr
 
 foldRoutine :: (Instruction -> a -> a) -> a -> Routine -> a
-foldRoutine f a (Routine name instrs) =
+foldRoutine f a (Routine name outputs instrs) =
     foldBlock f a instrs
 
 foldRoutines :: (Instruction -> a -> a) -> a -> [Routine] -> a
@@ -164,10 +165,14 @@ lookupDecl (Program decls _) name =
     lookupDecl' (filter (isLocationDecl) decls) name
 
 lookupDecl' [] _ = Nothing
-lookupDecl' (decl:decls) name =
-    if
-        (getDeclLocationName decl) == name
-      then
-        Just decl
-      else
-        lookupDecl' decls name
+lookupDecl' (decl:decls) name
+    | (getDeclLocationName decl) == name = Just decl
+    | otherwise                          = lookupDecl' decls name
+
+lookupRoutine (Program _ routines) name =
+    lookupRoutine' routines name
+
+lookupRoutine' [] _ = Nothing
+lookupRoutine' (rout@(Routine rname _ _):routs) name
+    | rname == name = Just rout
+    | otherwise     = lookupRoutine' routs name

src/SixtyPical/Parser.hs

@@ -15,7 +15,7 @@ Decl     := "reserve" StorageType LocationName
           | "assign" StorageType LocationName Address
           | "external" RoutineName Address.
 StorageType := "byte" | "word" | "vector".
-Routine  := "routine" RoutineName Block.
+Routine  := "routine" RoutineName ["outputs" "(" {LocationName} ")"] Block.
 Block    := "{" [Comment] {Command [Comment]} "}".
 Command  := "if" Branch Block "else" Block
           | "lda" (LocationName | Immediate)
@@ -93,8 +93,20 @@ routine = do
     string "routine"
     spaces
     name <- routineName
+    outputs <- (try routine_outputs <|> return [])
     instrs <- block
-    return (Routine name instrs)
+    return (Routine name outputs instrs)
+
+routine_outputs :: Parser [StorageLocation]
+routine_outputs = do
+    string "outputs"
+    spaces
+    string "("
+    spaces
+    locations <- many locationName
+    string ")"
+    spaces
+    return (map (\x -> NamedLocation Nothing x) locations)
 
 block :: Parser [Instruction]
 block = do