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

scheme: Phase 9 — define-record-type + 9 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
Details

Browse Source 
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).
This commit is contained in:
giles
2026-05-14 06:49:24 +00:00
parent e200935698
commit f927fb6515
2 changed files with 240 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

144
lib/scheme/eval.sx
View File

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