diff --git a/src/jolt/compiler.janet b/src/jolt/compiler.janet index a250919..ff440ba 100644 --- a/src/jolt/compiler.janet +++ b/src/jolt/compiler.janet @@ -110,7 +110,6 @@ # ============================================================ (defn- resolve-macro - "Resolve a symbol struct to a macro var. Returns the var or nil." [ctx sym-s] (when ctx (let [name (sym-s :name) @@ -129,7 +128,7 @@ (if (and cv (var-macro? cv)) cv)))))))) # ============================================================ -# Core function value lookup — resolved at compile time +# Core function value lookup # ============================================================ (def- core-fn-values @@ -218,6 +217,18 @@ (put t "core-pr-str" core-str) (put t "core-nth" core-get) t)) + +# Loop counter for generating unique loop function names +(var loop-counter 0) + +(defn- make-loop-name + [] + (let [name (string "_loop_" loop-counter)] + (++ loop-counter) + name)) + +# ============================================================ +# Analyzer # ============================================================ (defn analyze-form @@ -245,8 +256,7 @@ head-name (if (and (struct? first-form) (= :symbol (first-form :jolt/type))) (first-form :name) nil)] - # Macro expansion: if ctx is provided and head resolves to a macro, - # expand it and re-analyze the expanded form + # Macro expansion (if (and ctx head-name (not (special-form? head-name)) (resolve-macro ctx first-form)) @@ -257,6 +267,41 @@ (if head-name (match head-name "quote" {:op :quote :expr (in form 1)} + "throw" {:op :throw :val (analyze-form (in form 1) bindings ctx)} + "try" (let [body-form (in form 1) + clauses (tuple/slice form 2) + n (length clauses)] + (var catch-sym nil) + (var catch-body nil) + (var finally-body nil) + (var i 0) + (while (< i n) + (let [clause (in clauses i) + head (first clause)] + (if (and (struct? head) (= :symbol (head :jolt/type))) + (match (head :name) + "catch" (do + (set catch-sym (in clause 2)) + (set catch-body (tuple/slice clause 3))) + "finally" (set finally-body (tuple/slice clause 1))))) + (++ i)) + (let [catch-bindings (if catch-sym + (do + (var cb @{}) + (loop [[k v] :pairs bindings] (put cb k v)) + (put cb (catch-sym :name) :jolt/local) + cb) + nil)] + {:op :try + :body (analyze-form body-form bindings ctx) + :catch-sym (if catch-sym (catch-sym :name)) + :catch-body (if catch-body + (map |(analyze-form $ catch-bindings ctx) catch-body)) + :finally-body (if finally-body + (map |(analyze-form $ bindings ctx) finally-body))})) + "recur" (let [args (map |(analyze-form $ bindings ctx) (tuple/slice form 1)) + loop-name (get bindings :jolt/current-loop)] + {:op :recur :args args :loop-name loop-name}) "do" (let [all-statements (array/slice form 1) n (length all-statements) analyzed (map |(analyze-form $ bindings ctx) all-statements)] @@ -317,6 +362,40 @@ :statements (array/slice analyzed-body 0 (- n-body 1)) :ret (last analyzed-body)} (first analyzed-body))}) + "loop*" (let [bind-vec (in form 1) + loop-name (make-loop-name) + binding-pairs (do + (var pairs @[]) + (var i 0) + (let [n (length bind-vec)] + (while (< i n) + (let [sym-s (in bind-vec i) + name (if (struct? sym-s) (sym-s :name) sym-s) + val-form (if (< (+ i 1) n) (in bind-vec (+ i 1)) nil) + val-ast (if val-form (analyze-form val-form bindings ctx) {:op :const :val nil})] + (array/push pairs {:name name :init val-ast}) + (+= i 2)))) + pairs) + param-names (map |($ :name) binding-pairs) + body-bindings (do + (var bb @{}) + (loop [[k v] :pairs bindings] (put bb k v)) + (each bp binding-pairs + (put bb (bp :name) :jolt/local)) + (put bb :jolt/current-loop loop-name) + bb) + body-exprs (tuple/slice form 2) + analyzed-body (map |(analyze-form $ body-bindings ctx) body-exprs) + n-body (length analyzed-body)] + {:op :loop + :loop-name loop-name + :param-names param-names + :init-vals (map |($ :init) binding-pairs) + :body (if (> n-body 1) + {:op :do + :statements (array/slice analyzed-body 0 (- n-body 1)) + :ret (last analyzed-body)} + (first analyzed-body))}) (let [f-ast (analyze-form first-form bindings ctx) args (map |(analyze-form $ bindings ctx) (tuple/slice form 1))] {:op :invoke :fn f-ast :args args})) @@ -393,6 +472,55 @@ (++ i))) (buffer/push buf "] ") (emit-ast body buf) (buffer/push buf ")")) +(defn- emit-throw-str [val buf] + (buffer/push buf "(error ") (emit-ast val buf) (buffer/push buf ")")) + +(defn- emit-try-str [body catch-sym catch-body finally-body buf] + (buffer/push buf "(try ") + (emit-ast body buf) + (when catch-sym + (buffer/push buf " ([") + (buffer/push buf catch-sym) + (buffer/push buf "] ") + (if (= 1 (length catch-body)) + (emit-ast (first catch-body) buf) + (do + (buffer/push buf "(do ") + (var i 0) + (let [n (length catch-body)] + (while (< i n) + (emit-ast (in catch-body i) buf) + (when (< (+ i 1) n) (buffer/push buf " ")) + (++ i))) + (buffer/push buf ")"))) + (buffer/push buf ")")) + (buffer/push buf ")")) + +(defn- emit-loop-str [loop-name param-names init-vals body buf] + (buffer/push buf "(do (var ") (buffer/push buf loop-name) (buffer/push buf " nil) ") + (buffer/push buf "(set ") (buffer/push buf loop-name) (buffer/push buf " (fn [") + (var i 0) + (let [n (length param-names)] + (while (< i n) + (buffer/push buf (in param-names i)) + (when (< (+ i 1) n) (buffer/push buf " ")) + (++ i))) + (buffer/push buf "] ") + (emit-ast body buf) + (buffer/push buf ")) (") + (buffer/push buf loop-name) + (each iv init-vals + (buffer/push buf " ") + (emit-ast iv buf)) + (buffer/push buf "))")) + +(defn- emit-recur-str [args loop-name buf] + (buffer/push buf "(") (buffer/push buf loop-name) + (each arg args + (buffer/push buf " ") + (emit-ast arg buf)) + (buffer/push buf ")")) + (defn- emit-invoke-str [f-ast args buf] (buffer/push buf "(") (emit-ast f-ast buf) (each arg args (buffer/push buf " ") (emit-ast arg buf)) @@ -434,6 +562,10 @@ :def (emit-def-str (ast :name) (ast :init) buf) :fn (emit-fn-str (ast :params) (ast :body) buf) :let (emit-let-str (ast :binding-pairs) (ast :body) buf) + :throw (emit-throw-str (ast :val) buf) + :try (emit-try-str (ast :body) (ast :catch-sym) (ast :catch-body) (ast :finally-body) buf) + :loop (emit-loop-str (ast :loop-name) (ast :param-names) (ast :init-vals) (ast :body) buf) + :recur (emit-recur-str (ast :args) (ast :loop-name) buf) :invoke (emit-invoke-str (ast :fn) (ast :args) buf) :vector (emit-vector-str (ast :items) buf) :map (emit-map-str (ast :form) buf) @@ -447,6 +579,15 @@ (var emit-expr nil) (defn- emit-const-expr [val] val) +(defn- emit-symbol-expr [name] (symbol name)) +(defn- emit-local-expr [name] (symbol name)) + +(defn- emit-core-symbol-expr [janet-name] + (or (get core-fn-values janet-name) + (error (string "Core fn not found: " janet-name)))) + +(defn- emit-qualified-symbol-expr [ns name] + (error (string "Cannot eval qualified symbol at compile time: " ns "/" name))) (defn- emit-do-expr [statements ret] (def exprs @['do]) @@ -477,21 +618,51 @@ (array/push bind-tuple (emit-expr (bp :init)))) ['let (tuple/slice (tuple ;bind-tuple)) (emit-expr body)]) +(defn- emit-throw-expr [val] + ['error (emit-expr val)]) + +(defn- emit-try-expr [body catch-sym catch-body finally-body] + # Janet try: (try body ([err] handler-body)) + (def forms @['try (emit-expr body)]) + (when catch-sym + (def err-binding [(symbol catch-sym)]) + (def handler + (if (= 1 (length catch-body)) + (emit-expr (first catch-body)) + (do + (def do-body @['do]) + (each cb catch-body (array/push do-body (emit-expr cb))) + (tuple/slice (tuple ;do-body))))) + (array/push forms [(tuple ;err-binding) handler])) + (when finally-body + (def finally-do @['do]) + (each fb finally-body (array/push finally-do (emit-expr fb))) + (array/push forms (tuple/slice (tuple ;finally-do)))) + (tuple/slice (tuple ;forms))) + +(defn- emit-loop-expr [loop-name param-names init-vals body] + # Emit: (do (var loop-name nil) (set loop-name (fn [params] body)) (loop-name init-vals...)) + (def param-syms (map symbol param-names)) + (def loop-sym (symbol loop-name)) + (def body-emitted (emit-expr body)) + # For recur calls, rewrite (recur arg1 arg2) → (loop-name arg1 arg2) + # This is done by the :recur op handler below which uses the loop-name from ast + ['do + ['var loop-sym nil] + ['set loop-sym ['fn (tuple/slice (tuple ;param-syms)) body-emitted]] + (tuple ;(array/insert (map emit-expr init-vals) 0 loop-sym))]) + +(defn- emit-recur-expr [args loop-name] + # Emit: (loop-name arg1 arg2...) + (def exprs @[(symbol loop-name)]) + (each arg args (array/push exprs (emit-expr arg))) + (tuple/slice (tuple ;exprs))) + (defn- emit-invoke-expr [f-ast args] (def exprs @[(emit-expr f-ast)]) (each arg args (array/push exprs (emit-expr arg))) (tuple/slice (tuple ;exprs))) -(defn- emit-symbol-expr [name] (symbol name)) -(defn- emit-local-expr [name] (symbol name)) - -(defn- emit-core-symbol-expr [janet-name] - (or (get core-fn-values janet-name) - (error (string "Core fn not found: " janet-name)))) - -(defn- emit-qualified-symbol-expr [ns name] - (error (string "Cannot eval qualified symbol at compile time: " ns "/" name))) - (defn- emit-vector-expr [items] (def exprs @[]) (each item items (array/push exprs (emit-expr item))) @@ -515,6 +686,10 @@ :def (emit-def-expr (ast :name) (ast :init)) :fn (emit-fn-expr (ast :params) (ast :body)) :let (emit-let-expr (ast :binding-pairs) (ast :body)) + :throw (emit-throw-expr (ast :val)) + :try (emit-try-expr (ast :body) (ast :catch-sym) (ast :catch-body) (ast :finally-body)) + :loop (emit-loop-expr (ast :loop-name) (ast :param-names) (ast :init-vals) (ast :body)) + :recur (emit-recur-expr (ast :args) (ast :loop-name)) :invoke (emit-invoke-expr (ast :fn) (ast :args)) :vector (emit-vector-expr (ast :items)) :map (emit-map-expr (ast :form)) @@ -526,8 +701,7 @@ # ============================================================ (defn compile-form - "Compile a Clojure form to a Janet source string. - Pass ctx for macro expansion." + "Compile a Clojure form to a Janet source string." [form &opt ctx] (default ctx nil) (let [ast (analyze-form form @{} ctx) @@ -536,14 +710,12 @@ (string buf))) (defn compile-ast - "Compile a Clojure form to an eval-able Janet data structure. - Core function symbols are resolved to actual function values." + "Compile a Clojure form to an eval-able Janet data structure." [form &opt ctx] (default ctx nil) (emit-expr (analyze-form form @{} ctx))) (defn compile-and-eval - "Compile a Clojure form and evaluate it as Janet. - Emits Janet data structures with resolved core functions." + "Compile a Clojure form and evaluate it as Janet." [form ctx] (eval (compile-ast form ctx))) diff --git a/test/compiler-test.janet b/test/compiler-test.janet index c02610f..cdcaaa7 100644 --- a/test/compiler-test.janet +++ b/test/compiler-test.janet @@ -170,3 +170,34 @@ (print " passed") (print "\nAll compiler Phase 4 tests passed!") + +# ============================================================ +# 12. throw, try, loop*/recur (Phase 5) +# ============================================================ +(print "12: throw/try/loop...") +(use ../src/jolt/api) + +(let [ctx (init {:compile? true})] + # throw/catch via compiler + (assert (= "caught" + (eval-string ctx "(try (throw 42) (catch Exception e \"caught\"))")) + "try/catch") + + # try without catch returns body + (assert (= 1 (eval-string ctx "(try 1 (catch Exception e 2))")) "try no throw") + + # throw in nested context + (assert (= "ok" + (eval-string ctx "(try (do (throw 99) 1) (catch Exception e \"ok\"))")) + "throw in do") + + # loop*/recur + (assert (= 3 (eval-string ctx "(loop* [x 0] (if (< x 3) (recur (inc x)) x))")) + "loop count up") + (assert (= 3 + (eval-string ctx "(loop* [i 0 acc 0] (if (< i 3) (recur (inc i) (+ acc i)) acc))")) + "loop with acc")) + +(print " passed") + +(print "\nAll compiler Phase 5 tests passed!")