> module Swf.Assembler where -- arch-tag: c132961f-870e-4db5-b462-d4f56a59b921 > import Control.Monad.State > import Data.Bits > import Data.List > import Data.Maybe > import Data.Word > import GHC.Base > import GHC.Word > import GHC.Float > import Swf.Assembly > import Swf.Bin The problem is: We need a ``symbol table'' that maps labels to addresses. For backwards jumps, this is trivial, since the address of the label has already been calculated, but for forward jumps the address is not know yet. Perhaps the solution is similar to the function: "This sentence is " ++ (show n) ++ " characeters long". > type Label = String > type Position = Int > type SymTbl = [(Label,Position)] Function that assembles opcodes that have no operands/data > assembleSimple :: Word8 -> [SwfAssembly] -> Position -> SymTbl -> (SymTbl, [Word8]) > assembleSimple op asm pos symTbl = > let (newSymbols, objCode) = assemble asm (pos + 1) symTbl in > (newSymbols, op : objCode) > assemble :: [SwfAssembly] -> Position -> SymTbl -> (SymTbl, [Word8]) > assemble [] _ symTbl = ([],[]) SWF 3 Actions / Player Control Actions > assemble (ActionGotoFrame frameIndex : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 2) symTbl in > (newSymbols, 0x81 : (toBin (2 :: Word16)) ++ toBin frameIndex ++ objCode) > assemble (ActionGetURL url target : ops) pos symTbl = > let strLen = length url + 1 + length target + 1 > (newSymbols, objCode) = assemble ops (pos + 1 + 2 + strLen) symTbl in > (newSymbols, 0x83 : (toBin (fromIntegral strLen :: Word16)) ++ toBin url ++ toBin target ++ objCode) > assemble (ActionNextFrame : ops) pos symTbl = assembleSimple 0x04 ops pos symTbl > assemble (ActionPreviousFrame : ops) pos symTbl = assembleSimple 0x05 ops pos symTbl > assemble (ActionPlay : ops) pos symTbl = assembleSimple 0x06 ops pos symTbl > assemble (ActionStop : ops) pos symTbl = assembleSimple 0x07 ops pos symTbl > assemble (ActionToggleQuality : ops) pos symTbl = assembleSimple 0x08 ops pos symTbl > assemble (ActionStopSounds : ops) pos symTbl = assembleSimple 0x09 ops pos symTbl > assemble (ActionWaitForFrame frame skipCount : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 2 + 1) symTbl in > (newSymbols, 0x8A : (toBin (3 :: Word16)) ++ toBin frame ++ toBin skipCount ++ objCode) > assemble (ActionSetTarget targetName : ops) pos symTbl = > let strLen = length targetName + 1 > (newSymbols, objCode) = assemble ops (pos + 1 + 2 + strLen) symTbl in > (newSymbols, 0x8B : (toBin (fromIntegral strLen :: Word16)) ++ toBin targetName ++ objCode) > assemble (ActionGotoLabel label : ops) pos symTbl = > let strLen = length label + 1 > (newSymbols, objCode) = assemble ops (pos + 1 + 2 + strLen) symTbl in > (newSymbols, 0x8C : (toBin (fromIntegral strLen :: Word16)) ++ toBin label ++ objCode) Stack Operations > assemble (ActionPushString s : ops) pos symTbl = > let strlen = (length s) > (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1 + strlen + 1) symTbl in > (newSymbols, 0x96 : (toBin ((fromIntegral (strlen + 2)) :: Word16)) ++ [0] ++ (map (fromIntegral . fromEnum) s) ++ [0] ++ objCode) > assemble (ActionPushFloat f : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1 + 4) symTbl in > (newSymbols, 0x96 : toBin (5 :: Word16) ++ [0x01] ++ (toBin f) ++ objCode) > assemble (ActionPushNull : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1) symTbl in > (newSymbols, 0x96 : toBin (1 :: Word16) ++ [0x02] ++ objCode) > assemble (ActionPushUndefined : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1) symTbl in > (newSymbols, 0x96 : toBin (1 :: Word16) ++ [0x03] ++ objCode) > assemble (ActionPushRegister r : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1 + 1) symTbl in > (newSymbols, 0x96 : toBin (2 :: Word16) ++ [0x04] ++ (toBin r) ++ objCode) > assemble (ActionPushBool b : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1 + 1) symTbl in > (newSymbols, 0x96 : toBin (2 :: Word16) ++ [0x05] ++ (toBin (if b then (1 :: Word8) else 0)) ++ objCode) > assemble (ActionPushDouble d : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1 + 8) symTbl in > (newSymbols, 0x96 : toBin (9 :: Word16) ++ [0x06] ++ (toBin d) ++ objCode) > assemble (ActionPushInt i : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1 + 4) symTbl in > (newSymbols, 0x96 : toBin (5 :: Word16) ++ [0x07] ++ (toBin i) ++ objCode) > assemble (ActionPop : ops) pos symTbl = assembleSimple 0x17 ops pos symTbl > assemble (ActionBitAnd : ops) pos symTbl = assembleSimple 0x60 ops pos symTbl > assemble (ActionBitLShift : ops) pos symTbl = assembleSimple 0x63 ops pos symTbl > assemble (ActionBitOr : ops) pos symTbl = assembleSimple 0x61 ops pos symTbl > assemble (ActionBitRShift : ops) pos symTbl = assembleSimple 0x64 ops pos symTbl > assemble (ActionBitURShift : ops) pos symTbl = assembleSimple 0x65 ops pos symTbl > assemble (ActionBitXor : ops) pos symTbl = assembleSimple 0x62 ops pos symTbl > assemble (ActionDecrement : ops) pos symTbl = assembleSimple 0x51 ops pos symTbl > assemble (ActionIncrement : ops) pos symTbl = assembleSimple 0x50 ops pos symTbl > assemble (ActionPushDuplicate : ops) pos symTbl = assembleSimple 0x4C ops pos symTbl > assemble (ActionReturn : ops) pos symTbl = assembleSimple 0x3E ops pos symTbl > assemble (ActionStackSwap : ops) pos symTbl = assembleSimple 0x4D ops pos symTbl regNum should be limited to 0-3... > assemble (ActionStoreRegister regNum : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1) symTbl in > (newSymbols, 0x87 : toBin (1 :: Word16) ++ [regNum] ++ objCode) Arithemitc Operations > assemble (ActionAdd : ops) pos symTbl = assembleSimple 0x0A ops pos symTbl > assemble (ActionSubtract : ops) pos symTbl = assembleSimple 0x0B ops pos symTbl > assemble (ActionMultiply : ops) pos symTbl = assembleSimple 0x0C ops pos symTbl > assemble (ActionDivide : ops) pos symTbl = assembleSimple 0x0D ops pos symTbl > assemble (ActionAdd2 : ops) pos symTbl = assembleSimple 0x47 ops pos symTbl > assemble (ActionModulo : ops) pos symTbl = assembleSimple 0x3F ops pos symTbl Numeric Comparisons > assemble (ActionEquals : ops) pos symTbl = assembleSimple 0x0E ops pos symTbl > assemble (ActionLess : ops) pos symTbl = assembleSimple 0x0F ops pos symTbl > assemble (ActionLess2 : ops) pos symTbl = assembleSimple 0x48 ops pos symTbl > assemble (ActionGreater : ops) pos symTbl = assembleSimple 0x67 ops pos symTbl Logical Operators > assemble (ActionAnd : ops) pos symTbl = assembleSimple 0x10 ops pos symTbl > assemble (ActionOr : ops) pos symTbl = assembleSimple 0x11 ops pos symTbl > assemble (ActionNot : ops) pos symTbl = assembleSimple 0x12 ops pos symTbl String Manipulation > assemble (ActionStringEquals : ops) pos symTbl = assembleSimple 0x13 ops pos symTbl > assemble (ActionStringLength : ops) pos symTbl = assembleSimple 0x14 ops pos symTbl > assemble (ActionStringAdd : ops) pos symTbl = assembleSimple 0x21 ops pos symTbl > assemble (ActionStringExtract : ops) pos symTbl = assembleSimple 0x15 ops pos symTbl > assemble (ActionStringLess : ops) pos symTbl = assembleSimple 0x29 ops pos symTbl > assemble (ActionMBStringLength : ops) pos symTbl = assembleSimple 0x31 ops pos symTbl > assemble (ActionMBStringExtract : ops) pos symTbl = assembleSimple 0x35 ops pos symTbl > assemble (ActionStringGreater : ops) pos symTbl = assembleSimple 0x68 ops pos symTbl Type Conversion > assemble (ActionToInteger : ops) pos symTbl = assembleSimple 0x18 ops pos symTbl > assemble (ActionCharToAscii : ops) pos symTbl = assembleSimple 0x32 ops pos symTbl > assemble (ActionAsciiToChar : ops) pos symTbl = assembleSimple 0x33 ops pos symTbl > assemble (ActionMBCharToAscii : ops) pos symTbl = assembleSimple 0x36 ops pos symTbl > assemble (ActionMBAsciiToChar : ops) pos symTbl = assembleSimple 0x37 ops pos symTbl > assemble (ActionToNumber : ops) pos symTbl = assembleSimple 0x4A ops pos symTbl > assemble (ActionToString : ops) pos symTbl = assembleSimple 0x4B ops pos symTbl > assemble (ActionTypeOf : ops) pos symTbl = assembleSimple 0x44 ops pos symTbl > assemble (ActionCastOp : ops) pos symTbl = assembleSimple 0x2B ops pos symTbl Control Flow > assemble (Label lbl:ops) pos symTbl = > let (newSymbols,objCode) = assemble ops pos ((lbl,pos) : symTbl) in > ((lbl,pos) : newSymbols, objCode) > assemble (ActionJump lbl : ops) pos symTbl = > let dest = maybe (error ("could not find label: " ++ lbl)) id $ lookup lbl (symTbl ++ newSymbols) > (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 2) symTbl in > (newSymbols, 0x99 : toBin (2 :: Word16) ++ toBin ((fromIntegral (dest - (pos + 5))) :: Word16) ++ objCode) > assemble (ActionIf lbl : ops) pos symTbl = > let dest = maybe (error ("could not find label: " ++ lbl)) id $ lookup lbl (symTbl ++ newSymbols) > (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 2) symTbl in > (newSymbols, 0x9D : toBin (2 :: Word16) ++ toBin ((fromIntegral (dest - (pos + 5))) :: Word16) ++ objCode) Note that the high-bit is set, even though the opcode takes no operands. Tis a bug in swf. > assemble (ActionCall : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2) symTbl in > (newSymbols, 0x9E : 0x00 : 0x00 : objCode) Variables > assemble (ActionGetVariable : ops) pos symTbl = assembleSimple 0x1C ops pos symTbl > assemble (ActionSetVariable : ops) pos symTbl = assembleSimple 0x1D ops pos symTbl Movie Control > assemble (ActionGetURL2 method : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1) symTbl in > (newSymbols, 0x9A : toBin (1 :: Word16) ++ [method] ++ objCode) > assemble (ActionGotoFrame2 playFlag : ops) pos symTbl = > let playFlagWord8 = > if playFlag > then 1 > else 0 > (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1) symTbl in > (newSymbols, 0x9F : toBin (1 :: Word16) ++ [playFlagWord8] ++ objCode) > assemble (ActionSetTarget2 : ops) pos symTbl = assembleSimple 0x20 ops pos symTbl > assemble (ActionGetProperty : ops) pos symTbl = assembleSimple 0x22 ops pos symTbl > assemble (ActionSetProperty : ops) pos symTbl = assembleSimple 0x23 ops pos symTbl > assemble (ActionCloneSprite : ops) pos symTbl = assembleSimple 0x24 ops pos symTbl > assemble (ActionRemoveSprite : ops) pos symTbl = assembleSimple 0x25 ops pos symTbl > assemble (ActionStartDrag : ops) pos symTbl = assembleSimple 0x27 ops pos symTbl > assemble (ActionEndDrag : ops) pos symTbl = assembleSimple 0x28 ops pos symTbl > assemble (ActionWaitForFrame2 skipCount : ops) pos symTbl = > let (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 1) symTbl in > (newSymbols, 0x8D : toBin (1 :: Word16) ++ [skipCount] ++ objCode) Utilities > assemble (ActionTrace : ops) pos symTbl = assembleSimple 0x26 ops pos symTbl > assemble (ActionGetTime : ops) pos symTbl = assembleSimple 0x34 ops pos symTbl > assemble (ActionRandomNumber : ops) pos symTbl = assembleSimple 0x30 ops pos symTbl ScriptObject Actions > assemble (ActionCallFunction : ops) pos symTbl = assembleSimple 0x3D ops pos symTbl > assemble (ActionCallMethod : ops) pos symTbl = assembleSimple 0x52 ops pos symTbl > assemble (ActionConstantPool constants : ops) pos symTbl = > let poolLen = foldl (\len s -> len + 1 + length s) 0 constants > (newSymbols, objCode) = assemble ops (pos + 1 + 2 + 2 + poolLen) symTbl in > (newSymbols, 0x88 : toBin (2 + fromIntegral poolLen :: Word16) ++ > toBin (fromIntegral (length constants) :: Word16) ++ > (concatMap toBin constants) ++ objCode) > assemble (ActionDefineFunction name args body : ops) pos symTbl = > let (_,bodyObjCode) = assemble body 0 [] -- I don't think you can jump to a label that is not in the current function (symTbl ++ newSymbols) > nameStr = maybe [0x0] toBin name > codeSize = (fromIntegral (length bodyObjCode)) :: Word16 > numArgs = (fromIntegral (length args)) :: Word16 > argsLen = foldl (\len arg -> length arg + 1 + len) 0 args > immediateData = nameStr ++ toBin numArgs ++ concat (map toBin args) ++ toBin codeSize ++ bodyObjCode > (newSymbols,objCode) = assemble ops (pos + 1 + 2 + length immediateData) symTbl in > (newSymbols, 0x9B : toBin (((1 + maybe 0 (fromIntegral . length) name) + 2 + (fromIntegral argsLen) + 2) :: Word16) ++ immediateData ++ objCode) > assemble (ActionDefineLocal : ops) pos symTbl = assembleSimple 0x3C ops pos symTbl > assemble (ActionDefineLocal2 : ops) pos symTbl = assembleSimple 0x41 ops pos symTbl > assemble (ActionDelete : ops) pos symTbl = assembleSimple 0x3A ops pos symTbl > assemble (ActionDelete2 : ops) pos symTbl = assembleSimple 0x3B ops pos symTbl > assemble (ActionEnumerate : ops) pos symTbl = assembleSimple 0x46 ops pos symTbl > assemble (ActionEquals2 : ops) pos symTbl = assembleSimple 0x49 ops pos symTbl > assemble (ActionGetMember : ops) pos symTbl = assembleSimple 0x4E ops pos symTbl > assemble (ActionInitArray : ops) pos symTbl = assembleSimple 0x42 ops pos symTbl > assemble (ActionInitObject : ops) pos symTbl = assembleSimple 0x43 ops pos symTbl > assemble (ActionNewMethod : ops) pos symTbl = assembleSimple 0x53 ops pos symTbl > assemble (ActionNewObject : ops) pos symTbl = assembleSimple 0x40 ops pos symTbl > assemble (ActionSetMember : ops) pos symTbl = assembleSimple 0x4F ops pos symTbl > assemble (ActionTargetPath : ops) pos symTbl = assembleSimple 0x45 ops pos symTbl > assemble (ActionInstanceOf : ops) pos symTbl = assembleSimple 0x54 ops pos symTbl > assemble (ActionEnumerate2 : ops) pos symTbl = assembleSimple 0x55 ops pos symTbl > assemble (ActionStrictEquals : ops) pos symTbl = assembleSimple 0x66 ops pos symTbl assemble (ActionDefineFunction2 : ops) pos symTbl = > assemble (ActionExtends : ops) pos symTbl = assembleSimple 0x69 ops pos symTbl > assemble (ActionImplementsOp : ops) pos symTbl = assembleSimple 0x2C ops pos symTbl assemble (ActionTry : ops) pos symTbl = > assemble (ActionThrow : ops) pos symTbl = assembleSimple 0x2A ops pos symTbl From Usenet: a.. On page 78 of the FFFS, the following table is incorrect. withblock is not a STRING (null terminated), and is not part of the ActionWith bytecode. As I understand it -- withblock is a Size length PC forward offset into the bytecodes that follow, over which the ActionWith context extends (IMHO the description of this action in the spec could be somewhat improved). assemble (ActionWith : ops) pos symTbl = Other > assemble ((Comment _) : ops) pos symTbl = assemble ops pos symTbl > assemble (op : ops) pos symTbl = error ("Unhandle op " ++ show op) assemble pos (opcode:opcodes) symbols (Frag sym intermediate : needed_symbols) | isLabel opcode sym = pos : intermediate ++ assemble pos opcodes (addsym symbols sym pos) needed_symbols | data Frag = Frag String [Word8] This code is similar (i hope) to tying the knot. Whereis takes a symbol table and returns a symbol table. We fancily pass the data Lst a = Node a (Lst a) | LNil deriving Show findL :: Num a => a -> Lst a -> a findL a (Node a' rest) | a' == a*a = a' | otherwise = findL a rest mkList n = (Node n (mkList (n + 1))) takeL :: Int -> Lst a -> [a] takeL 0 _ = []tla chagnes takeL n (Node a rest) = a : (takeL (n - 1) rest) whereis :: Int -> Int -> [(Int,Int)] -> (Lst Int, [(Int,Int)]) whereis n acc sym | n == acc = let n' = fromJust $ lookup n sym' (rest,sym') = whereis n (acc + 1) sym in ((Node n' rest), sym') | acc == n*n = let sym' = (n,acc) : sym'' (rest, sym'') = whereis n (acc + 1) sym' in ((Node acc rest), sym') | acc == 10 = if tail [] == [1] then (LNil, sym) else (LNil, sym) | otherwise = let (rest,sym') = whereis n (acc + 1) sym in ((Node acc rest), sym') test = let (lst,sym) = whereis 3 0 [] in (takeL 10 lst,head sym) {- -- this one seems right whereis :: Int -> Int -> [(Int,Int)] -> (Lst Int, [(Int,Int)]) whereis n acc insym | n == acc = let n' = fromJust $ lookup n insym (rest,outsym') = whereis n (acc + 1) insym in ((Node n' rest), outsym') | acc == n*n = let (rest, outsym') = whereis n (acc + 1) insym in ((Node acc rest), (n,acc) : outsym') | acc == n*n*n = let (rest, outsym') = whereis n (acc + 1) insym in ((Node acc rest), (n,acc) : outsym') -- | acc == 10 = if tail [] == [1] -- then (LNil, sym) -- else (LNil, sym) | otherwise = let (rest,outsym') = whereis n (acc + 1) insym in ((Node acc rest), outsym') -} whereis :: Int -> Int -> [(Int,Int)] -> (Lst Int, [(Int,Int)]) whereis n acc insym | n == acc = let n' = fromJust $ lookup n (insym ++ sym) (rest,sym) = whereis n (acc + 1) insym in ((Node n' rest), sym) | acc == n*n = let (rest, sym) = whereis n (acc + 1) ((n,acc) : insym) in ((Node acc rest), (n,acc) : sym ) | acc == n*n+1 = let (rest, sym) = whereis n (acc + 1) ((n,acc) : insym) in ((Node acc rest), (n,acc) : sym ) | acc == n*n*n = let (rest, sym) = whereis n (acc + 1) ((n,acc) : insym) in ((Node acc rest), (n,acc) : sym ) {- | acc == 28 = if (tail [] == [1]) then (LNil, insym) else (LNil, insym) -} -- | acc == 30 = (LNil, []) -- | acc == 10 = if tail [] == [1] -- then (LNil, sym) -- else (LNil, sym) | otherwise = let (rest,outsym') = whereis n (acc + 1) insym in ((Node acc rest), outsym')