giles
f927fb6515
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
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).
97 lines
3.8 KiB
Plaintext
97 lines
3.8 KiB
Plaintext
;; 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}))
|