Commitf57cece2Recorded31 Mar 2026Repositorysigil-r7rs

Add SRFI-9 (define-record-type) — moved from sigil-stdlib

Changed
 src/srfi/srfi-9.sgl | 196 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 196 insertions(+)
Diff
src/srfi/srfi-9.sgladded
@@ -0,0 +1,196 @@
+1
;;; (srfi srfi-9) - Record Types
+2
;;;
+3
;;; Define structured data types with named fields. SRFI-9 records provide
+4
;;; type-safe constructors, predicates, and field accessors. This is the
+5
;;; standard way to define compound data structures in Scheme.
+6
;;;
+7
;;; See: [SRFI-9 Specification](https://srfi.schemers.org/srfi-9/srfi-9.html)
+8
;;;
+9
;;; ```scheme
+10
;;; (import (srfi srfi-9))
+11
;;;
+12
;;; ;; Define a point type with x and y coordinates
+13
;;; (define-record-type <point>
+14
;;; (make-point x y) ; constructor
+15
;;; point? ; predicate
+16
;;; (x point-x) ; read-only field
+17
;;; (y point-y set-point-y!)) ; read-write field
+18
;;;
+19
;;; ;; Use the record
+20
;;; (define p (make-point 10 20))
+21
;;; (point? p) ; => #t
+22
;;; (point-x p) ; => 10
+23
;;; (set-point-y! p 30)
+24
;;; (point-y p) ; => 30
+25
;;; ```
+26
;;;
+27
;;; ## Syntax
+28
;;;
+29
;;; ```scheme
+30
;;; (define-record-type <type-name>
+31
;;; (constructor-name field-name ...)
+32
;;; predicate-name
+33
;;; (field-name accessor-name)
+34
;;; (field-name accessor-name mutator-name)
+35
;;; ...)
+36
;;; ```
+37
;;;
+38
;;; - **type-name**: A symbol (conventionally in angle brackets like `<point>`)
+39
;;; - **constructor-name**: Creates instances; takes values for listed fields
+40
;;; - **predicate-name**: Returns `#t` for instances of this type
+41
;;; - **field specs**: Each field has an accessor; optionally a mutator
+42
;;;
+43
;;; ## Examples
+44
;;;
+45
;;; ```scheme
+46
;;; ;; Immutable record (no setters)
+47
;;; (define-record-type <rgb>
+48
;;; (rgb r g b)
+49
;;; rgb?
+50
;;; (r rgb-r)
+51
;;; (g rgb-g)
+52
;;; (b rgb-b))
+53
;;;
+54
;;; (define red (rgb 255 0 0))
+55
;;; (rgb-r red) ; => 255
+56
;;;
+57
;;; ;; Record with partial constructor
+58
;;; (define-record-type <person>
+59
;;; (make-person name) ; only name required
+60
;;; person?
+61
;;; (name person-name)
+62
;;; (age person-age set-person-age!)) ; age set later
+63
;;;
+64
;;; (define p (make-person "Alice"))
+65
;;; (set-person-age! p 30)
+66
;;; ```
+67
+68
(define-library (srfi srfi-9)
+69
(import (sigil core))
+70
(export define-record-type
+71
;; Internal helper needed for macro expansion in other modules
+72
%srfi9--transformer)
+73
+74
(begin
+75
;;; Helper: Unwrap syntax object to get datum
+76
(define (srfi9--unwrap v)
+77
(if (syntax? v) (syntax-datum v) v))
+78
+79
;;; Helper: Get docstring from syntax object
+80
(define (srfi9--get-doc v)
+81
(if (syntax? v) (syntax-doc v) #f))
+82
+83
;;; Helper: Get srcloc from syntax object
+84
(define (srfi9--get-srcloc v)
+85
(if (syntax? v) (syntax-srcloc v) #f))
+86
+87
;;; Helper: Strip angle brackets from type name for base name
+88
(define (srfi9--strip-angles sym)
+89
(let* ((sym (srfi9--unwrap sym))
+90
(s (symbol->string sym))
+91
(len (string-length s)))
+92
(if (and (> len 2)
+93
(eq? (string-ref s 0) #\<)
+94
(eq? (string-ref s (- len 1)) #\>))
+95
(substring s 1 (- len 1))
+96
s)))
+97
+98
;;; Build accessor/mutator definitions for a field spec
+99
;;; field-spec is (field-name getter) or (field-name getter setter)
+100
;;; Returns list of syntax-wrapped definitions with docstrings
+101
(define (srfi9--build-field-accessor field-spec index type-name srcloc)
+102
(let* ((spec-doc (srfi9--get-doc field-spec))
+103
(spec-datum (srfi9--unwrap field-spec))
+104
(field-name (srfi9--unwrap (car spec-datum)))
+105
(getter (srfi9--unwrap (car (cdr spec-datum))))
+106
(base (srfi9--strip-angles type-name))
+107
;; Generate docstrings
+108
(getter-doc (if (and spec-doc (string? spec-doc))
+109
spec-doc
+110
(string-append "Get the `" (symbol->string field-name)
+111
"` field of a `" base "` record."))))
+112
(if (null? (cdr (cdr spec-datum)))
+113
;; Accessor only
+114
(let ((getter-def (list 'define (list getter 'obj)
+115
(list 'vector-ref 'obj index))))
+116
(list (syntax-with-metadata
+117
(datum->syntax type-name getter-def)
+118
doc: getter-doc
+119
srcloc: srcloc)))
+120
;; Accessor and mutator
+121
(let* ((setter (srfi9--unwrap (car (cdr (cdr spec-datum)))))
+122
(setter-doc (string-append "Set the `" (symbol->string field-name)
+123
"` field of a `" base "` record."))
+124
(getter-def (list 'define (list getter 'obj)
+125
(list 'vector-ref 'obj index)))
+126
(setter-def (list 'define (list setter 'obj 'val)
+127
(list 'vector-set! 'obj index 'val))))
+128
(list (syntax-with-metadata
+129
(datum->syntax type-name getter-def)
+130
doc: getter-doc
+131
srcloc: srcloc)
+132
(syntax-with-metadata
+133
(datum->syntax type-name setter-def)
+134
doc: setter-doc
+135
srcloc: srcloc))))))
+136
+137
;;; Build all accessor/mutator definitions
+138
(define (srfi9--build-accessors field-specs index type-name srcloc)
+139
(if (null? field-specs)
+140
'()
+141
(append (srfi9--build-field-accessor (car field-specs) index type-name srcloc)
+142
(srfi9--build-accessors (cdr field-specs) (+ index 1) type-name srcloc))))
+143
+144
;;; The define-record-type transformer
+145
;;; Form: (define-record-type <type-name>
+146
;;; (constructor-name field ...)
+147
;;; predicate-name
+148
;;; field-spec ...)
+149
(define (%srfi9--transformer form)
+150
(let* (;; Get form-level metadata
+151
(form-doc (srfi9--get-doc form))
+152
(srcloc (srfi9--get-srcloc form))
+153
;; Parse form structure
+154
(form-datum (srfi9--unwrap form))
+155
(type-name-raw (car (cdr form-datum)))
+156
(type-name (srfi9--unwrap type-name-raw))
+157
(constructor-form (srfi9--unwrap (car (cdr (cdr form-datum)))))
+158
(constructor-name (srfi9--unwrap (car constructor-form)))
+159
(constructor-fields (map srfi9--unwrap (cdr constructor-form)))
+160
(predicate-name (srfi9--unwrap (car (cdr (cdr (cdr form-datum))))))
+161
(field-specs (cdr (cdr (cdr (cdr form-datum)))))
+162
(base (srfi9--strip-angles type-name))
+163
;; Build constructor definition
+164
(ctor-def (cons 'define
+165
(cons (cons constructor-name constructor-fields)
+166
(list (cons 'vector
+167
(cons (list 'quote type-name)
+168
constructor-fields))))))
+169
(ctor-doc (if (and form-doc (string? form-doc))
+170
form-doc
+171
(string-append "Construct a `" base "` record.")))
+172
(ctor-stx (syntax-with-metadata
+173
(datum->syntax type-name ctor-def)
+174
doc: ctor-doc
+175
srcloc: srcloc))
+176
;; Build predicate definition
+177
(pred-def (list 'define (list predicate-name 'obj)
+178
(list 'and (list 'vector? 'obj)
+179
(list '> (list 'vector-length 'obj) 0)
+180
(list 'eq? (list 'vector-ref 'obj 0)
+181
(list 'quote type-name)))))
+182
(pred-doc (string-append "Test if a value is a `" base "` record."))
+183
(pred-stx (syntax-with-metadata
+184
(datum->syntax type-name pred-def)
+185
doc: pred-doc
+186
srcloc: srcloc)))
+187
(cons 'begin
+188
(cons ctor-stx
+189
(cons pred-stx
+190
;; Accessors/mutators with docstrings
+191
(srfi9--build-accessors field-specs 1 type-name srcloc))))))
+192
+193
;; Register the macro
+194
(define-syntax define-record-type
+195
(lambda (form)
+196
(%srfi9--transformer form)))))