VegOwOtenks/ubcf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

implemented the program

Browse source
This commit is contained in:
VegOwOtenks 2024-09-26 23:58:27 +02:00
commit 807ea6f130
16 changed files with 517 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored Normal file
View file

@ -0,0 +1,2 @@
.stack-work/
*~

11
CHANGELOG.md Normal file
View file

@ -0,0 +1,11 @@
# Changelog for `ubcf`
All notable changes to this project will be documented in this file.
The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
and this project adheres to the
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
## Unreleased
## 0.1.0.0 - YYYY-MM-DD

26
LICENSE Normal file
View file

@ -0,0 +1,26 @@
Copyright 2024 VegOwOtenks
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
3. Neither the name of the copyright holder nor the names of its contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

3
README.md Normal file
View file

@ -0,0 +1,3 @@
# ubcf
brainfuck to ubc compiler
assumes the output will be on the ubcf-runtime

2
Setup.hs Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

18
app/Main.hs Normal file
View file

@ -0,0 +1,18 @@
module Main (main) where
import Lib
import Control.Monad (mapM_)
import Data.Binary (Word32, Word8, encode)
import Data.Bits
import qualified Data.ByteString.Lazy as BL
convertWord32 :: Word32 -> [Word8]
convertWord32 w = [fromIntegral (w), fromIntegral (w .>>. 8), fromIntegral (w .>>. 16), fromIntegral (w .>>. 24)]
main :: IO ()
main = do
s <- getContents
let tokens = tokenize s
case parseTokens tokens of
Left err -> putStr err
Right ops -> mapM_ (BL.putStr . encode) . (concatMap (convertWord32)) $ (compile ops)

61
package.yaml Normal file
View file

@ -0,0 +1,61 @@
name: ubcf
version: 0.1.0.0
github: "githubuser/ubcf"
license: BSD-3-Clause
author: "VegOwOtenks"
maintainer: "vegowotenks@jossco.de"
copyright: "AGPL3"
extra-source-files:
- README.md
- CHANGELOG.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/githubuser/ubcf#readme>
dependencies:
- base >= 4.7 && < 5
- binary
- bytestring
ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wmissing-export-lists
- -Wmissing-home-modules
- -Wpartial-fields
- -Wredundant-constraints
library:
source-dirs: src
executables:
ubcf-exe:
main: Main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- ubcf
tests:
ubcf-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- ubcf

205
src/Lib.hs Normal file
View file

