Monday, December 21, 2009

The RESOL programming language

RESOL (REtro Statement Oriented Language) is a language inspired by fixed-format FORTRAN. (See also: resol)

RESOL uses fixed format lines. If the first column contains C, the line is a comment. Otherwise, columns 1-5 contain an optional label consisting of digits (0-9). Column 6, if not empty nor containing a space, indicates a continuation line. Columns 7-72 contain the statement. The first line cannot be a continuation line and a continuation line cannot directly follow a comment line.
Statements

Every labeled statement (except the first statement), has a call stack. Having multiple call stacks permits convoluted code where the returns (from different call sites) are not in the reverse order of the calls.

It is an error for more than one statement to have the same label.

Statements can take one or two arguments. An argument is a sequence of one or more digits (0-9). If there are two arguments, they are separated by a comma.

Every labeled DATA statement has a queue stack. If the first statement is a labeled DATA statement, it has a special queue where reading the queue reads the program's input, and writing to the queue writes the program's output. The statement's queue is the top of queue stack.

The DATA statement can take one or two arguments. If the statement is labeled, the first argument defines the size of the queue item in digits, and the second argument, if present, defines the initial contents of the statement's queue, which would otherwise be empty. When executing a DATA statement, if the first argument does not match any labeled DATA statement, it is a NO-OP, otherwise, if there is one argument, the top item in the matching DATA statement's queue is removed, and if there are two arguments, the value of the second argument, as defined later, will be added to the end of the matching DATA statement's queue.

The CALL statement can take one or two arguments. The first argument must match a label. The statement following the CALL statement is pushed onto the call stack of the matching statement. If there is no second argument, a new empty queue is pushed onto the matching statement's queue stack, otherwise a new queue containing the value of the second argument, as defined later, is pushed onto the matching statement's queue stack. Execution continues with the matching statement. It is an error if the matching statement is the first statement and the first statement is a labeled DATA statement.

The CONTINUE statement can take one or two arguments. All arguments must match a label. If the statement matching the first argument is not a DATA statement, there must not be a second argument, and execution continues with the statement popped from the matching statement's call stack. Otherwise, if the DATA statement's queue is not empty, execution continues with the statement matching the second argument, if present, otherwise, execution continues with the matching DATA statement. If the DATA statement's queue is empty, then the DATA statement's queue stack is popped, and execution continues with the statement popped from the DATA statement's call stack. Stack underflow is an error. As a special case, if the first argument matches the first statement and the first statement is a labeled DATA statement, then, if there is more input available, execution continues with the statement matching the second argument if available, otherwise execution continues with the first statement. If there is no more available input, execution continues with the statement following the CONTINUE statement.

The IF statement must take two arguments. If the values of both arguments, as defined later, are not equal, the next statement is skipped.

The STOP statement takes no arguments and ends the program.

It is an error if there are no more statements to execute. This error can be avoided with a STOP or CONTINUE statement as the last reachable statement.

Here is the definition of the value of the second argument of an executed DATA statement, the second argument of a CALL statement or either argument of an IF statement: if the argument matches a label of a DATA statement, then the value is top item in the matching statement's queue. Otherwise, the value is the literal value of the argument.
Input and output

If the first statement is a labeled DATA statement, then that statement's queue is used for input and output. The size of the queue item determines how the input and output are converted between bits and digits. If the size is 1, then each digit corresponds to 3 bits, and the output bits are equal to the digit's value modulo 8. If the size is 2, then each digit corresponds to 6 bits, and the output bits are equal to the item's value modulo 64. If the size is 3, then each item corresponds to 9 bits, and the output bits are equal to the item's value modulo 512. If the size is 4, then each item corresponds to 13 bits, and the output bits are equal to the item's value modulo 8192. Larger sizes work analogously.
Examples

HELLO WORLD

07734 DATA 4 0000001
DATA 07734,23125425157546133742526705450266 0000002
STOP 0000003

CAT

0 DATA 1 0000001
1 CONTINUE 0,2 0000002
STOP 0000003
2 DATA 0,0 0000004
DATA 0 0000005
CONTINUE 0,2 0000006
STOP 0000007

Interpreter

Here is a RESOL interpreter in Haskell. I wrote it in multiple modules, but crammed everything into a single module for this post.

module Main(main) where

