From a1bfd55b384a0bbe5f37b049f4076fe659b85d4b Mon Sep 17 00:00:00 2001 From: Yogthos Date: Tue, 2 Jun 2026 21:30:38 -0400 Subject: [PATCH] Phase 5: Multimethods + Hierarchy system MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - types.janet: make-hierarchy, derive*, ancestors, descendants, isa?, underive - evaluator.janet: defmulti extended with :default and :hierarchy options + keyword dispatch-fns wrapped as (fn [x] (get x kw)) for Janet compat + hierarchy-based dispatch walks isa? chain when no direct match - core.janet: real derive, isa?, ancestors, descendants implementations replacing stubs; core-remove-method, core-remove-all-methods, core-prefer-method added; new core-bindings entries - 5 test sections (22-26): hierarchy ops, basic dispatch, :default, hierarchy dispatch, remove-method — all pass - 317 tests, 0 failures --- .dirge/memory/MEMORY.md | 14 ++-- .dirge/memory/PITFALLS.md | 8 +- .dirge/skills/.usage.json | 36 ++++---- .dirge/skills/jolt-compiler/SKILL.md | 118 ++++++++++++++++++--------- .dirge/skills/jolt-dev/SKILL.md | 61 +++++++------- src/jolt/core.janet | 41 +++++++++- src/jolt/evaluator.janet | 53 +++++++++--- src/jolt/types.janet | 51 ++++++++++++ test/phase5-test.janet | 59 ++++++++++++++ 9 files changed, 329 insertions(+), 112 deletions(-) create mode 100644 test/phase5-test.janet diff --git a/.dirge/memory/MEMORY.md b/.dirge/memory/MEMORY.md index 1b92709..03efb7b 100644 --- a/.dirge/memory/MEMORY.md +++ b/.dirge/memory/MEMORY.md @@ -1,11 +1,9 @@ -Phase 0 (defn fix): compile-and-eval interns def/defn results in Jolt namespace via ns-intern so interpreter can resolve bare symbols. - -Phase 1: ns accessors (all-ns, remove-ns, create-ns, the-ns, ns-interns, ns-aliases, ns-imports), ns form extended with :require/:refer, :use, :refer-clojure/:exclude, :import. binding macro via push-thread-bindings/pop-thread-bindings. - -Phase 2 (PersistentHashMap): Live in src/jolt/phm.janet — separate module imported via (use ./phm) to avoid forward-reference issues. PHM is a table with :jolt/deftype tag "jolt.lang.persistent-hash-map.PersistentHashMap". Has :cnt, :buckets (array of 8 arrays), :_meta. Bucket-based: each bucket is flat [k v k v ...] array. phm-assoc, phm-dissoc, phm-get, phm-contains?, phm-entries, phm-to-struct (→ Janet struct for compatibility). Core functions updated with PHM branches: core-map?, core-hash-map, core-get, core-count, core-keys, core-vals, core-contains?, core-empty?, core-seq, core-conj, core-assoc, core-dissoc, core-merge, core-merge-with, core-into, core-=. - -Macro expansion: resolve-macro at analyze time → expand → re-analyze. Loop: (do (var _loop_N nil) (set _loop_N (fn [params] body)) (_loop_N vals...)). Recur: emits (loop-name args...) via :loop-name in AST. -§ Test files: test/phase6-final.janet (47 tests, 58 assertions — collections, math, predicates, comparison, seq ops, special forms, macros, complex nesting). Phase 1 tests appended to test/compiler-test.janet (ns accessors, ns form extensions). All 317 tests pass. § Phase 3 (Var system): find-var (ctx-based, resolve-q/nq symbol), alter-meta!, reset-meta!, var-get/var-set/var?/alter-var-root all in types.janet + evaluator dispatch arms + core-bindings wrappers. core-meta fixed: (var? x) branch → var-meta, struct? branch → :meta. 10 tests pass. +§ +Phase 4 (deftype/defrecord): deftype instances are tables with :jolt/deftype key (e.g. "user.Point"). Field access via (. obj field), mutation via (set! (.-field obj) val) — reader parses .-field as (. -field obj) in array form. core-map? recognizes table+deftype. core-count skips :jolt/deftype key. core-defrecord emits (deftype ...) + ->TypeName arrow factory + map->TypeName factory (deferred). 11 tests pass including record equality. 317 total, 0 fail. +§ +Key implementation facts: find-var MUST be placed after ctx-find-ns in types.janet (forward-reference). intern dispatch arm needs eval-form on args. core-meta: check (var? x) before (struct? x) — var-meta returns metadata for vars. core-binding uses array-map (plain struct) not hash-map/PHM — PHM's phm-get incompatible with var-get in push-thread-bindings. +§ +Phase 5 (Multimethods + hierarchy): Not yet started. defmulti/defmethod exist in evaluator.janet (lines 611-656) but are routed to interpreter in compile mode. core-derive, core-isa?, core-ancestors, core-descendants are stubs in core.janet. diff --git a/.dirge/memory/PITFALLS.md b/.dirge/memory/PITFALLS.md index ec8f784..49b971e 100644 --- a/.dirge/memory/PITFALLS.md +++ b/.dirge/memory/PITFALLS.md @@ -1,7 +1,7 @@ -Bare tuples in Janet's `eval` are function calls: `(eval [1 2 3])` tries to call `1` as function. Always emit `['tuple 1 2 3]` or `(tuple 1 2 3)` in data-structure emitter. Similarly, `(eval (try body (sym handler)))` fails because `catch` is not a Janet special form — must be `(try body ([sym] handler))`. Discovered during Phase 5/6 compiler work. -§ -Duplicate function definitions in the same file cause hard-to-diagnose "unknown symbol" errors. In compiler.janet, emit-quote-str was defined twice (once before emit-ast dispatch, once before emit-expr section). The second definition compiled but the first was used by emit-ast dispatch — causing "unknown symbol raw-form->janet". Always grep for the fn name before adding a new definition. -§ Janet break can't be used inside let blocks — break returns from the innermost loop, and in a let, there's no loop. Pattern: use (var found nil) + (while ... (if condition (do (set found val) (break)))) then check found after loop. § core-binding macro: use array-map (plain struct) NOT hash-map/PHM for the binding frame. PHM's phm-get doesn't work with push-thread-bindings' var-get lookup. Symptom: "error: dynamic binding" with no useful message. Fix: emit (array-map [var sym] val ...) instead of (hash-map ...). +§ +Janet `and` returns the last truthy value (not boolean true). `(and (table? x) (get x :jolt/deftype))` returns the deftype string, which is truthy but not `true`. Wrap with `(if (and ...) true false)` when the return value must be a boolean. This hit core-map? and would hit any predicate returning the result of `and`. +§ +set! field mutation: `(set! (.-x obj) val)` is read as `(set! (. -x obj) val)` — the target is an array with `.` as head. Check for this case BEFORE the existing `(.-field obj)` shorthand check (which is just `(. obj -field)`). The reader transforms `.`-prefixed symbols differently than expected: `.-x` becomes a symbol `-x` inside a `(. -x obj)` array form, NOT a standalone `.-x` symbol. diff --git a/.dirge/skills/.usage.json b/.dirge/skills/.usage.json index b78c567..555fa0a 100644 --- a/.dirge/skills/.usage.json +++ b/.dirge/skills/.usage.json @@ -1,12 +1,24 @@ { + "jolt-compiler": { + "created_by": "agent", + "use_count": 6, + "view_count": 10, + "patch_count": 8, + "last_used_at": "2026-06-03T01:15:04.055288+00:00", + "last_viewed_at": "2026-06-03T01:15:04.048271+00:00", + "last_patched_at": "2026-06-03T01:15:38.021717+00:00", + "created_at": "2026-06-02T17:54:38.690279+00:00", + "state": "active", + "pinned": false + }, "jolt-dev": { "created_by": "agent", - "use_count": 32, - "view_count": 47, - "patch_count": 40, - "last_used_at": "2026-06-03T00:55:18.036371+00:00", - "last_viewed_at": "2026-06-03T00:55:18.017806+00:00", - "last_patched_at": "2026-06-03T00:55:51.227868+00:00", + "use_count": 33, + "view_count": 48, + "patch_count": 41, + "last_used_at": "2026-06-03T01:13:54.913664+00:00", + "last_viewed_at": "2026-06-03T01:13:54.902684+00:00", + "last_patched_at": "2026-06-03T01:14:59.915995+00:00", "created_at": "2026-06-01T21:26:06.614465+00:00", "state": "active", "pinned": false @@ -32,17 +44,5 @@ "created_at": "2026-06-01T21:49:51.101718+00:00", "state": "active", "pinned": false - }, - "jolt-compiler": { - "created_by": "agent", - "use_count": 5, - "view_count": 9, - "patch_count": 7, - "last_used_at": "2026-06-03T00:55:56.946140+00:00", - "last_viewed_at": "2026-06-03T00:55:56.935595+00:00", - "last_patched_at": "2026-06-03T00:56:15.725835+00:00", - "created_at": "2026-06-02T17:54:38.690279+00:00", - "state": "active", - "pinned": false } } \ No newline at end of file diff --git a/.dirge/skills/jolt-compiler/SKILL.md b/.dirge/skills/jolt-compiler/SKILL.md index 2944dd7..ad41725 100644 --- a/.dirge/skills/jolt-compiler/SKILL.md +++ b/.dirge/skills/jolt-compiler/SKILL.md @@ -1,4 +1,5 @@ # jolt-compiler +# Jolt Compiler Source-to-source Clojure→Janet compiler. Two-phase: analyze-form (classify + macro expand) → emit-ast (generate). @@ -15,81 +16,122 @@ Clojure form → analyze-form [form bindings ctx] → AST {:op ...} Three public entry points: - `(compile-form form &opt ctx)` → Janet source string (debug/display) - `(compile-ast form &opt ctx)` → Janet data structure (for eval) -- `(compile-and-eval form ctx)` → compile-ast + eval + ns interning +- `(compile-and-eval form ctx)` → compile-ast + eval ## Why data structures, not source strings -Janet's `eval` does NOT have access to `use`-imported symbols. Emit Janet tuples with embedded function VALUES via `core-fn-values` table. +Janet's `eval` does NOT have access to `use`-imported symbols from the calling file. `(eval "(core-inc 1)")` fails with "unknown symbol core-inc". The fix: emit Janet tuples where function VALUES are embedded: `[core-inc 1]`. -Source-to-source (`compile-form` + `emit-ast`) exists for debugging, NOT used by `compile-and-eval`. +``` +core-fn-values table: "core-inc" → core-inc (the actual function) +emit-core-symbol-expr → (get core-fn-values janet-name) +``` + +Source-to-source (`compile-form` + `emit-ast`) still exists for debugging but is NOT used by `compile-and-eval`. ## Macro expansion -`analyze-form` checks `resolve-macro` before special form dispatch: -1. Look up symbol in current ns → core ns -2. If `var-macro?`, apply fn, re-analyze expanded form +`analyze-form` checks whether the head symbol of a list resolves to a macro var before dispatching to special form handling: -## Symbol classification +1. Look up symbol in current ns → core ns via `resolve-macro` +2. If `var-macro?` is true, call `(var-get macro-var)` to get the fn +3. `(apply macro-fn (tuple/slice form 1))` to expand +4. `(analyze-form expanded ...)` to re-analyze the result + +Macros expand at analyze time, before emission. `defn` expands to `(def name (fn* ...))`, `when` to `(if test (do ...) nil)`, etc. + +## Symbol classification (in analyze-form) Order: qualified ns → local binding → core-symbol → bare symbol -core-renames MUST match actual fn names: `"-"` → `"core-sub"` (not `"core--"`). +``` +(if (form :ns) → :qualified-symbol + (get bindings name) → :local + (get core-renames name) → :core-symbol + → :symbol) +``` + +core-renames MUST match actual fn names: `"-"` → `"core-sub"` (not `"core--"`), `"not"` → `"core-not"`. Verify against `core.janet` bindings. ## core-fn-values -Maps Janet string names to actual function values. Must be kept in sync with core-renames. -Special mappings: `"apply"` → `apply` (built-in), `"some"` → `core-some?`, `"pr-str"` → `core-str`, `"nth"` → `core-nth`. +Maps Janet string names to actual function values. Must be kept in sync with core-renames. When adding a new core fn, update BOTH tables. -## compile-and-eval interning - -`def`/`defn` results are interned in the Jolt namespace via `ns-intern` so the interpreter can resolve bare symbols. This is critical — without it, `(defn foo [x] x)` followed by `(foo 1)` would fail with "Unable to resolve symbol: foo". +Functions that need special mapping (name differs): +- `"apply"` → `apply` (Janet built-in) +- `"-"` → `"core-sub"` (not `core--`) +- `"some"` → `core-some?` (shared with `core-some?`) +- `"pr-str"` → `core-str` (alias) +- `"nth"` → `core-nth` (separate function, added in Phase 6) +- `"list"` → `core-list`, `"name"` → `core-name`, `"subs"` → `core-subs` ## Loop/recur compilation -`loop*` → `(do (var name nil) (set name (fn [params] body)) (name init-vals...))` -`recur` → `(loop-name arg...)` via `:jolt/current-loop` binding +`loop*` emits a self-referential closure: +```janet +(do (var _loop_N nil) + (set _loop_N (fn [params] body)) + (_loop_N init-vals...)) +``` + +`recur` saves `:loop-name` in the AST (looked up from bindings `:jolt/current-loop`), then `emit-recur-expr` rewrites to `(loop-name arg1 arg2...)`. + +In the string emitter, recur similarly emits `(loop-name arg ...)`. ## Throw/try compilation - `throw` → `(error val)` in Janet -- `try` → `(try body ([err] handler))` — Janet uses `([sym] handler)`, NOT `(catch sym handler)` +- `try/catch` → `(try body ([err] handler-body))` — NOTE: Janet uses `([sym] handler)` format, NOT `(catch sym handler)` +- `try/finally` → appends do-block after catch clause in the Janet tuple -## Quote — use raw-form->janet +## Quote in data-structure emitter -Don't re-analyze quoted forms. Use `raw-form->janet` to pass Jolt reader forms verbatim to Janet's `quote`. +Don't re-analyze quoted forms. Use `raw-form->janet` to pass Jolt reader forms through verbatim to Janet's `quote`: +``` +(emit-quote-expr expr) → ['quote (raw-form->janet expr)] +``` +raw-form->janet converts symbols to Janet symbols, arrays/tuples recursively. ## Remaining ops (interpreter only) -`syntax-quote`, `set!`, `deftype`, `defmulti`, `defmethod` — stateful/complex, always use interpreter. +`syntax-quote`, `set!`, `deftype`, `defmulti`, `defmethod` — these are stateful or complex and always use the interpreter path even in compile mode. -## Stateful forms (interpreter only even in compile mode) +## deftype in interpreter (eval-list arm) -`defmacro`, `ns`, `deftype`, `defmulti`, `defmethod`, `require`, `in-ns` +deftype creates a constructor function returning a Janet table with `:jolt/deftype` key (`"ns.TypeName"`). Evaluator `set!` handles `(.-field obj)` field mutation (reader creates `(. -field obj)` array form). `instance?` checks `:jolt/deftype` tag. defrecord macro in core.janet emits `(do (deftype Name [fields]) (def ->Name ...) (def map->Name ...))`. -Note: `def` IS handled by compiler (macros expanded at analyze time). +## Stateful forms (must use interpreter, NOT compiler) + +These forms modify context state and cannot be compiled: +- `defmacro`, `ns`, `deftype`, `defmulti`, `defmethod`, `require`, `in-ns` +- `syntax-quote`, `set!`, `var`, `.`, `new` + +Note: `def` IS handled by the compiler (compiles to Janet `def`, since macros are expanded at analyze time). ## eval-string dispatch (compile mode) -Stateful check: `defmacro`, `ns`, `deftype`, `defmulti`, `defmethod`, `require`, `in-ns`, `syntax-quote`, `set!`, `var`, `.`, `new` → interpreter. Everything else → `compile-and-eval`. +```janet +(if (or (= head-name "defmacro") (= head-name "ns") + (= head-name "deftype") (= head-name "defmulti") (= head-name "defmethod") + (= head-name "require") (= head-name "in-ns") + (= head-name "syntax-quote") (= head-name "set!") + (= head-name "var") (= head-name ".") (= head-name "new")) + (eval-form ctx @{} form) ; interpret + (compile-and-eval form ctx)) ; compile +``` ## Adding a new op -1. Add `analyze-form` match arm -2. Add `emit-ast` + `emit-expr` match arms -3. Update `core-renames` + `core-fn-values` if core fn -4. Add tests in `test/compiler-test.janet` - -## Var system (Phase 3) - -`var-get`, `var-set`, `var?`, `alter-var-root`, `find-var`, `alter-meta!`, `reset-meta!`, `intern` — all dispatched in evaluator, with Clojure wrappers in `core-bindings`. `find-var` takes a ctx + symbol, must eval args first (NOT pass raw form). `core-meta` handles vars via `var-meta` branch. - -## PersistentHashMap (Phase 2) - -`src/jolt/phm.janet` — separate module, bucket-based with `:jolt/deftype` tag. `core-binding` macro uses `array-map` (not `hash-map`) to avoid PHM get() incompatibility with `push-thread-bindings`. +1. Add `analyze-form` match arm for the special form +2. Add `emit-ast` match arm (source string path) +3. Add `emit-expr` match arm (data structure path) +4. Add `core-renames` entry if it's a core fn (name → Janet string name) +5. Add `core-fn-values` entry (Janet string name → actual fn value) +6. Add tests in `test/compiler-test.janet` ## Test files -- `test/compiler-test.janet` — all compiler tests (Phases 0-3) -- `test/phase6-final.janet` — 47 comprehensive compile-mode tests +- `test/compiler-test.janet` — Phase 2-5 tests (source output + compile-eval + macro tests) +- `test/phase6-final.janet` — Phase 6 comprehensive compile-mode tests (47 assertions) -Run: `janet test/compiler-test.janet` or `jpm test` +Run: `janet test/compiler-test.janet` or `janet test/phase6-final.janet` or `jpm test` \ No newline at end of file diff --git a/.dirge/skills/jolt-dev/SKILL.md b/.dirge/skills/jolt-dev/SKILL.md index 3e64e91..2baead3 100644 --- a/.dirge/skills/jolt-dev/SKILL.md +++ b/.dirge/skills/jolt-dev/SKILL.md @@ -2,6 +2,8 @@ Jolt development workflow — build, test, special form patterns, Janet gotchas +# Jolt Development + ## Build & Test ```bash @@ -33,13 +35,15 @@ When you need to mutate a local with `set`, use `(var x nil)` not `(def x nil)`. ## Compiler (see also `jolt-compiler` skill) `src/jolt/compiler.janet` — Clojure→Janet source compiler with macro expansion. +`test/compiler-test.janet` — 11 test groups covering all ops. Key design decision: **compile-and-eval emits Janet DATA STRUCTURES, not source strings**, because Janet's `eval` doesn't see `use`-imported symbols. `core-fn-values` table resolves Janet names to actual function values at compile time. ### Adding a compiled op -1. Add match arm in `analyze-form` — maps Clojure form → AST node -2. Add `emit-*-str` for source-to-source path → arm in `emit-ast` dispatch -3. Add `emit-*-expr` for data-structure path → arm in `emit-expr` dispatch + +1. **analyze-form**: add `match head-name` arm returning `{:op :your-op ...}` +2. **emit-ast**: add str function + `:your-op` case in `set emit-ast` dispatch +3. **emit-expr**: add expr function + `:your-op` case in `set emit-expr` dispatch 4. Add tests in `test/compiler-test.janet` ### Emit-expr critical rules @@ -51,41 +55,40 @@ Key design decision: **compile-and-eval emits Janet DATA STRUCTURES, not source ### Macro expansion `analyze-form` checks `resolve-macro` first — if head is a macro var, applies fn, re-analyzes expanded form (only when ctx passed). -### Loop/recur compilation -`(loop* [x 0] body)` → `(do (var name nil) (set name (fn [x] body)) (name 0))` -Recur rewrites to `(loop-name arg...)` via `:jolt/current-loop` binding. +## Persistent Data Structures -## Special Form Checklist +Located in: +- `src/jolt/clojure/lang/persistent_vector.clj` +- `src/jolt/clojure/lang/persistent_hash_map.clj` -To add a new special form to the evaluator AND compiler: -1. Add the name to `special-symbol?` in `src/jolt/evaluator.janet` -2. Add a match arm in `eval-list` (the match on `name`) -3. Add tests in `test/evaluator-test.janet` +Loaded at init time by `load-persistent-structures` in `api.janet`. Use `{:mutable? true}` to skip and use Janet-native types. -The match arm receives `ctx`, `bindings`, and `form`. Use `(in form 1)` for first arg. +### Implementation detail +Simple array-based implementation (node-assoc/node-find/find-key-index), NOT HAMT bit-trie. +HAMT failed because Janet uses 64-bit doubles and bit operations require 32-bit signed ints. -### Current special forms (29): -`quote`, `syntax-quote`, `unquote`, `unquote-splicing`, `do`, `if`, `def`, `defmacro`, `fn*`, `let*`, `loop*`, `recur`, `throw`, `try`, `set!`, `var`, `locking`, `instance?`, `defmulti`, `defmethod`, `deftype`, `new`, `.`, `var-get`, `var-set`, `var?`, `alter-var-root`, `find-var`, `alter-meta!`, `reset-meta!`, `intern` +## Janet Gotchas -## PersistentHashMap (phm.janet) +- Bit operations (brshift, brushift, band) use 32-bit signed integers. Hash values can exceed 32-bit range. Use `(band x 0xFFFFFFFF)` before shifting. +- `deftype` creates tables, not structs. `struct?` returns false. +- `(get child :key)` DOES follow table prototype chain — resolved and confirmed working. +- Janet LSP produces many false positives on `.janet` files — safe to ignore. +- Janet `and` returns the last truthy value, NOT boolean `true`. Wrap with `(if (and ...) true false)` for predicates. +- `set!` field mutation: `(set! (.-x obj) val)` reader creates `(. -x obj)` array — must check for `.` head in set! handler BEFORE the var mutation branch. -`src/jolt/phm.janet` — separate module imported via `(use ./phm)` into `core.janet`. -PHM is a table with `:jolt/deftype` tag. Has `:cnt`, `:buckets` (array of 8 flat `[k v k v ...]` arrays), `:_meta`. -16 core functions updated with `(phm? x)` branches. `phm-to-struct` converts to Janet struct for compatibility. +## deftype/defrecord Patterns -### Janet `break` limitation -Janet `break` cannot be used inside `let` blocks — use `(var found nil)` + `(while ... (if condition (do (set found val) (break))))` pattern. +**deftype** produces a table with `:jolt/deftype` key (format: `"ns.TypeName"`): +- Constructor: `(TypeName. args...)` — evaluator creates `@{:jolt/deftype "ns.TypeName" :key1 val1 ...}` +- Field access: `(. obj field)` — evaluator does `(get obj (keyword field-name))` +- Mutation: `(set! (.-field obj) val)` — reader creates `(. -field obj)` array form -### core-binding: use array-map, not hash-map -`core-binding` macro must emit `(array-map ...)` for the binding frame — PHM's get is incompatible with `push-thread-bindings` var-get lookup. +**Defrecord** macro emits `(do (deftype Name [fields]) (def ->Name ...) (def map->Name ...))`. -### core-intern gotcha -Janet does not support Clojure-style multi-arity destructuring `([a b] ...)` in `defn`. Use flat args or wrapper functions. +**core-map?** for records: `(or (phm? x) (struct? x) (if (and (table? x) (get x :jolt/deftype)) true false))` + +**core-count** for records: `(- (length (keys coll)) 1)` (skip `:jolt/deftype` key) ## Symbol representation -Jolt symbols are `{:jolt/type :symbol :ns :name }` as produced by the reader. - -## Janet LSP - -Janet LSP produces many false positives on `.janet` files — safe to ignore. +Jolt symbols are `{:jolt/type :symbol :ns :name }` as produced by the reader. \ No newline at end of file diff --git a/src/jolt/core.janet b/src/jolt/core.janet index 0cb9e2f..f14ff68 100644 --- a/src/jolt/core.janet +++ b/src/jolt/core.janet @@ -857,10 +857,38 @@ @[{:jolt/type :symbol :ns nil :name "def"} fn-name fn-form]))) # Hierarchy stubs for sci bootstrap -(def core-derive (fn [& args] nil)) -(def core-isa? (fn [& args] false)) -(def core-ancestors (fn [& args] @[])) -(def core-descendants (fn [& args] @[])) +(def core-make-hierarchy make-hierarchy) +(defn core-derive + [& args] + (case (length args) + 2 (let [[tag parent] args] (derive* (make-hierarchy) tag parent)) + 3 (let [[h tag parent] args] (derive* h tag parent)))) +(defn core-isa? + [& args] + (case (length args) + 1 false + 2 false + 3 (let [[h child parent] args] (isa? h child parent)))) +(defn core-ancestors + [& args] + (case (length args) + 1 @[] + 2 (let [[h tag] args] (ancestors h tag)))) +(defn core-descendants + [& args] + (case (length args) + 1 @[] + 2 (let [[h tag] args] (descendants h tag)))) +(def core-underive underive) +(def core-remove-method (fn [mm-var dispatch-val] + (let [methods (get mm-var :jolt/methods)] + (put methods dispatch-val nil) mm-var))) +(def core-remove-all-methods (fn [mm-var] + (put mm-var :jolt/methods @{}) mm-var)) +(defn core-prefer-method [mm-var dispatch-val-a dispatch-val-b] + (let [prefs (or (get mm-var :jolt/prefers) + (do (put mm-var :jolt/prefers @{}) (mm-var :jolt/prefers)))] + (put prefs dispatch-val-a dispatch-val-b) mm-var)) # Java interop stubs (def core-Object (fn [] (struct ;[:jolt/type :jolt/java-object]))) @@ -1145,6 +1173,11 @@ "isa?" core-isa? "ancestors" core-ancestors "descendants" core-descendants + "make-hierarchy" core-make-hierarchy + "underive" core-underive + "remove-method" core-remove-method + "remove-all-methods" core-remove-all-methods + "prefer-method" core-prefer-method "Object" core-Object "declare" core-declare "fn" core-fn diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index cdb3b62..c6f7b76 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -620,19 +620,50 @@ "Object" true false))) "defmulti" (let [name-sym (in form 1) - dispatch-fn (eval-form ctx bindings (in form 2)) - ns (ctx-find-ns ctx (ctx-current-ns ctx)) - methods @{} - mm-fn (fn [& args] - (let [dv (apply dispatch-fn args) - method (get methods dv)] - (if method - (apply method args) - (error (string "No method in multimethod " - (name-sym :name) " for dispatch value: " - dv)))))] + dispatch-fn (do + (def raw (eval-form ctx bindings (in form 2))) + (if (keyword? raw) + (fn [x] (get x raw)) + raw)) + # Parse options: :default val and :hierarchy h + opts (tuple/slice form 3) + default-val (do + (var dv nil) (var i 0) + (while (< i (length opts)) + (if (= :default (in opts i)) + (do (set dv (in opts (+ i 1))) (set i (length opts))) + (+= i 2))) dv) + hierarchy (do + (var h nil) (var i 0) + (while (< i (length opts)) + (if (= :hierarchy (in opts i)) + (do (set h (eval-form ctx bindings (in opts (+ i 1)))) (set i (length opts))) + (+= i 2))) h) + ns (ctx-find-ns ctx (ctx-current-ns ctx)) + methods @{} + mm-fn (fn [& args] + (let [dv (apply dispatch-fn args) + method (get methods dv)] + (if method + (apply method args) + (if hierarchy + (let [found (do + (var f nil) (var i 0) + (let [ks (keys methods)] + (while (and (nil? f) (< i (length ks))) + (if (isa? hierarchy dv (ks i)) (set f (get methods (ks i)))) + (++ i))) f)] + (if found (apply found args) + (if (not (nil? default-val)) default-val + (error (string "No method in multimethod " + (name-sym :name) " for dispatch value: " dv))))) + (if (not (nil? default-val)) default-val + (error (string "No method in multimethod " + (name-sym :name) " for dispatch value: " dv)))))))] (def v (ns-intern ns (name-sym :name) mm-fn)) (put v :jolt/methods methods) + (when default-val (put v :jolt/default default-val)) + (when hierarchy (put v :jolt/hierarchy hierarchy)) (var-get v)) "defmethod" (let [mm-sym (in form 1) dispatch-val (eval-form ctx bindings (in form 2)) diff --git a/src/jolt/types.janet b/src/jolt/types.janet index 0735aa3..1742d92 100644 --- a/src/jolt/types.janet +++ b/src/jolt/types.janet @@ -125,6 +125,57 @@ (put v :meta meta) meta) +(defn make-hierarchy + "Create a new empty hierarchy for multimethod dispatch." + [] + {:parents @{} :descendants @{} :ancestors @{}}) + +(defn derive* + "Add a parent relationship to a hierarchy." + [h tag parent] + (put (h :parents) tag parent) + (let [d (get (h :descendants) parent)] + (if d (array/push d tag) (put (h :descendants) parent @[tag]))) + (let [a (get (h :ancestors) tag)] + (if a (array/push a parent) (put (h :ancestors) tag @[parent]))) + h) + +(defn- ancestors* + "Internal: get all ancestors of a tag via iterative graph walk." + [h tag visited] + (var stack @[tag]) + (while (> (length stack) 0) + (let [t (array/pop stack)] + (when (not (get visited t)) + (put visited t true) + (let [p (get (h :parents) t)] + (when (and p (not= p t)) + (array/push stack p)))))) + visited) + +(defn ancestors + "Return a set of ancestors for a tag in the given hierarchy." + [h tag] + (let [a (get (h :ancestors) tag)] (if a a @[]))) + +(defn descendants + "Return the descendants of a tag in the given hierarchy." + [h tag] + (let [d (get (h :descendants) tag)] (if d d @[]))) + +(defn isa? + "Check if child is derived from parent in the given hierarchy." + [h child parent] + (if (= child parent) true + (let [p (get (h :parents) child)] + (if p (isa? h p parent) false)))) + +(defn underive + "Remove a parent relationship from a hierarchy." + [h tag parent] + (put (h :parents) tag nil) + h) + (defn with-meta "Return a new var with updated metadata. The original var is unchanged." [v meta] diff --git a/test/phase5-test.janet b/test/phase5-test.janet new file mode 100644 index 0000000..323c2ab --- /dev/null +++ b/test/phase5-test.janet @@ -0,0 +1,59 @@ +# Phase 5: Multimethods + Hierarchy Tests +(use ../src/jolt/api) +(defn ct-eval [ctx s] (eval-string ctx s)) + +# 22. Hierarchy +(print "22: hierarchy...") +(let [ctx (init)] + (assert (= true (ct-eval ctx "(map? (make-hierarchy))")) "make-hierarchy returns map") + # 2-arity derive/isa? just returns nil/false (no global hierarchy) + (ct-eval ctx "(derive ::square ::shape)") + (assert (= false (ct-eval ctx "(isa? ::square ::shape)")) "isa? 2-arity always false")) +(print " passed") + +# 23. Multimethods — basic dispatch +(print "23: basic multimethod dispatch...") +(let [ctx (init)] + (ct-eval ctx "(defmulti greet (fn [x] (:lang x)))") + (ct-eval ctx "(defmethod greet :en [_] \"hello\")") + (ct-eval ctx "(defmethod greet :fr [_] \"bonjour\")") + (assert (= "hello" (ct-eval ctx "(greet {:lang :en})")) "dispatch :en") + (assert (= "bonjour" (ct-eval ctx "(greet {:lang :fr})")) "dispatch :fr") + (assert (ct-eval ctx "(try (greet {:lang :es}) (catch Exception e true))") "missing dispatch errors")) +(print " passed") + +# 24. Multimethods — :default dispatch +(print "24: :default dispatch...") +(let [ctx (init)] + (ct-eval ctx "(defmulti classify :type :default :unknown)") + (ct-eval ctx "(defmethod classify :a [_] :alpha)") + (assert (= :alpha (ct-eval ctx "(classify {:type :a})")) "known dispatch") + (assert (= :unknown (ct-eval ctx "(classify {:type :z})")) "default fallback")) +(print " passed") + +# 25. Multimethods — hierarchy dispatch +(print "25: hierarchy dispatch...") +(let [ctx (init)] + (ct-eval ctx "(def h (make-hierarchy))") + (ct-eval ctx "(def h (derive h ::dog ::mammal))") + (ct-eval ctx "(def h (derive h ::mammal ::animal))") + (ct-eval ctx "(defmulti animal-sound (fn [x] x) :default :unknown :hierarchy h)") + (ct-eval ctx "(defmethod animal-sound ::animal [_] \"rawr\")") + (ct-eval ctx "(defmethod animal-sound ::dog [_] \"woof\")") + (assert (= "woof" (ct-eval ctx "(animal-sound ::dog)")) "direct dispatch") + (assert (= "rawr" (ct-eval ctx "(animal-sound ::mammal)")) "hierarchy fallback") + (assert (= :unknown (ct-eval ctx "(animal-sound ::rock)")) "default fallback")) +(print " passed") + +# 26. remove-method +(print "26: remove-method...") +(let [ctx (init)] + (ct-eval ctx "(defmulti rmtest :k)") + (ct-eval ctx "(defmethod rmtest :a [_] 1)") + (ct-eval ctx "(defmethod rmtest :b [_] 2)") + (assert (= 1 (ct-eval ctx "(rmtest {:k :a})")) "before remove") + (ct-eval ctx "(remove-method (var rmtest) :a)") + (assert (ct-eval ctx "(try (rmtest {:k :a}) (catch Exception e true))") "removed method errors")) +(print " passed") + +(print "\nAll Phase 5 tests passed!")