@ -0,0 +1,205 @@
module Lib
( tokenize, BrainFuckToken, parseTokens, BrainFuckOperation, compile, CompileState
) where
import Control.Monad (liftM)
import qualified Data.Word as Word
import Data.Bits
import Data.Int (Int32)
data BrainFuckToken = OperatorPlus Int | OperatorMinus Int | OperatorLeft Int | OperatorRight Int | OperatorSkip | OperatorContinue | OperatorPut | OperatorRead | Comment String
deriving Show
partitionOn :: (a -> Bool) -> [a] -> ([a], [a])
partitionOn condition (a:as)
| condition a = ([], a:as)
| otherwise = (a:pre, post)
where
(pre, post) = partitionOn condition as
partitionOn _ [] = ([], [])
tokenizeQuantified :: Char -> String -> (Int -> BrainFuckToken) -> [BrainFuckToken]
tokenizeQuantified target cs constructor = constructor (length targetPartition) : tokenize restPartition
where
(targetPartition, restPartition) = partitionOn (/=target) cs
tokenizeComment :: String -> [BrainFuckToken]
tokenizeComment s = Comment comment : tokenize rest
where
(comment, rest) = partitionOn (flip elem "+-<>[]") s
tokenize :: String -> [BrainFuckToken]
tokenize [] = []
tokenize (c:cs)
| c == '+' = tokenizeQuantified '+' (c:cs) OperatorPlus
| c == '-' = tokenizeQuantified '-' (c:cs) OperatorMinus
| c == '<' = tokenizeQuantified '<' (c:cs) OperatorLeft
| c == '>' = tokenizeQuantified '>' (c:cs) OperatorRight
| c == '[' = OperatorSkip : tokenize cs
| c == ']' = OperatorContinue : tokenize cs
| c == '.' = OperatorPut : tokenize cs
| c == ',' = OperatorRead : tokenize cs
| otherwise = tokenizeComment (c:cs)
data BrainFuckOperation = IncrementCell Int | DecrementCell Int | MoveLeft Int | MoveRight Int | PutChar | ReadChar | Conditionally [BrainFuckOperation]
deriving Show
parseTokens :: [BrainFuckToken] -> Either String [BrainFuckOperation]
parseTokens ts = liftM (fst) (parseTokens' 0 ts)
parseTokens' :: Int -> [BrainFuckToken] -> Either String ([BrainFuckOperation], [BrainFuckToken])
parseTokens' 0 [] = Right ([], [])
parseTokens' n [] = Left ("Missing " ++ show n ++ " closing brackets ']'")
parseTokens' l (OperatorPlus amount:ts) = liftM (\t -> (IncrementCell amount:fst t, snd t)) (parseTokens' l ts)
parseTokens' l (OperatorMinus amount:ts) = liftM (\t -> (DecrementCell amount:fst t, snd t)) (parseTokens' l ts)
parseTokens' l (OperatorLeft amount:ts) = liftM (\t -> (MoveLeft amount:fst t, snd t)) (parseTokens' l ts)
parseTokens' l (OperatorRight amount:ts) = liftM (\t -> (MoveRight amount:fst t, snd t)) (parseTokens' l ts)
parseTokens' l (OperatorSkip :ts) = either (Left) (\(cs, _) -> either (Left) (Right . \(os, rs) -> (Conditionally cs:os, rs)) r) t
where
t = parseTokens' (l+1) ts
r = either (Left) (parseTokens' l . snd) t
parseTokens' 0 (OperatorContinue :_) = Left ("Found ] when there was none expected")
parseTokens' _ (OperatorContinue :ts) = Right ([], ts)
parseTokens' l (OperatorPut :ts) = liftM (\t -> ( PutChar:fst t, snd t)) (parseTokens' l ts)
parseTokens' l (OperatorRead :ts) = liftM (\t -> (ReadChar:fst t, snd t)) (parseTokens' l ts)
parseTokens' l (Comment _ :ts) = parseTokens' l ts
ubcOpcodeLoadUpper :: Word.Word32
ubcOpcodeLoadUpper = 0x02000000
ubcOpcodeLoadLower :: Word.Word32
ubcOpcodeLoadLower = 0x03000000
ubcOpcodeMem2Reg :: Word.Word32
ubcOpcodeMem2Reg = 0x04000000
ubcOpcodeReg2Mem :: Word.Word32
ubcOpcodeReg2Mem = 0x05000000
ubcOpcodeJumpRel :: Word.Word32
ubcOpcodeJumpRel = 0x09000000
ubcOpcodeForeignCall :: Word.Word32
ubcOpcodeForeignCall = 0x0F000000
ubcOpcodeAddU :: Word.Word32
ubcOpcodeAddU = 0x80000000
ubcOpcodeSubU :: Word.Word32
ubcOpcodeSubU = 0x81000000
ubcOpcodeCmpU :: Word.Word32
ubcOpcodeCmpU = 0x89000000
ubcConditionNone :: Word.Word32
ubcConditionNone = 0x00000000
ubcConditionEq :: Word.Word32
ubcConditionEq = 0x00800000
ubcForeignCall :: Int32 -> Word.Word32
ubcForeignCall r = ubcOpcodeForeignCall .|. ubcInstructionRegArg1 r
ubcInstructionRegArg1 :: Int32 -> Word.Word32
ubcInstructionRegArg1 r
| r < 16 = (shiftL (fromIntegral r .&. 0xF) 16)
| otherwise = error "Register index > 16"
ubcInstructionRegArg2 :: Int32 -> Word.Word32
ubcInstructionRegArg2 r
| r < 16 = (shiftL (fromIntegral r .&. 0xF) 12)
| otherwise = error "Register index > 16"
ubcInstructionRegArg3 :: Int32 -> Word.Word32
ubcInstructionRegArg3 r
| r < 16 = (shiftL (fromIntegral r .&. 0xF) 8)
| otherwise = error "Register index > 16"
ubcInstructionPayLoad :: Word.Word32 -> Word.Word32
ubcInstructionPayLoad w = 0x0000FFFF .&. w
ubcLoadUpper :: Word.Word16 -> Int32 -> Word.Word32
ubcLoadUpper w r = ubcOpcodeLoadUpper .|. ubcInstructionRegArg1 r .|. ubcInstructionPayLoad (fromIntegral w)
ubcLoadLower :: Word.Word16 -> Int32 -> Word.Word32
ubcLoadLower w r = ubcOpcodeLoadLower .|. ubcInstructionRegArg1 r .|. ubcInstructionPayLoad (fromIntegral w)
ubcLoadIntWords :: Int32 -> Int32 -> [Word.Word32]
ubcLoadIntWords i r = [ubcLoadUpper (fromIntegral u) r, ubcLoadLower (fromIntegral l) r]
where
w = fromIntegral i :: Word.Word32
u = w .>>. 16
l = w .&. 0xFFFF
ubcCmpU :: Int32 -> Int32 -> Word.Word32
ubcCmpU a b = ubcOpcodeCmpU .|. ubcInstructionRegArg1 a .|. ubcInstructionRegArg2 b
ubcJumpRel :: Int32 -> Int32 -> Word.Word32 -> [Word.Word32]
ubcJumpRel d r c = ubcLoadIntWords d r ++ [ubcOpcodeJumpRel .|. ubcInstructionRegArg1 r .|. c]
ubcLoadCellWord :: Int32 -> Word.Word32
ubcLoadCellWord r = ubcOpcodeMem2Reg .|. ubcConditionNone .|. ubcInstructionRegArg1 r .|. ubcInstructionRegArg2 0
ubcStoreCellWord :: Int32 -> Word.Word32
ubcStoreCellWord r = ubcOpcodeReg2Mem .|. ubcInstructionRegArg1 0 .|. ubcInstructionRegArg2 r
ubcAddWord :: Int32 -> Int32 -> Int32 -> Word.Word32
ubcAddWord d a b = ubcOpcodeAddU .|. ubcInstructionRegArg1 d .|. ubcInstructionRegArg2 a .|. ubcInstructionRegArg3 b
ubcSubWord :: Int32 -> Int32 -> Int32 -> Word.Word32
ubcSubWord d a b = ubcOpcodeSubU .|. ubcInstructionRegArg1 d .|. ubcInstructionRegArg2 a .|. ubcInstructionRegArg3 b
ubcIncrementRegisterWords :: Int32 -> Int32 -> Int32 -> [Word.Word32]
ubcIncrementRegisterWords i ir cr = ubcLoadIntWords i ir ++ [ubcAddWord cr cr ir]
ubcDecrementRegisterWords :: Int32 -> Int32 -> Int32 -> [Word.Word32]
ubcDecrementRegisterWords i ir cr = ubcLoadIntWords i ir ++ [ubcSubWord cr cr ir]
data CompileState = CompileState { isCellLoaded :: Bool, isCellModified :: Bool }
compileIncrement :: CompileState -> Int32 -> [BrainFuckOperation] -> [Word.Word32]
compileIncrement state i os
| isCellLoaded state = ubcIncrementRegisterWords i 2 1 ++ compile' (state{isCellModified=True}) os
| otherwise = ubcLoadCellWord 1 : compileIncrement (state{isCellLoaded=True}) i os
compileDecrement :: CompileState -> Int32 -> [BrainFuckOperation] -> [Word.Word32]
compileDecrement state i os
| isCellLoaded state = ubcDecrementRegisterWords i 2 1 ++ compile' (state{isCellModified=True}) os
| otherwise = ubcLoadCellWord 1 : compileIncrement (state{isCellLoaded=True}) i os
compileMoveLeft :: CompileState -> Int32 -> [BrainFuckOperation] -> [Word.Word32]
compileMoveLeft state d os
| isCellModified state = ubcStoreCellWord 1 : compileMoveLeft (state{isCellModified=False}) d os
| otherwise = ubcDecrementRegisterWords d 2 0 ++ compile' (state{isCellLoaded=False}) os
compileMoveRight :: CompileState -> Int32 -> [BrainFuckOperation] -> [Word.Word32]
compileMoveRight state d os
| isCellModified state = ubcStoreCellWord 1 : compileMoveLeft (state{isCellModified=False}) d os
| otherwise = ubcIncrementRegisterWords d 2 0 ++ compile' (state{isCellLoaded=False}) os
compileConditionally :: CompileState -> [BrainFuckOperation] -> [BrainFuckOperation] -> [Word.Word32]
compileConditionally s cs os
| isCellLoaded s = skipBlock ++ contained ++ continueBlock ++ compile os
| otherwise = ubcLoadCellWord 1 : compileConditionally (s{isCellLoaded=True}) cs os
where
contained = compile cs
containedLength = length contained
forwardDistance = containedLength + 4 -- plus one to land after the skip Block
continueDistance = negate (containedLength + 10)
-- continueBlock has length 1 + 3 = 4
continueBlock = ubcStoreCellWord 1 : ubcJumpRel (fromIntegral continueDistance) 2 ubcConditionNone
-- skipBlock has length 2 + 1 + 3 = 6
skipBlock = ubcLoadIntWords 0 2 ++ [ubcCmpU 1 2] ++ (ubcJumpRel (fromIntegral forwardDistance) 2 ubcConditionEq)
compile :: [BrainFuckOperation] -> [Word.Word32]
compile = compile' CompileState{isCellLoaded=False, isCellModified=False}
-- 0: cell pointer register
-- 1: cell value register
-- 2: temporary register
compile' :: CompileState -> [BrainFuckOperation] -> [Word.Word32]
compile' _ [] = []
compile' state (IncrementCell amount:os) = compileIncrement state (fromIntegral amount) os
compile' state (DecrementCell amount:os) = compileDecrement state (fromIntegral amount) os
compile' state (MoveRight distance:os) = compileMoveRight state (fromIntegral distance) os
compile' state (MoveLeft distance:os) = compileMoveLeft state (fromIntegral distance) os
compile' state (Conditionally ops:os) = compileConditionally state ops os
compile' state (PutChar :os) = ubcLoadIntWords 0 2 ++ [ubcForeignCall 2] ++ compile' state os
compile' state (ReadChar :os) = ubcLoadIntWords 1 2 ++ [ubcForeignCall 2] ++ compile' state os

