coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

spec: define-type special form — constructors, predicates, accessors (20 tests)

Browse Source 
Adds sf-define-type via register-special-form! in spec/evaluator.sx.
ADT values are dicts {:_adt true :_type "T" :_ctor "C" :_fields (list ...)}.
Each define-type call registers: ctor functions with arity checking, Name?
type predicate, Ctor? constructor predicates, Ctor-field positional accessors,
and populates *adt-registry* dict with type→[ctor-names] mapping.
20/20 JS tests pass in spec/tests/test-adt.sx.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-26 17:56:50 +00:00
parent 3fb0212414
commit 6c87210728
4 changed files with 306 additions and 37 deletions
Download Patch File Download Diff File Expand all files Collapse all files

161
spec/evaluator.sx
View File

@@ -1898,6 +1898,67 @@
:else (step-eval-call head args env kont)))))
(step-eval-call head args env kont))))))
(define
sf-define-type
(fn
(args env)
(let
((type-sym (first args)) (ctor-specs (rest args)))
(let
((type-name (symbol-name type-sym))
(ctor-names
(map (fn (spec) (symbol-name (first spec))) ctor-specs)))
(when
(not (env-has? env "*adt-registry*"))
(env-bind! env "*adt-registry*" {}))
(dict-set! (env-get env "*adt-registry*") type-name ctor-names)
(env-bind!
env
(str type-name "?")
(fn
(v)
(and (dict? v) (get v :_adt) (= (get v :_type) type-name))))
(for-each
(fn
(spec)
(let
((cn (symbol-name (first spec)))
(field-names (map (fn (f) (symbol-name f)) (rest spec)))
(arity (len (rest spec))))
(env-bind!
env
cn
(fn
(&rest ctor-args)
(if
(not (= (len ctor-args) arity))
(error
(str
cn
": expected "
arity
" args, got "
(len ctor-args)))
{:_ctor cn :_type type-name :_adt true :_fields ctor-args})))
(env-bind!
env
(str cn "?")
(fn
(v)
(and (dict? v) (get v :_adt) (= (get v :_ctor) cn))))
(for-each-indexed
(fn
(idx field-name)
(env-bind!
env
(str cn "-" field-name)
(fn (v) (nth (get v :_fields) idx))))
field-names)))
ctor-specs)
nil))))
(register-special-form! "define-type" sf-define-type)
(define
kont-extract-provides
(fn
@@ -1932,6 +1993,14 @@
subs)
(for-each (fn (sub) (cek-call sub (list kont))) subs))))))
;; ═══════════════════════════════════════════════════════════════
;; Part 10: Continue Phase — Frame Dispatch
;;
;; When phase="continue", pop the top frame and process the value.
;; Each frame type has its own handling: if frames check truthiness,
;; let frames bind the value, arg frames accumulate it, etc.
;; continue-with-call handles the final function/component dispatch.
;; ═══════════════════════════════════════════════════════════════
(define
fire-provide-subscribers
(fn
@@ -1951,18 +2020,13 @@
subs)
(for-each (fn (sub) (cek-call sub (list nil))) subs))))))
;; Final call dispatch from arg frame — all args evaluated, invoke function.
;; Handles: lambda (bind params + TCO), component (keyword args + TCO),
;; native fn (direct call), continuation (resume), callcc continuation (escape).
(define
batch-begin!
(fn () (set! *provide-batch-depth* (+ *provide-batch-depth* 1))))
;; ═══════════════════════════════════════════════════════════════
;; Part 10: Continue Phase — Frame Dispatch
;;
;; When phase="continue", pop the top frame and process the value.
;; Each frame type has its own handling: if frames check truthiness,
;; let frames bind the value, arg frames accumulate it, etc.
;; continue-with-call handles the final function/component dispatch.
;; ═══════════════════════════════════════════════════════════════
(define
batch-end!
(fn
@@ -1975,9 +2039,13 @@
(set! *provide-batch-queue* (list))
(for-each (fn (sub) (cek-call sub (list nil))) queue)))))
;; Final call dispatch from arg frame — all args evaluated, invoke function.
;; Handles: lambda (bind params + TCO), component (keyword args + TCO),
;; native fn (direct call), continuation (resume), callcc continuation (escape).
;; ═══════════════════════════════════════════════════════════════
;; Part 11: Entry Points
;;
;; eval-expr-cek / trampoline-cek: CEK evaluation entry points.
;; eval-expr / trampoline: top-level bindings that override the
;; forward declarations from Part 5.
;; ═══════════════════════════════════════════════════════════════
(define
step-sf-bind
(fn
@@ -2008,13 +2076,6 @@
(make-parameterize-frame bindings nil (list) body env)
kont)))))))
;; ═══════════════════════════════════════════════════════════════
;; Part 11: Entry Points
;;
;; eval-expr-cek / trampoline-cek: CEK evaluation entry points.
;; eval-expr / trampoline: top-level bindings that override the
;; forward declarations from Part 5.
;; ═══════════════════════════════════════════════════════════════
(define
syntax-rules-match
(fn
@@ -2186,7 +2247,10 @@
((all-vars (syntax-rules-find-all-vars elem bindings)))
(if
(empty? all-vars)
(syntax-rules-instantiate-list template (+ i 2) bindings)
(syntax-rules-instantiate-list
template
(+ i 2)
bindings)
(let
((count (len (get bindings (first all-vars))))
(expanded
@@ -2209,7 +2273,10 @@
(syntax-rules-instantiate elem b)))
(range count)))
(rest-result
(syntax-rules-instantiate-list template (+ i 2) bindings)))
(syntax-rules-instantiate-list
template
(+ i 2)
bindings)))
(append expanded rest-result))))
(cons
(syntax-rules-instantiate elem bindings)
@@ -2536,7 +2603,8 @@
(let
((proto-name (symbol-name (first args)))
(raw-type-name (symbol-name (nth args 1)))
(type-name (slice raw-type-name 1 (- (len raw-type-name) 1)))
(type-name
(slice raw-type-name 1 (- (len raw-type-name) 1)))
(method-defs (rest (rest args))))
(let
((proto (get *protocol-registry* proto-name)))
@@ -2678,8 +2746,12 @@
(and
(>= (len value) rest-idx)
(every?
(fn (pair) (match-pattern (first pair) (nth pair 1) env))
(zip (slice pattern 0 rest-idx) (slice value 0 rest-idx)))
(fn
(pair)
(match-pattern (first pair) (nth pair 1) env))
(zip
(slice pattern 0 rest-idx)
(slice value 0 rest-idx)))
(let
((rest-name (nth pattern (+ rest-idx 1))))
(env-bind! env (symbol-name rest-name) (slice value rest-idx))
@@ -2691,7 +2763,9 @@
(let
((pairs (zip pattern value)))
(every?
(fn (pair) (match-pattern (first pair) (nth pair 1) env))
(fn
(pair)
(match-pattern (first pair) (nth pair 1) env))
pairs)))
:else (= pattern value))))
@@ -3354,7 +3428,8 @@
kont)))))
("reduce"
(let
((init (nth ordered 1)) (coll (nth ordered 2)))
((init (nth ordered 1))
(coll (nth ordered 2)))
(if
(empty? coll)
(make-cek-value init env kont)
@@ -3658,7 +3733,10 @@
(next-test (first next-clause)))
(if
(is-else-clause? next-test)
(make-cek-state (nth next-clause 1) fenv rest-k)
(make-cek-state
(nth next-clause 1)
fenv
rest-k)
(make-cek-state
next-test
fenv
@@ -3830,7 +3908,9 @@
(let
((d (dict)))
(for-each
(fn (pair) (dict-set! d (first pair) (nth pair 1)))
(fn
(pair)
(dict-set! d (first pair) (nth pair 1)))
completed)
(make-cek-value d fenv rest-k))
(let
@@ -4156,9 +4236,14 @@
(list)
fenv
(list)
(kont-push (make-wind-return-frame body-result fenv) rest-k)))))
(kont-push
(make-wind-return-frame body-result fenv)
rest-k)))))
("wind-return"
(make-cek-value (get frame "body-result") (get frame "env") rest-k))
(make-cek-value
(get frame "body-result")
(get frame "env")
rest-k))
("raise-eval"
(let
((condition value)
@@ -4183,7 +4268,9 @@
(kont-push
(make-signal-return-frame fenv unwound-k)
unwound-k)
(kont-push (make-raise-guard-frame fenv unwound-k) unwound-k))))))
(kont-push
(make-raise-guard-frame fenv unwound-k)
unwound-k))))))
("raise-guard"
(do
(set! *last-error-kont* rest-k)
@@ -4317,9 +4404,7 @@
((arg (if (empty? args) nil (first args)))
(captured (callcc-continuation-data f))
(w-len (callcc-continuation-winders-len f)))
(do
(wind-escape-to w-len)
(make-cek-value arg env captured)))
(do (wind-escape-to w-len) (make-cek-value arg env captured)))
(continuation? f)
(let
((arg (if (empty? args) nil (first args)))
@@ -4364,7 +4449,9 @@
" args, got "
(len args))))
(for-each
(fn (pair) (env-bind! local (first pair) (nth pair 1)))
(fn
(pair)
(env-bind! local (first pair) (nth pair 1)))
(zip params args))
(for-each
(fn (p) (env-bind! local p nil))
@@ -4419,7 +4506,11 @@
(if
(= match-val test-val)
(make-cek-state body env kont)
(sf-case-step-loop match-val (slice clauses 2) env kont))))))))
(sf-case-step-loop
match-val
(slice clauses 2)
env
kont))))))))
(define
eval-expr-cek