Step 7c complete: protocols (define-protocol, implement, satisfies?)

Trait-like dispatch system for record types:

  (define-record-type <point>
    (make-point x y) point? (x point-x) (y point-y))

  (define-protocol Displayable (show self))

  (implement Displayable <point>
    (show self (str (point-x self) "," (point-y self))))

  (show (make-point 3 4))              ;; => "3,4"
  (satisfies? "Displayable" (make-point 1 2))  ;; => true
  (satisfies? "Displayable" 42)        ;; => false

Implementation:
- *protocol-registry* global dict stores protocol specs + implementations
- define-protocol creates dispatch functions via eval-expr (dynamic lambdas)
- implement registers method lambdas keyed by record type name
- Dispatch: (type-of self) → lookup in protocol impls → call method
- satisfies? checks if a record type has implementations for a protocol

2645 tests pass (+1 from protocol self-test).

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>

spec/evaluator.sx

@@ -1527,6 +1527,9 @@
               ("import" (step-sf-import args env kont))
               ("define-record-type"
                 (make-cek-value (sf-define-record-type args env) env kont))
+              ("define-protocol"
+                (make-cek-value (sf-define-protocol args env) env kont))
+              ("implement" (make-cek-value (sf-implement args env) env kont))
               ("parameterize" (step-sf-parameterize args env kont))
               ("syntax-rules"
                 (make-cek-value (sf-syntax-rules args env) env kont))
@@ -1959,6 +1962,15 @@
         env
         (kont-push (make-perform-frame env) kont)))))
 
+(define *protocol-registry* (dict))
+
+;; ═══════════════════════════════════════════════════════════════
+;; Part 9: Higher-Order Form Machinery
+;;
+;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
+;; ho-swap-args auto-detects argument order. HoSetupFrame stages
+;; argument evaluation, then dispatches to the appropriate step-ho-*.
+;; ═══════════════════════════════════════════════════════════════
 (define
   sf-define-record-type
   (fn
@@ -1995,13 +2007,122 @@
               field-specs)
             nil))))))
 
-;; ═══════════════════════════════════════════════════════════════
+(define
-;; Part 9: Higher-Order Form Machinery
+  sf-define-protocol
-;;
+  (fn
-;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
+    (args env)
-;; ho-swap-args auto-detects argument order. HoSetupFrame stages
+    (let
-;; argument evaluation, then dispatches to the appropriate step-ho-*.
+      ((proto-name (symbol-name (first args))) (method-specs (rest args)))
-;; ═══════════════════════════════════════════════════════════════
+      (do
+        (env-bind! env "*protocol-registry*" *protocol-registry*)
+        (env-bind! env "satisfies?" (fn (pname val) (satisfies? pname val))))
+      (dict-set! *protocol-registry* proto-name {:impls (dict) :methods (map (fn (spec) {:arity (len spec) :name (symbol-name (first spec))}) method-specs) :name proto-name})
+      (for-each
+        (fn
+          (spec)
+          (let
+            ((method-name (symbol-name (first spec)))
+              (params (rest spec))
+              (pname proto-name))
+            (let
+              ((self-sym (first params))
+                (lookup-expr
+                  (list
+                    (quote get)
+                    (list
+                      (quote get)
+                      (list
+                        (quote get)
+                        (list (quote get) (quote *protocol-registry*) pname)
+                        "impls")
+                      (list (quote type-of) self-sym))
+                    method-name)))
+              (env-bind!
+                env
+                method-name
+                (eval-expr
+                  (list
+                    (quote fn)
+                    params
+                    (list
+                      (quote let)
+                      (list (list (quote _impl) lookup-expr))
+                      (list
+                        (quote if)
+                        (list (quote nil?) (quote _impl))
+                        (list
+                          (quote error)
+                          (str
+                            pname
+                            "."
+                            method-name
+                            ": not implemented for this type"))
+                        (cons (quote _impl) params))))
+                  env)))))
+        method-specs)
+      nil)))
+
+(define
+  sf-implement
+  (fn
+    (args env)
+    (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)))
+        (method-defs (rest (rest args))))
+      (let
+        ((proto (get *protocol-registry* proto-name)))
+        (if
+          (nil? proto)
+          (error (str "Unknown protocol: " proto-name))
+          (let
+            ((impls (get proto "impls"))
+              (type-impls (or (get impls type-name) (dict))))
+            (for-each
+              (fn
+                (method-def)
+                (let
+                  ((mname (symbol-name (first method-def)))
+                    (proto-method
+                      (first
+                        (filter
+                          (fn (m) (= (get m "name") mname))
+                          (get proto "methods")))))
+                  (if
+                    (nil? proto-method)
+                    (error
+                      (str "Unknown method " mname " in protocol " proto-name))
+                    (let
+                      ((arity (get proto-method "arity"))
+                        (params (slice method-def 1 arity))
+                        (body
+                          (if
+                            (= (len method-def) (+ arity 1))
+                            (nth method-def arity)
+                            (cons (quote begin) (slice method-def arity)))))
+                      (dict-set!
+                        type-impls
+                        mname
+                        (eval-expr (list (quote fn) params body) env))))))
+              method-defs)
+            (dict-set! impls type-name type-impls)
+            nil))))))
+
+(define
+  satisfies?
+  (fn
+    (proto-name value)
+    (if
+      (not (record? value))
+      false
+      (let
+        ((proto (get *protocol-registry* (if (symbol? proto-name) (symbol-name proto-name) proto-name))))
+        (if
+          (nil? proto)
+          false
+          (not (nil? (get (get proto "impls") (type-of value)))))))))
+
 (define
   step-sf-callcc
   (fn
@@ -2154,6 +2275,14 @@
           (list condition)
           (kont-push (make-signal-return-frame env kont) kont))))))
 
+;; ═══════════════════════════════════════════════════════════════
+;; 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
   step-sf-invoke-restart
   (fn
@@ -2182,6 +2311,9 @@
               (env-bind! restart-env (first params) restart-arg))
             (make-cek-state body restart-env rest-kont)))))))
 
+;; 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
   step-sf-if
   (fn
@@ -2205,6 +2337,13 @@
       env
       (kont-push (make-when-frame (rest args) 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
   step-sf-begin
   (fn
@@ -2220,14 +2359,6 @@
           env
           (kont-push (make-begin-frame (rest args) env) kont))))))
 
-;; ═══════════════════════════════════════════════════════════════
-;; 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
   step-sf-let
   (fn
@@ -2272,9 +2403,6 @@
                   (make-let-frame vname rest-bindings body local)
                   kont)))))))))
 
-;; 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
   step-sf-define
   (fn
@@ -2322,13 +2450,6 @@
       env
       (kont-push (make-set-frame (symbol-name (first args)) 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
   step-sf-and
   (fn