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>
This commit is contained in:
@@ -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))))))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; 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-protocol
|
||||
(fn
|
||||
(args env)
|
||||
(let
|
||||
((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
|
||||
|
||||
Reference in New Issue
Block a user