Seventh installment. This time I have added a facility for debug :) The task before you is to study the following

eval "10 1 [+] 1 2 [[i] swap dip] swap dip"
11 1 2

That is see the pattern of swap and dip used to get at the nth deep nest. Now try the below.

eval "10 1 [+] 1 2 [[i] ; 1 swap dip] swap dip"

As you can see ; intlabel acts as a way to check the state of stack at that point. This also illustrates a kind of macro system called immediate words or parsing words. We are effectively using the presence of ‘;’ to intrepret the word after it in a different way. That means that you can get at the execution word queue before evaluation of terms. This can in effect allow us modify our abstract syntax tree before the real execution.

Try this too.

eval "10 1 [+] 1 2 [[i] ; 1 swap dip] ; 2 swap dip"

Now your task is to come up with a sequence of words to evaluate

eval "10 1 [+] 1 2 3 4 5 ??"
11 1 2 3 4 5

Happy hacking :)

Here is the full code so far.

module Main where

import System.Environment 
import System.IO 
import Data.Char
import Debug.Trace
import Text.ParserCombinators.Parsec

type Word = String
type Env = [(String, [Nest])]
type Stack = [Nest]

initlib = unlines[
  "[succ 1 +].",
  "[pred 1 -].",
  "[even? odd? not].",
  "[double dup +].",
  "[half dup odd? [succ 2 /] [2 /] if].",
  "[if* 2 nwrap [!] swap dip i swap if].",
  "[zero? 0 =?].", 
  "[split1 1 split].", 
  "[factorial [zero?] [pop 1] [dup pred factorial *] if*].",
  "[:  dup length swap [nwrap] dip zip [.] map pop]."
  ]

readLine :: String -> Nest
readLine input = case parse parseExpr "nest" input of
    Left err -> error (show err)
    Right q -> q

showStack = unwords . reverse . (map show)

eval :: String -> String
eval str = showStack $ bigStep [] e []
  where  Nested e = readLine (initlib ++ " " ++ str)

evalFile file = do
  str <- readFile file
  return $ eval str

main = do
  fn <- getArgs
  case fn of
      [] -> error "Need file.nst to evaluate."
      (x:xs) -> do res <- evalFile $ fn !! 0
                   putStrLn (show res)

parseExpr = do
  x <- many parseSingle
  return $ Nested x

parseSingle :: Parser Nest
parseSingle = do
  spaces
  x <- (try parseFloat) <|>
       (try parseInt) <|>
       (try parseNegInt) <|>
       (try parseBool) <|>
       (try parseString) <|>
       (try parseWord) <|>
       (try parseNest)
  spaces
  return x

parseNest :: Parser Nest
parseNest = do
  char '['
  e <- parseExpr
  char ']'
  return e

parseFloat :: Parser Nest
parseFloat = do
  I i <- parseInt
  char '.'
  I j <- parseInt
  res <- return $ (show i) ++ ['.'] ++ (show j)
  return $ F (read res)

parseNegInt :: Parser Nest
parseNegInt = do
  char '-'
  i <- many1 digit
  return $ I $ -1 * (read i)

parseInt :: Parser Nest
parseInt = do
  i <- many1 digit
  return $ I (read i)

parseWord :: Parser Nest
parseWord = do
  w <- many1 (noneOf " nrt[]")
  return $ W w

parseBool :: Parser Nest
parseBool = do
  (x:xs) <- string "true" <|> string "false"
  return $ B (read (toUpper x : xs))

parseString :: Parser Nest
parseString = do
  char '''
  s <- many (noneOf "'")
  char '''
  return $ S s

{-
 <digit>   ::= 0..9
 <num>     ::= <digit>
             | <digit><num>

 <letter>  ::= a..z | + | - | * | / | < | > | = | .
 <char>    ::= <letter>
             | <digit>
 <word>    ::= <letter>
              | <word> <char>
 <nest>    ::= <num>
             | <word>
             | [ <nest>* ]
 <expr>   ::= <nest>*
-}

data Nest = W String
          | I Int
          | F Float
          | B Bool
          | S String
          | Nested [Nest]
  deriving (Eq)

instance Show Nest where
  show (W s) = s
  show (S s) = (show s)
  show (I i) = (show i)
  show (F f) = (show f)
  show (B b) = (show b)
  show (Nested b) = "[" ++ (unwords (map show b)) ++ "]"