1
src/h.bf Normal file
View file

@ -0,0 +1 @@
++++++[>++++++++<-]>-.

BIN
src/h.ubc Normal file
View file

Binary file not shown.

33
src/hello-world.bf Normal file
View file

@ -0,0 +1,33 @@
1 +++++ +++ Set Cell #0 to 8
2 [
3 >++++ Add 4 to Cell #1; this will always set Cell #1 to 4
4 [ as the cell will be cleared by the loop
5 >++ Add 4*2 to Cell #2
6 >+++ Add 4*3 to Cell #3
7 >+++ Add 4*3 to Cell #4
8 >+ Add 4 to Cell #5
9 <<<<- Decrement the loop counter in Cell #1
10 ] Loop till Cell #1 is zero
11 >+ Add 1 to Cell #2
12 >+ Add 1 to Cell #3
13 >- Subtract 1 from Cell #4
14 >>+ Add 1 to Cell #6
15 [<] Move back to the first zero cell you find; this will
16 be Cell #1 which was cleared by the previous loop
17 <- Decrement the loop Counter in Cell #0
18 ] Loop till Cell #0 is zero
19
20 The result of this is:
21 Cell No : 0 1 2 3 4 5 6
22 Contents: 0 0 72 104 88 32 8
23 Pointer : ^
24
25 >>. Cell #2 has value 72 which is 'H'
26 >---. Subtract 3 from Cell #3 to get 101 which is 'e'
27 +++++ ++..+++. Likewise for 'llo' from Cell #3
28 >>. Cell #5 is 32 for the space
29 <-. Subtract 1 from Cell #4 for 87 to give a 'W'
30 <. Cell #3 was set to 'o' from the end of 'Hello'
31 +++.----- -.----- ---. Cell #3 for 'rl' and 'd'
32 >>+. Add 1 to Cell #5 gives us an exclamation point
33 >++. And finally a newline from Cell #6

