diff --git a/lib/scheme/eval.sx b/lib/scheme/eval.sx index fdcf01b4..48a1d208 100644 --- a/lib/scheme/eval.sx +++ b/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) diff --git a/lib/scheme/tests/records.sx b/lib/scheme/tests/records.sx new file mode 100644 index 00000000..8a4ab0bd --- /dev/null +++ b/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}))