diff --git a/src/SixtyPical/Checker.hs b/src/SixtyPical/Checker.hs index 499f662..62b79e6 100644 --- a/src/SixtyPical/Checker.hs +++ b/src/SixtyPical/Checker.hs @@ -65,7 +65,7 @@ checkAndTransformProgram program = let program' = numberProgramLoops program program'' = renameBlockDecls program' - program''' = liftBlockDecls program' + program''' = liftBlockDecls program'' program'''' = fillOutNamedLocationTypes program''' in Just program'''' diff --git a/src/SixtyPical/Transformer.hs b/src/SixtyPical/Transformer.hs index 2e33f9c..d6e0427 100644 --- a/src/SixtyPical/Transformer.hs +++ b/src/SixtyPical/Transformer.hs @@ -150,30 +150,89 @@ renameBlockDecls (Program decls routines) = routines' = map renameRoutineDecls routines in Program decls routines' - where - renameRoutineDecls (Routine name outputs block) = - let - (Block decls _) = block - block' = foldDeclsRenaming decls block - in - (Routine name outputs block') --- TODO will have to return new decls too --- TODO will have to take accumulator too --- TODO accumulator has to range across all routines too! -foldDeclsRenaming [] block = block -foldDeclsRenaming ((Reserve name typ Nothing):decls) block = +renameRoutineDecls (Routine name outputs block) = let - newName = "_temp_1" -- TODO base this on accumulator - block' = mapBlockNames name newName block + (Block decls _) = block + (id', block') = foldDeclsRenaming decls 0 block in - foldDeclsRenaming decls block' + (Routine name outputs block') + +-- TODO accumulator has to range across all routines too! +foldDeclsRenaming [] id block = (id, block) +foldDeclsRenaming ((Reserve name typ Nothing):decls) id block = + let + newName = "_temp_" ++ (show id) + id' = id + 1 + block' = mapBlockNames name newName block + block'' = substDeclName name newName block' + in + foldDeclsRenaming decls id' block'' + + +-- this is kind of horrible. that we do it this way, i mean +substDeclName n1 n2 (Block decls instrs) = + Block (map (s) decls) instrs + where + s d@(Reserve name typ Nothing) + | name == n1 = (Reserve n2 typ Nothing) + | otherwise = d + mapBlockNames n1 n2 (Block decls instrs) = (Block decls $ mapInstrsNames n1 n2 instrs) --- TODO: write this -mapInstrsNames n1 n2 instrs = instrs +mapInstrsNames n1 n2 instrs = + map (mapInstrName n1 n2) instrs + +mapInstrName n1 n2 (COPY sl1 sl2) = + COPY (mapStorageLocationName n1 n2 sl1) (mapStorageLocationName n1 n2 sl2) +mapInstrName n1 n2 (CMP sl1 sl2) = + CMP (mapStorageLocationName n1 n2 sl1) (mapStorageLocationName n1 n2 sl2) +mapInstrName n1 n2 (ADD sl1 sl2) = + ADD (mapStorageLocationName n1 n2 sl1) (mapStorageLocationName n1 n2 sl2) +mapInstrName n1 n2 (AND sl1 sl2) = + AND (mapStorageLocationName n1 n2 sl1) (mapStorageLocationName n1 n2 sl2) +mapInstrName n1 n2 (SUB sl1 sl2) = + SUB (mapStorageLocationName n1 n2 sl1) (mapStorageLocationName n1 n2 sl2) +mapInstrName n1 n2 (OR sl1 sl2) = + OR (mapStorageLocationName n1 n2 sl1) (mapStorageLocationName n1 n2 sl2) + +{- + | XOR StorageLocation StorageLocation + | SHL StorageLocation StorageLocation + | SHR StorageLocation StorageLocation + | BIT StorageLocation + | JMPVECTOR StorageLocation + | IF InternalID Branch Block Block + | REPEAT InternalID Branch Block + | DELTA StorageLocation DataValue + | WITH WithInstruction Block + | COPYROUTINE RoutineName StorageLocation +-} + +mapInstrName n1 n2 other = + other + +mapStorageLocationName n1 n2 (Indirect sl) = + Indirect $ mapStorageLocationName n1 n2 sl +mapStorageLocationName n1 n2 (Indexed sl1 sl2) = + Indexed (mapStorageLocationName n1 n2 sl1) sl2 +mapStorageLocationName n1 n2 (IndirectIndexed sl1 sl2) = + IndirectIndexed (mapStorageLocationName n1 n2 sl1) sl2 + +mapStorageLocationName n1 n2 sl@(NamedLocation typ name) + | name == n1 = NamedLocation typ n2 + | otherwise = sl + +mapStorageLocationName n1 n2 (LowByteOf sl) = + LowByteOf $ mapStorageLocationName n1 n2 sl + +mapStorageLocationName n1 n2 (HighByteOf sl) = + HighByteOf $ mapStorageLocationName n1 n2 sl + +mapStorageLocationName n1 n2 other = + other -- -- -- --