BIN
src/out.ubc Normal file
View file

Binary file not shown.

67
stack.yaml Normal file
View file

@ -0,0 +1,67 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/35.yaml
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# subdirs:
# - auto-update
# - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
#
# extra-deps:
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
# Override default flag values for local packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of Stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=2.9"
#
# Override the architecture used by Stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by Stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

13
stack.yaml.lock Normal file
View file

@ -0,0 +1,13 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/lock_files
packages: []
snapshots:
- completed:
sha256: 31a722458578b1f709b6fe098d9027bbb5c04b4430e7338a5e69707bd3990e5d
size: 720019
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/35.yaml
original:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/35.yaml

2
test/Spec.hs Normal file
View file

@ -0,0 +1,2 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"

73
ubcf.cabal Normal file
View file

@ -0,0 +1,73 @@
cabal-version: 2.2
-- This file has been generated from package.yaml by hpack version 0.35.2.
--
-- see: https://github.com/sol/hpack
name: ubcf
version: 0.1.0.0
description: Please see the README on GitHub at <https://github.com/githubuser/ubcf#readme>
homepage: https://github.com/githubuser/ubcf#readme
bug-reports: https://github.com/githubuser/ubcf/issues
author: VegOwOtenks
maintainer: vegowotenks@jossco.de
copyright: AGPL3
license: BSD-3-Clause
license-file: LICENSE
build-type: Simple
extra-source-files:
README.md
CHANGELOG.md
source-repository head
type: git
location: https://github.com/githubuser/ubcf
library
exposed-modules:
Lib
other-modules:
Paths_ubcf
autogen-modules:
Paths_ubcf
hs-source-dirs:
src
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
build-depends:
base >=4.7 && <5
, binary
, bytestring
default-language: Haskell2010
executable ubcf-exe
main-is: Main.hs
other-modules:
Paths_ubcf
autogen-modules:
Paths_ubcf
hs-source-dirs:
app
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
, binary
, bytestring
, ubcf
default-language: Haskell2010
test-suite ubcf-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Paths_ubcf
autogen-modules:
Paths_ubcf
hs-source-dirs:
test
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
, binary
, bytestring
, ubcf
default-language: Haskell2010