<commit_before>{-# LANGUAGE OverloadedStrings #-}
{-
  This file is part of CalcForth.
  Copyright <NAME> 2011

  Forth core words in native lambdas.

-}

module Forth.Core (addNatives, quit) where

import Control.Monad.State.Lazy hiding (state)
import Data.Vector.Storable.ByteString (ByteString)
import qualified Data.Vector.Storable.ByteString as B
import qualified Data.Vector.Storable.ByteString.Char8 as C
import Data.Char
import Data.Word
import Control.Monad
import Control.Monad.Trans
import Data.Bits
import Forth.Address
import Forth.Cell
import Forth.CellMemory
import Forth.DataField
import Forth.Machine
import Forth.Types
import Forth.Word
import Util.Memory
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import System.IO
import Numeric


-- | Populate the vocabulary with a basic set of Haskell native words.
addNatives :: Cell cell => MachineM cell ()
addNatives = do
  addNative "+"   $ binary (+)
  addNative "-"   $ binary (-)
  addNative "*"   $ binary (*)
  addNative "/"   $ binary divide
  addNative "AND" $ binary (.&.)
  addNative "OR"  $ binary (.|.)
  addNative "XOR" $ binary xor
  addNative "WORD" word
  addNative "FIND" find
  addNative "-INTERPRET" interpret
  addVar    "-INPUT-BUFFER" inputBufferId Nothing
  addVar    "STATE" stateId (Just $ Val 0)
  addVar    "SOURCE-ID" sourceId (Just $ Val 0)
  addVar    ">IN" toInId  (Just $ Val 0)
      where
        divide (Val a) (Val b) = Val (a `div` b)
        divide a b = Bot $ show a ++ " / " ++ show b


-- | Perform a binary operation
binary op = modify $ \s ->
    case stack s of
      s0 : s1 : ss -> s { stack = s0 `op` s1 : ss  }
      otherwise -> emptyStack


inputBuffer, toIn, sourceID, state :: Cell cell => ForthLambda cell
inputBuffer = wordIdExecute inputBufferId
toIn = wordIdExecute toInId
sourceID = wordIdExecute sourceId
state = wordIdExecute stateId


fetch :: Cell cell => ForthLambda cell
fetch = modify $ \s ->
    case stack s of
      Address (Just adr@(Addr wid _)) : rest
          | Just (DataField cm) <- IntMap.lookup wid (variables s),
            Just x <- readCell adr cm ->
                s { stack = x : rest }

store :: Cell cell => ForthLambda cell
store = modify $ \s ->
    case stack s of
      Address (Just adr@(Addr wid i)) : val : rest
          | Just (DataField cm) <- IntMap.lookup wid (variables s) ->
              s { variables = IntMap.insert wid (DataField $ writeCell val adr cm)
                              (variables s),
                  stack = rest }


-- | Find the name (counted string) in the dictionary
--   ( c-addr -- c-addr 0 | xt 1 | xt -1 )
find :: Cell cell => ForthLambda cell
find = do
  caddr <- pop
  findname <- caddrText caddr
  modify $ \s ->
      let locate (Just word) | name word == findname = Just word
                             | otherwise = locate $ link word
          locate Nothing = Nothing
      in case locate (dictionaryHead s) of
           Just word
               | immediate word -> s { stack = Val 1 : XT word : (stack s) }
               | otherwise -> s { stack = Val (-1) : XT word : (stack s) }
           Nothing -> s { stack = Val 0 : caddr : stack s }


-- | Copy word from given address with delimiter to a special transient area.
--   ( char "<chars>ccc<chars>" -- c-addr )
word :: Cell cell => ForthLambda cell
word = modify $ \s ->
  case stack s of
    Address (Just (Addr wid off)) : Val val : ss
        | Just (BufferField cmem) <- IntMap.lookup wid (variables s) ->
            let name = B.takeWhile (c /=) $ B.dropWhile (c ==) $ B.drop off (chunk cmem)
                counted = cmem { chunk = B.cons (fromIntegral $ B.length name) name }
                result = Address (Just $ Addr wordBufferId 0)
                c = fromIntegral val
            in s { stack = result : ss,
                   variables = IntMap.insert wordBufferId (BufferField counted) (variables s) }
    otherwise -> abortWith "WORD failed"


-- | Processes input text stored in the input buffer.
interpret :: Cell cell => ForthLambda cell
interpret = state >> fetch >> pop >>= interpretLoop where
    interpretLoop stateFlag = interpret1 where
        compiling = stateFlag /= Val 0
        interpret1 = do
          push (Val $ fromIntegral $ ord ' ') >> inputBuffer >> word >> find
          val <- pop
          case val of
            Val 0 -> parseNumber                     -- not found
            Val 1 -> execute >> interpret1           -- immediate word
            _ | compiling -> abortWith "compile word not implemented" -- normal word found
              | otherwise -> execute >> interpret1

    parseNumber = parse =<< caddrText =<< pop where
        parse bs = case readDec (C.unpack bs) of
                     [(x,"")] -> push $ Val x


-- | Given a caddr (counted string pointed out by an address), extract the
--   actual text as an individual ByteString
caddrText (Address (Just (Addr wid off))) = gets $ \s ->
    case IntMap.lookup wid (variables s) of
      Just (BufferField cmem) ->
          let count = fromIntegral $ B.index (chunk cmem) off
          in B.take count $ B.drop (off + 1) (chunk cmem)
      otherwise ->
          case IntMap.lookup wid (wordMap s) of
            Just word -> abortWith $ "expected address pointing to char buffer for " ++
                           (C.unpack $ name word)
            otherwise -> abortWith "expected address pointing to char buffer"
caddrText _ = abortWith "expected address"

quit :: Cell cell => ForthLambda cell
quit = do
  modify $ \s -> s { rstack = [] }
  push (Val 0) >> sourceID >> store
  mainLoop


mainLoop :: Cell cell => ForthLambda cell
mainLoop = do<commit_msg>Give appropriate message is word cannot be found and is not a number.<commit_after>{-# LANGUAGE OverloadedStrings #-}
{-
  This file is part of CalcForth.
  Copyright <NAME> 2011

  Forth core words in native lambdas.

-}

module Forth.Core (addNatives, quit) where

import Control.Monad.State.Lazy hiding (state)
import Data.Vector.Storable.ByteString (ByteString)
import qualified Data.Vector.Storable.ByteString as B
import qualified Data.Vector.Storable.ByteString.Char8 as C
import Data.Char
import Data.Word
import Control.Monad
import Control.Monad.Trans
import Data.Bits
import Forth.Address
import Forth.Cell
import Forth.CellMemory
import Forth.DataField
import Forth.Machine
import Forth.Types
import Forth.Word
import Util.Memory
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import System.IO
import Numeric


-- | Populate the vocabulary with a basic set of Haskell native words.
addNatives :: Cell cell => MachineM cell ()
addNatives = do
  addNative "+"   $ binary (+)
  addNative "-"   $ binary (-)
  addNative "*"   $ binary (*)
  addNative "/"   $ binary divide
  addNative "AND" $ binary (.&.)
  addNative "OR"  $ binary (.|.)
  addNative "XOR" $ binary xor
  addNative "WORD" word
  addNative "FIND" find
  addNative "-INTERPRET" interpret
  addVar    "-INPUT-BUFFER" inputBufferId Nothing
  addVar    "STATE" stateId (Just $ Val 0)
  addVar    "SOURCE-ID" sourceId (Just $ Val 0)
  addVar    ">IN" toInId  (Just $ Val 0)
      where
        divide (Val a) (Val b) = Val (a `div` b)
        divide a b = Bot $ show a ++ " / " ++ show b


-- | Perform a binary operation
binary op = modify $ \s ->
    case stack s of
      s0 : s1 : ss -> s { stack = s0 `op` s1 : ss  }
      otherwise -> emptyStack


inputBuffer, toIn, sourceID, state :: Cell cell => ForthLambda cell
inputBuffer = wordIdExecute inputBufferId
toIn = wordIdExecute toInId
sourceID = wordIdExecute sourceId
state = wordIdExecute stateId


fetch :: Cell cell => ForthLambda cell
fetch = modify $ \s ->
    case stack s of
      Address (Just adr@(Addr wid _)) : rest
          | Just (DataField cm) <- IntMap.lookup wid (variables s),
            Just x <- readCell adr cm ->
                s { stack = x : rest }

store :: Cell cell => ForthLambda cell
store = modify $ \s ->
    case stack s of
      Address (Just adr@(Addr wid i)) : val : rest
          | Just (DataField cm) <- IntMap.lookup wid (variables s) ->
              s { variables = IntMap.insert wid (DataField $ writeCell val adr cm)
                              (variables s),
                  stack = rest }


-- | Find the name (counted string) in the dictionary
--   ( c-addr -- c-addr 0 | xt 1 | xt -1 )
find :: Cell cell => ForthLambda cell
find = do
  caddr <- pop
  findname <- caddrText caddr
  modify $ \s ->
      let locate (Just word) | name word == findname = Just word
                             | otherwise = locate $ link word
          locate Nothing = Nothing
      in case locate (dictionaryHead s) of
           Just word
               | immediate word -> s { stack = Val 1 : XT word : (stack s) }
               | otherwise -> s { stack = Val (-1) : XT word : (stack s) }
           Nothing -> s { stack = Val 0 : caddr : stack s }


-- | Copy word from given address with delimiter to a special transient area.
--   ( char "<chars>ccc<chars>" -- c-addr )
word :: Cell cell => ForthLambda cell
word = modify $ \s ->
  case stack s of
    Address (Just (Addr wid off)) : Val val : ss
        | Just (BufferField cmem) <- IntMap.lookup wid (variables s) ->
            let name = B.takeWhile (c /=) $ B.dropWhile (c ==) $ B.drop off (chunk cmem)
                counted = cmem { chunk = B.cons (fromIntegral $ B.length name) name }
                result = Address (Just $ Addr wordBufferId 0)
                c = fromIntegral val
            in s { stack = result : ss,
                   variables = IntMap.insert wordBufferId (BufferField counted) (variables s) }
    otherwise -> abortWith "WORD failed"


-- | Processes input text stored in the input buffer.
interpret :: Cell cell => ForthLambda cell
interpret = state >> fetch >> pop >>= interpretLoop where
    interpretLoop stateFlag = interpret1 where
        compiling = stateFlag /= Val 0
        interpret1 = do
          push (Val $ fromIntegral $ ord ' ') >> inputBuffer >> word >> find
          val <- pop
          case val of
            Val 0 -> parseNumber                     -- not found
            Val 1 -> execute >> interpret1           -- immediate word
            _ | compiling -> abortWith "compile word not implemented" -- normal word found
              | otherwise -> execute >> interpret1

    parseNumber = parse =<< caddrText =<< pop where
        parse bs = case readDec text of
                     [(x,"")] -> push $ Val x
                     otherwise -> abortWith $ text ++ " ?"
            where text = C.unpack bs


-- | Given a caddr (counted string pointed out by an address), extract the
--   actual text as an individual ByteString
caddrText (Address (Just (Addr wid off))) = gets $ \s ->
    case IntMap.lookup wid (variables s) of
      Just (BufferField cmem) ->
          let count = fromIntegral $ B.index (chunk cmem) off
          in B.take count $ B.drop (off + 1) (chunk cmem)
      otherwise ->
          case IntMap.lookup wid (wordMap s) of
            Just word -> abortWith $ "expected address pointing to char buffer for " ++
                           (C.unpack $ name word)
            otherwise -> abortWith "expected address pointing to char buffer"
caddrText _ = abortWith "expected address"

quit :: Cell cell => ForthLambda cell
quit = do
  modify $ \s -> s { rstack = [] }
  push (Val 0) >> sourceID >> store
  mainLoop


mainLoop :: Cell cell => ForthLambda cell
mainLoop = do
{'fraction_non_alphanumeric': 0.10170082860880943, 'fraction_numerical': 0.0048844308765808985, 'mean_word_length': 2.2244094488188977, 'pattern_counts': {'":': 0, '<': 31, '<?xml version=': 0, '>': 120, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1022318', 'n_tokens_mistral': 3369, 'n_tokens_neox': 3257, 'n_words': 1282}