import Data.Bits(bit,shiftR,testBit)
import Data.Char(chr,ord)
import Data.Map((!))
import qualified Data.Map as M
import System.Environment(getArgs)

data Statement = Statement {
stmtFileName :: String,
stmtLineNumber :: Int,
stmtLabel :: [Int],
stmtCommand :: Command
}

data Command =
Data1 [Int]
| Data2 [Int] [Int]
| Call1 [Int]
| Call2 [Int] [Int]
| Continue1 [Int]
| Continue2 [Int] [Int]
| If [Int] [Int]
| Stop

parse :: String -> String -> [Statement]
parse fileName str =
reverse $ finishPartial fileName
$ foldl (parseLine fileName) (Nothing,[]) (zip (lines str) [1..])

data PartialStatement = PartialStatement {
psLineNumber :: Int,
psLabel :: String,
psStatement :: String
}

startPartial = PartialStatement

continuePartial label stmt ps = ps {psLabel = psLabel ps ++ label,
psStatement = psStatement ps ++ stmt }

finishPartial fileName (ps,stmts) =
maybe stmts ((: stmts) . parseStatement fileName) ps

parseLine fileName state ('C':_,_) = (Nothing,finishPartial fileName state)
parseLine fileName state@(ps,stmts) (l1:l2:l3:l4:l5:c:stmt,lineNumber)
| c == ' ' = (Just (startPartial lineNumber label (take 66 stmt)),
finishPartial fileName state)
| otherwise = maybe (errMsg fileName lineNumber
"Invalid continuation line")
(flip (,) stmts . Just
. continuePartial label (take 66 stmt))
ps
where label = [l1,l2,l3,l4,l5]
parseLine fileName state (label,lineNumber) =
(Just (startPartial lineNumber label ""), finishPartial fileName state)

parseStatement fileName ps =
Statement fileName (psLineNumber ps)
(parseNumber fileName (psLineNumber ps) (psLabel ps))
(parseCommand fileName (psLineNumber ps) (psStatement ps))

parseNumber fileName lineNumber str
| all (flip elem (' ':['0'..'9'])) str = map toDigit (filter (/= ' ') str)
| otherwise = errMsg fileName lineNumber "Invalid number"

toDigit c = ord c - ord '0'

parseCommand fileName lineNumber str =
let (cmd,args) = span (flip elem ['A'..'Z']) (filter (/= ' ') str)
(arg1,args') = span (/= ',') args
arg2 = drop 1 args'
in makeCommand fileName lineNumber cmd
(parseNumber fileName lineNumber arg1)
(parseNumber fileName lineNumber arg2)

makeCommand _ _ "DATA" arg@(_:_) [] = Data1 arg
makeCommand _ _ "DATA" arg1@(_:_) arg2@(_:_) = Data2 arg1 arg2
makeCommand _ _ "CALL" arg@(_:_) [] = Call1 arg
makeCommand _ _ "CALL" arg1@(_:_) arg2@(_:_) = Call2 arg1 arg2
makeCommand _ _ "CONTINUE" arg@(_:_) [] = Continue1 arg
makeCommand _ _ "CONTINUE" arg1@(_:_) arg2@(_:_) = Continue2 arg1 arg2
makeCommand _ _ "IF" arg1@(_:_) arg2@(_:_) = If arg1 arg2
makeCommand _ _ "STOP" [] [] = Stop
makeCommand fileName lineNumber cmd _ _ =
errMsg fileName lineNumber ("Invalid command: " ++ cmd)

errMsg fileName lineNumber msg =
error (fileName ++ ':' : show lineNumber ++ ": " ++ msg)

encode :: Int -> [Int] -> String
encode n = bitsToStr . digitsToBits n

decode :: Int -> String -> [Int]
decode n = bitsToDigits n . strToBits

digitsToInteger :: [Int] -> Integer
digitsToInteger ints = digitsToInteger' ints 0 where
digitsToInteger' [] acc = acc
digitsToInteger' (d:ds) acc = digitsToInteger' ds (10*acc + fromIntegral d)

digitCountToBitCount :: Int -> Int
digitCountToBitCount n = highBit (digitsToInteger (take n (repeat 9))) where
highBit 0 = -1
highBit m = 1 + highBit (shiftR m 1)

digitsToBits :: Int -> [Int] -> [Bool]
digitsToBits _ [] = []
digitsToBits n digits =
let bitIndices = reverse [0..digitCountToBitCount n - 1]
(item,rest) = splitAt n digits
in map (testBit (digitsToInteger item)) bitIndices ++ digitsToBits n rest

bitsToDigits :: Int -> [Bool] -> [Int]
bitsToDigits _ [] = []
bitsToDigits n bits =
let nbits = digitCountToBitCount n
bitIndices = reverse [0..nbits - 1]
toDigits :: Int -> Integer -> [Integer] -> [Int]
toDigits 0 _ acc = map fromIntegral acc
toDigits n' m acc = toDigits (n' - 1) (div m 10) (mod m 10 : acc)
bitValue flag bitIndex = if flag then bit bitIndex else 0
(item,rest) = splitAt nbits bits
in toDigits n (sum (zipWith bitValue item bitIndices)) []
++ bitsToDigits n rest

