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

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>

spec/evaluator.sx

@@ -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

spec/tests/test-adt.sx

@@ -0,0 +1,149 @@
+(defsuite
+  "algebraic-data-types"
+  (deftest
+    "constructor creates dict with adt marker"
+    (do
+      (define-type Maybe (Just value) (Nothing))
+      (assert= true (get (Just 42) :_adt))))
+  (deftest
+    "constructor stores type name"
+    (do
+      (define-type Shape (Circle radius) (Square side))
+      (assert= "Shape" (get (Circle 5) :_type))
+      (assert= "Shape" (get (Square 3) :_type))))
+  (deftest
+    "constructor stores constructor name"
+    (do
+      (define-type Opt (Some val) (None))
+      (assert= "Some" (get (Some 1) :_ctor))
+      (assert= "None" (get (None) :_ctor))))
+  (deftest
+    "constructor stores fields as list"
+    (do
+      (define-type Pair (Pair-of fst snd))
+      (assert-equal
+        (list 1 2)
+        (get (Pair-of 1 2) :_fields))))
+  (deftest
+    "zero-arg constructor has empty fields"
+    (do
+      (define-type Flag (Set) (Unset))
+      (assert-equal (list) (get (Set) :_fields))
+      (assert-equal (list) (get (Unset) :_fields))))
+  (deftest
+    "type predicate true for all constructors"
+    (do
+      (define-type Expr (Num n) (Add left right) (Neg e))
+      (assert= true (Expr? (Num 5)))
+      (assert= true (Expr? (Add (Num 1) (Num 2))))
+      (assert= true (Expr? (Neg (Num 3))))))
+  (deftest
+    "type predicate false for non-adt values"
+    (do
+      (define-type Box (Box-of x))
+      (assert= false (Box? 42))
+      (assert= false (Box? "hello"))
+      (assert= false (Box? nil))
+      (assert= false (Box? (list 1 2)))
+      (assert= false (Box? {}))))
+  (deftest
+    "type predicate false for wrong adt type"
+    (do
+      (define-type AT (AV x))
+      (define-type BT (BV x))
+      (assert= false (AT? (BV 1)))
+      (assert= false (BT? (AV 1)))))
+  (deftest
+    "constructor predicate true for matching constructor"
+    (do
+      (define-type Result (Ok value) (Err msg))
+      (assert= true (Ok? (Ok 42)))
+      (assert= true (Err? (Err "bad")))))
+  (deftest
+    "constructor predicate false for wrong constructor"
+    (do
+      (define-type Coin (Heads) (Tails))
+      (assert= false (Heads? (Tails)))
+      (assert= false (Tails? (Heads)))))
+  (deftest
+    "constructor predicate false for non-adt"
+    (do
+      (define-type Wrap (Wrapped x))
+      (assert= false (Wrapped? 42))
+      (assert= false (Wrapped? nil))
+      (assert= false (Wrapped? "str"))))
+  (deftest
+    "single-field accessor returns field value"
+    (do
+      (define-type Holder (Held content))
+      (assert= 99 (Held-content (Held 99)))
+      (assert= "hello" (Held-content (Held "hello")))))
+  (deftest
+    "multi-field accessors return correct fields"
+    (do
+      (define-type Triple (Triple-of a b c))
+      (let
+        ((t (Triple-of 10 20 30)))
+        (assert= 10 (Triple-of-a t))
+        (assert= 20 (Triple-of-b t))
+        (assert= 30 (Triple-of-c t)))))
+  (deftest
+    "tree constructors and accessors"
+    (do
+      (define-type Tree (Leaf) (Node left val right))
+      (let
+        ((t (Node (Leaf) 5 (Node (Leaf) 3 (Leaf)))))
+        (assert= true (Node? t))
+        (assert= 5 (Node-val t))
+        (assert= true (Leaf? (Node-left t)))
+        (assert= true (Node? (Node-right t)))
+        (assert= 3 (Node-val (Node-right t))))))
+  (deftest
+    "arity error on too few args"
+    (do
+      (define-type Pair2 (Pair2-of a b))
+      (let
+        ((ok false))
+        (guard (exn (else (set! ok true))) (Pair2-of 1))
+        (assert ok))))
+  (deftest
+    "arity error on too many args"
+    (do
+      (define-type Single (Single-of x))
+      (let
+        ((ok false))
+        (guard
+          (exn (else (set! ok true)))
+          (Single-of 1 2))
+        (assert ok))))
+  (deftest
+    "multiple types are independent"
+    (do
+      (define-type Color2 (Red2) (Green2) (Blue2))
+      (define-type Suit (Hearts) (Diamonds) (Clubs) (Spades))
+      (assert= false (Color2? (Hearts)))
+      (assert= false (Suit? (Red2)))
+      (assert= true (Color2? (Blue2)))
+      (assert= true (Suit? (Spades)))))
+  (deftest
+    "adt fields can hold any value"
+    (do
+      (define-type Container (Hold x))
+      (assert-equal
+        (list 1 2 3)
+        (Hold-x (Hold (list 1 2 3))))
+      (assert-equal {:a 1} (Hold-x (Hold {:a 1})))))
+  (deftest
+    "adt-registry tracks type constructor names"
+    (do
+      (define-type Days (Mon) (Tue) (Wed) (Thu) (Fri))
+      (assert-equal
+        (list "Mon" "Tue" "Wed" "Thu" "Fri")
+        (get *adt-registry* "Days"))))
+  (deftest
+    "constructors with same field name in different types are independent"
+    (do
+      (define-type P1 (P1-ctor value))
+      (define-type P2 (P2-ctor value))
+      (assert= 10 (P1-ctor-value (P1-ctor 10)))
+      (assert= 20 (P2-ctor-value (P2-ctor 20))))))