118 lines
3.8 KiB
Janet
118 lines
3.8 KiB
Janet
(def grammar (peg/compile ~{
|
|
:main (* :tok (any (* :s+ :tok)) -1)
|
|
:tok (+ (<- :word) (number (some (+ (range "09") "."))))
|
|
:word (* :init-char (any :rest-char))
|
|
:init-char (+ (range "AZ") (range "az") (set ":/{}><,.[]+=-_*&^%$#@!;()"))
|
|
:rest-char (+ :init-char (range "09"))
|
|
}))
|
|
|
|
# State @{ :dictionary @{ word { :definition [word] :immediate } } :stack @[] :mode fn }
|
|
(defn immediate [state word]
|
|
(cond
|
|
(or (number? word) (array? word) (tuple? word)) (array/push (state :stack) word)
|
|
(let
|
|
(word (or ((state :dictionary) word) (error (string "No such word defined: " word))))
|
|
((word :definition) state)
|
|
)))
|
|
|
|
(defn deferred [state word] (let
|
|
(definition ((state :dictionary) word)) (if (and definition (definition :immediate))
|
|
(immediate state word)
|
|
(array/push (array/peek (state :stack)) word)
|
|
)))
|
|
|
|
(defmacro fixed-word [args ret] ~{
|
|
:definition (fn [state]
|
|
(do
|
|
,;(map (fn [name] ~(def ,name (,array/pop (state :stack)))) (reverse args))
|
|
(array/concat (state :stack) ,ret)
|
|
)
|
|
)
|
|
})
|
|
|
|
(defn run-state [state words]
|
|
(loop [word :in words] (:mode state word))
|
|
)
|
|
|
|
(defn word-as [& words] { :definition (fn [state] (run-state state words)) })
|
|
|
|
(defn truthy [a] (and a (not (= a 0))))
|
|
|
|
(def std-dict @{
|
|
"pick" (fixed-word [a b] [a b a])
|
|
"drop" (fixed-word [a] [])
|
|
"swap" (fixed-word [a b] [b a])
|
|
"dup" (fixed-word [a] [a a])
|
|
"-" (fixed-word [a b] (- a b))
|
|
"+" (fixed-word [a b] (+ a b))
|
|
"*" (fixed-word [a b] (* a b))
|
|
"/" (fixed-word [a b] (/ a b))
|
|
"=" (fixed-word [a b] (= a b))
|
|
">" (fixed-word [a b] (> a b))
|
|
"<" (fixed-word [a b] (< a b))
|
|
"len" (fixed-word [a] (length a))
|
|
"true" (fixed-word [] true)
|
|
"false" (fixed-word [] false)
|
|
"dec" (word-as 1 "-")
|
|
"inc" (word-as 1 "+")
|
|
"negate" (word-as 0 "swap" "-")
|
|
"." (fixed-word [a] (do (print a) []))
|
|
".s" { :definition (fn [state] (pp (state :stack)))}
|
|
"{" { :definition (fn [state]
|
|
(array/push (state :stack) @[])
|
|
(set (state :mode) deferred)
|
|
)}
|
|
"}" { :definition (fn [state]
|
|
(def words (array/peek (state :stack)))
|
|
(if (> (count |(= $ "{") words) (count |(= $ "}") words))
|
|
(array/push words "}")
|
|
(do
|
|
(def dictionary (table/clone (state :dictionary)))
|
|
(array/pop (state :stack)) # Remove wordlist that's on stack top
|
|
(array/push (state :stack) (fn [state &opt recur]
|
|
(when recur (set (dictionary "recur") { :definition recur }))
|
|
(def state @{ :dictionary dictionary :stack (state :stack) :mode immediate })
|
|
(run-state state words)
|
|
))
|
|
(set (state :mode) immediate)
|
|
)
|
|
)
|
|
) :immediate true }
|
|
"()" { :definition (fn [state] ((array/pop (state :stack)) state)) }
|
|
":" { :definition (fn [state]
|
|
(set (state :mode) (fn [state word]
|
|
(def exec (array/pop (state :stack)))
|
|
(set ((state :dictionary) word) { :definition (fn [state] (exec state exec)) })
|
|
(set (state :mode) immediate)
|
|
))
|
|
)}
|
|
"if" (fixed-word [cond when-true when-false] (do ((if (truthy cond) when-true when-false) state) []))
|
|
"loop" { :definition (fn [state]
|
|
(def body (array/pop (state :stack)))
|
|
(body state)
|
|
(while (truthy (array/pop (state :stack))) (body state))
|
|
)}
|
|
"while" { :definition (fn [state]
|
|
(def body (array/pop (state :stack)))
|
|
(while (truthy (array/pop (state :stack))) (body state))
|
|
)}
|
|
"repeat" (fixed-word [count body] (for x 0 count (body state)))
|
|
"[" { :immediate true :definition (fn [state]
|
|
(set (state :mode) immediate)
|
|
)}
|
|
"]" { :definition (fn [state]
|
|
(def val (array/pop (state :stack)))
|
|
(array/push (array/peek (state :stack)) val)
|
|
(set (state :mode) deferred)
|
|
)}
|
|
})
|
|
|
|
|
|
|
|
(defn main [_ arg] (let (
|
|
words (peg/match grammar arg)
|
|
state @{ :dictionary (table/clone std-dict) :stack @[] :mode immediate }
|
|
)
|
|
(run-state state words)
|
|
))
|