twc/ludus
4
0
Fork 0
Code Issues 32 Pull Requests Packages Projects 8 Releases Wiki Activity

Start work on the interpreter

Browse Source
This commit is contained in:
Scott Richmond 2023-05-21 16:43:26 -04:00
parent e02e972d27
commit 8516f0e053
6 changed files with 322 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
src/ludus/compile.clj
View File

@ -11,3 +11,24 @@
(def result (->> source s/scan :tokens (p/apply-parser g/script)))
(println result)
(comment "
What sorts of compiling and validation do we want to do? Be specific.
- check used names are bound (validation)
- check bound names are available (validation)
- check `recur` is only ever in `loop` and in `fn` bodies (validation)
- separate function arities into different functions (optimization)
- desugar partially applied functions (simplification)
- desugar keyword entry shorthand (simplification)
- flag tail calls for optimization (optimization)
- direct tail calls
- through different expressions
- block
- if
- cond
- match
- let
- check ns access
")

64
src/ludus/grammar.clj
View File

@ -58,9 +58,11 @@
(def constraint (order-0 :constraint [(quiet :when) expression]))
(def pattern (choice :pattern [literal :ignored :placeholder :word :keyword tuple-pattern dict-pattern struct-pattern list-pattern]))
(def typed (group (weak-order :typed [:word (quiet :as) :keyword])))
(def match-clause (group (order-0 :match-clause
(def pattern (flat (choice :pattern [literal :ignored :placeholder typed :word :keyword tuple-pattern dict-pattern struct-pattern list-pattern])))
(def match-clause (group (weak-order :match-clause
[pattern (maybe constraint) (quiet :rarrow) expression])))
(def match-entry (weak-order :match-entry [match-clause terminators]))
@ -73,7 +75,7 @@
(quiet :rbrace)
])))
(def iff (order-1 :if [(quiet :if)
(def iff (group (order-1 :if [(quiet :if)
nls?
expression
nls?
@ -81,18 +83,18 @@
expression
nls?
(quiet :else)
expression]))
expression])))
(def cond-lhs (flat (choice :cond-lhs [expression :placeholder :else])))
(def cond-clause (group (order-0 :cond-clause [cond-lhs (quiet :rarrow) expression])))
(def cond-clause (group (weak-order :cond-clause [cond-lhs (quiet :rarrow) expression])))
(def cond-entry (weak-order :cond-entry [cond-clause terminators]))
(def condd (order-1 :cond [(quiet :cond) (quiet :lbrace)
(def condd (group (order-1 :cond [(quiet :cond) (quiet :lbrace)
(quiet (zero+ terminator))
(one+ cond-entry)
(quiet :rbrace)]))
(quiet :rbrace)])))
(def lett (group (order-1 :let [(quiet :let)
pattern
@ -147,19 +149,19 @@
(def arg-expr (flat (choice :arg-expr [:placeholder expression])))
(def arg-entry (order-1 :arg-entry [arg-expr separators]))
(def arg-entry (weak-order :arg-entry [arg-expr separators]))
(def arg-tuple (order-1 :arg-tuple
(def args (group (order-1 :args
[(quiet :lparen)
(quiet (zero+ separator))
(zero+ arg-entry)
(quiet :rparen)]))
(quiet :rparen)])))
(def synth-root (choice :synth-root [:keyword :word :recur]))
(def synth-root (flat (choice :synth-root [:keyword :word :recur])))
(def synth-term (choice :synth-term [arg-tuple :keyword]))
(def synth-term (flat (choice :synth-term [args :keyword])))
(def synthetic (order-1 :synthetic [synth-root (zero+ synth-term)]))
(def synthetic (group (order-1 :synthetic [synth-root (zero+ synth-term)])))
(def fn-clause (group (order-0 :fn-clause [tuple-pattern (maybe constraint) (quiet :rarrow) expression])))
@ -185,7 +187,7 @@
(def block (group (order-1 :block [(quiet :lbrace)
(quiet (zero+ terminator))
(zero+ block-line)
(one+ block-line)
(quiet :rbrace)])))
(def pipeline (order-0 :pipeline [nls? :pipeline]))
@ -256,3 +258,37 @@
(def script (order-0 :script [nls?
(one+ script-line)
(quiet :eof)]))
;;; REPL
(comment (def source
"if 1 then 2 else 3"
)
(def result (apply-parser script source))
(defn report [node]
(when (fail? node) (err-msg node))
node)
(defn clean [node]
(if (map? node)
(-> node
(report)
(dissoc
;:status
:remaining
:token)
(update :data #(into [] (map clean) %)))
node))
(defn tap [x] (println "\n\n\n\n******NEW RUN\n\n:::=> " x "\n\n") x)
(def my-data (-> result
clean
tap
))
(println my-data))

249
src/ludus/interpreter.clj
View File

@ -1,6 +1,8 @@
(ns ludus.interpreter
(:require
[ludus.parser :as parser]
[ludus.parser-new :as p]
[ludus.grammar :as g]
[ludus.scanner :as scanner]
[ludus.ast :as ast]
[ludus.prelude :as prelude]
@ -27,9 +29,9 @@
::not-found))))
(defn- resolve-word [word ctx]
(let [value (ludus-resolve (:word word) ctx)]
(let [value (ludus-resolve (-> word :data first) ctx)]
(if (= ::not-found value)
(throw (ex-info (str "Unbound name: " (:word word)) {:ast word}))
(throw (ex-info (str "Unbound name: " (-> word :data first)) {:ast word}))
value)))
(declare interpret-ast match interpret interpret-file)
@ -158,42 +160,86 @@
{:success false :reason (str "Could not match " pattern " with " value " at key " kw " because " (:reason match?))}))
{:success false :reason (str "Could not match " pattern " with " value " at key " kw ", because there is no value at " kw)})))))))
(defn- get-type [value]
(let [t (type value)]
(cond
(nil? value) :nil
(= clojure.lang.Keyword t) :keyword
(= java.lang.Long t) :number
(= java.lang.Double t) :number
(= java.lang.String t) :string
(= java.lang.Boolean t) :boolean
(= clojure.lang.PersistentHashSet t) :set
;; tuples and lists
(= clojure.lang.PersistentVector t)
(if (= ::data/tuple (first value)) :tuple :list)
;; structs dicts namespaces refs
(= clojure.lang.PersistentArrayMap t)
(cond
(::data/dict value) :dict
(::data/struct value) :struct
:else :none
)
)))
(get-type [::data/tuple])
(defn- match-typed [pattern value ctx]
(let [data (:data pattern)
name (-> data first :data)
type (-> data second :data)]
(cond
(contains? ctx name) {:success false :reason (str "Name " name "is already bound") :code :name-error}
(not (= type (get-type value))) {:success false :reason (str "Could not match " pattern " with " value ", because types do not match")}
:else {:success true :ctx {name value}})))
(defn- match [pattern value ctx-vol]
(let [ctx @ctx-vol]
(case (::ast/type pattern)
::ast/placeholder {:success true :ctx {}}
(case (:type pattern)
(:placeholder :ignored)
{:success true :ctx {}}
::ast/atom
(let [match-value (:value pattern)]
(:number :nil :true :false :string :keyword)
(let [match-value (-> pattern :data first)]
(if (= match-value value)
{:success true :ctx {}}
{:success false
:reason (str "No match: Could not match " match-value " with " value)}))
::ast/word
(let [word (:word pattern)]
:word
(let [word (-> pattern :data first)]
(if (contains? ctx word)
{:success false :reason (str "Name " word " is already bound") :code :name-error}
{:success true :ctx {word value}}))
::ast/tuple (match-tuple pattern value ctx-vol)
:typed (match-typed pattern value ctx)
::ast/list (match-list pattern value ctx-vol)
:tuple (match-tuple pattern value ctx-vol)
::ast/dict (match-dict pattern value ctx-vol)
:list (match-list pattern value ctx-vol)
::ast/struct (match-struct pattern value ctx-vol)
:dict (match-dict pattern value ctx-vol)
:struct (match-struct pattern value ctx-vol)
(throw (ex-info "Unknown pattern on line " {:pattern pattern})))))
(defn- update-ctx [ctx new-ctx]
(merge ctx new-ctx))
;; TODO: get "if let" pattern working
;; TODO: get typed exceptions to distinguish panics
(defn- interpret-let [ast ctx]
(let [pattern (:pattern ast)
expr (:expr ast)
(let [data (:data ast)
pattern (first data)
expr (second data)
value (interpret-ast expr ctx)
match (match pattern value ctx)
success (:success match)]
@ -203,13 +249,15 @@
value))
(defn- interpret-if-let [ast ctx]
(let [if-ast (:if ast)
then-expr (:then ast)
else-expr (:else ast)
if-pattern (:pattern if-ast)
if-expr (:expr if-ast)
if-value (interpret-ast if-expr ctx)
if-match (match if-pattern if-value ctx)
(let [data (:data ast)
if-ast (first data)
then-expr (second data)
else-expr (nth data 2)
if-data (:data if-ast)
let-pattern (first if-data)
let-expr (second if-data)
let-value (interpret-ast let-expr ctx)
if-match (match let-pattern let-value ctx)
success (:success if-match)]
(if success
(interpret-ast then-expr (volatile! (merge (:ctx if-match) {:parent ctx})))
@ -218,44 +266,59 @@
(interpret-ast else-expr ctx)))))
(defn- interpret-if [ast ctx]
(let [if-expr (:if ast)
then-expr (:then ast)
else-expr (:else ast)]
(if (= (::ast/type if-expr) ::ast/let)
(let [data (:data ast)
if-expr (first data)
then-expr (second data)
else-expr (nth data 2)]
(if (= (:type if-expr) :let)
(interpret-if-let ast ctx)
(if (interpret-ast if-expr ctx)
(interpret-ast then-expr ctx)
(interpret-ast else-expr ctx)))))
(defn- interpret-match [ast ctx]
(let [match-expr (:expr ast)
expr (interpret-ast match-expr ctx)
clauses (:clauses ast)]
(let [data (:data ast)
match-expr (first data)
value (interpret-ast match-expr ctx)
clauses (rest data)]
(loop [clause (first clauses)
clauses (rest clauses)]
(if clause
(let [pattern (:pattern clause)
body (:body clause)
(let [clause-data (:data clause)
pattern (first clause-data)
constraint (if (= 3 (count clause-data))
(second clause-data)
nil)
body (peek clause-data)
new-ctx (volatile! {::parent ctx})
match? (match pattern expr new-ctx)
match? (match pattern value new-ctx)
success (:success match?)
clause-ctx (:ctx match?)]
(if success
(do
(vswap! new-ctx #(merge % clause-ctx))
(interpret-ast body new-ctx))
(if constraint
(if (interpret-ast constraint new-ctx)
(interpret-ast body new-ctx)
(recur (first clauses) (rest clauses)))
(interpret-ast body new-ctx)))
(recur (first clauses) (rest clauses))))
(throw (ex-info "Match Error: No match found" {:ast ast}))))))
(defn- interpret-cond [ast ctx]
(let [clauses (:clauses ast)]
(let [clauses (:data ast)]
(loop [clause (first clauses)
clauses (rest clauses)]
(if (not clause)
(throw (ex-info "Cond Error: No match found" {:ast ast}))
(let [test-expr (:test clause)
body (:body clause)
truthy? (boolean (interpret-ast test-expr ctx))]
(let [data (:data clause)
test-expr (first data)
test-type (:type test-expr)
body (second data)
truthy? (or
(= :placeholder test-type)
(= :else test-type)
(interpret-ast test-expr ctx))]
(if truthy?
(interpret-ast body ctx)
(recur (first clauses) (rest clauses))))))))
@ -322,28 +385,48 @@
:else (throw (ex-info "I don't know how to call that" {:ast lfn}))))
(defn- validate-args [args]
(>= 1 (count (filter #(= :placeholder (:type %)) args))))
(defn- partial? [args]
(some #(= :placeholder (:type %)) args))
(defn- interpret-args [ast ctx]
(let [members (:data ast)]
(if (partial? args)
(if (validate-args)
() ; do the thing
(throw (ex-info "Partially applied functions may only take a single argument")))
(map #(interpret-ast % ctx) args)
)))
(defn- interpret-synthetic-term [prev-value curr ctx]
(let [type (::ast/type curr)]
(if (= type ::ast/atom)
(let [type (:type curr)
data (:data curr)]
(if (= type :keyword)
(if (::data/struct prev-value)
(if (contains? prev-value (:value curr))
(get prev-value (:value curr))
(if (contains? prev-value (first data))
(get prev-value (first data))
(if (= (::data/type prev-value) ::data/ns)
(throw (ex-info (str "Namespace error: no member " (:value curr) " in ns " (::data/name prev-value)) {:ast curr}))
(throw (ex-info (str "Struct error: no member " (:value curr)) {:ast curr}))))
(get prev-value (:value curr)))
(call-fn prev-value (interpret-ast curr ctx) ctx))))
(get prev-value (first data)))
(call-fn prev-value (interpret-args curr ctx) ctx))))
(defn- interpret-synthetic [ast ctx]
(let [terms (:terms ast)
first (first terms)
second (second terms)
rest (rest (rest terms))
first-term-type (::ast/type first)
first-val (if (= first-term-type ::ast/atom)
(interpret-called-kw first second ctx)
(interpret-synthetic-term (interpret-ast first ctx) second ctx))]
(reduce #(interpret-synthetic-term %1 %2 ctx) first-val rest)))
(let [data (:data ast)
first-term (first data)
terms (-> data second :data)]
(if terms
(let [second-term (first terms)
rest (rest terms)
first-val (if (= (:type first) :keyword)
(interpret-called-kw first-term second-term ctx)
(interpret-synthetic-term (interpret-ast first-term ctx) second-term ctx))]
(reduce #(interpret-synthetic-term %1 %2 ctx) first-val rest))
(do
;(println "interpreting " (:type first-term))
(interpret-ast first-term ctx)))))
(defn- interpret-fn [ast ctx] ;; TODO: fix context/closure (no cycles)?
(let [name (:name ast)
@ -548,23 +631,26 @@
(swap! process #(assoc % :status :dead))))
pid))
(defn- interpret-literal [ast] (-> ast :data first))
(defn interpret-ast [ast ctx]
(case (::ast/type ast)
::ast/self self
(println "interpreting ast type" (:type ast))
;(println "AST: " ast)
(case (:type ast)
::ast/atom (:value ast)
(:nil :true :false :number :string :keyword) (interpret-literal ast)
::ast/word (resolve-word ast ctx)
:let (interpret-let ast ctx)
::ast/let (interpret-let ast ctx)
:if (interpret-if ast ctx)
::ast/if (interpret-if ast ctx)
:word (resolve-word ast ctx)
::ast/match (interpret-match ast ctx)
:synthetic (interpret-synthetic ast ctx)
::ast/cond (interpret-cond ast ctx)
:match (interpret-match ast ctx)
::ast/synthetic (interpret-synthetic ast ctx)
:cond (interpret-cond ast ctx)
::ast/fn (interpret-fn ast ctx)
@ -591,7 +677,7 @@
::ast/loop (interpret-loop ast ctx)
::ast/block
:block
(let [exprs (:exprs ast)
inner (pop exprs)
last (peek exprs)
@ -599,8 +685,8 @@
(run! #(interpret-ast % ctx) inner)
(interpret-ast last ctx))
::ast/script
(let [exprs (:exprs ast)
:script
(let [exprs (:data ast)
inner (pop exprs)
last (peek exprs)]
(run! #(interpret-ast % ctx) inner)
@ -609,16 +695,13 @@
;; note that, excepting tuples and structs,
;; runtime representations are bare
;; tuples are vectors with a special first member
::ast/tuple
(let [members (:members ast)]
(into
[(if (:partial ast) ::data/partial ::data/tuple)]
(map #(interpret-ast % ctx)) members))
:tuple
(let [members (:data ast)]
(into [::data/tuple] (map #(interpret-ast % ctx)) members))
::ast/list (interpret-list ast ctx)
::ast/set
(interpret-set ast ctx)
::ast/set (interpret-set ast ctx)
::ast/dict (interpret-dict ast ctx)
@ -660,14 +743,14 @@
process (process/new-process)]
(process/start-vm)
(with-bindings {#'self (:pid @process)}
(let [result (interpret-ast (::parser/ast parsed) base-ctx)]
(let [result (interpret-ast parsed base-ctx)]
(swap! process #(assoc % :status :dead))
(process/stop-vm)
result)))
(catch clojure.lang.ExceptionInfo e
(process/stop-vm)
(println "Ludus panicked!")
(println "On line" (get-in (ex-data e) [:ast :token ::token/line]))
(println "On line" (get-in (ex-data e) [:ast :token :line]))
(println (ex-message e))
(pp/pprint (ex-data e)))))
@ -699,11 +782,10 @@
)))))
(comment
(do
(process/start-vm)
(def source "
let #{a, a} = #{:a 1}
a
id (1)
")
(println "")
@ -711,18 +793,19 @@
(println "*** *** NEW INTERPRETATION *** ***")
(println "")
(let [result (-> source
(scanner/scan)
(parser/parse)
(interpret-safe)
(show/show)
(let [result (->> source
scanner/scan
:tokens
(p/apply-parser g/script)
interpret-safe
;(show/show)
)]
(println result)
result))
(comment "
Left to do:
x if-let pattern
* improve panics
* add location info for panics
* refactor calling keywords

41
src/ludus/interpreter_new.clj Normal file
View File

@ -0,0 +1,41 @@
(ns ludus.interpreter-new
(:require
[ludus.grammar :as g]
[ludus.parser-new :as p]
[ludus.scanner :as s]))
(def source
"
foo (1, _)
"
)
(def tokens (-> source s/scan :tokens))
(def result (p/apply-parser g/script tokens))
(-> result :data)
(defn report [node]
(when (p/fail? node) (p/err-msg node))
node)
(defn clean [node]
(if (map? node)
(-> node
(report)
(dissoc
:status
:remaining
:token)
(update :data #(into [] (map clean) %)))
node))
(defn tap [x] (println "\n\n\n\n******NEW RUN\n\n:::=> " x "\n\n") x)
(def my-data (-> result
clean
tap
))
(println my-data)

2
src/ludus/parser_new.clj
View File

@ -253,7 +253,7 @@
(:ok :group :quiet)
{:status :group
:type name
:data (vec (concat [first-result] (data rest-result)))
:data (vec (concat (:data first-result) (data rest-result)))
:token (first tokens)
:remaining (remaining rest-result)}

5
src/ludus/prelude.clj
View File

@ -98,7 +98,10 @@
::data/type ::data/clj
:body d/ludus-draw})
(def prelude {"eq" eq
(def prelude {
"foo" :foo
"bar" :bar
"eq" eq
"add" add
"print" print-
"sub" sub