bigStep :: Env -> [Nest] -> Stack -> Stack
bigStep _ [] r = r
bigStep env (Nested n: xs) ys = bigStep env xs (Nested n: ys)
bigStep env (I i: xs) ys = bigStep env xs (I i: ys)
bigStep env (F i: xs) ys = bigStep env xs (F i: ys)
bigStep env (B i: xs) ys = bigStep env xs (B i: ys)
bigStep env (S i: xs) ys = bigStep env xs (S i: ys)
bigStep env (W "+": xs) (I i: I j: ys) = bigStep env xs (I (j+i): ys)
bigStep env (W "*": xs) (I i: I j: ys) = bigStep env xs (I (j*i): ys)
bigStep env (W "-": xs) (I i: I j: ys) = bigStep env xs (I (j-i): ys)
bigStep env (W "/": xs) (I i: I j: ys) = bigStep env xs (F ((fromIntegral j)/(fromIntegral i)): ys)
bigStep env (W ">": xs) (I i: I j: ys) = bigStep env xs (B (j > i): ys)
bigStep env (W "<": xs) (I i: I j: ys) = bigStep env xs (B (j < i): ys)

bigStep env (W "=?": xs) (I i: I j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (S i: S j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (B i: B j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (F i: F j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (Nested i: Nested j: ys) = bigStep env xs (B (j == i): ys)

bigStep env (W "odd?": xs) (I i: ys) = bigStep env xs (B (odd i): ys)

bigStep env (W "and": xs) (B a:B b:ys) = bigStep env xs (B (b && a):ys)
bigStep env (W "or": xs) (B a:B b:ys) = bigStep env xs (B (b || a):ys)
bigStep env (W "not": xs) (B a:ys) = bigStep env xs (B (not a):ys)
bigStep env (W "dup": xs) (y:ys) = bigStep env xs (y:y:ys)
bigStep env (W "swap": xs) (y:y':ys) = bigStep env xs (y':y:ys)
bigStep env (W "pop": xs) (y:ys) = bigStep env xs ys
bigStep env (W "cons": xs) (Nested y':y:ys) = bigStep env xs (Nested (y:y'):ys)
bigStep env (W "concat": xs) (Nested y':Nested y:ys) = bigStep env xs (Nested (y ++ y'):ys)
bigStep env (W "empty?": xs) (Nested y:ys) = bigStep env xs (B (length y == 0):ys)
bigStep env (W "reverse": xs) (Nested y:ys) = bigStep env xs (Nested (reverse y): ys)
bigStep env (W "split": xs) (I i:Nested nys:ys) = bigStep env xs (Nested arr1:(Nested arr2): ys)
  where (arr2,arr1) = splitAt i nys
bigStep env (W "nwrap": xs) (I i:ys) = bigStep env xs ((Nested lst) : rest)
  where lst = take i ys
        rest = drop i ys
bigStep env (W "i":xs) (Nested v:ys) = bigStep env (v ++ xs) ys
bigStep env (W "!":xs) ys = bigStep env xs $ (head res):(tail ys)
  where res = bigStep env (W "i":xs) ys
bigStep env (W "dip":xs) (y:ys) = bigStep env xs $ y:lst
  where lst = bigStep env [W "i"] ys
bigStep env (W "if":xs) (Nested v2:Nested v1:B c:ys) = bigStep env (res ++ xs) ys
  where res = if c then v1 else v2

bigStep env (W "length":xs) (Nested v:ys) = bigStep env xs (I (length v) :ys)
bigStep env (W ".":xs) (Nested ((W w):as):ys) = bigStep ((w,as):env) xs ys
bigStep env (W ";":I x:xs) ys = bigStep env xs (trace ("["++(show x) ++"] Stack was: " ++ (showStack ys) ++ "n") ys)
bigStep env (W "{":xs) ys = bigStep (("{",[]):env) xs ys
bigStep env (W "}":xs) ys = bigStep myenv xs ys
  where myenv = tail $ dropWhile (/= ("{", [])) env

bigStep env (W "(":xs) ys = bigStep env xs (W "(":ys)
bigStep env (W ")":xs) ys = bigStep env xs (Nested (reverse arr): (tail st))
  where (arr,st) = span (/= W "(") ys
bigStep env (W x :xs) ys = bigStep env (def ++ xs) ys
  where def = case lookup x env of
          Nothing -> error ("Definition not found or is not applicable for word  {" ++ x ++ "} with stack " ++ (showStack ys))  
          Just x -> x