Add the draftHEADmaster

The initial language description, its basic interpreter, and an
example program are added.

4 files changed, 355 insertions, 0 deletions

diff --git a/README b/README
new file mode 100644
index 0000000..4a8d928
--- /dev/null
+++ b/README
@@ -0,0 +1,42 @@
+A state transition language, for state and stack machines.
+
+Made to play with, without practical applications in mind. Intended to
+be simple.
+
+The basic idea is to define transitions on sequences of bits. For
+instance, a 2-bit increment (with overflow) machine:
+
+0 0 . 0 1
+0 1 . 1 0
+1 0 . 1 1
+1 1 . 0 0
+
+For compactness, wildcards and references are supported:
+
+_ 0 . ^0 1
+0 _ . 1 0
+_ _ . 0 0
+
+Only the matched part of a state changes, so it is suitable for
+defining reusable subroutines. Left-hand side and right-hand side may
+be of the same length, making it a state machine, or they may vary in
+length, so that it behaves rather like a stack.
+
+Basic syntactic sugar allows to employ hexadecimal numbers, strings,
+wildcards of a given length, and range references.
+
+Memory reading, writing, and syscalls are implemented with built-in
+(or "external", "magic") "subroutines":
+
+# request to write the x2a byte into memory at a 64-bit address given
+# after "test"
+'test _x40 . 'mwr? ^x20+x3f x2a 'step2
+
+# call exit(42) afterwards
+'mwr. _x40 _x8 'step2 . 'req1 x000000000000003c x000000000000002a
+
+
+An interpreter is implemented here in Haskell, along with an example
+program. To run it:
+
+cabal run < hello.stm ; echo $?
diff --git a/Stamp.hs b/Stamp.hs
new file mode 100644
index 0000000..b19929d
--- /dev/null
+++ b/Stamp.hs
@@ -0,0 +1,227 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import qualified Data.ByteString as BS
+import Data.List
+import Foreign.C.String
+import Foreign.Ptr
+import Foreign.Storable
+import Numeric
+import Data.Word
+import Data.Bits
+import Data.Char
+import Data.Proxy
+import Data.Maybe
+import Text.Parsec hiding (State)
+import Data.List.Split (chunksOf)
+-- import Text.Parsec.ByteString
+
+
+foreign import ccall "syscall" syscall0 :: Int -> IO Int
+foreign import ccall "syscall" syscall1 :: Int -> Int -> IO Int
+foreign import ccall "syscall" syscall2 :: Int -> Int -> Int -> IO Int
+foreign import ccall "syscall" syscall3 :: Int -> Int -> Int -> Int -> IO Int
+foreign import ccall "syscall" syscall4
+  :: Int -> Int -> Int -> Int -> Int -> IO Int
+foreign import ccall "syscall" syscall5
+  :: Int -> Int -> Int -> Int -> Int -> Int -> IO Int
+foreign import ccall "syscall" syscall6
+  :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO Int
+
+data LHSToken = LWildcard | LBit Bool
+  deriving (Show)
+data RHSToken = RRef Int | RBit Bool
+  deriving (Show)
+data Transition = Transition [LHSToken] [RHSToken]
+  deriving (Show)
+type Program = [Transition]
+type State = [Bool]
+
+matchesState :: State -> [LHSToken] -> Bool
+matchesState s l = bitsMatch s l
+  where
+    bitsMatch [] [] = True
+    bitsMatch _ [] = True
+    bitsMatch [] _ = False
+    bitsMatch (_:st) (LWildcard:lhs) = bitsMatch st lhs
+    bitsMatch (b1:st) (LBit b2:lhs) = b1 == b2 && bitsMatch st lhs
+
+iter :: Program -> State -> Either String State
+iter p s = case find (matchesState s . (\(Transition l _) -> l)) p of
+  Nothing -> Left "No matching pattern found"
+  Just (Transition l r) -> do
+    transitioned <- mapM transition r
+    pure $ transitioned ++ drop (length l) s
+  where
+    transition (RBit b) = Right b
+    transition (RRef n)
+      | length s > n = Right $ s !! n
+      | otherwise =
+        Left $ "The referenced index " ++ show n
+           ++ " is out of state bounds for state of length " ++ show (length s)
+
+iterIO :: Program -> State -> IO (Either String State)
+iterIO p s
+  | take 24 s == strBits "req" =
+    case bitsToChar (take 8 $ drop 24 s) of
+      'r' -> do
+        w8 <- peek (ptrAt 32) :: IO Word8
+        pure $ Right $ strBits "repr" ++ fbToBits w8 ++ drop (32 + 8) s
+      'w' -> do
+        poke (ptrAt 32) (fbAt (Proxy :: Proxy Word8) (32 + intSz))
+        pure $ Right $ strBits "repw" ++ drop 32 s
+      c -> if c >= '0' && c <= '6'
+           then do
+        r <- case c of
+          '0' -> syscall0 (intAt 32)
+          '1' -> syscall1 (intAt 32) (intAt (32 + intSz))
+          '2' -> syscall2 (intAt 32) (intAt (32 + intSz)) (intAt (32 + intSz * 2))
+          '3' -> syscall3 (intAt 32) (intAt (32 + intSz)) (intAt (32 + intSz * 2))
+            (intAt (32 + intSz * 3))
+          '4' -> syscall4 (intAt 32) (intAt (32 + intSz)) (intAt (32 + intSz * 2))
+            (intAt (32 + intSz * 3)) (intAt (32 + intSz * 4))
+          '5' -> syscall5 (intAt 32) (intAt (32 + intSz)) (intAt (32 + intSz * 2))
+            (intAt (32 + intSz * 3)) (intAt (32 + intSz * 4))
+            (intAt (32 + intSz * 5))
+          '6' -> syscall6 (intAt 32) (intAt (32 + intSz)) (intAt (32 + intSz * 2))
+            (intAt (32 + intSz * 3)) (intAt (32 + intSz * 4))
+            (intAt (32 + intSz * 5)) (intAt (32 + intSz * 6))
+        pure $ Right $ strBits ("rep" ++ [c]) ++ fbToBits r ++ drop (32 + intSz) s
+           else pure $ Left $ "An unknown sys command: " ++ [c]
+  | otherwise = pure $ iter p s
+  where
+    intSz = finiteBitSize (0 :: Int)
+    fbAt :: FiniteBits a => Proxy a -> Int -> a
+    fbAt (Proxy :: Proxy a) offset =
+      bitsToFB (take (finiteBitSize (zeroBits :: a)) (drop offset s))
+    intAt :: Int -> Int
+    intAt = fbAt (Proxy :: Proxy Int)
+    ptrAt offset = wordPtrToPtr (WordPtr (fbAt (Proxy :: Proxy Word) offset))
+
+run :: Program -> State -> IO (Either String State)
+run p s = do
+  let asBinary True = '1'
+      asBinary False = '0'
+  -- putStrLn $ map asBinary s
+  -- putStrLn $ map bitsToChar $ chunksOf 8 s
+  r <- iterIO p s
+  case r of
+    Left err -> pure $ Left err
+    Right s' -> run p s'
+
+main :: IO ()
+main = do
+  c <- BS.getContents
+  case runParser pProgram () "input" c of
+    Right p -> do
+      -- print p
+      print =<< run p (strBits "start")
+    Left err -> print err
+
+fbToBits :: FiniteBits a => a -> [Bool]
+fbToBits bits = let sz = finiteBitSize bits in
+            [ testBit bits (sz - n) | n <- [1..sz] ]
+
+bitsToFB :: FiniteBits a => [Bool] -> a
+bitsToFB [] = zeroBits
+bitsToFB (True:xs) = setBit (bitsToFB xs) (length xs)
+bitsToFB (False:xs) = bitsToFB xs
+
+charToBits :: Char -> [Bool]
+charToBits c
+  | ord c < 128 = fbToBits (fromIntegral (ord c) :: Word8)
+
+bitsToChar :: [Bool] -> Char
+bitsToChar b = chr $ fromIntegral (bitsToFB b :: Word8)
+
+bsBits :: BS.ByteString -> [Bool]
+bsBits = concatMap fbToBits . BS.unpack
+
+strBits :: String -> [Bool]
+strBits = concatMap charToBits
+
+-- data ParserState = PS { lhsBits :: Int
+--                       , rhsBits :: Int
+--                       } deriving (Show, Eq)
+
+type Parser = Parsec BS.ByteString ()
+
+pHex :: Parser (Integer, Int)
+pHex = do
+  char 'x'
+  digits <- many1 hexDigit
+  let bitNum = length digits * 4
+      [(n, "")] = readHex digits
+  pure (n, bitNum)
+
+pBin :: Parser (Integer, Int)
+pBin = do
+  digits <- many1 (oneOf ['0', '1'])
+  let bitNum = length digits
+      [(n, "")] =
+        readInt 2 (`elem` ("01" :: String)) (\x -> ord x - 0x30) digits
+  pure (n, bitNum)
+
+pChars :: Parser [Bool]
+pChars = do
+  char '\''
+  c <- anyChar
+  cs <- many (noneOf " \n")
+  pure $ concatMap charToBits (c:cs)
+
+pNum :: Parser (Integer, Int)
+pNum = choice [pHex, pBin]
+
+pNum' :: Parser Integer
+pNum' = fst <$> pNum
+
+pNumBits :: Parser [Bool]
+pNumBits = do
+  (n, nBits) <- pNum
+  pure $ map (\pos -> testBit n (nBits - pos)) [1..nBits]
+
+pWildcard :: Parser [LHSToken]
+pWildcard = char '_' *>
+            (((\n -> replicate (fromIntegral n) LWildcard) <$> pNum')
+              <|> pure [LWildcard])
+
+pLHS :: Parser [LHSToken]
+pLHS = choice
+  [ map LBit <$> pNumBits
+  , map LBit <$> pChars
+  , pWildcard
+  ]
+
+pRef :: Parser [RHSToken]
+pRef = do
+  char '^'
+  from <- pNum'
+  len <- option 0 (char '+' *> pNum')
+  pure $ map (RRef . fromInteger) [from..from + len]
+
+pRHS :: Parser [RHSToken]
+pRHS = choice
+  [ map RBit <$> pNumBits
+  , map RBit <$> pChars
+  , pRef
+  ]
+
+pTransition :: Parser Transition
+pTransition = do
+  lhs <- concat <$> (pLHS `sepEndBy` char ' ') <?> "LHS"
+  string ". "
+  rhs <- concat <$> (pRHS `sepBy` char ' ') <?> "RHS"
+  pure $ Transition lhs rhs
+
+pComment :: Parser String
+pComment = char '#' *> many (noneOf "\n")
+
+pProgramLine :: Parser (Maybe Transition)
+pProgramLine = (pComment *> pure Nothing)
+               <|> (pure <$> pTransition)
+
+pProgram :: Parser Program
+pProgram =
+  catMaybes <$> (pProgramLine <?> "transition") `sepEndBy1` (many1 newline)
+  <* eof
diff --git a/hello.stm b/hello.stm
new file mode 100644
index 0000000..ff1a5d0
--- /dev/null
+++ b/hello.stm
@@ -0,0 +1,50 @@
+# inc: increment a 64-bit number (incomplete)
+
+'inc? _x3f 0 . 'inc. ^x20+x3e 1
+'inc? _x3e 0 1 . 'inc. ^x20+x3d 10
+'inc? _x3d 0 11 . 'inc. ^x20+x3c 100
+'inc? _x3c 0 111 . 'inc. ^x20+x3b 1000
+'inc? _x3b 0 xf . 'inc. ^x20+x3a 1 x0
+'inc? _x3a 0 1 xf . 'inc. ^x20+x39 10 x0
+'inc? _x39 0 11 xf . 'inc. ^x20+x38 100 x0
+'inc? _x38 0 111 xf . 'inc. ^x20+x37 1000 x0
+'inc? _x37 0 xff . 'inc. ^x20+x36 1 x00
+'inc? _x36 0 1 xff . 'inc. ^x20+x35 10 x00
+'inc? _x35 0 11 xff . 'inc. ^x20+x34 100 x00
+'inc? _x34 0 111 xff . 'inc. ^x20+x33 1000 x00
+'inc? _x33 0 xfff . 'inc. ^x20+x32 1 x000
+'inc? _x32 0 1 xfff . 'inc. ^x20+x31 10 x000
+'inc? _x31 0 11 xfff . 'inc. ^x20+x30 100 x000
+'inc? _x30 0 111 xfff . 'inc. ^x20+x2f 1000 x000
+'inc? _x2f 0 xffff . 'inc. ^x20+x2e 1 x0000
+'inc? _x2e 0 1 xffff . 'inc. ^x20+x2d 10 x0000
+'inc? _x2d 0 11 xffff . 'inc. ^x20+x2c 100 x0000
+
+# mwr: write a byte into memory, increment the pointer
+
+'mwr? _x40 _x8 . 'reqw ^x20+x3f ^x60+x7 'mwr.
+'repw _x40 _x8 'mwr. . 'inc? ^x20+x3f ^x60+x7 'mwr.
+'inc. _x40 _x8 'mwr. . 'mwr. ^x20+x3f ^x60+x7
+
+
+# start: allocate memory with
+# mmap(NULL, 4096, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, NULL, 0)
+# mmap = 9
+# PROT_READ = 0x1, PROT_WRITE = 0x2
+# MAP_SHARED = 0x01, MAP_PRIVATE = 0x02, MAP_SHARED_VALIDATE = 0x03,
+# MAP_ANONYMOUS = 0x20
+'start . 'req6 x0000000000000009 x0000000000000000 x0000000000001000 x0000000000000003 x0000000000000022 x0000000000000000 x0000000000000000 'allocated
+
+# Prepare the "hello\n" message in the allocated memory
+'rep6 _x1c0 'allocated . 'mwr? ^x20+x3f 'h ^x20+x3f 'hello-1
+'mwr. _x40 _x8 _x40 'hello-1 . 'mwr? ^x20+x3f 'e ^x68+x3f 'hello-2
+'mwr. _x40 _x8 _x40 'hello-2 . 'mwr? ^x20+x3f 'l ^x68+x3f 'hello-3
+'mwr. _x40 _x8 _x40 'hello-3 . 'mwr? ^x20+x3f 'l ^x68+x3f 'hello-4
+'mwr. _x40 _x8 _x40 'hello-4 . 'mwr? ^x20+x3f 'o ^x68+x3f 'hello-5
+'mwr. _x40 _x8 _x40 'hello-5 . 'mwr? ^x20+x3f x0a ^x68+x3f 'hello-6
+
+# Call write(1, ptr, 6)
+'mwr. _x40 _x8 _x40 'hello-6 . 'req3 x0000000000000001 x0000000000000001 ^x68+x3f x0000000000000006 'wrote
+
+# Call exit(42)
+'rep3 _x40 _x40 _x40 _x40 'wrote . 'req1 x000000000000003c x000000000000002a
diff --git a/stamp.cabal b/stamp.cabal
new file mode 100644
index 0000000..ba1150b
--- /dev/null
+++ b/stamp.cabal
@@ -0,0 +1,36 @@
+cabal-version:      2.4
+name:               stamp
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- A URL where users can report bugs.
+-- bug-reports:
+
+-- The license under which the package is released.
+license:            MIT
+author:             defanor
+maintainer:         defanor@thunix.net
+
+-- A copyright notice.
+-- copyright:
+-- category:
+-- extra-source-files: CHANGELOG.md
+
+executable stamp
+    main-is:          Stamp.hs
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+    build-depends:    base >= 4.7 && < 5
+                    , bytestring >= 0.10
+                    , parsec >= 3 && < 4
+                    , split >= 0.2 && < 1
+    default-language: Haskell2010