strToBits :: String -> [Bool]
strToBits = concatMap (flip map [7,6..0] . testBit . ord)

bitsToStr :: [Bool] -> String
bitsToStr [] = []
bitsToStr bits =
let (octet,rest) = splitAt 8 bits
byte = sum (zipWith (\ f b -> if f then bit b else 0) octet [7,6..0])
in if length octet == 8
then chr byte : bitsToStr rest
else []

data Stmt = Stmt Statement (Maybe Stmt)

data State = State {
firstStmtLabel :: [Int],
firstStmtItemSize :: Int,
stmtByLabel :: [Int] -> Maybe Stmt,
queueItemSize :: [Int] -> Int,
queues :: M.Map [Int] [[Int]],
stacks :: M.Map [Int] [Stmt]
}

interpRaw :: [Statement] -> String -> [Int]
interpRaw = interp' (const id)

interp :: [Statement] -> String -> String
interp = interp' encode

interp' :: (Int -> [Int] -> a) -> [Statement] -> String -> a
interp' convert stmts input =
let (stmt,state) = initState stmts
itemSize = firstStmtItemSize state
in convert itemSize $ run stmt state $ decode itemSize input

initState :: [Statement] -> (Stmt,State)
initState statements =
let stmts = makeStmts statements
makeStmts [] = []
makeStmts (s:ss) =
let stmts' = makeStmts ss
in Stmt s (if length stmts' == 0
then Nothing
else Just (head stmts'))
: stmts'
byLabel = M.fromList $ filter ((/= []) . fst)
$ zip (map stmtLabel statements) stmts
toInt [] acc = acc
toInt (d:ds) acc = toInt ds (acc*10 + d)
itemSize (Just (Stmt (Statement {stmtCommand=Data1 arg}) _))
= toInt arg 0
itemSize (Just (Stmt (Statement {stmtCommand=Data2 arg _}) _)) =
toInt arg 0
itemSize _ = 0
initQueue (Stmt (Statement {stmtCommand=Data1 _}) _) = Just [[]]
initQueue (Stmt (Statement {stmtCommand=Data2 _ arg}) _) = Just [arg]
initQueue _ = Nothing
in (head stmts,
State {firstStmtLabel=stmtLabel (head statements),
firstStmtItemSize=itemSize (Just (head stmts)),
stmtByLabel=flip M.lookup byLabel,
queueItemSize=itemSize . flip M.lookup byLabel,
queues=M.mapMaybe initQueue byLabel,
stacks=fmap (const []) byLabel})

pushCall :: [Int] -> [Int] -> Stmt -> State -> State
pushCall label args returnStmt state =
let stacks' = M.adjust (returnStmt:) label (stacks state)
queues' = M.adjust (args:) label (queues state)
in state {stacks=stacks', queues=queues'}

retCall :: [Int] -> State -> (Stmt,State)
retCall label state =
let stmt = head ((stacks state) ! label)
stacks' = M.adjust tail label (stacks state)
queues' = M.adjust tail label (queues state)
in (stmt,state {stacks=stacks', queues=queues'})

modifyQueue :: ([Int] -> [Int]) -> [Int] -> State -> State
modifyQueue modify label state =
let modifyHead queues = (modify (head queues)) : tail queues
in state {queues = M.adjust modifyHead label (queues state)}

dequeue :: [Int] -> State -> State
dequeue label state =
modifyQueue (drop (queueItemSize state label)) label state

queueItem :: [Int] -> State -> [Int]
queueItem label state =
take (queueItemSize state label) (head (queues state ! label))

enqueue :: [Int] -> [Int] -> State -> State
enqueue label digits state = modifyQueue (++ digits) label state

isQueue :: [Int] -> State -> Bool
isQueue label state = M.member label (queues state)

isFirst :: [Int] -> State -> Bool
isFirst label state = label == firstStmtLabel state

value :: [Int] -> State -> [Int] -> [Int]
value arg state input =
if isQueue arg state
then if isFirst arg state
then take (firstStmtItemSize state) input
else queueItem arg state
else arg

run :: Stmt -> State -> [Int] -> [Int]

run (Stmt (Statement {stmtCommand=Data1 label}) (Just next)) state input =
if isFirst label state
then run next state (drop (firstStmtItemSize state) input)
else run next (dequeue label state) input

run (Stmt (Statement {stmtCommand=Data2 arg1 arg2}) (Just next)) state input =
if isFirst arg1 state
then (value arg2 state input) ++ run next state input
else run next (enqueue arg1 (value arg2 state input) state) input

run stmt@(Stmt (Statement {stmtCommand=Call1 label}) _) state input =
call [] label stmt state input

run stmt@(Stmt (Statement {stmtCommand=Call2 label args}) _) state input =
call (value args state input) label stmt state input

run stmt@(Stmt (Statement {stmtCommand=Continue1 label}) _) state input =
if isFirst label state
then continueFirst label label stmt state input
else continue label label stmt state input

run stmt@(Stmt (Statement {stmtCommand=Continue2 label label2}) _) state input=
if isFirst label state
then continueFirst label label2 stmt state input
else continue label label2 stmt state input

run (Stmt (Statement {stmtCommand=If arg1 arg2}) (Just next)) state input =
if value arg1 state input == value arg2 state input
then run next state input
else case next of
(Stmt _ (Just next')) -> run next' state input
_ -> errorMsg next "No following statement"

run (Stmt stmt@(Statement {stmtCommand=Stop}) _) state input = []

run stmt@(Stmt _ Nothing) _ _ = errorMsg stmt "No following statement"

call :: [Int] -> [Int] -> Stmt -> State -> [Int] -> [Int]
call args label stmt@(Stmt _ (Just next)) state input =
let doCall calledStmt =
run calledStmt (pushCall label args next state) input
in maybe (errorMsg stmt ("Undefined label: " ++ concatMap show label))
doCall
(stmtByLabel state label)

continueFirst :: [Int] -> [Int] -> Stmt -> State -> [Int] -> [Int]
continueFirst label label2 stmt@(Stmt _ next) state [] =
maybe (errorMsg stmt "No following statement")
(flip (flip run state) [])
next

continueFirst label label2 stmt state input =
maybe (errorMsg stmt ("Undefined label: " ++ concatMap show label2))
(flip (flip run state) input)
(stmtByLabel state label2)

continue :: [Int] -> [Int] -> Stmt -> State -> [Int] -> [Int]
continue label label2 stmt state input =
let ret = let (stmt',state') = retCall label state
in run stmt' state' input
cont ([]:_) = ret
cont _ = maybe (errorMsg stmt ("Undefined label: "
++ concatMap show label2))
(flip (flip run state) input)
(stmtByLabel state label2)
in maybe ret cont (M.lookup label (queues state))

errorMsg :: Stmt -> String -> a
errorMsg (Stmt statement _) msg =
error (stmtFileName statement ++ ':' : show (stmtLineNumber statement)
++ ": " ++ msg)

main :: IO ()
main = do
(srcs,run) <- fmap (parseArgs interp) getArgs
statements <- sequence (map readSrc srcs)
interact (run (concat statements))

readSrc :: String -> IO [Statement]
readSrc "" = fmap (uncurry parse . (,) "<stdin>") getContents
readSrc src = fmap (uncurry parse . (,) src) (readFile src)

parseArgs :: ([Statement] -> String -> String) -> [String]
-> ([String],[Statement] -> String -> String)
parseArgs run ("-r":args) =
parseArgs (\ stmts -> concatMap show . interpRaw stmts) args
parseArgs run [] = ([""],run)
parseArgs run srcs = (srcs,run)

No comments:

Post a Comment