<commit_before>{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, PatternGuards #-}
{-
  This file is part of Planet Pluto Forth.
  Copyright <NAME> 2011-2013

  Forth compiler and interpreter basic definitions.

-}

module Forth.Machine (MachineM, ForthLambda, Machine(..), push, pop, pushAdr,
                      ForthWord(..), StateT(..), emptyStack, abortWith, abortMessage,
                      updateState, updateStateVal, newState,
                      initialState, evalStateT, execute,
                      create, makeImmediate, smudge,
                      addNative, addNativeFixed, addFixed, addVar, putField,
                      wordBufferId,
                      inputBufferId, inputBufferPtrId, inputBufferLengthId,
                      stateId, sourceId, toInId, exitId,
                      wordIdExecute, wordLookup,
                      doColon, doVar, doConst,
                      withTempBuffer, searchDictionary, compileWord,
                      compile, comma) where

import Control.Applicative
import Control.Exception
import Control.Monad.State.Lazy
import qualified Data.Vector as V
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.Maybe
import Data.Typeable
import Data.Word
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Forth.Address
import Forth.Cell
import Forth.CellMemory
import {-# SOURCE #-} Forth.Core
import Forth.DataField
import Forth.Target
import Forth.Word
import Forth.WordId
import Forth.Types
import System.Console.Haskeline

type MachineM cell = StateT (Machine cell) (InputT IO)

-- The Forth state
data Machine cell = Machine { -- The Forth stacks
                              stack, rstack :: [Lit cell],
                              dictionaryHead :: LinkField cell,
                              defining :: LinkField cell,  -- ^ word being defined
                              ip :: Maybe (IP cell),
                              target :: Target cell,
                              -- Sequence of identies to allocate from
                              keys :: [WordId],
                              -- Data fields for words that need it. This need
                              -- to be modifiable as we mimic data ram. We
                              -- rely on that the underlaying identity of
                              -- a WordId is an Int here.
                              variables :: IntMap (DataField cell),
                              wordMap :: IntMap (ForthWord cell),
                              oldHandles :: [WordId]
    }

-- A Forth native lambda should obey this signature
type ForthLambda cell = MachineM cell ()

-- | Internal words that does not need to be redefinable can share
--   this identity.
pseudoId = 0

-- | WordId used for special purposes
wordBufferId = 1 :: Int     -- ^ Transient area for WORD
inputBufferId = 2 :: Int    -- ^ Input buffer (console)
inputBufferPtrId = 3 :: Int  -- ^ Variable that point out current input buffer
inputBufferLengthId = 4 :: Int    -- ^ Input buffer length
stateId = 5 :: Int          -- ^ Compile state
sourceId = 6 :: Int         -- ^ SOURCE-ID
toInId = 7 :: Int           -- ^ >IN
exitId = 8 :: Int

-- The first dynamic word identity
firstId = 9

-- | Lookup a word from its identity number
wordIdExecute wid = do
  w <- wordLookup wid
  case w of
    Just w -> call w

wordLookup :: WordId -> MachineM cell (Maybe (ForthWord cell))
wordLookup wid = gets $ \s -> IntMap.lookup wid (wordMap s)

call word = doer word word

-- | Top level item on stack should be an execution token that is invoked.
execute :: Cell cell => ForthLambda cell
execute = pop >>= executeXT

executeXT (XT word) = call word
executeXT _ = abortMessage "EXECUTE expects an execution token"

updateState f = do
  result <- StateT f
  case result of
    Left msg -> abortMessage msg
    Right x -> return x

updateStateVal x f = do
  result <- StateT f
  case result of
    Left msg -> abortMessage msg >> return x
    Right y -> return y

newState s = return (Right (), s)

-- | Pop from data stack
pop :: Cell cell => MachineM cell (Lit cell)
pop = updateStateVal (Val 0) $ \s ->
        case stack s of
          t:ts -> return (Right t, s { stack = ts })
          [] -> emptyStack s

emptyStack = abortWith "empty stack"

abortWith msg s = return (Left msg, s)

abortMessage msg = liftIO (putStrLn msg) >> abort<commit_msg>Improved error message when execute get a bad execution token.<commit_after>{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, PatternGuards #-}
{-
  This file is part of Planet Pluto Forth.
  Copyright <NAME> 2011-2013

  Forth compiler and interpreter basic definitions.

-}

module Forth.Machine (MachineM, ForthLambda, Machine(..), push, pop, pushAdr,
                      ForthWord(..), StateT(..), emptyStack, abortWith, abortMessage,
                      updateState, updateStateVal, newState,
                      initialState, evalStateT, execute,
                      create, makeImmediate, smudge,
                      addNative, addNativeFixed, addFixed, addVar, putField,
                      wordBufferId,
                      inputBufferId, inputBufferPtrId, inputBufferLengthId,
                      stateId, sourceId, toInId, exitId,
                      wordIdExecute, wordLookup,
                      doColon, doVar, doConst,
                      withTempBuffer, searchDictionary, compileWord,
                      compile, comma) where

import Control.Applicative
import Control.Exception
import Control.Monad.State.Lazy
import qualified Data.Vector as V
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.Maybe
import Data.Typeable
import Data.Word
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Forth.Address
import Forth.Cell
import Forth.CellMemory
import {-# SOURCE #-} Forth.Core
import Forth.DataField
import Forth.Target
import Forth.Word
import Forth.WordId
import Forth.Types
import System.Console.Haskeline

type MachineM cell = StateT (Machine cell) (InputT IO)

-- The Forth state
data Machine cell = Machine { -- The Forth stacks
                              stack, rstack :: [Lit cell],
                              dictionaryHead :: LinkField cell,
                              defining :: LinkField cell,  -- ^ word being defined
                              ip :: Maybe (IP cell),
                              target :: Target cell,
                              -- Sequence of identies to allocate from
                              keys :: [WordId],
                              -- Data fields for words that need it. This need
                              -- to be modifiable as we mimic data ram. We
                              -- rely on that the underlaying identity of
                              -- a WordId is an Int here.
                              variables :: IntMap (DataField cell),
                              wordMap :: IntMap (ForthWord cell),
                              oldHandles :: [WordId]
    }

-- A Forth native lambda should obey this signature
type ForthLambda cell = MachineM cell ()

-- | Internal words that does not need to be redefinable can share
--   this identity.
pseudoId = 0

-- | WordId used for special purposes
wordBufferId = 1 :: Int     -- ^ Transient area for WORD
inputBufferId = 2 :: Int    -- ^ Input buffer (console)
inputBufferPtrId = 3 :: Int  -- ^ Variable that point out current input buffer
inputBufferLengthId = 4 :: Int    -- ^ Input buffer length
stateId = 5 :: Int          -- ^ Compile state
sourceId = 6 :: Int         -- ^ SOURCE-ID
toInId = 7 :: Int           -- ^ >IN
exitId = 8 :: Int

-- The first dynamic word identity
firstId = 9

-- | Lookup a word from its identity number
wordIdExecute wid = do
  w <- wordLookup wid
  case w of
    Just w -> call w

wordLookup :: WordId -> MachineM cell (Maybe (ForthWord cell))
wordLookup wid = gets $ \s -> IntMap.lookup wid (wordMap s)

call word = doer word word

-- | Top level item on stack should be an execution token that is invoked.
execute :: Cell cell => ForthLambda cell
execute = pop >>= executeXT

executeXT (XT word) = call word
executeXT x = abortMessage $ "EXECUTE expects an execution token, got " ++ show x

updateState f = do
  result <- StateT f
  case result of
    Left msg -> abortMessage msg
    Right x -> return x

updateStateVal x f = do
  result <- StateT f
  case result of
    Left msg -> abortMessage msg >> return x
    Right y -> return y

newState s = return (Right (), s)

-- | Pop from data stack
pop :: Cell cell => MachineM cell (Lit cell)
pop = updateStateVal (Val 0) $ \s ->
        case stack s of
          t:ts -> return (Right t, s { stack = ts })
          [] -> emptyStack s

emptyStack = abortWith "empty stack"

abortWith msg s = return (Left msg, s)

abortMessage msg = liftIO (putStrLn msg) >> abort
{'fraction_non_alphanumeric': 0.07954670480800968, 'fraction_numerical': 0.004400924194080757, 'mean_word_length': 1.997032640949555, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 43, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 12, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '312577', 'n_tokens_mistral': 2444, 'n_tokens_neox': 2360, 'n_words': 932}