scheme: Phase 9 — define-record-type + 9 tests

eval.sx adds the define-record-type syntactic operator:

  (define-record-type NAME
    (CONSTRUCTOR ARG...)
    PREDICATE
    (FIELD ACCESSOR [MUTATOR])...)

Records are tagged dicts:
  {:scm-record TYPE-NAME :fields {FIELD VALUE ...}}

For each record type, the operator binds:
- Constructor: takes the listed ARGs, populates :fields, returns
  the record. Fields not in CONSTRUCTOR ARGs default to nil.
- Predicate: returns true iff its arg is a record of THIS type
  (tag-match via :scm-record).
- Accessor per field: extracts the field value; errors if not
  a record of the right type.
- Mutator per field (optional): sets the field via dict-set!;
  same type-check.

Distinct types are isolated via their tag — point? returns false
on a circle, even if both have the same shape.

9 tests cover: constructor + predicate + accessors, mutator,
distinct-types-via-tag, records as first-class values (in lists,
passed to map/filter), constructor arity errors.

289 total Scheme tests (62+23+49+78+25+20+13+10+9).

lib/scheme/eval.sx

@@ -568,6 +568,150 @@
          :rules (rest args)
          :env env}))))
 
+;; ── define-record-type (R7RS Phase 9) ──────────────────────────
+;;
+;; (define-record-type NAME
+;;   (CONSTRUCTOR ARG...)
+;;   PREDICATE
+;;   (FIELD ACCESSOR [MUTATOR])...)
+;;
+;; Defines a new record type. Records are tagged dicts:
+;;   {:scm-record TYPE-NAME :fields {FIELD-NAME VALUE ...}}
+;;
+;; CONSTRUCTOR is a procedure (ARG ...) → record. Each ARG must
+;; correspond to a FIELD name in the field list; remaining fields
+;; are initialised to nil.
+;; PREDICATE returns true iff its arg is a record of this type.
+;; ACCESSOR returns the field value. MUTATOR (if present) sets it.
+
+(define scm-find-field-index
+  (fn (name fields i)
+    (cond
+      ((or (nil? fields) (= (length fields) 0)) nil)
+      ((= (first (first fields)) name) i)
+      (:else (scm-find-field-index name (rest fields) (+ i 1))))))
+
+(define scm-make-record-ctor
+  (fn (type-name field-specs ctor-args)
+    (fn (args)
+      (cond
+        ((not (= (length args) (length ctor-args)))
+          (error (str type-name ": wrong number of constructor arguments")))
+        (:else
+          (let ((record {:scm-record type-name :fields {}}))
+            (begin
+              (scm-record-init-fields! record field-specs)
+              (scm-record-set-ctor-args! record ctor-args args)
+              record)))))))
+
+(define scm-record-init-fields!
+  (fn (record field-specs)
+    (cond
+      ((or (nil? field-specs) (= (length field-specs) 0)) nil)
+      (:else
+        (begin
+          (dict-set! (get record :fields) (first (first field-specs)) nil)
+          (scm-record-init-fields! record (rest field-specs)))))))
+
+(define scm-record-set-ctor-args!
+  (fn (record names values)
+    (cond
+      ((or (nil? names) (= (length names) 0)) nil)
+      (:else
+        (begin
+          (dict-set! (get record :fields) (first names) (first values))
+          (scm-record-set-ctor-args! record (rest names) (rest values)))))))
+
+(define scm-install-record-type!
+  (fn (env type-name ctor-spec pred-name field-specs)
+    (let ((ctor-name (first ctor-spec))
+          (ctor-args (rest ctor-spec)))
+      (begin
+        ;; Constructor
+        (scheme-env-bind! env ctor-name
+          (scm-make-record-ctor type-name field-specs ctor-args))
+        ;; Predicate
+        (scheme-env-bind! env pred-name
+          (fn (args)
+            (cond
+              ((not (= (length args) 1))
+                (error (str pred-name ": expects 1 argument")))
+              (:else
+                (let ((v (first args)))
+                  (and (dict? v)
+                       (= (get v :scm-record) type-name)))))))
+        ;; Accessors + optional mutators
+        (scm-install-field-procs! env type-name field-specs)))))
+
+(define scm-install-field-procs!
+  (fn (env type-name field-specs)
+    (cond
+      ((or (nil? field-specs) (= (length field-specs) 0)) nil)
+      (:else
+        (let ((spec (first field-specs)))
+          (cond
+            ((< (length spec) 2)
+              (error "define-record-type: each field needs (name accessor [mutator])"))
+            (:else
+              (let ((field-name (first spec))
+                    (accessor-name (nth spec 1)))
+                (begin
+                  ;; Accessor
+                  (scheme-env-bind! env accessor-name
+                    (fn (args)
+                      (cond
+                        ((not (= (length args) 1))
+                          (error (str accessor-name ": expects 1 argument")))
+                        ((not (and (dict? (first args))
+                                   (= (get (first args) :scm-record) type-name)))
+                          (error (str accessor-name ": not a " type-name)))
+                        (:else
+                          (get (get (first args) :fields) field-name)))))
+                  ;; Mutator (if present)
+                  (cond
+                    ((>= (length spec) 3)
+                      (let ((mutator-name (nth spec 2)))
+                        (scheme-env-bind! env mutator-name
+                          (fn (args)
+                            (cond
+                              ((not (= (length args) 2))
+                                (error (str mutator-name ": expects 2 arguments")))
+                              ((not (and (dict? (first args))
+                                         (= (get (first args) :scm-record) type-name)))
+                                (error (str mutator-name ": not a " type-name)))
+                              (:else
+                                (dict-set! (get (first args) :fields)
+                                           field-name
+                                           (nth args 1))))))))
+                    (:else nil))
+                  (scm-install-field-procs! env type-name (rest field-specs)))))))))))
+
+(scheme-define-op! "define-record-type"
+  (fn (args env)
+    (cond
+      ((< (length args) 3)
+        (error "define-record-type: expects (name (ctor args) pred [fields])"))
+      (:else
+        (let ((type-name (first args))
+              (ctor-spec (nth args 1))
+              (pred-name (nth args 2))
+              (field-specs
+                (cond
+                  ((>= (length args) 4) (rest (rest (rest args))))
+                  (:else (list)))))
+          (cond
+            ((not (string? type-name))
+              (error "define-record-type: type name must be a symbol"))
+            ((not (list? ctor-spec))
+              (error "define-record-type: constructor spec must be a list"))
+            ((not (string? pred-name))
+              (error "define-record-type: predicate name must be a symbol"))
+            (:else
+              (begin
+                (scm-install-record-type! env type-name ctor-spec
+                                          pred-name field-specs)
+                type-name))))))))
+
 ;; (define-syntax NAME SYNTAX-RULES-FORM)
 (scheme-define-op! "define-syntax"
   (fn (args env)

lib/scheme/tests/records.sx

@@ -0,0 +1,96 @@
+;; lib/scheme/tests/records.sx — define-record-type.
+
+(define scm-rec-pass 0)
+(define scm-rec-fail 0)
+(define scm-rec-fails (list))
+
+(define
+  scm-rec-test
+  (fn
+    (name actual expected)
+    (if
+      (= actual expected)
+      (set! scm-rec-pass (+ scm-rec-pass 1))
+      (begin
+        (set! scm-rec-fail (+ scm-rec-fail 1))
+        (append! scm-rec-fails {:name name :actual actual :expected expected})))))
+
+(define
+  scm-rec
+  (fn (src) (scheme-eval (scheme-parse src) (scheme-standard-env))))
+
+(define
+  scm-rec-all
+  (fn
+    (src)
+    (scheme-eval-program (scheme-parse-all src) (scheme-standard-env))))
+
+;; ── Basic record: point ─────────────────────────────────────────
+
+(scm-rec-test
+  "point: constructor + predicate"
+  (scm-rec-all
+    "(define-record-type point\n       (make-point x y) point?\n       (x point-x) (y point-y))\n     (point? (make-point 3 4))")
+  true)
+(scm-rec-test
+  "point: accessor x"
+  (scm-rec-all
+    "(define-record-type point\n       (make-point x y) point?\n       (x point-x) (y point-y))\n     (point-x (make-point 3 4))")
+  3)
+(scm-rec-test
+  "point: accessor y"
+  (scm-rec-all
+    "(define-record-type point\n       (make-point x y) point?\n       (x point-x) (y point-y))\n     (point-y (make-point 3 4))")
+  4)
+(scm-rec-test
+  "point: predicate false on number"
+  (scm-rec-all
+    "(define-record-type point\n       (make-point x y) point?\n       (x point-x) (y point-y))\n     (point? 42)")
+  false)
+
+;; ── Mutator ─────────────────────────────────────────────────────
+
+(scm-rec-test
+  "point: mutator"
+  (scm-rec-all
+    "(define-record-type point\n       (make-point x y) point?\n       (x point-x) (y point-y set-point-y!))\n     (define p (make-point 3 4))\n     (set-point-y! p 99)\n     (point-y p)")
+  99)
+
+;; ── Multiple record types are distinct ──────────────────────────
+
+(scm-rec-test
+  "distinct types: point? false on circle"
+  (scm-rec-all
+    "(define-record-type point\n       (make-point x y) point? (x point-x) (y point-y))\n     (define-record-type circle\n       (make-circle r) circle? (r circle-r))\n     (point? (make-circle 5))")
+  false)
+(scm-rec-test
+  "distinct types: circle? true on circle"
+  (scm-rec-all
+    "(define-record-type point\n       (make-point x y) point? (x point-x) (y point-y))\n     (define-record-type circle\n       (make-circle r) circle? (r circle-r))\n     (circle? (make-circle 5))")
+  true)
+
+;; ── Records as first-class values ───────────────────────────────
+
+(scm-rec-test
+  "record in a list"
+  (scm-rec-all
+    "(define-record-type box\n       (make-box v) box? (v box-v))\n     (map box-v (list (make-box 1) (make-box 2) (make-box 3)))")
+  (list 1 2 3))
+
+;; ── Records via map/filter ──────────────────────────────────────
+
+(scm-rec-test
+  "filter records by predicate"
+  (scm-rec-all
+    "(define-record-type box\n       (make-box v) box? (v box-v))\n     (length\n       (filter (lambda (b) (> (box-v b) 5))\n               (list (make-box 1) (make-box 7) (make-box 3) (make-box 10)))))")
+  2)
+
+;; ── Constructor arity errors ────────────────────────────────────
+
+(scm-rec-test
+  "ctor: wrong arity errors"
+  (scm-rec-all
+    "(define-record-type point (make-point x y) point? (x point-x) (y point-y))\n     (guard (e (else 'arity-err)) (make-point 1))")
+  "arity-err")
+
+(define scm-rec-tests-run! (fn () {:total (+ scm-rec-pass scm-rec-fail) :passed scm-rec-pass :failed scm-rec-fail :fails scm-rec-fails}))