From 8516f0e0532fb3b6c063dfd723f69318f0457741 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Sun, 21 May 2023 16:43:26 -0400 Subject: [PATCH] Start work on the interpreter --- src/ludus/compile.clj | 23 ++- src/ludus/grammar.clj | 90 +++++++---- src/ludus/interpreter.clj | 295 ++++++++++++++++++++++------------ src/ludus/interpreter_new.clj | 41 +++++ src/ludus/parser_new.clj | 2 +- src/ludus/prelude.clj | 9 +- 6 files changed, 322 insertions(+), 138 deletions(-) create mode 100644 src/ludus/interpreter_new.clj diff --git a/src/ludus/compile.clj b/src/ludus/compile.clj index bcfd8df..b732707 100644 --- a/src/ludus/compile.clj +++ b/src/ludus/compile.clj @@ -10,4 +10,25 @@ (def result (->> source s/scan :tokens (p/apply-parser g/script))) -(println result) \ No newline at end of file +(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 + + ") \ No newline at end of file diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index eafaa33..79a35dd 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -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,26 +75,26 @@ (quiet :rbrace) ]))) -(def iff (order-1 :if [(quiet :if) - nls? - expression - nls? - (quiet :then) - expression - nls? - (quiet :else) - expression])) +(def iff (group (order-1 :if [(quiet :if) + nls? + expression + nls? + (quiet :then) + expression + nls? + (quiet :else) + 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) - (quiet (zero+ terminator)) - (one+ cond-entry) - (quiet :rbrace)])) +(def condd (group (order-1 :cond [(quiet :cond) (quiet :lbrace) + (quiet (zero+ terminator)) + (one+ cond-entry) + (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 - [(quiet :lparen) - (quiet (zero+ separator)) - (zero+ arg-entry) - (quiet :rparen)])) +(def args (group (order-1 :args + [(quiet :lparen) + (quiet (zero+ separator)) + (zero+ arg-entry) + (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])) @@ -255,4 +257,38 @@ (def script (order-0 :script [nls? (one+ script-line) - (quiet :eof)])) \ No newline at end of file + (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)) \ No newline at end of file diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index 181e52a..6ac3138 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -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) @@ -95,16 +97,16 @@ :else (let [members (:members pattern) - ctx-diff (volatile! @ctx-vol)] - (loop [i (dec (count members))] - (if (> 0 i) - {:success true :ctx @ctx-diff} - (let [match? (match (nth members i) (nth value i) ctx-diff)] - (if (:success match?) - (do - (vswap! ctx-diff #(merge % (:ctx match?))) - (recur (dec i))) - {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))}))))))) + ctx-diff (volatile! @ctx-vol)] + (loop [i (dec (count members))] + (if (> 0 i) + {:success true :ctx @ctx-diff} + (let [match? (match (nth members i) (nth value i) ctx-diff)] + (if (:success match?) + (do + (vswap! ctx-diff #(merge % (:ctx match?))) + (recur (dec i))) + {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))}))))))) (defn- match-dict [pattern value ctx-vol] (cond @@ -131,7 +133,7 @@ (recur (dec i))) {: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)}))))))) + :reason (str "Could not match " pattern " with " value " at key " kw " because there is no value at " kw)}))))))) (defn- match-struct [pattern value ctx-vol] (cond @@ -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,59 +249,76 @@ 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) - success (:success if-match)] - (if success - (interpret-ast then-expr (volatile! (merge (:ctx if-match) {:parent ctx}))) - (if (:code if-match) - (throw (ex-info (:reason if-match) {:ast if-ast})) - (interpret-ast else-expr 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}))) + (if (:code if-match) + (throw (ex-info (:reason if-match) {:ast if-ast})) + (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) - (interpret-if-let ast ctx) - (if (interpret-ast if-expr ctx) - (interpret-ast then-expr ctx) - (interpret-ast else-expr ctx))))) + (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 + (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,30 +782,30 @@ ))))) -(comment +(do (process/start-vm) (def source " - let #{a, a} = #{:a 1} - a - ") + id (1) + ") (println "") (println "****************************************") (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 diff --git a/src/ludus/interpreter_new.clj b/src/ludus/interpreter_new.clj new file mode 100644 index 0000000..95b3f0b --- /dev/null +++ b/src/ludus/interpreter_new.clj @@ -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) diff --git a/src/ludus/parser_new.clj b/src/ludus/parser_new.clj index 6dfc8b5..981faeb 100644 --- a/src/ludus/parser_new.clj +++ b/src/ludus/parser_new.clj @@ -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)} diff --git a/src/ludus/prelude.clj b/src/ludus/prelude.clj index d2fb63e..707d760 100644 --- a/src/ludus/prelude.clj +++ b/src/ludus/prelude.clj @@ -95,10 +95,13 @@ :body get}) (def draw {:name "draw" - ::data/type ::data/clj - :body d/ludus-draw}) + ::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