blob: 71e69434c0e78d6a73a8454f607ddada92b20705 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
{-# LANGUAGE BinaryLiterals #-}
module Device where
import Prelude hiding (Word)
import Data.Word (Word32, Word16, Word8)
import Data.IORef
import Data.Char
import Data.List
import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO)
import System.IO
import Data.String
import Data.ByteString
import Machine
import Network.Socket
getSock :: Long -> Emulator (Maybe Handle)
getSock a | a < 0x900000 = do { m <- ask; liftIO $ sock (c0 m) (s0 m) }
| a < 0xa00000 = do { m <- ask; liftIO $ sock (c1 m) (s1 m) }
| a < 0xb00000 = do { m <- ask; liftIO $ sock (c2 m) (s2 m) }
| a < 0xc00000 = do { m <- ask; liftIO $ sock (c3 m) (s3 m) }
| a < 0xd00000 = do { m <- ask; liftIO $ sock (c4 m) (s4 m) }
| a < 0xe00000 = do { m <- ask; liftIO $ sock (c5 m) (s5 m) }
| a < 0xf00000 = do { m <- ask; liftIO $ sock (c6 m) (s6 m) }
| otherwise = do { m <- ask; liftIO $ sock (c7 m) (s7 m) }
where
sock c (Just s) = do
cval <- readIORef c
case cval of
(Just val) -> return $ Just val
Nothing -> do
(newsock, _) <- accept s
handle <- socketToHandle newsock ReadWriteMode
writeIORef c $ Just handle
return $ Just handle
sock _ _ = return Nothing
toStr = Prelude.map (chr . fromEnum) . unpack
-------------------------------------------------------------------------------
-- Protocol Constants
-- Protocol itself is simple,
-- suem send commands to devices, they response.
-- Example communication:
-- s: h ababe
-- d: o 07
-- s: W ababe 1999
-- d: o
-- d: i
-- s: l abab3
-- d: x
-- All numbers are in hex and have correct length
-- (zeroes on the left are mandatory).
-- requests
device_get_high_byte = "h" -- <5 hexes>; 2 hexes in response
device_get_low_byte = "l" -- <5 hexes>; 2 hexes in response
device_get_word = "w" -- <5 hexes>; 4 hexes in response
device_set_high_byte = "H" -- <5 hexes> <2 hexes>
device_set_low_byte = "L" -- <5 hexes> <2 hexes>
device_set_word = "W" -- <5 hexes> <4 hexes>
-- responses
device_interrupt = "i" -- and nothing else
device_ok = "o" -- maybe number in response to get (with correct size)
device_bad = "x" -- and nothing else =)
toHex :: Long -> Int -> String
toHex _ 0 = ""
toHex num digits = toHex (div num 16) (digits - 1)
++ ["0123456789abcdef"
!! fromIntegral (num `mod` fromIntegral 16)]
fromHex :: String -> Int -> Long -> Long
fromHex _ 0 a = a
fromHex (d:ds) n a = fromHex ds (n - 1)
(a * (fromIntegral 16) + maybe (error "") fromIntegral
(Data.List.elemIndex d "0123456789abcdef"))
readOk :: Handle -> Emulator ()
readOk h = do
line <- liftIO $ Data.ByteString.hGetLine h
if line == fromString device_ok
then return ()
else if line == fromString device_bad
then error "Device sent BAD signal."
else if line == fromString device_interrupt
then readOk h -- doInterrupt
else error "Unknown Device Protocol Line."
readOkWord :: Handle -> Emulator Word
readOkWord h = do
line <- liftIO $ Data.ByteString.hGetLine h
if fromString device_ok `Data.ByteString.isPrefixOf` line
then let (_:ltail) = Prelude.drop (Prelude.length device_ok) (toStr line)
in return $ fromIntegral $ fromHex ltail 4 (fromIntegral 0)
else if line == fromString device_bad
then error "Device sent BAD signal."
else if line == fromString device_interrupt
then readOkWord h -- doInterrupt
else error "Unknown Device Protocol Line."
-------------------------------------------------------------------------------
-- Memory
deviceGetByte :: Long -> Emulator Byte
deviceGetByte a | a `mod` 2 == 0 = return 0xFF
| otherwise = return 0xFF
deviceGetWord :: Long -> Emulator Word
deviceGetWord a = do
handle <- getSock a
if handle == Nothing
then return 0xffff
else do
let (Just h) = handle
liftIO $ hPut h $ fromString $
device_get_word ++ " " ++ toHex a 5 ++"\n"
readOkWord h
deviceSetByte :: Long -> Byte -> Emulator ()
deviceSetByte a b
| a `mod` 2 == 0 = do
handle <- getSock a
if handle == Nothing
then return ()
else do
let (Just h) = handle
liftIO $ hPut h $ fromString $
device_set_high_byte ++ " " ++ toHex a 5 ++ " "
++ toHex (fromIntegral b) 2 ++"\n"
readOk h
| otherwise = do
handle <- getSock a
if handle == Nothing
then return ()
else do
let (Just h) = handle
liftIO $ hPut h $ fromString $
device_set_low_byte ++ " " ++ toHex a 5 ++ " "
++ toHex (fromIntegral b) 2 ++"\n"
readOk h
deviceSetWord :: Long -> Word -> Emulator ()
deviceSetWord a w = do
handle <- getSock a
if handle == Nothing
then return ()
else do
let (Just h) = handle
liftIO $ hPut h $ fromString $
device_set_word ++ " " ++ toHex a 5 ++ " "
++ toHex (fromIntegral w) 4 ++"\n"
readOk h
-------------------------------------------------------------------------------
-- Interrupts
checkInteruptsFromDevices :: Emulator ()
checkInteruptsFromDevices = return ()
|
