src/srfi/srfi-9.sgl — sigil-r7rs

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;;; ```

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)

74 (begin

75 ;;; Helper: Unwrap syntax object to get datum

76 (define (srfi9--unwrap v)

77 (if (syntax? v) (syntax-datum v) v))

79 ;;; Helper: Get docstring from syntax object

80 (define (srfi9--get-doc v)

81 (if (syntax? v) (syntax-doc v) #f))

83 ;;; Helper: Get srcloc from syntax object

84 (define (srfi9--get-srcloc v)

85 (if (syntax? v) (syntax-srcloc v) #f))

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

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